diff --git a/src/Doc/Isar_Ref/Generic.thy b/src/Doc/Isar_Ref/Generic.thy
--- a/src/Doc/Isar_Ref/Generic.thy
+++ b/src/Doc/Isar_Ref/Generic.thy
@@ -1,1826 +1,1826 @@
 (*:maxLineLen=78:*)
 
 theory Generic
 imports Main Base
 begin
 
 chapter \<open>Generic tools and packages \label{ch:gen-tools}\<close>
 
 section \<open>Configuration options \label{sec:config}\<close>
 
 text \<open>
   Isabelle/Pure maintains a record of named configuration options within the
   theory or proof context, with values of type \<^ML_type>\<open>bool\<close>, \<^ML_type>\<open>int\<close>, \<^ML_type>\<open>real\<close>, or \<^ML_type>\<open>string\<close>. Tools may declare options in
   ML, and then refer to these values (relative to the context). Thus global
   reference variables are easily avoided. The user may change the value of a
   configuration option by means of an associated attribute of the same name.
   This form of context declaration works particularly well with commands such
   as @{command "declare"} or @{command "using"} like this:
 \<close>
 
 (*<*)experiment begin(*>*)
 declare [[show_main_goal = false]]
 
 notepad
 begin
   note [[show_main_goal = true]]
 end
 (*<*)end(*>*)
 
 text \<open>
   \begin{matharray}{rcll}
     @{command_def "print_options"} & : & \<open>context \<rightarrow>\<close> \\
   \end{matharray}
 
   \<^rail>\<open>
     @@{command print_options} ('!'?)
     ;
     @{syntax name} ('=' ('true' | 'false' | @{syntax int} | @{syntax float} | @{syntax name}))?
   \<close>
 
   \<^descr> @{command "print_options"} prints the available configuration options,
   with names, types, and current values; the ``\<open>!\<close>'' option indicates extra
   verbosity.
   
   \<^descr> \<open>name = value\<close> as an attribute expression modifies the named option, with
   the syntax of the value depending on the option's type. For \<^ML_type>\<open>bool\<close>
   the default value is \<open>true\<close>. Any attempt to change a global option in a
   local context is ignored.
 \<close>
 
 
 section \<open>Basic proof tools\<close>
 
 subsection \<open>Miscellaneous methods and attributes \label{sec:misc-meth-att}\<close>
 
 text \<open>
   \begin{matharray}{rcl}
     @{method_def unfold} & : & \<open>method\<close> \\
     @{method_def fold} & : & \<open>method\<close> \\
     @{method_def insert} & : & \<open>method\<close> \\[0.5ex]
     @{method_def erule}\<open>\<^sup>*\<close> & : & \<open>method\<close> \\
     @{method_def drule}\<open>\<^sup>*\<close> & : & \<open>method\<close> \\
     @{method_def frule}\<open>\<^sup>*\<close> & : & \<open>method\<close> \\
     @{method_def intro} & : & \<open>method\<close> \\
     @{method_def elim} & : & \<open>method\<close> \\
     @{method_def fail} & : & \<open>method\<close> \\
     @{method_def succeed} & : & \<open>method\<close> \\
     @{method_def sleep} & : & \<open>method\<close> \\
   \end{matharray}
 
   \<^rail>\<open>
     (@@{method fold} | @@{method unfold} | @@{method insert}) @{syntax thms}
     ;
     (@@{method erule} | @@{method drule} | @@{method frule})
       ('(' @{syntax nat} ')')? @{syntax thms}
     ;
     (@@{method intro} | @@{method elim}) @{syntax thms}?
     ;
     @@{method sleep} @{syntax real}
   \<close>
 
   \<^descr> @{method unfold}~\<open>a\<^sub>1 \<dots> a\<^sub>n\<close> and @{method fold}~\<open>a\<^sub>1 \<dots> a\<^sub>n\<close> expand (or
   fold back) the given definitions throughout all goals; any chained facts
   provided are inserted into the goal and subject to rewriting as well.
 
   Unfolding works in two stages: first, the given equations are used directly
   for rewriting; second, the equations are passed through the attribute
   @{attribute_ref abs_def} before rewriting --- to ensure that definitions are
   fully expanded, regardless of the actual parameters that are provided.
 
   \<^descr> @{method insert}~\<open>a\<^sub>1 \<dots> a\<^sub>n\<close> inserts theorems as facts into all goals of
   the proof state. Note that current facts indicated for forward chaining are
   ignored.
 
   \<^descr> @{method erule}~\<open>a\<^sub>1 \<dots> a\<^sub>n\<close>, @{method drule}~\<open>a\<^sub>1 \<dots> a\<^sub>n\<close>, and @{method
   frule}~\<open>a\<^sub>1 \<dots> a\<^sub>n\<close> are similar to the basic @{method rule} method (see
   \secref{sec:pure-meth-att}), but apply rules by elim-resolution,
   destruct-resolution, and forward-resolution, respectively \<^cite>\<open>"isabelle-implementation"\<close>. The optional natural number argument (default 0)
   specifies additional assumption steps to be performed here.
 
   Note that these methods are improper ones, mainly serving for
   experimentation and tactic script emulation. Different modes of basic rule
   application are usually expressed in Isar at the proof language level,
   rather than via implicit proof state manipulations. For example, a proper
   single-step elimination would be done using the plain @{method rule} method,
   with forward chaining of current facts.
 
   \<^descr> @{method intro} and @{method elim} repeatedly refine some goal by intro-
   or elim-resolution, after having inserted any chained facts. Exactly the
   rules given as arguments are taken into account; this allows fine-tuned
   decomposition of a proof problem, in contrast to common automated tools.
 
   \<^descr> @{method fail} yields an empty result sequence; it is the identity of the
   ``\<open>|\<close>'' method combinator (cf.\ \secref{sec:proof-meth}).
 
   \<^descr> @{method succeed} yields a single (unchanged) result; it is the identity
   of the ``\<open>,\<close>'' method combinator (cf.\ \secref{sec:proof-meth}).
 
   \<^descr> @{method sleep}~\<open>s\<close> succeeds after a real-time delay of \<open>s\<close> seconds. This
   is occasionally useful for demonstration and testing purposes.
 
 
   \begin{matharray}{rcl}
     @{attribute_def tagged} & : & \<open>attribute\<close> \\
     @{attribute_def untagged} & : & \<open>attribute\<close> \\[0.5ex]
     @{attribute_def THEN} & : & \<open>attribute\<close> \\
     @{attribute_def unfolded} & : & \<open>attribute\<close> \\
     @{attribute_def folded} & : & \<open>attribute\<close> \\
     @{attribute_def abs_def} & : & \<open>attribute\<close> \\[0.5ex]
     @{attribute_def rotated} & : & \<open>attribute\<close> \\
     @{attribute_def (Pure) elim_format} & : & \<open>attribute\<close> \\
     @{attribute_def no_vars}\<open>\<^sup>*\<close> & : & \<open>attribute\<close> \\
   \end{matharray}
 
   \<^rail>\<open>
     @@{attribute tagged} @{syntax name} @{syntax name}
     ;
     @@{attribute untagged} @{syntax name}
     ;
     @@{attribute THEN} ('[' @{syntax nat} ']')? @{syntax thm}
     ;
     (@@{attribute unfolded} | @@{attribute folded}) @{syntax thms}
     ;
     @@{attribute rotated} @{syntax int}?
   \<close>
 
   \<^descr> @{attribute tagged}~\<open>name value\<close> and @{attribute untagged}~\<open>name\<close> add and
   remove \<^emph>\<open>tags\<close> of some theorem. Tags may be any list of string pairs that
   serve as formal comment. The first string is considered the tag name, the
   second its value. Note that @{attribute untagged} removes any tags of the
   same name.
 
   \<^descr> @{attribute THEN}~\<open>a\<close> composes rules by resolution; it resolves with the
   first premise of \<open>a\<close> (an alternative position may be also specified). See
   also \<^ML_infix>\<open>RS\<close> in \<^cite>\<open>"isabelle-implementation"\<close>.
   
   \<^descr> @{attribute unfolded}~\<open>a\<^sub>1 \<dots> a\<^sub>n\<close> and @{attribute folded}~\<open>a\<^sub>1 \<dots> a\<^sub>n\<close>
   expand and fold back again the given definitions throughout a rule.
 
   \<^descr> @{attribute abs_def} turns an equation of the form \<^prop>\<open>f x y \<equiv> t\<close>
   into \<^prop>\<open>f \<equiv> \<lambda>x y. t\<close>, which ensures that @{method simp} steps always
   expand it. This also works for object-logic equality.
 
   \<^descr> @{attribute rotated}~\<open>n\<close> rotate the premises of a theorem by \<open>n\<close> (default
   1).
 
   \<^descr> @{attribute (Pure) elim_format} turns a destruction rule into elimination
   rule format, by resolving with the rule \<^prop>\<open>PROP A \<Longrightarrow> (PROP A \<Longrightarrow> PROP B) \<Longrightarrow>
   PROP B\<close>.
   
   Note that the Classical Reasoner (\secref{sec:classical}) provides its own
   version of this operation.
 
   \<^descr> @{attribute no_vars} replaces schematic variables by free ones; this is
   mainly for tuning output of pretty printed theorems.
 \<close>
 
 
 subsection \<open>Low-level equational reasoning\<close>
 
 text \<open>
   \begin{matharray}{rcl}
     @{method_def subst} & : & \<open>method\<close> \\
     @{method_def hypsubst} & : & \<open>method\<close> \\
     @{method_def split} & : & \<open>method\<close> \\
   \end{matharray}
 
   \<^rail>\<open>
     @@{method subst} ('(' 'asm' ')')? \<newline> ('(' (@{syntax nat}+) ')')? @{syntax thm}
     ;
     @@{method split} @{syntax thms}
   \<close>
 
   These methods provide low-level facilities for equational reasoning that are
   intended for specialized applications only. Normally, single step
   calculations would be performed in a structured text (see also
   \secref{sec:calculation}), while the Simplifier methods provide the
   canonical way for automated normalization (see \secref{sec:simplifier}).
 
   \<^descr> @{method subst}~\<open>eq\<close> performs a single substitution step using rule \<open>eq\<close>,
   which may be either a meta or object equality.
 
   \<^descr> @{method subst}~\<open>(asm) eq\<close> substitutes in an assumption.
 
   \<^descr> @{method subst}~\<open>(i \<dots> j) eq\<close> performs several substitutions in the
   conclusion. The numbers \<open>i\<close> to \<open>j\<close> indicate the positions to substitute at.
   Positions are ordered from the top of the term tree moving down from left to
   right. For example, in \<open>(a + b) + (c + d)\<close> there are three positions where
   commutativity of \<open>+\<close> is applicable: 1 refers to \<open>a + b\<close>, 2 to the whole
   term, and 3 to \<open>c + d\<close>.
 
   If the positions in the list \<open>(i \<dots> j)\<close> are non-overlapping (e.g.\ \<open>(2 3)\<close> in
   \<open>(a + b) + (c + d)\<close>) you may assume all substitutions are performed
   simultaneously. Otherwise the behaviour of \<open>subst\<close> is not specified.
 
   \<^descr> @{method subst}~\<open>(asm) (i \<dots> j) eq\<close> performs the substitutions in the
   assumptions. The positions refer to the assumptions in order from left to
   right. For example, given in a goal of the form \<open>P (a + b) \<Longrightarrow> P (c + d) \<Longrightarrow> \<dots>\<close>,
   position 1 of commutativity of \<open>+\<close> is the subterm \<open>a + b\<close> and position 2 is
   the subterm \<open>c + d\<close>.
 
   \<^descr> @{method hypsubst} performs substitution using some assumption; this only
   works for equations of the form \<open>x = t\<close> where \<open>x\<close> is a free or bound
   variable.
 
   \<^descr> @{method split}~\<open>a\<^sub>1 \<dots> a\<^sub>n\<close> performs single-step case splitting using the
   given rules. Splitting is performed in the conclusion or some assumption of
   the subgoal, depending of the structure of the rule.
   
   Note that the @{method simp} method already involves repeated application of
   split rules as declared in the current context, using @{attribute split},
   for example.
 \<close>
 
 
 section \<open>The Simplifier \label{sec:simplifier}\<close>
 
 text \<open>
   The Simplifier performs conditional and unconditional rewriting and uses
   contextual information: rule declarations in the background theory or local
   proof context are taken into account, as well as chained facts and subgoal
   premises (``local assumptions''). There are several general hooks that allow
   to modify the simplification strategy, or incorporate other proof tools that
   solve sub-problems, produce rewrite rules on demand etc.
 
   The rewriting strategy is always strictly bottom up, except for congruence
   rules, which are applied while descending into a term. Conditions in
   conditional rewrite rules are solved recursively before the rewrite rule is
   applied.
 
   The default Simplifier setup of major object logics (HOL, HOLCF, FOL, ZF)
   makes the Simplifier ready for immediate use, without engaging into the
   internal structures. Thus it serves as general-purpose proof tool with the
   main focus on equational reasoning, and a bit more than that.
 \<close>
 
 
 subsection \<open>Simplification methods \label{sec:simp-meth}\<close>
 
 text \<open>
   \begin{tabular}{rcll}
     @{method_def simp} & : & \<open>method\<close> \\
     @{method_def simp_all} & : & \<open>method\<close> \\
     \<open>Pure.\<close>@{method_def (Pure) simp} & : & \<open>method\<close> \\
     \<open>Pure.\<close>@{method_def (Pure) simp_all} & : & \<open>method\<close> \\
     @{attribute_def simp_depth_limit} & : & \<open>attribute\<close> & default \<open>100\<close> \\
   \end{tabular}
   \<^medskip>
 
   \<^rail>\<open>
     (@@{method simp} | @@{method simp_all}) opt? (@{syntax simpmod} * )
     ;
 
     opt: '(' ('no_asm' | 'no_asm_simp' | 'no_asm_use' | 'asm_lr' ) ')'
     ;
     @{syntax_def simpmod}: ('add' | 'del' | 'flip' | 'only' |
       'split' (() | '!' | 'del') | 'cong' (() | 'add' | 'del'))
     ':' @{syntax thms}
   \<close>
 
   \<^descr> @{method simp} invokes the Simplifier on the first subgoal, after
   inserting chained facts as additional goal premises; further rule
   declarations may be included via \<open>(simp add: facts)\<close>. The proof method fails
   if the subgoal remains unchanged after simplification.
 
   Note that the original goal premises and chained facts are subject to
   simplification themselves, while declarations via \<open>add\<close>/\<open>del\<close> merely follow
   the policies of the object-logic to extract rewrite rules from theorems,
   without further simplification. This may lead to slightly different behavior
   in either case, which might be required precisely like that in some boundary
   situations to perform the intended simplification step!
 
   \<^medskip>
 Modifier \<open>flip\<close> deletes the following theorems from the simpset and adds
 their symmetric version (i.e.\ lhs and rhs exchanged). No warning is shown
 if the original theorem was not present.
 
   \<^medskip>
   The \<open>only\<close> modifier first removes all other rewrite rules, looper tactics
   (including split rules), congruence rules, and then behaves like \<open>add\<close>.
   Implicit solvers remain, which means that trivial rules like reflexivity or
   introduction of \<open>True\<close> are available to solve the simplified subgoals, but
   also non-trivial tools like linear arithmetic in HOL. The latter may lead to
   some surprise of the meaning of ``only'' in Isabelle/HOL compared to
   English!
 
   \<^medskip>
   The \<open>split\<close> modifiers add or delete rules for the Splitter (see also
   \secref{sec:simp-strategies} on the looper). This works only if the
   Simplifier method has been properly setup to include the Splitter (all major
   object logics such HOL, HOLCF, FOL, ZF do this already).
   The \<open>!\<close> option causes the split rules to be used aggressively:
   after each application of a split rule in the conclusion, the \<open>safe\<close>
   tactic of the classical reasoner (see \secref{sec:classical:partial})
   is applied to the new goal. The net effect is that the goal is split into
   the different cases. This option can speed up simplification of goals
   with many nested conditional or case expressions significantly.
 
   There is also a separate @{method_ref split} method available for
   single-step case splitting. The effect of repeatedly applying \<open>(split thms)\<close>
   can be imitated by ``\<open>(simp only: split: thms)\<close>''.
 
   \<^medskip>
   The \<open>cong\<close> modifiers add or delete Simplifier congruence rules (see also
   \secref{sec:simp-rules}); the default is to add.
 
   \<^descr> @{method simp_all} is similar to @{method simp}, but acts on all goals,
   working backwards from the last to the first one as usual in Isabelle.\<^footnote>\<open>The
   order is irrelevant for goals without schematic variables, so simplification
   might actually be performed in parallel here.\<close>
 
   Chained facts are inserted into all subgoals, before the simplification
   process starts. Further rule declarations are the same as for @{method
   simp}.
 
   The proof method fails if all subgoals remain unchanged after
   simplification.
 
   \<^descr> @{attribute simp_depth_limit} limits the number of recursive invocations
   of the Simplifier during conditional rewriting.
 
 
   By default the Simplifier methods above take local assumptions fully into
   account, using equational assumptions in the subsequent normalization
   process, or simplifying assumptions themselves. Further options allow to
   fine-tune the behavior of the Simplifier in this respect, corresponding to a
   variety of ML tactics as follows.\<^footnote>\<open>Unlike the corresponding Isar proof
   methods, the ML tactics do not insist in changing the goal state.\<close>
 
   \begin{center}
   \small
   \begin{tabular}{|l|l|p{0.3\textwidth}|}
   \hline
   Isar method & ML tactic & behavior \\\hline
 
   \<open>(simp (no_asm))\<close> & \<^ML>\<open>simp_tac\<close> & assumptions are ignored completely
   \\\hline
 
   \<open>(simp (no_asm_simp))\<close> & \<^ML>\<open>asm_simp_tac\<close> & assumptions are used in the
   simplification of the conclusion but are not themselves simplified \\\hline
 
   \<open>(simp (no_asm_use))\<close> & \<^ML>\<open>full_simp_tac\<close> & assumptions are simplified but
   are not used in the simplification of each other or the conclusion \\\hline
 
   \<open>(simp)\<close> & \<^ML>\<open>asm_full_simp_tac\<close> & assumptions are used in the
   simplification of the conclusion and to simplify other assumptions \\\hline
 
   \<open>(simp (asm_lr))\<close> & \<^ML>\<open>asm_lr_simp_tac\<close> & compatibility mode: an
   assumption is only used for simplifying assumptions which are to the right
   of it \\\hline
 
   \end{tabular}
   \end{center}
 
   \<^medskip>
   In Isabelle/Pure, proof methods @{method (Pure) simp} and @{method (Pure)
   simp_all} only know about meta-equality \<open>\<equiv>\<close>. Any new object-logic needs to
   re-define these methods via \<^ML>\<open>Simplifier.method_setup\<close> in ML:
   Isabelle/FOL or Isabelle/HOL may serve as blue-prints.
 \<close>
 
 
 subsubsection \<open>Examples\<close>
 
 text \<open>
   We consider basic algebraic simplifications in Isabelle/HOL. The rather
   trivial goal \<^prop>\<open>0 + (x + 0) = x + 0 + 0\<close> looks like a good candidate
   to be solved by a single call of @{method simp}:
 \<close>
 
 lemma "0 + (x + 0) = x + 0 + 0" apply simp? oops
 
 text \<open>
   The above attempt \<^emph>\<open>fails\<close>, because \<^term>\<open>0\<close> and \<^term>\<open>(+)\<close> in the
   HOL library are declared as generic type class operations, without stating
   any algebraic laws yet. More specific types are required to get access to
   certain standard simplifications of the theory context, e.g.\ like this:\<close>
 
 lemma fixes x :: nat shows "0 + (x + 0) = x + 0 + 0" by simp
 lemma fixes x :: int shows "0 + (x + 0) = x + 0 + 0" by simp
 lemma fixes x :: "'a :: monoid_add" shows "0 + (x + 0) = x + 0 + 0" by simp
 
 text \<open>
   \<^medskip>
   In many cases, assumptions of a subgoal are also needed in the
   simplification process. For example:
 \<close>
 
 lemma fixes x :: nat shows "x = 0 \<Longrightarrow> x + x = 0" by simp
 lemma fixes x :: nat assumes "x = 0" shows "x + x = 0" apply simp oops
 lemma fixes x :: nat assumes "x = 0" shows "x + x = 0" using assms by simp
 
 text \<open>
   As seen above, local assumptions that shall contribute to simplification
   need to be part of the subgoal already, or indicated explicitly for use by
   the subsequent method invocation. Both too little or too much information
   can make simplification fail, for different reasons.
 
   In the next example the malicious assumption \<^prop>\<open>\<And>x::nat. f x = g (f (g
   x))\<close> does not contribute to solve the problem, but makes the default
   @{method simp} method loop: the rewrite rule \<open>f ?x \<equiv> g (f (g ?x))\<close> extracted
   from the assumption does not terminate. The Simplifier notices certain
   simple forms of nontermination, but not this one. The problem can be solved
   nonetheless, by ignoring assumptions via special options as explained
   before:
 \<close>
 
 lemma "(\<And>x::nat. f x = g (f (g x))) \<Longrightarrow> f 0 = f 0 + 0"
   by (simp (no_asm))
 
 text \<open>
   The latter form is typical for long unstructured proof scripts, where the
   control over the goal content is limited. In structured proofs it is usually
   better to avoid pushing too many facts into the goal state in the first
   place. Assumptions in the Isar proof context do not intrude the reasoning if
   not used explicitly. This is illustrated for a toplevel statement and a
   local proof body as follows:
 \<close>
 
 lemma
   assumes "\<And>x::nat. f x = g (f (g x))"
   shows "f 0 = f 0 + 0" by simp
 
 notepad
 begin
   assume "\<And>x::nat. f x = g (f (g x))"
   have "f 0 = f 0 + 0" by simp
 end
 
 text \<open>
   \<^medskip>
   Because assumptions may simplify each other, there can be very subtle cases
   of nontermination. For example, the regular @{method simp} method applied to
   \<^prop>\<open>P (f x) \<Longrightarrow> y = x \<Longrightarrow> f x = f y \<Longrightarrow> Q\<close> gives rise to the infinite
   reduction sequence
   \[
   \<open>P (f x)\<close> \stackrel{\<open>f x \<equiv> f y\<close>}{\longmapsto}
   \<open>P (f y)\<close> \stackrel{\<open>y \<equiv> x\<close>}{\longmapsto}
   \<open>P (f x)\<close> \stackrel{\<open>f x \<equiv> f y\<close>}{\longmapsto} \cdots
   \]
   whereas applying the same to \<^prop>\<open>y = x \<Longrightarrow> f x = f y \<Longrightarrow> P (f x) \<Longrightarrow> Q\<close>
   terminates (without solving the goal):
 \<close>
 
 lemma "y = x \<Longrightarrow> f x = f y \<Longrightarrow> P (f x) \<Longrightarrow> Q"
   apply simp
   oops
 
 text \<open>
   See also \secref{sec:simp-trace} for options to enable Simplifier trace
   mode, which often helps to diagnose problems with rewrite systems.
 \<close>
 
 
 subsection \<open>Declaring rules \label{sec:simp-rules}\<close>
 
 text \<open>
   \begin{matharray}{rcl}
     @{attribute_def simp} & : & \<open>attribute\<close> \\
     @{attribute_def split} & : & \<open>attribute\<close> \\
     @{attribute_def cong} & : & \<open>attribute\<close> \\
     @{command_def "print_simpset"}\<open>\<^sup>*\<close> & : & \<open>context \<rightarrow>\<close> \\
   \end{matharray}
 
   \<^rail>\<open>
     (@@{attribute simp} | @@{attribute cong}) (() | 'add' | 'del') |
     @@{attribute split} (() | '!' | 'del')
     ;
     @@{command print_simpset} ('!'?)
   \<close>
 
   \<^descr> @{attribute simp} declares rewrite rules, by adding or deleting them from
   the simpset within the theory or proof context. Rewrite rules are theorems
   expressing some form of equality, for example:
 
   \<open>Suc ?m + ?n = ?m + Suc ?n\<close> \\
   \<open>?P \<and> ?P \<longleftrightarrow> ?P\<close> \\
   \<open>?A \<union> ?B \<equiv> {x. x \<in> ?A \<or> x \<in> ?B}\<close>
 
   \<^medskip>
   Conditional rewrites such as \<open>?m < ?n \<Longrightarrow> ?m div ?n = 0\<close> are also permitted;
   the conditions can be arbitrary formulas.
 
   \<^medskip>
   Internally, all rewrite rules are translated into Pure equalities, theorems
   with conclusion \<open>lhs \<equiv> rhs\<close>. The simpset contains a function for extracting
   equalities from arbitrary theorems, which is usually installed when the
   object-logic is configured initially. For example, \<open>\<not> ?x \<in> {}\<close> could be
   turned into \<open>?x \<in> {} \<equiv> False\<close>. Theorems that are declared as @{attribute
   simp} and local assumptions within a goal are treated uniformly in this
   respect.
 
   The Simplifier accepts the following formats for the \<open>lhs\<close> term:
 
     \<^enum> First-order patterns, considering the sublanguage of application of
     constant operators to variable operands, without \<open>\<lambda>\<close>-abstractions or
     functional variables. For example:
 
     \<open>(?x + ?y) + ?z \<equiv> ?x + (?y + ?z)\<close> \\
     \<open>f (f ?x ?y) ?z \<equiv> f ?x (f ?y ?z)\<close>
 
     \<^enum> Higher-order patterns in the sense of \<^cite>\<open>"nipkow-patterns"\<close>. These
     are terms in \<open>\<beta>\<close>-normal form (this will always be the case unless you have
     done something strange) where each occurrence of an unknown is of the form
     \<open>?F x\<^sub>1 \<dots> x\<^sub>n\<close>, where the \<open>x\<^sub>i\<close> are distinct bound variables.
 
     For example, \<open>(\<forall>x. ?P x \<and> ?Q x) \<equiv> (\<forall>x. ?P x) \<and> (\<forall>x. ?Q x)\<close> or its
     symmetric form, since the \<open>rhs\<close> is also a higher-order pattern.
 
     \<^enum> Physical first-order patterns over raw \<open>\<lambda>\<close>-term structure without
     \<open>\<alpha>\<beta>\<eta>\<close>-equality; abstractions and bound variables are treated like
     quasi-constant term material.
 
     For example, the rule \<open>?f ?x \<in> range ?f = True\<close> rewrites the term \<open>g a \<in>
     range g\<close> to \<open>True\<close>, but will fail to match \<open>g (h b) \<in> range (\<lambda>x. g (h
     x))\<close>. However, offending subterms (in our case \<open>?f ?x\<close>, which is not a
     pattern) can be replaced by adding new variables and conditions like this:
     \<open>?y = ?f ?x \<Longrightarrow> ?y \<in> range ?f = True\<close> is acceptable as a conditional rewrite
     rule of the second category since conditions can be arbitrary terms.
 
   \<^descr> @{attribute split} declares case split rules.
 
   \<^descr> @{attribute cong} declares congruence rules to the Simplifier context.
 
   Congruence rules are equalities of the form @{text [display]
   "\<dots> \<Longrightarrow> f ?x\<^sub>1 \<dots> ?x\<^sub>n = f ?y\<^sub>1 \<dots> ?y\<^sub>n"}
 
   This controls the simplification of the arguments of \<open>f\<close>. For example, some
   arguments can be simplified under additional assumptions:
   @{text [display]
     "?P\<^sub>1 \<longleftrightarrow> ?Q\<^sub>1 \<Longrightarrow>
     (?Q\<^sub>1 \<Longrightarrow> ?P\<^sub>2 \<longleftrightarrow> ?Q\<^sub>2) \<Longrightarrow>
     (?P\<^sub>1 \<longrightarrow> ?P\<^sub>2) \<longleftrightarrow> (?Q\<^sub>1 \<longrightarrow> ?Q\<^sub>2)"}
 
   Given this rule, the Simplifier assumes \<open>?Q\<^sub>1\<close> and extracts rewrite rules
   from it when simplifying \<open>?P\<^sub>2\<close>. Such local assumptions are effective for
   rewriting formulae such as \<open>x = 0 \<longrightarrow> y + x = y\<close>.
 
   %FIXME
   %The local assumptions are also provided as theorems to the solver;
   %see \secref{sec:simp-solver} below.
 
   \<^medskip>
   The following congruence rule for bounded quantifiers also supplies
   contextual information --- about the bound variable: @{text [display]
   "(?A = ?B) \<Longrightarrow>
     (\<And>x. x \<in> ?B \<Longrightarrow> ?P x \<longleftrightarrow> ?Q x) \<Longrightarrow>
     (\<forall>x \<in> ?A. ?P x) \<longleftrightarrow> (\<forall>x \<in> ?B. ?Q x)"}
 
   \<^medskip>
   This congruence rule for conditional expressions can supply contextual
   information for simplifying the arms: @{text [display]
   "?p = ?q \<Longrightarrow>
     (?q \<Longrightarrow> ?a = ?c) \<Longrightarrow>
     (\<not> ?q \<Longrightarrow> ?b = ?d) \<Longrightarrow>
     (if ?p then ?a else ?b) = (if ?q then ?c else ?d)"}
 
   A congruence rule can also \<^emph>\<open>prevent\<close> simplification of some arguments. Here
   is an alternative congruence rule for conditional expressions that conforms
   to non-strict functional evaluation: @{text [display]
   "?p = ?q \<Longrightarrow>
     (if ?p then ?a else ?b) = (if ?q then ?a else ?b)"}
 
   Only the first argument is simplified; the others remain unchanged. This can
   make simplification much faster, but may require an extra case split over
   the condition \<open>?q\<close> to prove the goal.
 
   \<^descr> @{command "print_simpset"} prints the collection of rules declared to the
   Simplifier, which is also known as ``simpset'' internally; the ``\<open>!\<close>''
   option indicates extra verbosity.
 
   The implicit simpset of the theory context is propagated monotonically
   through the theory hierarchy: forming a new theory, the union of the
   simpsets of its imports are taken as starting point. Also note that
   definitional packages like @{command "datatype"}, @{command "primrec"},
   @{command "fun"} routinely declare Simplifier rules to the target context,
   while plain @{command "definition"} is an exception in \<^emph>\<open>not\<close> declaring
   anything.
 
   \<^medskip>
   It is up the user to manipulate the current simpset further by explicitly
   adding or deleting theorems as simplification rules, or installing other
   tools via simplification procedures (\secref{sec:simproc}). Good simpsets
   are hard to design. Rules that obviously simplify, like \<open>?n + 0 \<equiv> ?n\<close> are
   good candidates for the implicit simpset, unless a special non-normalizing
   behavior of certain operations is intended. More specific rules (such as
   distributive laws, which duplicate subterms) should be added only for
   specific proof steps. Conversely, sometimes a rule needs to be deleted just
   for some part of a proof. The need of frequent additions or deletions may
   indicate a poorly designed simpset.
 
   \begin{warn}
   The union of simpsets from theory imports (as described above) is not always
   a good starting point for the new theory. If some ancestors have deleted
   simplification rules because they are no longer wanted, while others have
   left those rules in, then the union will contain the unwanted rules, and
   thus have to be deleted again in the theory body.
   \end{warn}
 \<close>
 
 
 subsection \<open>Ordered rewriting with permutative rules\<close>
 
 text \<open>
   A rewrite rule is \<^emph>\<open>permutative\<close> if the left-hand side and right-hand side
   are the equal up to renaming of variables. The most common permutative rule
   is commutativity: \<open>?x + ?y = ?y + ?x\<close>. Other examples include \<open>(?x - ?y) -
   ?z = (?x - ?z) - ?y\<close> in arithmetic and \<open>insert ?x (insert ?y ?A) = insert ?y
   (insert ?x ?A)\<close> for sets. Such rules are common enough to merit special
   attention.
 
   Because ordinary rewriting loops given such rules, the Simplifier employs a
   special strategy, called \<^emph>\<open>ordered rewriting\<close>. Permutative rules are
   detected and only applied if the rewriting step decreases the redex wrt.\ a
   given term ordering. For example, commutativity rewrites \<open>b + a\<close> to \<open>a + b\<close>,
   but then stops, because the redex cannot be decreased further in the sense
   of the term ordering.
 
   The default is lexicographic ordering of term structure, but this could be
   also changed locally for special applications via @{define_ML
   Simplifier.set_term_ord} in Isabelle/ML.
 
   \<^medskip>
   Permutative rewrite rules are declared to the Simplifier just like other
   rewrite rules. Their special status is recognized automatically, and their
   application is guarded by the term ordering accordingly.
 \<close>
 
 
 subsubsection \<open>Rewriting with AC operators\<close>
 
 text \<open>
   Ordered rewriting is particularly effective in the case of
   associative-commutative operators. (Associativity by itself is not
   permutative.) When dealing with an AC-operator \<open>f\<close>, keep the following
   points in mind:
 
     \<^item> The associative law must always be oriented from left to right, namely
     \<open>f (f x y) z = f x (f y z)\<close>. The opposite orientation, if used with
     commutativity, leads to looping in conjunction with the standard term
     order.
 
     \<^item> To complete your set of rewrite rules, you must add not just
     associativity (A) and commutativity (C) but also a derived rule
     \<^emph>\<open>left-commutativity\<close> (LC): \<open>f x (f y z) = f y (f x z)\<close>.
 
   Ordered rewriting with the combination of A, C, and LC sorts a term
   lexicographically --- the rewriting engine imitates bubble-sort.
 \<close>
 
 experiment
   fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infix "\<bullet>" 60)
   assumes assoc: "(x \<bullet> y) \<bullet> z = x \<bullet> (y \<bullet> z)"
   assumes commute: "x \<bullet> y = y \<bullet> x"
 begin
 
 lemma left_commute: "x \<bullet> (y \<bullet> z) = y \<bullet> (x \<bullet> z)"
 proof -
   have "(x \<bullet> y) \<bullet> z = (y \<bullet> x) \<bullet> z" by (simp only: commute)
   then show ?thesis by (simp only: assoc)
 qed
 
 lemmas AC_rules = assoc commute left_commute
 
 text \<open>
   Thus the Simplifier is able to establish equalities with arbitrary
   permutations of subterms, by normalizing to a common standard form. For
   example:
 \<close>
 
 lemma "(b \<bullet> c) \<bullet> a = xxx"
   apply (simp only: AC_rules)
   txt \<open>\<^subgoals>\<close>
   oops
 
 lemma "(b \<bullet> c) \<bullet> a = a \<bullet> (b \<bullet> c)" by (simp only: AC_rules)
 lemma "(b \<bullet> c) \<bullet> a = c \<bullet> (b \<bullet> a)" by (simp only: AC_rules)
 lemma "(b \<bullet> c) \<bullet> a = (c \<bullet> b) \<bullet> a" by (simp only: AC_rules)
 
 end
 
 text \<open>
   Martin and Nipkow \<^cite>\<open>"martin-nipkow"\<close> discuss the theory and give many
   examples; other algebraic structures are amenable to ordered rewriting, such
   as Boolean rings. The Boyer-Moore theorem prover \<^cite>\<open>bm88book\<close> also
   employs ordered rewriting.
 \<close>
 
 
 subsubsection \<open>Re-orienting equalities\<close>
 
 text \<open>Another application of ordered rewriting uses the derived rule
   @{thm [source] eq_commute}: @{thm [source = false] eq_commute} to
   reverse equations.
 
   This is occasionally useful to re-orient local assumptions according
   to the term ordering, when other built-in mechanisms of
   reorientation and mutual simplification fail to apply.\<close>
 
 
 subsection \<open>Simplifier tracing and debugging \label{sec:simp-trace}\<close>
 
 text \<open>
   \begin{tabular}{rcll}
     @{attribute_def simp_trace} & : & \<open>attribute\<close> & default \<open>false\<close> \\
     @{attribute_def simp_trace_depth_limit} & : & \<open>attribute\<close> & default \<open>1\<close> \\
     @{attribute_def simp_debug} & : & \<open>attribute\<close> & default \<open>false\<close> \\
     @{attribute_def simp_trace_new} & : & \<open>attribute\<close> \\
     @{attribute_def simp_break} & : & \<open>attribute\<close> \\
   \end{tabular}
   \<^medskip>
 
   \<^rail>\<open>
     @@{attribute simp_trace_new} ('interactive')? \<newline>
       ('mode' '=' ('full' | 'normal'))? \<newline>
       ('depth' '=' @{syntax nat})?
     ;
 
     @@{attribute simp_break} (@{syntax term}*)
   \<close>
 
   These attributes and configurations options control various aspects of
   Simplifier tracing and debugging.
 
   \<^descr> @{attribute simp_trace} makes the Simplifier output internal operations.
   This includes rewrite steps, but also bookkeeping like modifications of the
   simpset.
 
   \<^descr> @{attribute simp_trace_depth_limit} limits the effect of @{attribute
   simp_trace} to the given depth of recursive Simplifier invocations (when
   solving conditions of rewrite rules).
 
   \<^descr> @{attribute simp_debug} makes the Simplifier output some extra information
   about internal operations. This includes any attempted invocation of
   simplification procedures.
 
   \<^descr> @{attribute simp_trace_new} controls Simplifier tracing within
   Isabelle/PIDE applications, notably Isabelle/jEdit \<^cite>\<open>"isabelle-jedit"\<close>.
   This provides a hierarchical representation of the rewriting steps performed
   by the Simplifier.
 
   Users can configure the behaviour by specifying breakpoints, verbosity and
   enabling or disabling the interactive mode. In normal verbosity (the
   default), only rule applications matching a breakpoint will be shown to the
   user. In full verbosity, all rule applications will be logged. Interactive
   mode interrupts the normal flow of the Simplifier and defers the decision
   how to continue to the user via some GUI dialog.
 
   \<^descr> @{attribute simp_break} declares term or theorem breakpoints for
   @{attribute simp_trace_new} as described above. Term breakpoints are
   patterns which are checked for matches on the redex of a rule application.
   Theorem breakpoints trigger when the corresponding theorem is applied in a
   rewrite step. For example:
 \<close>
 
 (*<*)experiment begin(*>*)
 declare conjI [simp_break]
 declare [[simp_break "?x \<and> ?y"]]
 (*<*)end(*>*)
 
 
 subsection \<open>Simplification procedures \label{sec:simproc}\<close>
 
 text \<open>
   Simplification procedures are ML functions that produce proven rewrite rules
   on demand. They are associated with higher-order patterns that approximate
   the left-hand sides of equations. The Simplifier first matches the current
   redex against one of the LHS patterns; if this succeeds, the corresponding
   ML function is invoked, passing the Simplifier context and redex term. Thus
   rules may be specifically fashioned for particular situations, resulting in
   a more powerful mechanism than term rewriting by a fixed set of rules.
 
   Any successful result needs to be a (possibly conditional) rewrite rule \<open>t \<equiv>
   u\<close> that is applicable to the current redex. The rule will be applied just as
   any ordinary rewrite rule. It is expected to be already in \<^emph>\<open>internal form\<close>,
   bypassing the automatic preprocessing of object-level equivalences.
 
   \begin{matharray}{rcl}
     @{command_def "simproc_setup"} & : & \<open>local_theory \<rightarrow> local_theory\<close> \\
     simproc & : & \<open>attribute\<close> \\
   \end{matharray}
 
   \<^rail>\<open>
     @@{command simproc_setup} @{syntax name} '(' (@{syntax term} + '|') ')' '='
       @{syntax text};
 
     @@{attribute simproc} (('add' ':')? | 'del' ':') (@{syntax name}+)
   \<close>
 
   \<^descr> @{command "simproc_setup"} defines a named simplification procedure that
   is invoked by the Simplifier whenever any of the given term patterns match
   the current redex. The implementation, which is provided as ML source text,
   needs to be of type
   \<^ML_type>\<open>morphism -> Proof.context -> cterm -> thm option\<close>, where the
   \<^ML_type>\<open>cterm\<close> represents the current redex \<open>r\<close> and the result is supposed
   to be some proven rewrite rule \<open>r \<equiv> r'\<close> (or a generalized version), or \<^ML>\<open>NONE\<close> to indicate failure. The \<^ML_type>\<open>Proof.context\<close> argument holds the
   full context of the current Simplifier invocation. The \<^ML_type>\<open>morphism\<close>
   informs about the difference of the original compilation context wrt.\ the
   one of the actual application later on.
 
   Morphisms are only relevant for simprocs that are defined within a local
   target context, e.g.\ in a locale.
 
   \<^descr> \<open>simproc add: name\<close> and \<open>simproc del: name\<close> add or delete named simprocs
   to the current Simplifier context. The default is to add a simproc. Note
   that @{command "simproc_setup"} already adds the new simproc to the
   subsequent context.
 \<close>
 
 
 subsubsection \<open>Example\<close>
 
 text \<open>
   The following simplification procedure for @{thm [source = false,
   show_types] unit_eq} in HOL performs fine-grained control over rule
   application, beyond higher-order pattern matching. Declaring @{thm unit_eq}
   as @{attribute simp} directly would make the Simplifier loop! Note that a
   version of this simplification procedure is already active in Isabelle/HOL.
 \<close>
 
 (*<*)experiment begin(*>*)
 simproc_setup unit ("x::unit") =
-  \<open>fn _ => fn _ => fn ct =>
+  \<open>K (K (fn ct =>
     if HOLogic.is_unit (Thm.term_of ct) then NONE
-    else SOME (mk_meta_eq @{thm unit_eq})\<close>
+    else SOME (mk_meta_eq @{thm unit_eq})))\<close>
 (*<*)end(*>*)
 
 text \<open>
   Since the Simplifier applies simplification procedures frequently, it is
   important to make the failure check in ML reasonably fast.\<close>
 
 
 subsection \<open>Configurable Simplifier strategies \label{sec:simp-strategies}\<close>
 
 text \<open>
   The core term-rewriting engine of the Simplifier is normally used in
   combination with some add-on components that modify the strategy and allow
   to integrate other non-Simplifier proof tools. These may be reconfigured in
   ML as explained below. Even if the default strategies of object-logics like
   Isabelle/HOL are used unchanged, it helps to understand how the standard
   Simplifier strategies work.\<close>
 
 
 subsubsection \<open>The subgoaler\<close>
 
 text \<open>
   \begin{mldecls}
   @{define_ML Simplifier.set_subgoaler: "(Proof.context -> int -> tactic) ->
   Proof.context -> Proof.context"} \\
   @{define_ML Simplifier.prems_of: "Proof.context -> thm list"} \\
   \end{mldecls}
 
   The subgoaler is the tactic used to solve subgoals arising out of
   conditional rewrite rules or congruence rules. The default should be
   simplification itself. In rare situations, this strategy may need to be
   changed. For example, if the premise of a conditional rule is an instance of
   its conclusion, as in \<open>Suc ?m < ?n \<Longrightarrow> ?m < ?n\<close>, the default strategy could
   loop. % FIXME !??
 
     \<^descr> \<^ML>\<open>Simplifier.set_subgoaler\<close>~\<open>tac ctxt\<close> sets the subgoaler of the
     context to \<open>tac\<close>. The tactic will be applied to the context of the running
     Simplifier instance.
 
     \<^descr> \<^ML>\<open>Simplifier.prems_of\<close>~\<open>ctxt\<close> retrieves the current set of premises
     from the context. This may be non-empty only if the Simplifier has been
     told to utilize local assumptions in the first place (cf.\ the options in
     \secref{sec:simp-meth}).
 
   As an example, consider the following alternative subgoaler:
 \<close>
 
 ML_val \<open>
   fun subgoaler_tac ctxt =
     assume_tac ctxt ORELSE'
     resolve_tac ctxt (Simplifier.prems_of ctxt) ORELSE'
     asm_simp_tac ctxt
 \<close>
 
 text \<open>
   This tactic first tries to solve the subgoal by assumption or by resolving
   with with one of the premises, calling simplification only if that fails.\<close>
 
 
 subsubsection \<open>The solver\<close>
 
 text \<open>
   \begin{mldecls}
   @{define_ML_type solver} \\
   @{define_ML Simplifier.mk_solver: "string ->
   (Proof.context -> int -> tactic) -> solver"} \\
   @{define_ML_infix setSolver: "Proof.context * solver -> Proof.context"} \\
   @{define_ML_infix addSolver: "Proof.context * solver -> Proof.context"} \\
   @{define_ML_infix setSSolver: "Proof.context * solver -> Proof.context"} \\
   @{define_ML_infix addSSolver: "Proof.context * solver -> Proof.context"} \\
   \end{mldecls}
 
   A solver is a tactic that attempts to solve a subgoal after simplification.
   Its core functionality is to prove trivial subgoals such as \<^prop>\<open>True\<close>
   and \<open>t = t\<close>, but object-logics might be more ambitious. For example,
   Isabelle/HOL performs a restricted version of linear arithmetic here.
 
   Solvers are packaged up in abstract type \<^ML_type>\<open>solver\<close>, with \<^ML>\<open>Simplifier.mk_solver\<close> as the only operation to create a solver.
 
   \<^medskip>
   Rewriting does not instantiate unknowns. For example, rewriting alone cannot
   prove \<open>a \<in> ?A\<close> since this requires instantiating \<open>?A\<close>. The solver, however,
   is an arbitrary tactic and may instantiate unknowns as it pleases. This is
   the only way the Simplifier can handle a conditional rewrite rule whose
   condition contains extra variables. When a simplification tactic is to be
   combined with other provers, especially with the Classical Reasoner, it is
   important whether it can be considered safe or not. For this reason a
   simpset contains two solvers: safe and unsafe.
 
   The standard simplification strategy solely uses the unsafe solver, which is
   appropriate in most cases. For special applications where the simplification
   process is not allowed to instantiate unknowns within the goal,
   simplification starts with the safe solver, but may still apply the ordinary
   unsafe one in nested simplifications for conditional rules or congruences.
   Note that in this way the overall tactic is not totally safe: it may
   instantiate unknowns that appear also in other subgoals.
 
   \<^descr> \<^ML>\<open>Simplifier.mk_solver\<close>~\<open>name tac\<close> turns \<open>tac\<close> into a solver; the
   \<open>name\<close> is only attached as a comment and has no further significance.
 
   \<^descr> \<open>ctxt setSSolver solver\<close> installs \<open>solver\<close> as the safe solver of \<open>ctxt\<close>.
 
   \<^descr> \<open>ctxt addSSolver solver\<close> adds \<open>solver\<close> as an additional safe solver; it
   will be tried after the solvers which had already been present in \<open>ctxt\<close>.
 
   \<^descr> \<open>ctxt setSolver solver\<close> installs \<open>solver\<close> as the unsafe solver of \<open>ctxt\<close>.
 
   \<^descr> \<open>ctxt addSolver solver\<close> adds \<open>solver\<close> as an additional unsafe solver; it
   will be tried after the solvers which had already been present in \<open>ctxt\<close>.
 
 
   \<^medskip>
   The solver tactic is invoked with the context of the running Simplifier.
   Further operations may be used to retrieve relevant information, such as the
   list of local Simplifier premises via \<^ML>\<open>Simplifier.prems_of\<close> --- this
   list may be non-empty only if the Simplifier runs in a mode that utilizes
   local assumptions (see also \secref{sec:simp-meth}). The solver is also
   presented the full goal including its assumptions in any case. Thus it can
   use these (e.g.\ by calling \<^ML>\<open>assume_tac\<close>), even if the Simplifier proper
   happens to ignore local premises at the moment.
 
   \<^medskip>
   As explained before, the subgoaler is also used to solve the premises of
   congruence rules. These are usually of the form \<open>s = ?x\<close>, where \<open>s\<close> needs to
   be simplified and \<open>?x\<close> needs to be instantiated with the result. Typically,
   the subgoaler will invoke the Simplifier at some point, which will
   eventually call the solver. For this reason, solver tactics must be prepared
   to solve goals of the form \<open>t = ?x\<close>, usually by reflexivity. In particular,
   reflexivity should be tried before any of the fancy automated proof tools.
 
   It may even happen that due to simplification the subgoal is no longer an
   equality. For example, \<open>False \<longleftrightarrow> ?Q\<close> could be rewritten to \<open>\<not> ?Q\<close>. To cover
   this case, the solver could try resolving with the theorem \<open>\<not> False\<close> of the
   object-logic.
 
   \<^medskip>
   \begin{warn}
   If a premise of a congruence rule cannot be proved, then the congruence is
   ignored. This should only happen if the rule is \<^emph>\<open>conditional\<close> --- that is,
   contains premises not of the form \<open>t = ?x\<close>. Otherwise it indicates that some
   congruence rule, or possibly the subgoaler or solver, is faulty.
   \end{warn}
 \<close>
 
 
 subsubsection \<open>The looper\<close>
 
 text \<open>
   \begin{mldecls}
   @{define_ML_infix setloop: "Proof.context *
   (Proof.context -> int -> tactic) -> Proof.context"} \\
   @{define_ML_infix addloop: "Proof.context *
   (string * (Proof.context -> int -> tactic))
   -> Proof.context"} \\
   @{define_ML_infix delloop: "Proof.context * string -> Proof.context"} \\
   @{define_ML Splitter.add_split: "thm -> Proof.context -> Proof.context"} \\
   @{define_ML Splitter.add_split: "thm -> Proof.context -> Proof.context"} \\
   @{define_ML Splitter.add_split_bang: "
   thm -> Proof.context -> Proof.context"} \\
   @{define_ML Splitter.del_split: "thm -> Proof.context -> Proof.context"} \\
   \end{mldecls}
 
   The looper is a list of tactics that are applied after simplification, in
   case the solver failed to solve the simplified goal. If the looper succeeds,
   the simplification process is started all over again. Each of the subgoals
   generated by the looper is attacked in turn, in reverse order.
 
   A typical looper is \<^emph>\<open>case splitting\<close>: the expansion of a conditional.
   Another possibility is to apply an elimination rule on the assumptions. More
   adventurous loopers could start an induction.
 
     \<^descr> \<open>ctxt setloop tac\<close> installs \<open>tac\<close> as the only looper tactic of \<open>ctxt\<close>.
 
     \<^descr> \<open>ctxt addloop (name, tac)\<close> adds \<open>tac\<close> as an additional looper tactic
     with name \<open>name\<close>, which is significant for managing the collection of
     loopers. The tactic will be tried after the looper tactics that had
     already been present in \<open>ctxt\<close>.
 
     \<^descr> \<open>ctxt delloop name\<close> deletes the looper tactic that was associated with
     \<open>name\<close> from \<open>ctxt\<close>.
 
     \<^descr> \<^ML>\<open>Splitter.add_split\<close>~\<open>thm ctxt\<close> adds split tactic
     for \<open>thm\<close> as additional looper tactic of \<open>ctxt\<close>
     (overwriting previous split tactic for the same constant).
 
     \<^descr> \<^ML>\<open>Splitter.add_split_bang\<close>~\<open>thm ctxt\<close> adds aggressive
     (see \S\ref{sec:simp-meth})
     split tactic for \<open>thm\<close> as additional looper tactic of \<open>ctxt\<close>
     (overwriting previous split tactic for the same constant).
 
     \<^descr> \<^ML>\<open>Splitter.del_split\<close>~\<open>thm ctxt\<close> deletes the split tactic
     corresponding to \<open>thm\<close> from the looper tactics of \<open>ctxt\<close>.
 
   The splitter replaces applications of a given function; the right-hand side
   of the replacement can be anything. For example, here is a splitting rule
   for conditional expressions:
 
   @{text [display] "?P (if ?Q ?x ?y) \<longleftrightarrow> (?Q \<longrightarrow> ?P ?x) \<and> (\<not> ?Q \<longrightarrow> ?P ?y)"}
 
   Another example is the elimination operator for Cartesian products (which
   happens to be called \<^const>\<open>case_prod\<close> in Isabelle/HOL:
 
   @{text [display] "?P (case_prod ?f ?p) \<longleftrightarrow> (\<forall>a b. ?p = (a, b) \<longrightarrow> ?P (f a b))"}
 
   For technical reasons, there is a distinction between case splitting in the
   conclusion and in the premises of a subgoal. The former is done by \<^ML>\<open>Splitter.split_tac\<close> with rules like @{thm [source] if_split} or @{thm
   [source] option.split}, which do not split the subgoal, while the latter is
   done by \<^ML>\<open>Splitter.split_asm_tac\<close> with rules like @{thm [source]
   if_split_asm} or @{thm [source] option.split_asm}, which split the subgoal.
   The function \<^ML>\<open>Splitter.add_split\<close> automatically takes care of which
   tactic to call, analyzing the form of the rules given as argument; it is the
   same operation behind \<open>split\<close> attribute or method modifier syntax in the
   Isar source language.
 
   Case splits should be allowed only when necessary; they are expensive and
   hard to control. Case-splitting on if-expressions in the conclusion is
   usually beneficial, so it is enabled by default in Isabelle/HOL and
   Isabelle/FOL/ZF.
 
   \begin{warn}
   With \<^ML>\<open>Splitter.split_asm_tac\<close> as looper component, the Simplifier may
   split subgoals! This might cause unexpected problems in tactic expressions
   that silently assume 0 or 1 subgoals after simplification.
   \end{warn}
 \<close>
 
 
 subsection \<open>Forward simplification \label{sec:simp-forward}\<close>
 
 text \<open>
   \begin{matharray}{rcl}
     @{attribute_def simplified} & : & \<open>attribute\<close> \\
   \end{matharray}
 
   \<^rail>\<open>
     @@{attribute simplified} opt? @{syntax thms}?
     ;
 
     opt: '(' ('no_asm' | 'no_asm_simp' | 'no_asm_use') ')'
   \<close>
 
   \<^descr> @{attribute simplified}~\<open>a\<^sub>1 \<dots> a\<^sub>n\<close> causes a theorem to be simplified,
   either by exactly the specified rules \<open>a\<^sub>1, \<dots>, a\<^sub>n\<close>, or the implicit
   Simplifier context if no arguments are given. The result is fully simplified
   by default, including assumptions and conclusion; the options \<open>no_asm\<close> etc.\
   tune the Simplifier in the same way as the for the \<open>simp\<close> method.
 
   Note that forward simplification restricts the Simplifier to its most basic
   operation of term rewriting; solver and looper tactics
   (\secref{sec:simp-strategies}) are \<^emph>\<open>not\<close> involved here. The @{attribute
   simplified} attribute should be only rarely required under normal
   circumstances.
 \<close>
 
 
 section \<open>The Classical Reasoner \label{sec:classical}\<close>
 
 subsection \<open>Basic concepts\<close>
 
 text \<open>Although Isabelle is generic, many users will be working in
   some extension of classical first-order logic.  Isabelle/ZF is built
   upon theory FOL, while Isabelle/HOL conceptually contains
   first-order logic as a fragment.  Theorem-proving in predicate logic
   is undecidable, but many automated strategies have been developed to
   assist in this task.
 
   Isabelle's classical reasoner is a generic package that accepts
   certain information about a logic and delivers a suite of automatic
   proof tools, based on rules that are classified and declared in the
   context.  These proof procedures are slow and simplistic compared
   with high-end automated theorem provers, but they can save
   considerable time and effort in practice.  They can prove theorems
   such as Pelletier's \<^cite>\<open>pelletier86\<close> problems 40 and 41 in a few
   milliseconds (including full proof reconstruction):\<close>
 
 lemma "(\<exists>y. \<forall>x. F x y \<longleftrightarrow> F x x) \<longrightarrow> \<not> (\<forall>x. \<exists>y. \<forall>z. F z y \<longleftrightarrow> \<not> F z x)"
   by blast
 
 lemma "(\<forall>z. \<exists>y. \<forall>x. f x y \<longleftrightarrow> f x z \<and> \<not> f x x) \<longrightarrow> \<not> (\<exists>z. \<forall>x. f x z)"
   by blast
 
 text \<open>The proof tools are generic.  They are not restricted to
   first-order logic, and have been heavily used in the development of
   the Isabelle/HOL library and applications.  The tactics can be
   traced, and their components can be called directly; in this manner,
   any proof can be viewed interactively.\<close>
 
 
 subsubsection \<open>The sequent calculus\<close>
 
 text \<open>Isabelle supports natural deduction, which is easy to use for
   interactive proof.  But natural deduction does not easily lend
   itself to automation, and has a bias towards intuitionism.  For
   certain proofs in classical logic, it can not be called natural.
   The \<^emph>\<open>sequent calculus\<close>, a generalization of natural deduction,
   is easier to automate.
 
   A \<^bold>\<open>sequent\<close> has the form \<open>\<Gamma> \<turnstile> \<Delta>\<close>, where \<open>\<Gamma>\<close>
   and \<open>\<Delta>\<close> are sets of formulae.\<^footnote>\<open>For first-order
   logic, sequents can equivalently be made from lists or multisets of
   formulae.\<close> The sequent \<open>P\<^sub>1, \<dots>, P\<^sub>m \<turnstile> Q\<^sub>1, \<dots>, Q\<^sub>n\<close> is
   \<^bold>\<open>valid\<close> if \<open>P\<^sub>1 \<and> \<dots> \<and> P\<^sub>m\<close> implies \<open>Q\<^sub>1 \<or> \<dots> \<or>
   Q\<^sub>n\<close>.  Thus \<open>P\<^sub>1, \<dots>, P\<^sub>m\<close> represent assumptions, each of which
   is true, while \<open>Q\<^sub>1, \<dots>, Q\<^sub>n\<close> represent alternative goals.  A
   sequent is \<^bold>\<open>basic\<close> if its left and right sides have a common
   formula, as in \<open>P, Q \<turnstile> Q, R\<close>; basic sequents are trivially
   valid.
 
   Sequent rules are classified as \<^bold>\<open>right\<close> or \<^bold>\<open>left\<close>,
   indicating which side of the \<open>\<turnstile>\<close> symbol they operate on.
   Rules that operate on the right side are analogous to natural
   deduction's introduction rules, and left rules are analogous to
   elimination rules.  The sequent calculus analogue of \<open>(\<longrightarrow>I)\<close>
   is the rule
   \[
   \infer[\<open>(\<longrightarrow>R)\<close>]{\<open>\<Gamma> \<turnstile> \<Delta>, P \<longrightarrow> Q\<close>}{\<open>P, \<Gamma> \<turnstile> \<Delta>, Q\<close>}
   \]
   Applying the rule backwards, this breaks down some implication on
   the right side of a sequent; \<open>\<Gamma>\<close> and \<open>\<Delta>\<close> stand for
   the sets of formulae that are unaffected by the inference.  The
   analogue of the pair \<open>(\<or>I1)\<close> and \<open>(\<or>I2)\<close> is the
   single rule
   \[
   \infer[\<open>(\<or>R)\<close>]{\<open>\<Gamma> \<turnstile> \<Delta>, P \<or> Q\<close>}{\<open>\<Gamma> \<turnstile> \<Delta>, P, Q\<close>}
   \]
   This breaks down some disjunction on the right side, replacing it by
   both disjuncts.  Thus, the sequent calculus is a kind of
   multiple-conclusion logic.
 
   To illustrate the use of multiple formulae on the right, let us
   prove the classical theorem \<open>(P \<longrightarrow> Q) \<or> (Q \<longrightarrow> P)\<close>.  Working
   backwards, we reduce this formula to a basic sequent:
   \[
   \infer[\<open>(\<or>R)\<close>]{\<open>\<turnstile> (P \<longrightarrow> Q) \<or> (Q \<longrightarrow> P)\<close>}
     {\infer[\<open>(\<longrightarrow>R)\<close>]{\<open>\<turnstile> (P \<longrightarrow> Q), (Q \<longrightarrow> P)\<close>}
       {\infer[\<open>(\<longrightarrow>R)\<close>]{\<open>P \<turnstile> Q, (Q \<longrightarrow> P)\<close>}
         {\<open>P, Q \<turnstile> Q, P\<close>}}}
   \]
 
   This example is typical of the sequent calculus: start with the
   desired theorem and apply rules backwards in a fairly arbitrary
   manner.  This yields a surprisingly effective proof procedure.
   Quantifiers add only few complications, since Isabelle handles
   parameters and schematic variables.  See \<^cite>\<open>\<open>Chapter 10\<close> in
   "paulson-ml2"\<close> for further discussion.\<close>
 
 
 subsubsection \<open>Simulating sequents by natural deduction\<close>
 
 text \<open>Isabelle can represent sequents directly, as in the
   object-logic LK.  But natural deduction is easier to work with, and
   most object-logics employ it.  Fortunately, we can simulate the
   sequent \<open>P\<^sub>1, \<dots>, P\<^sub>m \<turnstile> Q\<^sub>1, \<dots>, Q\<^sub>n\<close> by the Isabelle formula
   \<open>P\<^sub>1 \<Longrightarrow> \<dots> \<Longrightarrow> P\<^sub>m \<Longrightarrow> \<not> Q\<^sub>2 \<Longrightarrow> ... \<Longrightarrow> \<not> Q\<^sub>n \<Longrightarrow> Q\<^sub>1\<close> where the order of
   the assumptions and the choice of \<open>Q\<^sub>1\<close> are arbitrary.
   Elim-resolution plays a key role in simulating sequent proofs.
 
   We can easily handle reasoning on the left.  Elim-resolution with
   the rules \<open>(\<or>E)\<close>, \<open>(\<bottom>E)\<close> and \<open>(\<exists>E)\<close> achieves
   a similar effect as the corresponding sequent rules.  For the other
   connectives, we use sequent-style elimination rules instead of
   destruction rules such as \<open>(\<and>E1, 2)\<close> and \<open>(\<forall>E)\<close>.
   But note that the rule \<open>(\<not>L)\<close> has no effect under our
   representation of sequents!
   \[
   \infer[\<open>(\<not>L)\<close>]{\<open>\<not> P, \<Gamma> \<turnstile> \<Delta>\<close>}{\<open>\<Gamma> \<turnstile> \<Delta>, P\<close>}
   \]
 
   What about reasoning on the right?  Introduction rules can only
   affect the formula in the conclusion, namely \<open>Q\<^sub>1\<close>.  The
   other right-side formulae are represented as negated assumptions,
   \<open>\<not> Q\<^sub>2, \<dots>, \<not> Q\<^sub>n\<close>.  In order to operate on one of these, it
   must first be exchanged with \<open>Q\<^sub>1\<close>.  Elim-resolution with the
   \<open>swap\<close> rule has this effect: \<open>\<not> P \<Longrightarrow> (\<not> R \<Longrightarrow> P) \<Longrightarrow> R\<close>
 
   To ensure that swaps occur only when necessary, each introduction
   rule is converted into a swapped form: it is resolved with the
   second premise of \<open>(swap)\<close>.  The swapped form of \<open>(\<and>I)\<close>, which might be called \<open>(\<not>\<and>E)\<close>, is
   @{text [display] "\<not> (P \<and> Q) \<Longrightarrow> (\<not> R \<Longrightarrow> P) \<Longrightarrow> (\<not> R \<Longrightarrow> Q) \<Longrightarrow> R"}
 
   Similarly, the swapped form of \<open>(\<longrightarrow>I)\<close> is
   @{text [display] "\<not> (P \<longrightarrow> Q) \<Longrightarrow> (\<not> R \<Longrightarrow> P \<Longrightarrow> Q) \<Longrightarrow> R"}
 
   Swapped introduction rules are applied using elim-resolution, which
   deletes the negated formula.  Our representation of sequents also
   requires the use of ordinary introduction rules.  If we had no
   regard for readability of intermediate goal states, we could treat
   the right side more uniformly by representing sequents as @{text
   [display] "P\<^sub>1 \<Longrightarrow> \<dots> \<Longrightarrow> P\<^sub>m \<Longrightarrow> \<not> Q\<^sub>1 \<Longrightarrow> \<dots> \<Longrightarrow> \<not> Q\<^sub>n \<Longrightarrow> \<bottom>"}
 \<close>
 
 
 subsubsection \<open>Extra rules for the sequent calculus\<close>
 
 text \<open>As mentioned, destruction rules such as \<open>(\<and>E1, 2)\<close> and
   \<open>(\<forall>E)\<close> must be replaced by sequent-style elimination rules.
   In addition, we need rules to embody the classical equivalence
   between \<open>P \<longrightarrow> Q\<close> and \<open>\<not> P \<or> Q\<close>.  The introduction
   rules \<open>(\<or>I1, 2)\<close> are replaced by a rule that simulates
   \<open>(\<or>R)\<close>: @{text [display] "(\<not> Q \<Longrightarrow> P) \<Longrightarrow> P \<or> Q"}
 
   The destruction rule \<open>(\<longrightarrow>E)\<close> is replaced by @{text [display]
   "(P \<longrightarrow> Q) \<Longrightarrow> (\<not> P \<Longrightarrow> R) \<Longrightarrow> (Q \<Longrightarrow> R) \<Longrightarrow> R"}
 
   Quantifier replication also requires special rules.  In classical
   logic, \<open>\<exists>x. P x\<close> is equivalent to \<open>\<not> (\<forall>x. \<not> P x)\<close>;
   the rules \<open>(\<exists>R)\<close> and \<open>(\<forall>L)\<close> are dual:
   \[
   \infer[\<open>(\<exists>R)\<close>]{\<open>\<Gamma> \<turnstile> \<Delta>, \<exists>x. P x\<close>}{\<open>\<Gamma> \<turnstile> \<Delta>, \<exists>x. P x, P t\<close>}
   \qquad
   \infer[\<open>(\<forall>L)\<close>]{\<open>\<forall>x. P x, \<Gamma> \<turnstile> \<Delta>\<close>}{\<open>P t, \<forall>x. P x, \<Gamma> \<turnstile> \<Delta>\<close>}
   \]
   Thus both kinds of quantifier may be replicated.  Theorems requiring
   multiple uses of a universal formula are easy to invent; consider
   @{text [display] "(\<forall>x. P x \<longrightarrow> P (f x)) \<and> P a \<longrightarrow> P (f\<^sup>n a)"} for any
   \<open>n > 1\<close>.  Natural examples of the multiple use of an
   existential formula are rare; a standard one is \<open>\<exists>x. \<forall>y. P x
   \<longrightarrow> P y\<close>.
 
   Forgoing quantifier replication loses completeness, but gains
   decidability, since the search space becomes finite.  Many useful
   theorems can be proved without replication, and the search generally
   delivers its verdict in a reasonable time.  To adopt this approach,
   represent the sequent rules \<open>(\<exists>R)\<close>, \<open>(\<exists>L)\<close> and
   \<open>(\<forall>R)\<close> by \<open>(\<exists>I)\<close>, \<open>(\<exists>E)\<close> and \<open>(\<forall>I)\<close>,
   respectively, and put \<open>(\<forall>E)\<close> into elimination form: @{text
   [display] "\<forall>x. P x \<Longrightarrow> (P t \<Longrightarrow> Q) \<Longrightarrow> Q"}
 
   Elim-resolution with this rule will delete the universal formula
   after a single use.  To replicate universal quantifiers, replace the
   rule by @{text [display] "\<forall>x. P x \<Longrightarrow> (P t \<Longrightarrow> \<forall>x. P x \<Longrightarrow> Q) \<Longrightarrow> Q"}
 
   To replicate existential quantifiers, replace \<open>(\<exists>I)\<close> by
   @{text [display] "(\<not> (\<exists>x. P x) \<Longrightarrow> P t) \<Longrightarrow> \<exists>x. P x"}
 
   All introduction rules mentioned above are also useful in swapped
   form.
 
   Replication makes the search space infinite; we must apply the rules
   with care.  The classical reasoner distinguishes between safe and
   unsafe rules, applying the latter only when there is no alternative.
   Depth-first search may well go down a blind alley; best-first search
   is better behaved in an infinite search space.  However, quantifier
   replication is too expensive to prove any but the simplest theorems.
 \<close>
 
 
 subsection \<open>Rule declarations\<close>
 
 text \<open>The proof tools of the Classical Reasoner depend on
   collections of rules declared in the context, which are classified
   as introduction, elimination or destruction and as \<^emph>\<open>safe\<close> or
   \<^emph>\<open>unsafe\<close>.  In general, safe rules can be attempted blindly,
   while unsafe rules must be used with care.  A safe rule must never
   reduce a provable goal to an unprovable set of subgoals.
 
   The rule \<open>P \<Longrightarrow> P \<or> Q\<close> is unsafe because it reduces \<open>P
   \<or> Q\<close> to \<open>P\<close>, which might turn out as premature choice of an
   unprovable subgoal.  Any rule whose premises contain new unknowns is
   unsafe. The elimination rule \<open>\<forall>x. P x \<Longrightarrow> (P t \<Longrightarrow> Q) \<Longrightarrow> Q\<close> is
   unsafe, since it is applied via elim-resolution, which discards the
   assumption \<open>\<forall>x. P x\<close> and replaces it by the weaker
   assumption \<open>P t\<close>.  The rule \<open>P t \<Longrightarrow> \<exists>x. P x\<close> is
   unsafe for similar reasons.  The quantifier duplication rule \<open>\<forall>x. P x \<Longrightarrow> (P t \<Longrightarrow> \<forall>x. P x \<Longrightarrow> Q) \<Longrightarrow> Q\<close> is unsafe in a different sense:
   since it keeps the assumption \<open>\<forall>x. P x\<close>, it is prone to
   looping.  In classical first-order logic, all rules are safe except
   those mentioned above.
 
   The safe~/ unsafe distinction is vague, and may be regarded merely
   as a way of giving some rules priority over others.  One could argue
   that \<open>(\<or>E)\<close> is unsafe, because repeated application of it
   could generate exponentially many subgoals.  Induction rules are
   unsafe because inductive proofs are difficult to set up
   automatically.  Any inference that instantiates an unknown
   in the proof state is unsafe --- thus matching must be used, rather than
   unification.  Even proof by assumption is unsafe if it instantiates
   unknowns shared with other subgoals.
 
   \begin{matharray}{rcl}
     @{command_def "print_claset"}\<open>\<^sup>*\<close> & : & \<open>context \<rightarrow>\<close> \\
     @{attribute_def intro} & : & \<open>attribute\<close> \\
     @{attribute_def elim} & : & \<open>attribute\<close> \\
     @{attribute_def dest} & : & \<open>attribute\<close> \\
     @{attribute_def rule} & : & \<open>attribute\<close> \\
     @{attribute_def iff} & : & \<open>attribute\<close> \\
     @{attribute_def swapped} & : & \<open>attribute\<close> \\
   \end{matharray}
 
   \<^rail>\<open>
     (@@{attribute intro} | @@{attribute elim} | @@{attribute dest}) ('!' | () | '?') @{syntax nat}?
     ;
     @@{attribute rule} 'del'
     ;
     @@{attribute iff} (((() | 'add') '?'?) | 'del')
   \<close>
 
   \<^descr> @{command "print_claset"} prints the collection of rules
   declared to the Classical Reasoner, i.e.\ the \<^ML_type>\<open>claset\<close>
   within the context.
 
   \<^descr> @{attribute intro}, @{attribute elim}, and @{attribute dest}
   declare introduction, elimination, and destruction rules,
   respectively.  By default, rules are considered as \<^emph>\<open>unsafe\<close>
   (i.e.\ not applied blindly without backtracking), while ``\<open>!\<close>'' classifies as \<^emph>\<open>safe\<close>.  Rule declarations marked by
   ``\<open>?\<close>'' coincide with those of Isabelle/Pure, cf.\
   \secref{sec:pure-meth-att} (i.e.\ are only applied in single steps
   of the @{method rule} method).  The optional natural number
   specifies an explicit weight argument, which is ignored by the
   automated reasoning tools, but determines the search order of single
   rule steps.
 
   Introduction rules are those that can be applied using ordinary
   resolution.  Their swapped forms are generated internally, which
   will be applied using elim-resolution.  Elimination rules are
   applied using elim-resolution.  Rules are sorted by the number of
   new subgoals they will yield; rules that generate the fewest
   subgoals will be tried first.  Otherwise, later declarations take
   precedence over earlier ones.
 
   Rules already present in the context with the same classification
   are ignored.  A warning is printed if the rule has already been
   added with some other classification, but the rule is added anyway
   as requested.
 
   \<^descr> @{attribute rule}~\<open>del\<close> deletes all occurrences of a
   rule from the classical context, regardless of its classification as
   introduction~/ elimination~/ destruction and safe~/ unsafe.
 
   \<^descr> @{attribute iff} declares logical equivalences to the
   Simplifier and the Classical reasoner at the same time.
   Non-conditional rules result in a safe introduction and elimination
   pair; conditional ones are considered unsafe.  Rules with negative
   conclusion are automatically inverted (using \<open>\<not>\<close>-elimination
   internally).
 
   The ``\<open>?\<close>'' version of @{attribute iff} declares rules to
   the Isabelle/Pure context only, and omits the Simplifier
   declaration.
 
   \<^descr> @{attribute swapped} turns an introduction rule into an
   elimination, by resolving with the classical swap principle \<open>\<not> P \<Longrightarrow> (\<not> R \<Longrightarrow> P) \<Longrightarrow> R\<close> in the second position.  This is mainly for
   illustrative purposes: the Classical Reasoner already swaps rules
   internally as explained above.
 \<close>
 
 
 subsection \<open>Structured methods\<close>
 
 text \<open>
   \begin{matharray}{rcl}
     @{method_def rule} & : & \<open>method\<close> \\
     @{method_def contradiction} & : & \<open>method\<close> \\
   \end{matharray}
 
   \<^rail>\<open>
     @@{method rule} @{syntax thms}?
   \<close>
 
   \<^descr> @{method rule} as offered by the Classical Reasoner is a
   refinement over the Pure one (see \secref{sec:pure-meth-att}).  Both
   versions work the same, but the classical version observes the
   classical rule context in addition to that of Isabelle/Pure.
 
   Common object logics (HOL, ZF, etc.) declare a rich collection of
   classical rules (even if these would qualify as intuitionistic
   ones), but only few declarations to the rule context of
   Isabelle/Pure (\secref{sec:pure-meth-att}).
 
   \<^descr> @{method contradiction} solves some goal by contradiction,
   deriving any result from both \<open>\<not> A\<close> and \<open>A\<close>.  Chained
   facts, which are guaranteed to participate, may appear in either
   order.
 \<close>
 
 
 subsection \<open>Fully automated methods\<close>
 
 text \<open>
   \begin{matharray}{rcl}
     @{method_def blast} & : & \<open>method\<close> \\
     @{method_def auto} & : & \<open>method\<close> \\
     @{method_def force} & : & \<open>method\<close> \\
     @{method_def fast} & : & \<open>method\<close> \\
     @{method_def slow} & : & \<open>method\<close> \\
     @{method_def best} & : & \<open>method\<close> \\
     @{method_def fastforce} & : & \<open>method\<close> \\
     @{method_def slowsimp} & : & \<open>method\<close> \\
     @{method_def bestsimp} & : & \<open>method\<close> \\
     @{method_def deepen} & : & \<open>method\<close> \\
   \end{matharray}
 
   \<^rail>\<open>
     @@{method blast} @{syntax nat}? (@{syntax clamod} * )
     ;
     @@{method auto} (@{syntax nat} @{syntax nat})? (@{syntax clasimpmod} * )
     ;
     @@{method force} (@{syntax clasimpmod} * )
     ;
     (@@{method fast} | @@{method slow} | @@{method best}) (@{syntax clamod} * )
     ;
     (@@{method fastforce} | @@{method slowsimp} | @@{method bestsimp})
       (@{syntax clasimpmod} * )
     ;
     @@{method deepen} (@{syntax nat} ?) (@{syntax clamod} * )
     ;
     @{syntax_def clamod}:
       (('intro' | 'elim' | 'dest') ('!' | () | '?') | 'del') ':' @{syntax thms}
     ;
     @{syntax_def clasimpmod}: ('simp' (() | 'add' | 'del' | 'only') |
       'cong' (() | 'add' | 'del') |
       'split' (() | '!' | 'del') |
       'iff' (((() | 'add') '?'?) | 'del') |
       (('intro' | 'elim' | 'dest') ('!' | () | '?') | 'del')) ':' @{syntax thms}
   \<close>
 
   \<^descr> @{method blast} is a separate classical tableau prover that
   uses the same classical rule declarations as explained before.
 
   Proof search is coded directly in ML using special data structures.
   A successful proof is then reconstructed using regular Isabelle
   inferences.  It is faster and more powerful than the other classical
   reasoning tools, but has major limitations too.
 
     \<^item> It does not use the classical wrapper tacticals, such as the
     integration with the Simplifier of @{method fastforce}.
 
     \<^item> It does not perform higher-order unification, as needed by the
     rule @{thm [source=false] rangeI} in HOL.  There are often
     alternatives to such rules, for example @{thm [source=false]
     range_eqI}.
 
     \<^item> Function variables may only be applied to parameters of the
     subgoal.  (This restriction arises because the prover does not use
     higher-order unification.)  If other function variables are present
     then the prover will fail with the message
     @{verbatim [display] \<open>Function unknown's argument not a bound variable\<close>}
 
     \<^item> Its proof strategy is more general than @{method fast} but can
     be slower.  If @{method blast} fails or seems to be running forever,
     try @{method fast} and the other proof tools described below.
 
   The optional integer argument specifies a bound for the number of
   unsafe steps used in a proof.  By default, @{method blast} starts
   with a bound of 0 and increases it successively to 20.  In contrast,
   \<open>(blast lim)\<close> tries to prove the goal using a search bound
   of \<open>lim\<close>.  Sometimes a slow proof using @{method blast} can
   be made much faster by supplying the successful search bound to this
   proof method instead.
 
   \<^descr> @{method auto} combines classical reasoning with
   simplification.  It is intended for situations where there are a lot
   of mostly trivial subgoals; it proves all the easy ones, leaving the
   ones it cannot prove.  Occasionally, attempting to prove the hard
   ones may take a long time.
 
   The optional depth arguments in \<open>(auto m n)\<close> refer to its
   builtin classical reasoning procedures: \<open>m\<close> (default 4) is for
   @{method blast}, which is tried first, and \<open>n\<close> (default 2) is
   for a slower but more general alternative that also takes wrappers
   into account.
 
   \<^descr> @{method force} is intended to prove the first subgoal
   completely, using many fancy proof tools and performing a rather
   exhaustive search.  As a result, proof attempts may take rather long
   or diverge easily.
 
   \<^descr> @{method fast}, @{method best}, @{method slow} attempt to
   prove the first subgoal using sequent-style reasoning as explained
   before.  Unlike @{method blast}, they construct proofs directly in
   Isabelle.
 
   There is a difference in search strategy and back-tracking: @{method
   fast} uses depth-first search and @{method best} uses best-first
   search (guided by a heuristic function: normally the total size of
   the proof state).
 
   Method @{method slow} is like @{method fast}, but conducts a broader
   search: it may, when backtracking from a failed proof attempt, undo
   even the step of proving a subgoal by assumption.
 
   \<^descr> @{method fastforce}, @{method slowsimp}, @{method bestsimp}
   are like @{method fast}, @{method slow}, @{method best},
   respectively, but use the Simplifier as additional wrapper. The name
   @{method fastforce}, reflects the behaviour of this popular method
   better without requiring an understanding of its implementation.
 
   \<^descr> @{method deepen} works by exhaustive search up to a certain
   depth.  The start depth is 4 (unless specified explicitly), and the
   depth is increased iteratively up to 10.  Unsafe rules are modified
   to preserve the formula they act on, so that it be used repeatedly.
   This method can prove more goals than @{method fast}, but is much
   slower, for example if the assumptions have many universal
   quantifiers.
 
 
   Any of the above methods support additional modifiers of the context
   of classical (and simplifier) rules, but the ones related to the
   Simplifier are explicitly prefixed by \<open>simp\<close> here.  The
   semantics of these ad-hoc rule declarations is analogous to the
   attributes given before.  Facts provided by forward chaining are
   inserted into the goal before commencing proof search.
 \<close>
 
 
 subsection \<open>Partially automated methods\label{sec:classical:partial}\<close>
 
 text \<open>These proof methods may help in situations when the
   fully-automated tools fail.  The result is a simpler subgoal that
   can be tackled by other means, such as by manual instantiation of
   quantifiers.
 
   \begin{matharray}{rcl}
     @{method_def safe} & : & \<open>method\<close> \\
     @{method_def clarify} & : & \<open>method\<close> \\
     @{method_def clarsimp} & : & \<open>method\<close> \\
   \end{matharray}
 
   \<^rail>\<open>
     (@@{method safe} | @@{method clarify}) (@{syntax clamod} * )
     ;
     @@{method clarsimp} (@{syntax clasimpmod} * )
   \<close>
 
   \<^descr> @{method safe} repeatedly performs safe steps on all subgoals.
   It is deterministic, with at most one outcome.
 
   \<^descr> @{method clarify} performs a series of safe steps without
   splitting subgoals; see also @{method clarify_step}.
 
   \<^descr> @{method clarsimp} acts like @{method clarify}, but also does
   simplification.  Note that if the Simplifier context includes a
   splitter for the premises, the subgoal may still be split.
 \<close>
 
 
 subsection \<open>Single-step tactics\<close>
 
 text \<open>
   \begin{matharray}{rcl}
     @{method_def safe_step} & : & \<open>method\<close> \\
     @{method_def inst_step} & : & \<open>method\<close> \\
     @{method_def step} & : & \<open>method\<close> \\
     @{method_def slow_step} & : & \<open>method\<close> \\
     @{method_def clarify_step} & : &  \<open>method\<close> \\
   \end{matharray}
 
   These are the primitive tactics behind the automated proof methods
   of the Classical Reasoner.  By calling them yourself, you can
   execute these procedures one step at a time.
 
   \<^descr> @{method safe_step} performs a safe step on the first subgoal.
   The safe wrapper tacticals are applied to a tactic that may include
   proof by assumption or Modus Ponens (taking care not to instantiate
   unknowns), or substitution.
 
   \<^descr> @{method inst_step} is like @{method safe_step}, but allows
   unknowns to be instantiated.
 
   \<^descr> @{method step} is the basic step of the proof procedure, it
   operates on the first subgoal.  The unsafe wrapper tacticals are
   applied to a tactic that tries @{method safe}, @{method inst_step},
   or applies an unsafe rule from the context.
 
   \<^descr> @{method slow_step} resembles @{method step}, but allows
   backtracking between using safe rules with instantiation (@{method
   inst_step}) and using unsafe rules.  The resulting search space is
   larger.
 
   \<^descr> @{method clarify_step} performs a safe step on the first
   subgoal; no splitting step is applied.  For example, the subgoal
   \<open>A \<and> B\<close> is left as a conjunction.  Proof by assumption,
   Modus Ponens, etc., may be performed provided they do not
   instantiate unknowns.  Assumptions of the form \<open>x = t\<close> may
   be eliminated.  The safe wrapper tactical is applied.
 \<close>
 
 
 subsection \<open>Modifying the search step\<close>
 
 text \<open>
   \begin{mldecls}
     @{define_ML_type wrapper = "(int -> tactic) -> (int -> tactic)"} \\[0.5ex]
     @{define_ML_infix addSWrapper: "Proof.context *
   (string * (Proof.context -> wrapper)) -> Proof.context"} \\
     @{define_ML_infix addSbefore: "Proof.context *
   (string * (Proof.context -> int -> tactic)) -> Proof.context"} \\
     @{define_ML_infix addSafter: "Proof.context *
   (string * (Proof.context -> int -> tactic)) -> Proof.context"} \\
     @{define_ML_infix delSWrapper: "Proof.context * string -> Proof.context"} \\[0.5ex]
     @{define_ML_infix addWrapper: "Proof.context *
   (string * (Proof.context -> wrapper)) -> Proof.context"} \\
     @{define_ML_infix addbefore: "Proof.context *
   (string * (Proof.context -> int -> tactic)) -> Proof.context"} \\
     @{define_ML_infix addafter: "Proof.context *
   (string * (Proof.context -> int -> tactic)) -> Proof.context"} \\
     @{define_ML_infix delWrapper: "Proof.context * string -> Proof.context"} \\[0.5ex]
     @{define_ML addSss: "Proof.context -> Proof.context"} \\
     @{define_ML addss: "Proof.context -> Proof.context"} \\
   \end{mldecls}
 
   The proof strategy of the Classical Reasoner is simple.  Perform as
   many safe inferences as possible; or else, apply certain safe rules,
   allowing instantiation of unknowns; or else, apply an unsafe rule.
   The tactics also eliminate assumptions of the form \<open>x = t\<close>
   by substitution if they have been set up to do so.  They may perform
   a form of Modus Ponens: if there are assumptions \<open>P \<longrightarrow> Q\<close> and
   \<open>P\<close>, then replace \<open>P \<longrightarrow> Q\<close> by \<open>Q\<close>.
 
   The classical reasoning tools --- except @{method blast} --- allow
   to modify this basic proof strategy by applying two lists of
   arbitrary \<^emph>\<open>wrapper tacticals\<close> to it.  The first wrapper list,
   which is considered to contain safe wrappers only, affects @{method
   safe_step} and all the tactics that call it.  The second one, which
   may contain unsafe wrappers, affects the unsafe parts of @{method
   step}, @{method slow_step}, and the tactics that call them.  A
   wrapper transforms each step of the search, for example by
   attempting other tactics before or after the original step tactic.
   All members of a wrapper list are applied in turn to the respective
   step tactic.
 
   Initially the two wrapper lists are empty, which means no
   modification of the step tactics. Safe and unsafe wrappers are added
   to the context with the functions given below, supplying them with
   wrapper names.  These names may be used to selectively delete
   wrappers.
 
   \<^descr> \<open>ctxt addSWrapper (name, wrapper)\<close> adds a new wrapper,
   which should yield a safe tactic, to modify the existing safe step
   tactic.
 
   \<^descr> \<open>ctxt addSbefore (name, tac)\<close> adds the given tactic as a
   safe wrapper, such that it is tried \<^emph>\<open>before\<close> each safe step of
   the search.
 
   \<^descr> \<open>ctxt addSafter (name, tac)\<close> adds the given tactic as a
   safe wrapper, such that it is tried when a safe step of the search
   would fail.
 
   \<^descr> \<open>ctxt delSWrapper name\<close> deletes the safe wrapper with
   the given name.
 
   \<^descr> \<open>ctxt addWrapper (name, wrapper)\<close> adds a new wrapper to
   modify the existing (unsafe) step tactic.
 
   \<^descr> \<open>ctxt addbefore (name, tac)\<close> adds the given tactic as an
   unsafe wrapper, such that it its result is concatenated
   \<^emph>\<open>before\<close> the result of each unsafe step.
 
   \<^descr> \<open>ctxt addafter (name, tac)\<close> adds the given tactic as an
   unsafe wrapper, such that it its result is concatenated \<^emph>\<open>after\<close>
   the result of each unsafe step.
 
   \<^descr> \<open>ctxt delWrapper name\<close> deletes the unsafe wrapper with
   the given name.
 
   \<^descr> \<open>addSss\<close> adds the simpset of the context to its
   classical set. The assumptions and goal will be simplified, in a
   rather safe way, after each safe step of the search.
 
   \<^descr> \<open>addss\<close> adds the simpset of the context to its
   classical set. The assumptions and goal will be simplified, before
   the each unsafe step of the search.
 \<close>
 
 
 section \<open>Object-logic setup \label{sec:object-logic}\<close>
 
 text \<open>
   \begin{matharray}{rcl}
     @{command_def "judgment"} & : & \<open>theory \<rightarrow> theory\<close> \\
     @{method_def atomize} & : & \<open>method\<close> \\
     @{attribute_def atomize} & : & \<open>attribute\<close> \\
     @{attribute_def rule_format} & : & \<open>attribute\<close> \\
     @{attribute_def rulify} & : & \<open>attribute\<close> \\
   \end{matharray}
 
   The very starting point for any Isabelle object-logic is a ``truth
   judgment'' that links object-level statements to the meta-logic
   (with its minimal language of \<open>prop\<close> that covers universal
   quantification \<open>\<And>\<close> and implication \<open>\<Longrightarrow>\<close>).
 
   Common object-logics are sufficiently expressive to internalize rule
   statements over \<open>\<And>\<close> and \<open>\<Longrightarrow>\<close> within their own
   language.  This is useful in certain situations where a rule needs
   to be viewed as an atomic statement from the meta-level perspective,
   e.g.\ \<open>\<And>x. x \<in> A \<Longrightarrow> P x\<close> versus \<open>\<forall>x \<in> A. P x\<close>.
 
   From the following language elements, only the @{method atomize}
   method and @{attribute rule_format} attribute are occasionally
   required by end-users, the rest is for those who need to setup their
   own object-logic.  In the latter case existing formulations of
   Isabelle/FOL or Isabelle/HOL may be taken as realistic examples.
 
   Generic tools may refer to the information provided by object-logic
   declarations internally.
 
   \<^rail>\<open>
     @@{command judgment} @{syntax name} '::' @{syntax type} @{syntax mixfix}?
     ;
     @@{attribute atomize} ('(' 'full' ')')?
     ;
     @@{attribute rule_format} ('(' 'noasm' ')')?
   \<close>
 
   \<^descr> @{command "judgment"}~\<open>c :: \<sigma> (mx)\<close> declares constant
   \<open>c\<close> as the truth judgment of the current object-logic.  Its
   type \<open>\<sigma>\<close> should specify a coercion of the category of
   object-level propositions to \<open>prop\<close> of the Pure meta-logic;
   the mixfix annotation \<open>(mx)\<close> would typically just link the
   object language (internally of syntactic category \<open>logic\<close>)
   with that of \<open>prop\<close>.  Only one @{command "judgment"}
   declaration may be given in any theory development.
   
   \<^descr> @{method atomize} (as a method) rewrites any non-atomic
   premises of a sub-goal, using the meta-level equations declared via
   @{attribute atomize} (as an attribute) beforehand.  As a result,
   heavily nested goals become amenable to fundamental operations such
   as resolution (cf.\ the @{method (Pure) rule} method).  Giving the ``\<open>(full)\<close>'' option here means to turn the whole subgoal into an
   object-statement (if possible), including the outermost parameters
   and assumptions as well.
 
   A typical collection of @{attribute atomize} rules for a particular
   object-logic would provide an internalization for each of the
   connectives of \<open>\<And>\<close>, \<open>\<Longrightarrow>\<close>, and \<open>\<equiv>\<close>.
   Meta-level conjunction should be covered as well (this is
   particularly important for locales, see \secref{sec:locale}).
 
   \<^descr> @{attribute rule_format} rewrites a theorem by the equalities
   declared as @{attribute rulify} rules in the current object-logic.
   By default, the result is fully normalized, including assumptions
   and conclusions at any depth.  The \<open>(no_asm)\<close> option
   restricts the transformation to the conclusion of a rule.
 
   In common object-logics (HOL, FOL, ZF), the effect of @{attribute
   rule_format} is to replace (bounded) universal quantification
   (\<open>\<forall>\<close>) and implication (\<open>\<longrightarrow>\<close>) by the corresponding
   rule statements over \<open>\<And>\<close> and \<open>\<Longrightarrow>\<close>.
 \<close>
 
 
 section \<open>Tracing higher-order unification\<close>
 
 text \<open>
   \begin{tabular}{rcll}
     @{attribute_def unify_trace_simp} & : & \<open>attribute\<close> & default \<open>false\<close> \\
     @{attribute_def unify_trace_types} & : & \<open>attribute\<close> & default \<open>false\<close> \\
     @{attribute_def unify_trace_bound} & : & \<open>attribute\<close> & default \<open>50\<close> \\
     @{attribute_def unify_search_bound} & : & \<open>attribute\<close> & default \<open>60\<close> \\
   \end{tabular}
   \<^medskip>
 
   Higher-order unification works well in most practical situations,
   but sometimes needs extra care to identify problems.  These tracing
   options may help.
 
   \<^descr> @{attribute unify_trace_simp} controls tracing of the
   simplification phase of higher-order unification.
 
   \<^descr> @{attribute unify_trace_types} controls warnings of
   incompleteness, when unification is not considering all possible
   instantiations of schematic type variables.
 
   \<^descr> @{attribute unify_trace_bound} determines the depth where
   unification starts to print tracing information once it reaches
   depth; 0 for full tracing.  At the default value, tracing
   information is almost never printed in practice.
 
   \<^descr> @{attribute unify_search_bound} prevents unification from
   searching past the given depth.  Because of this bound, higher-order
   unification cannot return an infinite sequence, though it can return
   an exponentially long one.  The search rarely approaches the default
   value in practice.  If the search is cut off, unification prints a
   warning ``Unification bound exceeded''.
 
 
   \begin{warn}
   Options for unification cannot be modified in a local context.  Only
   the global theory content is taken into account.
   \end{warn}
 \<close>
 
 end
diff --git a/src/HOL/Bali/Eval.thy b/src/HOL/Bali/Eval.thy
--- a/src/HOL/Bali/Eval.thy
+++ b/src/HOL/Bali/Eval.thy
@@ -1,1179 +1,1179 @@
 (*  Title:      HOL/Bali/Eval.thy
     Author:     David von Oheimb
 *)
 subsection \<open>Operational evaluation (big-step) semantics of Java expressions and 
           statements
 \<close>
 
 theory Eval imports State DeclConcepts begin
 
 text \<open>
 
 improvements over Java Specification 1.0:
 \begin{itemize}
 \item dynamic method lookup does not need to consider the return type 
       (cf.15.11.4.4)
 \item throw raises a NullPointer exception if a null reference is given, and 
       each throw of a standard exception yield a fresh exception object 
       (was not specified)
 \item if there is not enough memory even to allocate an OutOfMemory exception,
   evaluation/execution fails, i.e. simply stops (was not specified)
 \item array assignment checks lhs (and may throw exceptions) before evaluating 
       rhs
 \item fixed exact positions of class initializations 
       (immediate at first active use)
 \end{itemize}
 
 design issues:
 \begin{itemize}
 \item evaluation vs. (single-step) transition semantics
   evaluation semantics chosen, because:
   \begin{itemize} 
   \item[++] less verbose and therefore easier to read (and to handle in proofs)
   \item[+]  more abstract
   \item[+]  intermediate values (appearing in recursive rules) need not be 
      stored explicitly, e.g. no call body construct or stack of invocation 
      frames containing local variables and return addresses for method calls 
      needed
   \item[+]  convenient rule induction for subject reduction theorem
   \item[-]  no interleaving (for parallelism) can be described
   \item[-]  stating a property of infinite executions requires the meta-level 
      argument that this property holds for any finite prefixes of it 
      (e.g. stopped using a counter that is decremented to zero and then 
      throwing an exception)
   \end{itemize}
 \item unified evaluation for variables, expressions, expression lists, 
       statements
 \item the value entry in statement rules is redundant 
 \item the value entry in rules is irrelevant in case of exceptions, but its full
   inclusion helps to make the rule structure independent of exception occurrence.
 \item as irrelevant value entries are ignored, it does not matter if they are 
       unique.
   For simplicity, (fixed) arbitrary values are preferred over "free" values.
 \item the rule format is such that the start state may contain an exception.
   \begin{itemize}
   \item[++] faciliates exception handling
   \item[+]  symmetry
   \end{itemize}
 \item the rules are defined carefully in order to be applicable even in not
   type-correct situations (yielding undefined values),
   e.g. \<open>the_Addr (Val (Bool b)) = undefined\<close>.
   \begin{itemize}
   \item[++] fewer rules 
   \item[-]  less readable because of auxiliary functions like \<open>the_Addr\<close>
   \end{itemize}
   Alternative: "defensive" evaluation throwing some InternalError exception
                in case of (impossible, for correct programs) type mismatches
 \item there is exactly one rule per syntactic construct
   \begin{itemize}
   \item[+] no redundancy in case distinctions
   \end{itemize}
 \item halloc fails iff there is no free heap address. When there is
   only one free heap address left, it returns an OutOfMemory exception.
   In this way it is guaranteed that when an OutOfMemory exception is thrown for
   the first time, there is a free location on the heap to allocate it.
 \item the allocation of objects that represent standard exceptions is deferred 
       until execution of any enclosing catch clause, which is transparent to 
       the program.
   \begin{itemize}
   \item[-]  requires an auxiliary execution relation
   \item[++] avoids copies of allocation code and awkward case distinctions 
            (whether there is enough memory to allocate the exception) in 
             evaluation rules
   \end{itemize}
 \item unfortunately \<open>new_Addr\<close> is not directly executable because of 
       Hilbert operator.
 \end{itemize}
 simplifications:
 \begin{itemize}
 \item local variables are initialized with default values 
       (no definite assignment)
 \item garbage collection not considered, therefore also no finalizers
 \item stack overflow and memory overflow during class initialization not 
       modelled
 \item exceptions in initializations not replaced by ExceptionInInitializerError
 \end{itemize}
 \<close>
 
 
 type_synonym vvar = "val \<times> (val \<Rightarrow> state \<Rightarrow> state)"
 type_synonym vals = "(val, vvar, val list) sum3"
 translations
   (type) "vvar" <= (type) "val \<times> (val \<Rightarrow> state \<Rightarrow> state)"
   (type) "vals" <= (type) "(val, vvar, val list) sum3" 
 
 text \<open>To avoid redundancy and to reduce the number of rules, there is only 
  one evaluation rule for each syntactic term. This is also true for variables
  (e.g. see the rules below for \<open>LVar\<close>, \<open>FVar\<close> and \<open>AVar\<close>). 
  So evaluation of a variable must capture both possible further uses: 
  read (rule \<open>Acc\<close>) or write (rule \<open>Ass\<close>) to the variable. 
  Therefor a variable evaluates to a special value \<^term>\<open>vvar\<close>, which is 
  a pair, consisting of the current value (for later read access) and an update 
  function (for later write access). Because
  during assignment to an array variable an exception may occur if the types
  don't match, the update function is very generic: it transforms the 
  full state. This generic update function causes some technical trouble during
  some proofs (e.g. type safety, correctness of definite assignment). There we
  need to prove some additional invariant on this update function to prove the
  assignment correct, since the update function could potentially alter the whole
  state in an arbitrary manner. This invariant must be carried around through
  the whole induction.
  So for future approaches it may be better not to take
  such a generic update function, but only to store the address and the kind
  of variable (array (+ element type), local variable or field) for later 
  assignment. 
 \<close>
 
 abbreviation
   dummy_res :: "vals" ("\<diamondsuit>")
   where "\<diamondsuit> == In1 Unit"
 
 abbreviation (input)
   val_inj_vals ("\<lfloor>_\<rfloor>\<^sub>e" 1000)
   where "\<lfloor>e\<rfloor>\<^sub>e == In1 e"
 
 abbreviation (input)
   var_inj_vals  ("\<lfloor>_\<rfloor>\<^sub>v" 1000)
   where "\<lfloor>v\<rfloor>\<^sub>v == In2 v"
 
 abbreviation (input)
   lst_inj_vals  ("\<lfloor>_\<rfloor>\<^sub>l" 1000)
   where "\<lfloor>es\<rfloor>\<^sub>l == In3 es"
 
 definition undefined3 :: "('al + 'ar, 'b, 'c) sum3 \<Rightarrow> vals" where
  "undefined3 = case_sum3 (In1 \<circ> case_sum (\<lambda>x. undefined) (\<lambda>x. Unit))
                      (\<lambda>x. In2 undefined) (\<lambda>x. In3 undefined)"
 
 lemma [simp]: "undefined3 (In1l x) = In1 undefined"
 by (simp add: undefined3_def)
 
 lemma [simp]: "undefined3 (In1r x) = \<diamondsuit>"
 by (simp add: undefined3_def)
 
 lemma [simp]: "undefined3 (In2  x) = In2 undefined"
 by (simp add: undefined3_def)
 
 lemma [simp]: "undefined3 (In3  x) = In3 undefined"
 by (simp add: undefined3_def)
 
 
 subsubsection "exception throwing and catching"
 
 definition
   throw :: "val \<Rightarrow> abopt \<Rightarrow> abopt" where
   "throw a' x = abrupt_if True (Some (Xcpt (Loc (the_Addr a')))) (np a' x)"
 
 lemma throw_def2: 
  "throw a' x = abrupt_if True (Some (Xcpt (Loc (the_Addr a')))) (np a' x)"
 apply (unfold throw_def)
 apply (simp (no_asm))
 done
 
 definition
   fits :: "prog \<Rightarrow> st \<Rightarrow> val \<Rightarrow> ty \<Rightarrow> bool" ("_,_\<turnstile>_ fits _"[61,61,61,61]60)
   where "G,s\<turnstile>a' fits T = ((\<exists>rt. T=RefT rt) \<longrightarrow> a'=Null \<or> G\<turnstile>obj_ty(lookup_obj s a')\<preceq>T)"
 
 lemma fits_Null [simp]: "G,s\<turnstile>Null fits T"
 by (simp add: fits_def)
 
 
 lemma fits_Addr_RefT [simp]:
   "G,s\<turnstile>Addr a fits RefT t = G\<turnstile>obj_ty (the (heap s a))\<preceq>RefT t"
 by (simp add: fits_def)
 
 lemma fitsD: "\<And>X. G,s\<turnstile>a' fits T \<Longrightarrow> (\<exists>pt. T = PrimT pt) \<or>  
   (\<exists>t. T = RefT t) \<and> a' = Null \<or>  
   (\<exists>t. T = RefT t) \<and> a' \<noteq> Null \<and>  G\<turnstile>obj_ty (lookup_obj s a')\<preceq>T"
 apply (unfold fits_def)
 apply (case_tac "\<exists>pt. T = PrimT pt")
 apply  simp_all
 apply (case_tac "T")
 defer 
 apply (case_tac "a' = Null")
 apply  simp_all
 done
 
 definition
   catch :: "prog \<Rightarrow> state \<Rightarrow> qtname \<Rightarrow> bool" ("_,_\<turnstile>catch _"[61,61,61]60) where
   "G,s\<turnstile>catch C = (\<exists>xc. abrupt s=Some (Xcpt xc) \<and> 
                         G,store s\<turnstile>Addr (the_Loc xc) fits Class C)"
 
 lemma catch_Norm [simp]: "\<not>G,Norm s\<turnstile>catch tn"
 apply (unfold catch_def)
 apply (simp (no_asm))
 done
 
 lemma catch_XcptLoc [simp]: 
   "G,(Some (Xcpt (Loc a)),s)\<turnstile>catch C = G,s\<turnstile>Addr a fits Class C"
 apply (unfold catch_def)
 apply (simp (no_asm))
 done
 
 lemma catch_Jump [simp]: "\<not>G,(Some (Jump j),s)\<turnstile>catch tn"
 apply (unfold catch_def)
 apply (simp (no_asm))
 done
 
 lemma catch_Error [simp]: "\<not>G,(Some (Error e),s)\<turnstile>catch tn"
 apply (unfold catch_def)
 apply (simp (no_asm))
 done
 
 definition
   new_xcpt_var :: "vname \<Rightarrow> state \<Rightarrow> state" where
   "new_xcpt_var vn = (\<lambda>(x,s). Norm (lupd(VName vn\<mapsto>Addr (the_Loc (the_Xcpt (the x)))) s))"
 
 lemma new_xcpt_var_def2 [simp]: 
  "new_xcpt_var vn (x,s) = 
     Norm (lupd(VName vn\<mapsto>Addr (the_Loc (the_Xcpt (the x)))) s)"
 apply (unfold new_xcpt_var_def)
 apply (simp (no_asm))
 done
 
 
 
 subsubsection "misc"
 
 definition
   assign :: "('a \<Rightarrow> state \<Rightarrow> state) \<Rightarrow> 'a \<Rightarrow> state \<Rightarrow> state" where
  "assign f v = (\<lambda>(x,s). let (x',s') = (if x = None then f v else id) (x,s)
                         in  (x',if x' = None then s' else s))"
 
 (*
 lemma assign_Norm_Norm [simp]: 
 "f v \<lparr>abrupt=None,store=s\<rparr> = \<lparr>abrupt=None,store=s'\<rparr> 
  \<Longrightarrow> assign f v \<lparr>abrupt=None,store=s\<rparr> = \<lparr>abrupt=None,store=s'\<rparr>"
 by (simp add: assign_def Let_def)
 *)
 
 lemma assign_Norm_Norm [simp]: 
 "f v (Norm s) = Norm s' \<Longrightarrow> assign f v (Norm s) = Norm s'"
 by (simp add: assign_def Let_def)
 
 (*
 lemma assign_Norm_Some [simp]: 
   "\<lbrakk>abrupt (f v \<lparr>abrupt=None,store=s\<rparr>) = Some y\<rbrakk> 
    \<Longrightarrow> assign f v \<lparr>abrupt=None,store=s\<rparr> = \<lparr>abrupt=Some y,store =s\<rparr>"
 by (simp add: assign_def Let_def split_beta)
 *)
 
 lemma assign_Norm_Some [simp]: 
   "\<lbrakk>abrupt (f v (Norm s)) = Some y\<rbrakk> 
    \<Longrightarrow> assign f v (Norm s) = (Some y,s)"
 by (simp add: assign_def Let_def split_beta)
 
 
 lemma assign_Some [simp]: 
 "assign f v (Some x,s) = (Some x,s)" 
 by (simp add: assign_def Let_def split_beta)
 
 lemma assign_Some1 [simp]:  "\<not> normal s \<Longrightarrow> assign f v s = s" 
 by (auto simp add: assign_def Let_def split_beta)
 
 lemma assign_supd [simp]: 
 "assign (\<lambda>v. supd (f v)) v (x,s)  
   = (x, if x = None then f v s else s)"
 apply auto
 done
 
 lemma assign_raise_if [simp]: 
   "assign (\<lambda>v (x,s). ((raise_if (b s v) xcpt) x, f v s)) v (x, s) =  
   (raise_if (b s v) xcpt x, if x=None \<and> \<not>b s v then f v s else s)"
 apply (case_tac "x = None")
 apply auto
 done
 
 
 (*
 lemma assign_raise_if [simp]: 
   "assign (\<lambda>v s. \<lparr>abrupt=(raise_if (b (store s) v) xcpt) (abrupt s),
                   store = f v (store s)\<rparr>) v s =  
   \<lparr>abrupt=raise_if (b (store s) v) xcpt (abrupt s),
    store= if (abrupt s)=None \<and> \<not>b (store s) v 
              then f v (store s) else (store s)\<rparr>"
 apply (case_tac "abrupt s = None")
 apply auto
 done
 *)
 
 definition
   init_comp_ty :: "ty \<Rightarrow> stmt"
   where "init_comp_ty T = (if (\<exists>C. T = Class C) then Init (the_Class T) else Skip)"
 
 lemma init_comp_ty_PrimT [simp]: "init_comp_ty (PrimT pt) = Skip"
 apply (unfold init_comp_ty_def)
 apply (simp (no_asm))
 done
 
 definition
   invocation_class :: "inv_mode \<Rightarrow> st \<Rightarrow> val \<Rightarrow> ref_ty \<Rightarrow> qtname" where
  "invocation_class m s a' statT =
     (case m of
        Static \<Rightarrow> if (\<exists> statC. statT = ClassT statC) 
                     then the_Class (RefT statT) 
                     else Object
      | SuperM \<Rightarrow> the_Class (RefT statT)
      | IntVir \<Rightarrow> obj_class (lookup_obj s a'))"
 
 definition
   invocation_declclass :: "prog \<Rightarrow> inv_mode \<Rightarrow> st \<Rightarrow> val \<Rightarrow> ref_ty \<Rightarrow> sig \<Rightarrow> qtname" where
   "invocation_declclass G m s a' statT sig =
     declclass (the (dynlookup G statT
                                 (invocation_class m s a' statT)
                                 sig))" 
   
 lemma invocation_class_IntVir [simp]: 
 "invocation_class IntVir s a' statT = obj_class (lookup_obj s a')"
 by (simp add: invocation_class_def)
 
 lemma dynclass_SuperM [simp]: 
  "invocation_class SuperM s a' statT = the_Class (RefT statT)"
 by (simp add: invocation_class_def)
 
 lemma invocation_class_Static [simp]: 
   "invocation_class Static s a' statT = (if (\<exists> statC. statT = ClassT statC) 
                                             then the_Class (RefT statT) 
                                             else Object)"
 by (simp add: invocation_class_def)
 
 definition
   init_lvars :: "prog \<Rightarrow> qtname \<Rightarrow> sig \<Rightarrow> inv_mode \<Rightarrow> val \<Rightarrow> val list \<Rightarrow> state \<Rightarrow> state"
 where
   "init_lvars G C sig mode a' pvs =
     (\<lambda>(x,s). 
       let m = mthd (the (methd G C sig));
           l = \<lambda> k. 
               (case k of
                  EName e 
                    \<Rightarrow> (case e of 
                          VNam v \<Rightarrow> (Map.empty ((pars m)[\<mapsto>]pvs)) v
                        | Res    \<Rightarrow> None)
                | This 
                    \<Rightarrow> (if mode=Static then None else Some a'))
       in set_lvars l (if mode = Static then x else np a' x,s))"
 
 
 
 lemma init_lvars_def2: \<comment> \<open>better suited for simplification\<close> 
 "init_lvars G C sig mode a' pvs (x,s) =  
   set_lvars 
     (\<lambda> k. 
        (case k of
           EName e 
             \<Rightarrow> (case e of 
                   VNam v 
                   \<Rightarrow> (Map.empty ((pars (mthd (the (methd G C sig))))[\<mapsto>]pvs)) v
                | Res \<Rightarrow> None)
         | This 
             \<Rightarrow> (if mode=Static then None else Some a')))
     (if mode = Static then x else np a' x,s)"
 apply (unfold init_lvars_def)
 apply (simp (no_asm) add: Let_def)
 done
 
 definition
   body :: "prog \<Rightarrow> qtname \<Rightarrow> sig \<Rightarrow> expr" where
  "body G C sig =
     (let m = the (methd G C sig) 
      in Body (declclass m) (stmt (mbody (mthd m))))"
 
 lemma body_def2: \<comment> \<open>better suited for simplification\<close> 
 "body G C sig = Body  (declclass (the (methd G C sig))) 
                       (stmt (mbody (mthd (the (methd G C sig)))))"
 apply (unfold body_def Let_def)
 apply auto
 done
 
 subsubsection "variables"
 
 definition
   lvar :: "lname \<Rightarrow> st \<Rightarrow> vvar"
   where "lvar vn s = (the (locals s vn), \<lambda>v. supd (lupd(vn\<mapsto>v)))"
 
 definition
   fvar :: "qtname \<Rightarrow> bool \<Rightarrow> vname \<Rightarrow> val \<Rightarrow> state \<Rightarrow> vvar \<times> state" where
  "fvar C stat fn a' s =
    (let (oref,xf) = if stat then (Stat C,id)
                             else (Heap (the_Addr a'),np a');
                   n = Inl (fn,C); 
                   f = (\<lambda>v. supd (upd_gobj oref n v)) 
     in ((the (values (the (globs (store s) oref)) n),f),abupd xf s))"
 
 definition
   avar :: "prog \<Rightarrow> val \<Rightarrow> val \<Rightarrow> state \<Rightarrow> vvar \<times> state" where
   "avar G i' a' s =
     (let   oref = Heap (the_Addr a'); 
               i = the_Intg i'; 
               n = Inr i;
        (T,k,cs) = the_Arr (globs (store s) oref); 
               f = (\<lambda>v (x,s). (raise_if (\<not>G,s\<turnstile>v fits T) 
                                            ArrStore x
                               ,upd_gobj oref n v s)) 
      in ((the (cs n),f),abupd (raise_if (\<not>i in_bounds k) IndOutBound \<circ> np a') s))"
 
 lemma fvar_def2: \<comment> \<open>better suited for simplification\<close> 
 "fvar C stat fn a' s =  
   ((the 
      (values 
       (the (globs (store s) (if stat then Stat C else Heap (the_Addr a')))) 
       (Inl (fn,C)))
    ,(\<lambda>v. supd (upd_gobj (if stat then Stat C else Heap (the_Addr a')) 
                         (Inl (fn,C)) 
                         v)))
   ,abupd (if stat then id else np a') s)
   "
 apply (unfold fvar_def)
 apply (simp (no_asm) add: Let_def split_beta)
 done
 
 lemma avar_def2: \<comment> \<open>better suited for simplification\<close> 
 "avar G i' a' s =  
   ((the ((snd(snd(the_Arr (globs (store s) (Heap (the_Addr a')))))) 
            (Inr (the_Intg i')))
    ,(\<lambda>v (x,s').  (raise_if (\<not>G,s'\<turnstile>v fits (fst(the_Arr (globs (store s)
                                                    (Heap (the_Addr a')))))) 
                             ArrStore x
                  ,upd_gobj  (Heap (the_Addr a')) 
                                (Inr (the_Intg i')) v s')))
   ,abupd (raise_if (\<not>(the_Intg i') in_bounds (fst(snd(the_Arr (globs (store s) 
                    (Heap (the_Addr a'))))))) IndOutBound \<circ> np a')
           s)"
 apply (unfold avar_def)
 apply (simp (no_asm) add: Let_def split_beta)
 done
 
 definition
   check_field_access :: "prog \<Rightarrow> qtname \<Rightarrow> qtname \<Rightarrow> vname \<Rightarrow> bool \<Rightarrow> val \<Rightarrow> state \<Rightarrow> state" where
   "check_field_access G accC statDeclC fn stat a' s =
     (let oref = if stat then Stat statDeclC
                 else Heap (the_Addr a');
          dynC = case oref of
                    Heap a \<Rightarrow> obj_class (the (globs (store s) oref))
                  | Stat C \<Rightarrow> C;
          f    = (the (table_of (DeclConcepts.fields G dynC) (fn,statDeclC)))
      in abupd 
         (error_if (\<not> G\<turnstile>Field fn (statDeclC,f) in dynC dyn_accessible_from accC)
                   AccessViolation)
         s)"
 
 definition
   check_method_access :: "prog \<Rightarrow> qtname \<Rightarrow> ref_ty \<Rightarrow> inv_mode \<Rightarrow>  sig \<Rightarrow> val \<Rightarrow> state \<Rightarrow> state" where
   "check_method_access G accC statT mode sig  a' s =
     (let invC = invocation_class mode (store s) a' statT;
        dynM = the (dynlookup G statT invC sig)
      in abupd 
         (error_if (\<not> G\<turnstile>Methd sig dynM in invC dyn_accessible_from accC)
                   AccessViolation)
         s)"
        
 subsubsection "evaluation judgments"
 
 inductive
   halloc :: "[prog,state,obj_tag,loc,state]\<Rightarrow>bool" ("_\<turnstile>_ \<midarrow>halloc _\<succ>_\<rightarrow> _"[61,61,61,61,61]60) for G::prog
 where \<comment> \<open>allocating objects on the heap, cf. 12.5\<close>
 
   Abrupt: 
   "G\<turnstile>(Some x,s) \<midarrow>halloc oi\<succ>undefined\<rightarrow> (Some x,s)"
 
 | New:    "\<lbrakk>new_Addr (heap s) = Some a; 
             (x,oi') = (if atleast_free (heap s) (Suc (Suc 0)) then (None,oi)
                        else (Some (Xcpt (Loc a)),CInst (SXcpt OutOfMemory)))\<rbrakk>
             \<Longrightarrow>
             G\<turnstile>Norm s \<midarrow>halloc oi\<succ>a\<rightarrow> (x,init_obj G oi' (Heap a) s)"
 
 inductive sxalloc :: "[prog,state,state]\<Rightarrow>bool" ("_\<turnstile>_ \<midarrow>sxalloc\<rightarrow> _"[61,61,61]60) for G::prog
 where \<comment> \<open>allocating exception objects for
   standard exceptions (other than OutOfMemory)\<close>
 
   Norm:  "G\<turnstile> Norm              s   \<midarrow>sxalloc\<rightarrow>  Norm             s"
 
 | Jmp:   "G\<turnstile>(Some (Jump j), s)  \<midarrow>sxalloc\<rightarrow> (Some (Jump j), s)"
 
 | Error: "G\<turnstile>(Some (Error e), s)  \<midarrow>sxalloc\<rightarrow> (Some (Error e), s)"
 
 | XcptL: "G\<turnstile>(Some (Xcpt (Loc a) ),s)  \<midarrow>sxalloc\<rightarrow> (Some (Xcpt (Loc a)),s)"
 
 | SXcpt: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>halloc (CInst (SXcpt xn))\<succ>a\<rightarrow> (x,s1)\<rbrakk> \<Longrightarrow>
           G\<turnstile>(Some (Xcpt (Std xn)),s0) \<midarrow>sxalloc\<rightarrow> (Some (Xcpt (Loc a)),s1)"
 
 
 inductive
   eval :: "[prog,state,term,vals,state]\<Rightarrow>bool" ("_\<turnstile>_ \<midarrow>_\<succ>\<rightarrow> '(_, _')"  [61,61,80,0,0]60)
   and exec ::"[prog,state,stmt      ,state]\<Rightarrow>bool"("_\<turnstile>_ \<midarrow>_\<rightarrow> _"   [61,61,65,   61]60)
   and evar ::"[prog,state,var  ,vvar,state]\<Rightarrow>bool"("_\<turnstile>_ \<midarrow>_=\<succ>_\<rightarrow> _"[61,61,90,61,61]60)
   and eval'::"[prog,state,expr ,val ,state]\<Rightarrow>bool"("_\<turnstile>_ \<midarrow>_-\<succ>_\<rightarrow> _"[61,61,80,61,61]60)
   and evals::"[prog,state,expr list ,
                     val  list ,state]\<Rightarrow>bool"("_\<turnstile>_ \<midarrow>_\<doteq>\<succ>_\<rightarrow> _"[61,61,61,61,61]60)
   for G::prog
 where
 
   "G\<turnstile>s \<midarrow>c    \<rightarrow>     s' \<equiv> G\<turnstile>s \<midarrow>In1r c\<succ>\<rightarrow> (\<diamondsuit>,  s')"
 | "G\<turnstile>s \<midarrow>e-\<succ>v \<rightarrow>     s' \<equiv> G\<turnstile>s \<midarrow>In1l e\<succ>\<rightarrow> (In1 v,  s')"
 | "G\<turnstile>s \<midarrow>e=\<succ>vf\<rightarrow>     s' \<equiv> G\<turnstile>s \<midarrow>In2  e\<succ>\<rightarrow> (In2 vf, s')"
 | "G\<turnstile>s \<midarrow>e\<doteq>\<succ>v \<rightarrow>     s' \<equiv> G\<turnstile>s \<midarrow>In3  e\<succ>\<rightarrow> (In3 v,  s')"
 
 \<comment> \<open>propagation of abrupt completion\<close>
 
   \<comment> \<open>cf. 14.1, 15.5\<close>
 | Abrupt: 
    "G\<turnstile>(Some xc,s) \<midarrow>t\<succ>\<rightarrow> (undefined3 t, (Some xc, s))"
 
 
 \<comment> \<open>execution of statements\<close>
 
   \<comment> \<open>cf. 14.5\<close>
 | Skip:                             "G\<turnstile>Norm s \<midarrow>Skip\<rightarrow> Norm s"
 
   \<comment> \<open>cf. 14.7\<close>
 | Expr: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e-\<succ>v\<rightarrow> s1\<rbrakk> \<Longrightarrow>
                                   G\<turnstile>Norm s0 \<midarrow>Expr e\<rightarrow> s1"
 
 | Lab:  "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>c \<rightarrow> s1\<rbrakk> \<Longrightarrow>
                                 G\<turnstile>Norm s0 \<midarrow>l\<bullet> c\<rightarrow> abupd (absorb l) s1"
   \<comment> \<open>cf. 14.2\<close>
 | Comp: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>c1 \<rightarrow> s1;
           G\<turnstile>     s1 \<midarrow>c2 \<rightarrow> s2\<rbrakk> \<Longrightarrow>
                                  G\<turnstile>Norm s0 \<midarrow>c1;; c2\<rightarrow> s2"
 
   \<comment> \<open>cf. 14.8.2\<close>
 | If:   "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e-\<succ>b\<rightarrow> s1;
           G\<turnstile>     s1\<midarrow>(if the_Bool b then c1 else c2)\<rightarrow> s2\<rbrakk> \<Longrightarrow>
                        G\<turnstile>Norm s0 \<midarrow>If(e) c1 Else c2 \<rightarrow> s2"
 
   \<comment> \<open>cf. 14.10, 14.10.1\<close>
   
   \<comment> \<open>A continue jump from the while body \<^term>\<open>c\<close> is handled by 
      this rule. If a continue jump with the proper label was invoked inside 
      \<^term>\<open>c\<close> this label (Cont l) is deleted out of the abrupt component of 
      the state before the iterative evaluation of the while statement.
      A break jump is handled by the Lab Statement \<open>Lab l (while\<dots>)\<close>.\<close>
 | Loop: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e-\<succ>b\<rightarrow> s1;
           if the_Bool b 
              then (G\<turnstile>s1 \<midarrow>c\<rightarrow> s2 \<and> 
                    G\<turnstile>(abupd (absorb (Cont l)) s2) \<midarrow>l\<bullet> While(e) c\<rightarrow> s3)
              else s3 = s1\<rbrakk> \<Longrightarrow>
                               G\<turnstile>Norm s0 \<midarrow>l\<bullet> While(e) c\<rightarrow> s3"
 
 | Jmp: "G\<turnstile>Norm s \<midarrow>Jmp j\<rightarrow> (Some (Jump j), s)"
    
   \<comment> \<open>cf. 14.16\<close>
 | Throw: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e-\<succ>a'\<rightarrow> s1\<rbrakk> \<Longrightarrow>
                                  G\<turnstile>Norm s0 \<midarrow>Throw e\<rightarrow> abupd (throw a') s1"
 
   \<comment> \<open>cf. 14.18.1\<close>
 | Try:  "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>c1\<rightarrow> s1; G\<turnstile>s1 \<midarrow>sxalloc\<rightarrow> s2; 
           if G,s2\<turnstile>catch C then G\<turnstile>new_xcpt_var vn s2 \<midarrow>c2\<rightarrow> s3 else s3 = s2\<rbrakk> \<Longrightarrow>
                   G\<turnstile>Norm s0 \<midarrow>Try c1 Catch(C vn) c2\<rightarrow> s3"
 
   \<comment> \<open>cf. 14.18.2\<close>
 | Fin:  "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>c1\<rightarrow> (x1,s1);
           G\<turnstile>Norm s1 \<midarrow>c2\<rightarrow> s2;
           s3=(if (\<exists> err. x1=Some (Error err)) 
               then (x1,s1) 
               else abupd (abrupt_if (x1\<noteq>None) x1) s2) \<rbrakk> 
           \<Longrightarrow>
           G\<turnstile>Norm s0 \<midarrow>c1 Finally c2\<rightarrow> s3"
   \<comment> \<open>cf. 12.4.2, 8.5\<close>
 | Init: "\<lbrakk>the (class G C) = c;
           if inited C (globs s0) then s3 = Norm s0
           else (G\<turnstile>Norm (init_class_obj G C s0) 
                   \<midarrow>(if C = Object then Skip else Init (super c))\<rightarrow> s1 \<and>
                G\<turnstile>set_lvars Map.empty s1 \<midarrow>init c\<rightarrow> s2 \<and> s3 = restore_lvars s1 s2)\<rbrakk> 
               \<Longrightarrow>
                  G\<turnstile>Norm s0 \<midarrow>Init C\<rightarrow> s3"
    \<comment> \<open>This class initialisation rule is a little bit inaccurate. Look at the
       exact sequence:
       (1) The current class object (the static fields) are initialised
            (\<open>init_class_obj\<close>),
       (2) the superclasses are initialised,
       (3) the static initialiser of the current class is invoked.
       More precisely we should expect another ordering, namely 2 1 3.
       But we can't just naively toggle 1 and 2. By calling 
       \<open>init_class_obj\<close> 
       before initialising the superclasses, we also implicitly record that
       we have started to initialise the current class (by setting an 
       value for the class object). This becomes 
       crucial for the completeness proof of the axiomatic semantics 
       \<open>AxCompl.thy\<close>. Static initialisation requires an induction on 
       the number of classes not yet initialised (or to be more precise, 
       classes were the initialisation has not yet begun). 
       So we could first assign a dummy value to the class before
       superclass initialisation and afterwards set the correct values.
       But as long as we don't take memory overflow into account 
       when allocating class objects, we can leave things as they are for 
       convenience.\<close>
 \<comment> \<open>evaluation of expressions\<close>
 
   \<comment> \<open>cf. 15.8.1, 12.4.1\<close>
 | NewC: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>Init C\<rightarrow> s1;
           G\<turnstile>     s1 \<midarrow>halloc (CInst C)\<succ>a\<rightarrow> s2\<rbrakk> \<Longrightarrow>
                                   G\<turnstile>Norm s0 \<midarrow>NewC C-\<succ>Addr a\<rightarrow> s2"
 
   \<comment> \<open>cf. 15.9.1, 12.4.1\<close>
 | NewA: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>init_comp_ty T\<rightarrow> s1; G\<turnstile>s1 \<midarrow>e-\<succ>i'\<rightarrow> s2; 
           G\<turnstile>abupd (check_neg i') s2 \<midarrow>halloc (Arr T (the_Intg i'))\<succ>a\<rightarrow> s3\<rbrakk> \<Longrightarrow>
                                 G\<turnstile>Norm s0 \<midarrow>New T[e]-\<succ>Addr a\<rightarrow> s3"
 
   \<comment> \<open>cf. 15.15\<close>
 | Cast: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e-\<succ>v\<rightarrow> s1;
           s2 = abupd (raise_if (\<not>G,store s1\<turnstile>v fits T) ClassCast) s1\<rbrakk> \<Longrightarrow>
                                 G\<turnstile>Norm s0 \<midarrow>Cast T e-\<succ>v\<rightarrow> s2"
 
   \<comment> \<open>cf. 15.19.2\<close>
 | Inst: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e-\<succ>v\<rightarrow> s1;
           b = (v\<noteq>Null \<and> G,store s1\<turnstile>v fits RefT T)\<rbrakk> \<Longrightarrow>
                               G\<turnstile>Norm s0 \<midarrow>e InstOf T-\<succ>Bool b\<rightarrow> s1"
 
   \<comment> \<open>cf. 15.7.1\<close>
 | Lit:  "G\<turnstile>Norm s \<midarrow>Lit v-\<succ>v\<rightarrow> Norm s"
 
 | UnOp: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e-\<succ>v\<rightarrow> s1\<rbrakk> 
          \<Longrightarrow> G\<turnstile>Norm s0 \<midarrow>UnOp unop e-\<succ>(eval_unop unop v)\<rightarrow> s1"
  
 | BinOp: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e1-\<succ>v1\<rightarrow> s1; 
           G\<turnstile>s1 \<midarrow>(if need_second_arg binop v1 then (In1l e2) else (In1r Skip))
                 \<succ>\<rightarrow> (In1 v2, s2)
           \<rbrakk> 
          \<Longrightarrow> G\<turnstile>Norm s0 \<midarrow>BinOp binop e1 e2-\<succ>(eval_binop binop v1 v2)\<rightarrow> s2"
    
   \<comment> \<open>cf. 15.10.2\<close>
 | Super: "G\<turnstile>Norm s \<midarrow>Super-\<succ>val_this s\<rightarrow> Norm s"
 
   \<comment> \<open>cf. 15.2\<close>
 | Acc:  "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>va=\<succ>(v,f)\<rightarrow> s1\<rbrakk> \<Longrightarrow>
                                   G\<turnstile>Norm s0 \<midarrow>Acc va-\<succ>v\<rightarrow> s1"
 
   \<comment> \<open>cf. 15.25.1\<close>
 | Ass:  "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>va=\<succ>(w,f)\<rightarrow> s1;
           G\<turnstile>     s1 \<midarrow>e-\<succ>v  \<rightarrow> s2\<rbrakk> \<Longrightarrow>
                                    G\<turnstile>Norm s0 \<midarrow>va:=e-\<succ>v\<rightarrow> assign f v s2"
 
   \<comment> \<open>cf. 15.24\<close>
 | Cond: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e0-\<succ>b\<rightarrow> s1;
           G\<turnstile>     s1 \<midarrow>(if the_Bool b then e1 else e2)-\<succ>v\<rightarrow> s2\<rbrakk> \<Longrightarrow>
                             G\<turnstile>Norm s0 \<midarrow>e0 ? e1 : e2-\<succ>v\<rightarrow> s2"
 
 
 \<comment> \<open>The interplay of  \<^term>\<open>Call\<close>, \<^term>\<open>Methd\<close> and \<^term>\<open>Body\<close>:
       Method invocation is split up into these three rules:
       \begin{itemize}
       \item [\<^term>\<open>Call\<close>] Calculates the target address and evaluates the
                            arguments of the method, and then performs dynamic
                            or static lookup of the method, corresponding to the
                            call mode. Then the \<^term>\<open>Methd\<close> rule is evaluated
                            on the calculated declaration class of the method
                            invocation.
       \item [\<^term>\<open>Methd\<close>] A syntactic bridge for the folded method body.
                             It is used by the axiomatic semantics to add the
                             proper hypothesis for recursive calls of the method.
       \item [\<^term>\<open>Body\<close>] An extra syntactic entity for the unfolded method
                            body was introduced to properly trigger class 
                            initialisation. Without class initialisation we 
                            could just evaluate the body statement. 
       \end{itemize}\<close>
   \<comment> \<open>cf. 15.11.4.1, 15.11.4.2, 15.11.4.4, 15.11.4.5\<close>
 | Call: 
   "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e-\<succ>a'\<rightarrow> s1; G\<turnstile>s1 \<midarrow>args\<doteq>\<succ>vs\<rightarrow> s2;
     D = invocation_declclass G mode (store s2) a' statT \<lparr>name=mn,parTs=pTs\<rparr>;
     s3=init_lvars G D \<lparr>name=mn,parTs=pTs\<rparr> mode a' vs s2;
     s3' = check_method_access G accC statT mode \<lparr>name=mn,parTs=pTs\<rparr> a' s3;
     G\<turnstile>s3' \<midarrow>Methd D \<lparr>name=mn,parTs=pTs\<rparr>-\<succ>v\<rightarrow> s4\<rbrakk>
    \<Longrightarrow>
        G\<turnstile>Norm s0 \<midarrow>{accC,statT,mode}e\<cdot>mn({pTs}args)-\<succ>v\<rightarrow> (restore_lvars s2 s4)"
 \<comment> \<open>The accessibility check is after \<^term>\<open>init_lvars\<close>, to keep it simple. 
    \<^term>\<open>init_lvars\<close> already tests for the absence of a null-pointer 
    reference in case of an instance method invocation.\<close>
 
 | Methd:        "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>body G D sig-\<succ>v\<rightarrow> s1\<rbrakk> \<Longrightarrow>
                                 G\<turnstile>Norm s0 \<midarrow>Methd D sig-\<succ>v\<rightarrow> s1"
   
 | Body: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>Init D\<rightarrow> s1; G\<turnstile>s1 \<midarrow>c\<rightarrow> s2; 
           s3 = (if (\<exists> l. abrupt s2 = Some (Jump (Break l)) \<or>  
                          abrupt s2 = Some (Jump (Cont l)))
                   then abupd (\<lambda> x. Some (Error CrossMethodJump)) s2 
                   else s2)\<rbrakk> \<Longrightarrow>
            G\<turnstile>Norm s0 \<midarrow>Body D c-\<succ>the (locals (store s2) Result)
               \<rightarrow>abupd (absorb Ret) s3"
   \<comment> \<open>cf. 14.15, 12.4.1\<close>
   \<comment> \<open>We filter out a break/continue in \<^term>\<open>s2\<close>, so that we can proof 
      definite assignment
      correct, without the need of conformance of the state. By this the
      different parts of the typesafety proof can be disentangled a little.\<close>
 
 \<comment> \<open>evaluation of variables\<close>
 
   \<comment> \<open>cf. 15.13.1, 15.7.2\<close>
 | LVar: "G\<turnstile>Norm s \<midarrow>LVar vn=\<succ>lvar vn s\<rightarrow> Norm s"
 
   \<comment> \<open>cf. 15.10.1, 12.4.1\<close>
 | FVar: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>Init statDeclC\<rightarrow> s1; G\<turnstile>s1 \<midarrow>e-\<succ>a\<rightarrow> s2;
           (v,s2') = fvar statDeclC stat fn a s2;
           s3 = check_field_access G accC statDeclC fn stat a s2' \<rbrakk> \<Longrightarrow>
           G\<turnstile>Norm s0 \<midarrow>{accC,statDeclC,stat}e..fn=\<succ>v\<rightarrow> s3"
  \<comment> \<open>The accessibility check is after \<^term>\<open>fvar\<close>, to keep it simple. 
     \<^term>\<open>fvar\<close> already tests for the absence of a null-pointer reference 
     in case of an instance field\<close>
 
   \<comment> \<open>cf. 15.12.1, 15.25.1\<close>
 | AVar: "\<lbrakk>G\<turnstile> Norm s0 \<midarrow>e1-\<succ>a\<rightarrow> s1; G\<turnstile>s1 \<midarrow>e2-\<succ>i\<rightarrow> s2;
           (v,s2') = avar G i a s2\<rbrakk> \<Longrightarrow>
                       G\<turnstile>Norm s0 \<midarrow>e1.[e2]=\<succ>v\<rightarrow> s2'"
 
 
 \<comment> \<open>evaluation of expression lists\<close>
 
   \<comment> \<open>cf. 15.11.4.2\<close>
 | Nil:
                                     "G\<turnstile>Norm s0 \<midarrow>[]\<doteq>\<succ>[]\<rightarrow> Norm s0"
 
   \<comment> \<open>cf. 15.6.4\<close>
 | Cons: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e -\<succ> v \<rightarrow> s1;
           G\<turnstile>     s1 \<midarrow>es\<doteq>\<succ>vs\<rightarrow> s2\<rbrakk> \<Longrightarrow>
                                    G\<turnstile>Norm s0 \<midarrow>e#es\<doteq>\<succ>v#vs\<rightarrow> s2"
 
 (* Rearrangement of premisses:
 [0,1(Abrupt),2(Skip),8(Jmp),4(Lab),30(Nil),31(Cons),27(LVar),17(Cast),18(Inst),
  17(Lit),18(UnOp),19(BinOp),20(Super),21(Acc),3(Expr),5(Comp),25(Methd),26(Body),23(Cond),6(If),
  7(Loop),11(Fin),9(Throw),13(NewC),14(NewA),12(Init),22(Ass),10(Try),28(FVar),
  29(AVar),24(Call)]
 *)
 
 ML \<open>
 ML_Thms.bind_thm ("eval_induct", rearrange_prems 
 [0,1,2,8,4,30,31,27,15,16,
  17,18,19,20,21,3,5,25,26,23,6,
  7,11,9,13,14,12,22,10,28,
  29,24] @{thm eval.induct})
 \<close>
 
 
 declare if_split     [split del] if_split_asm     [split del] 
         option.split [split del] option.split_asm [split del]
 inductive_cases halloc_elim_cases: 
   "G\<turnstile>(Some xc,s) \<midarrow>halloc oi\<succ>a\<rightarrow> s'"
   "G\<turnstile>(Norm    s) \<midarrow>halloc oi\<succ>a\<rightarrow> s'"
 
 inductive_cases sxalloc_elim_cases:
         "G\<turnstile> Norm                 s  \<midarrow>sxalloc\<rightarrow> s'"
         "G\<turnstile>(Some (Jump j),s) \<midarrow>sxalloc\<rightarrow> s'"
         "G\<turnstile>(Some (Error e),s) \<midarrow>sxalloc\<rightarrow> s'"
         "G\<turnstile>(Some (Xcpt (Loc a )),s) \<midarrow>sxalloc\<rightarrow> s'"
         "G\<turnstile>(Some (Xcpt (Std xn)),s) \<midarrow>sxalloc\<rightarrow> s'"
 inductive_cases sxalloc_cases: "G\<turnstile>s \<midarrow>sxalloc\<rightarrow> s'"
 
 lemma sxalloc_elim_cases2: "\<lbrakk>G\<turnstile>s \<midarrow>sxalloc\<rightarrow> s';  
        \<And>s.   \<lbrakk>s' = Norm s\<rbrakk> \<Longrightarrow> P;  
        \<And>j s. \<lbrakk>s' = (Some (Jump j),s)\<rbrakk> \<Longrightarrow> P;
        \<And>e s. \<lbrakk>s' = (Some (Error e),s)\<rbrakk> \<Longrightarrow> P;
        \<And>a s. \<lbrakk>s' = (Some (Xcpt (Loc a)),s)\<rbrakk> \<Longrightarrow> P  
       \<rbrakk> \<Longrightarrow> P"
 apply cut_tac 
 apply (erule sxalloc_cases)
 apply blast+
 done
 
 declare not_None_eq [simp del] (* IntDef.Zero_def [simp del] *)
 declare split_paired_All [simp del] split_paired_Ex [simp del]
 setup \<open>map_theory_simpset (fn ctxt => ctxt delloop "split_all_tac")\<close>
 
 inductive_cases eval_cases: "G\<turnstile>s \<midarrow>t\<succ>\<rightarrow> (v, s')"
 
 inductive_cases eval_elim_cases [cases set]:
         "G\<turnstile>(Some xc,s) \<midarrow>t                              \<succ>\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1r Skip                           \<succ>\<rightarrow> (x, s')"
         "G\<turnstile>Norm s \<midarrow>In1r (Jmp j)                        \<succ>\<rightarrow> (x, s')"
         "G\<turnstile>Norm s \<midarrow>In1r (l\<bullet> c)                         \<succ>\<rightarrow> (x, s')"
         "G\<turnstile>Norm s \<midarrow>In3  ([])                           \<succ>\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In3  (e#es)                         \<succ>\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1l (Lit w)                        \<succ>\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1l (UnOp unop e)                  \<succ>\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1l (BinOp binop e1 e2)            \<succ>\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In2  (LVar vn)                      \<succ>\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1l (Cast T e)                     \<succ>\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1l (e InstOf T)                   \<succ>\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1l (Super)                        \<succ>\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1l (Acc va)                       \<succ>\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1r (Expr e)                       \<succ>\<rightarrow> (x, s')"
         "G\<turnstile>Norm s \<midarrow>In1r (c1;; c2)                      \<succ>\<rightarrow> (x, s')"
         "G\<turnstile>Norm s \<midarrow>In1l (Methd C sig)                  \<succ>\<rightarrow> (x, s')"
         "G\<turnstile>Norm s \<midarrow>In1l (Body D c)                     \<succ>\<rightarrow> (x, s')"
         "G\<turnstile>Norm s \<midarrow>In1l (e0 ? e1 : e2)                 \<succ>\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1r (If(e) c1 Else c2)             \<succ>\<rightarrow> (x, s')"
         "G\<turnstile>Norm s \<midarrow>In1r (l\<bullet> While(e) c)                \<succ>\<rightarrow> (x, s')"
         "G\<turnstile>Norm s \<midarrow>In1r (c1 Finally c2)                \<succ>\<rightarrow> (x, s')"
         "G\<turnstile>Norm s \<midarrow>In1r (Throw e)                      \<succ>\<rightarrow> (x, s')"
         "G\<turnstile>Norm s \<midarrow>In1l (NewC C)                       \<succ>\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1l (New T[e])                     \<succ>\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1l (Ass va e)                     \<succ>\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1r (Try c1 Catch(tn vn) c2)       \<succ>\<rightarrow> (x, s')"
         "G\<turnstile>Norm s \<midarrow>In2  ({accC,statDeclC,stat}e..fn)   \<succ>\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In2  (e1.[e2])                      \<succ>\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1l ({accC,statT,mode}e\<cdot>mn({pT}p)) \<succ>\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1r (Init C)                       \<succ>\<rightarrow> (x, s')"
 declare not_None_eq [simp]  (* IntDef.Zero_def [simp] *)
 declare split_paired_All [simp] split_paired_Ex [simp]
 declaration \<open>K (Simplifier.map_ss (fn ss => ss addloop ("split_all_tac", split_all_tac)))\<close>
 declare if_split     [split] if_split_asm     [split] 
         option.split [split] option.split_asm [split]
 
 lemma eval_Inj_elim: 
  "G\<turnstile>s \<midarrow>t\<succ>\<rightarrow> (w,s') 
  \<Longrightarrow> case t of 
        In1 ec \<Rightarrow> (case ec of 
                     Inl e \<Rightarrow> (\<exists>v. w = In1 v) 
                   | Inr c \<Rightarrow> w = \<diamondsuit>)  
      | In2 e \<Rightarrow> (\<exists>v. w = In2 v) 
      | In3 e \<Rightarrow> (\<exists>v. w = In3 v)"
 apply (erule eval_cases)
 apply auto
 apply (induct_tac "t")
 apply (rename_tac a, induct_tac "a")
 apply auto
 done
 
 text \<open>The following simplification procedures set up the proper injections of
  terms and their corresponding values in the evaluation relation:
  E.g. an expression 
  (injection \<^term>\<open>In1l\<close> into terms) always evaluates to ordinary values 
  (injection \<^term>\<open>In1\<close> into generalised values \<^term>\<open>vals\<close>). 
 \<close>
 
 lemma eval_expr_eq: "G\<turnstile>s \<midarrow>In1l t\<succ>\<rightarrow> (w, s') = (\<exists>v. w=In1 v \<and> G\<turnstile>s \<midarrow>t-\<succ>v \<rightarrow> s')"
   by (auto, frule eval_Inj_elim, auto)
 
 lemma eval_var_eq: "G\<turnstile>s \<midarrow>In2 t\<succ>\<rightarrow> (w, s') = (\<exists>vf. w=In2 vf \<and> G\<turnstile>s \<midarrow>t=\<succ>vf\<rightarrow> s')"
   by (auto, frule eval_Inj_elim, auto)
 
 lemma eval_exprs_eq: "G\<turnstile>s \<midarrow>In3 t\<succ>\<rightarrow> (w, s') = (\<exists>vs. w=In3 vs \<and> G\<turnstile>s \<midarrow>t\<doteq>\<succ>vs\<rightarrow> s')"
   by (auto, frule eval_Inj_elim, auto)
 
 lemma eval_stmt_eq: "G\<turnstile>s \<midarrow>In1r t\<succ>\<rightarrow> (w, s') = (w=\<diamondsuit> \<and> G\<turnstile>s \<midarrow>t \<rightarrow> s')"
   by (auto, frule eval_Inj_elim, auto, frule eval_Inj_elim, auto)
 
 simproc_setup eval_expr ("G\<turnstile>s \<midarrow>In1l t\<succ>\<rightarrow> (w, s')") = \<open>
-  fn _ => fn _ => fn ct =>
-    (case Thm.term_of ct of
-      (_ $ _ $ _ $ _ $ (Const _ $ _) $ _) => NONE
-    | _ => SOME (mk_meta_eq @{thm eval_expr_eq}))\<close>
-
-simproc_setup eval_var ("G\<turnstile>s \<midarrow>In2 t\<succ>\<rightarrow> (w, s')") = \<open>
-  fn _ => fn _ => fn ct =>
+  K (K (fn ct =>
     (case Thm.term_of ct of
       (_ $ _ $ _ $ _ $ (Const _ $ _) $ _) => NONE
-    | _ => SOME (mk_meta_eq @{thm eval_var_eq}))\<close>
+    | _ => SOME (mk_meta_eq @{thm eval_expr_eq}))))\<close>
 
-simproc_setup eval_exprs ("G\<turnstile>s \<midarrow>In3 t\<succ>\<rightarrow> (w, s')") = \<open>
-  fn _ => fn _ => fn ct =>
+simproc_setup eval_var ("G\<turnstile>s \<midarrow>In2 t\<succ>\<rightarrow> (w, s')") = \<open>
+  K (K (fn ct =>
     (case Thm.term_of ct of
       (_ $ _ $ _ $ _ $ (Const _ $ _) $ _) => NONE
-    | _ => SOME (mk_meta_eq @{thm eval_exprs_eq}))\<close>
+    | _ => SOME (mk_meta_eq @{thm eval_var_eq}))))\<close>
+
+simproc_setup eval_exprs ("G\<turnstile>s \<midarrow>In3 t\<succ>\<rightarrow> (w, s')") = \<open>
+  K (K (fn ct =>
+    (case Thm.term_of ct of
+      (_ $ _ $ _ $ _ $ (Const _ $ _) $ _) => NONE
+    | _ => SOME (mk_meta_eq @{thm eval_exprs_eq}))))\<close>
 
 simproc_setup eval_stmt ("G\<turnstile>s \<midarrow>In1r t\<succ>\<rightarrow> (w, s')") = \<open>
-  fn _ => fn _ => fn ct =>
+  K (K (fn ct =>
     (case Thm.term_of ct of
       (_ $ _ $ _ $ _ $ (Const _ $ _) $ _) => NONE
-    | _ => SOME (mk_meta_eq @{thm eval_stmt_eq}))\<close>
+    | _ => SOME (mk_meta_eq @{thm eval_stmt_eq}))))\<close>
 
 ML \<open>
 ML_Thms.bind_thms ("AbruptIs", sum3_instantiate \<^context> @{thm eval.Abrupt})
 \<close>
 
 declare halloc.Abrupt [intro!] eval.Abrupt [intro!]  AbruptIs [intro!]
 
 text\<open>\<open>Callee\<close>,\<open>InsInitE\<close>, \<open>InsInitV\<close>, \<open>FinA\<close> are only
 used in smallstep semantics, not in the bigstep semantics. So their is no
 valid evaluation of these terms 
 \<close>
 
 
 lemma eval_Callee: "G\<turnstile>Norm s\<midarrow>Callee l e-\<succ>v\<rightarrow> s' = False"
 proof -
   { fix s t v s'
     assume eval: "G\<turnstile>s \<midarrow>t\<succ>\<rightarrow> (v,s')" and
          normal: "normal s" and
          callee: "t=In1l (Callee l e)"
     then have "False" by induct auto
   }  
   then show ?thesis
     by (cases s') fastforce
 qed
 
 
 lemma eval_InsInitE: "G\<turnstile>Norm s\<midarrow>InsInitE c e-\<succ>v\<rightarrow> s' = False"
 proof -
   { fix s t v s'
     assume eval: "G\<turnstile>s \<midarrow>t\<succ>\<rightarrow> (v,s')" and
          normal: "normal s" and
          callee: "t=In1l (InsInitE c e)"
     then have "False" by induct auto
   }
   then show ?thesis
     by (cases s') fastforce
 qed
 
 lemma eval_InsInitV: "G\<turnstile>Norm s\<midarrow>InsInitV c w=\<succ>v\<rightarrow> s' = False"
 proof -
   { fix s t v s'
     assume eval: "G\<turnstile>s \<midarrow>t\<succ>\<rightarrow> (v,s')" and
          normal: "normal s" and
          callee: "t=In2 (InsInitV c w)"
     then have "False" by induct auto
   }  
   then show ?thesis
     by (cases s') fastforce
 qed
 
 lemma eval_FinA: "G\<turnstile>Norm s\<midarrow>FinA a c\<rightarrow> s' = False"
 proof -
   { fix s t v s'
     assume eval: "G\<turnstile>s \<midarrow>t\<succ>\<rightarrow> (v,s')" and
          normal: "normal s" and
          callee: "t=In1r (FinA a c)"
     then have "False" by induct auto
   }  
   then show ?thesis
     by (cases s') fastforce 
 qed
 
 lemma eval_no_abrupt_lemma: 
    "\<And>s s'. G\<turnstile>s \<midarrow>t\<succ>\<rightarrow> (w,s') \<Longrightarrow> normal s' \<longrightarrow> normal s"
 by (erule eval_cases, auto)
 
 lemma eval_no_abrupt: 
   "G\<turnstile>(x,s) \<midarrow>t\<succ>\<rightarrow> (w,Norm s') = 
         (x = None \<and> G\<turnstile>Norm s \<midarrow>t\<succ>\<rightarrow> (w,Norm s'))"
 apply auto
 apply (frule eval_no_abrupt_lemma, auto)+
 done
 
 simproc_setup eval_no_abrupt ("G\<turnstile>(x,s) \<midarrow>e\<succ>\<rightarrow> (w,Norm s')") = \<open>
-  fn _ => fn _ => fn ct =>
+  K (K (fn ct =>
     (case Thm.term_of ct of
       (_ $ _ $ (Const (\<^const_name>\<open>Pair\<close>, _) $ (Const (\<^const_name>\<open>None\<close>, _)) $ _) $ _  $ _ $ _) => NONE
-    | _ => SOME (mk_meta_eq @{thm eval_no_abrupt}))
+    | _ => SOME (mk_meta_eq @{thm eval_no_abrupt}))))
 \<close>
 
 
 lemma eval_abrupt_lemma: 
   "G\<turnstile>s \<midarrow>t\<succ>\<rightarrow> (v,s') \<Longrightarrow> abrupt s=Some xc \<longrightarrow> s'= s \<and> v = undefined3 t"
 by (erule eval_cases, auto)
 
 lemma eval_abrupt: 
  " G\<turnstile>(Some xc,s) \<midarrow>t\<succ>\<rightarrow> (w,s') =  
      (s'=(Some xc,s) \<and> w=undefined3 t \<and> 
      G\<turnstile>(Some xc,s) \<midarrow>t\<succ>\<rightarrow> (undefined3 t,(Some xc,s)))"
 apply auto
 apply (frule eval_abrupt_lemma, auto)+
 done
 
 simproc_setup eval_abrupt ("G\<turnstile>(Some xc,s) \<midarrow>e\<succ>\<rightarrow> (w,s')") = \<open>
-  fn _ => fn _ => fn ct =>
+  K (K (fn ct =>
     (case Thm.term_of ct of
       (_ $ _ $ _ $ _ $ _ $ (Const (\<^const_name>\<open>Pair\<close>, _) $ (Const (\<^const_name>\<open>Some\<close>, _) $ _)$ _)) => NONE
-    | _ => SOME (mk_meta_eq @{thm eval_abrupt}))
+    | _ => SOME (mk_meta_eq @{thm eval_abrupt}))))
 \<close>
 
 lemma LitI: "G\<turnstile>s \<midarrow>Lit v-\<succ>(if normal s then v else undefined)\<rightarrow> s"
 apply (case_tac "s", case_tac "a = None")
 by (auto intro!: eval.Lit)
 
 lemma SkipI [intro!]: "G\<turnstile>s \<midarrow>Skip\<rightarrow> s"
 apply (case_tac "s", case_tac "a = None")
 by (auto intro!: eval.Skip)
 
 lemma ExprI: "G\<turnstile>s \<midarrow>e-\<succ>v\<rightarrow> s' \<Longrightarrow> G\<turnstile>s \<midarrow>Expr e\<rightarrow> s'"
 apply (case_tac "s", case_tac "a = None")
 by (auto intro!: eval.Expr)
 
 lemma CompI: "\<lbrakk>G\<turnstile>s \<midarrow>c1\<rightarrow> s1; G\<turnstile>s1 \<midarrow>c2\<rightarrow> s2\<rbrakk> \<Longrightarrow> G\<turnstile>s \<midarrow>c1;; c2\<rightarrow> s2"
 apply (case_tac "s", case_tac "a = None")
 by (auto intro!: eval.Comp)
 
 lemma CondI: 
   "\<And>s1. \<lbrakk>G\<turnstile>s \<midarrow>e-\<succ>b\<rightarrow> s1; G\<turnstile>s1 \<midarrow>(if the_Bool b then e1 else e2)-\<succ>v\<rightarrow> s2\<rbrakk> \<Longrightarrow> 
          G\<turnstile>s \<midarrow>e ? e1 : e2-\<succ>(if normal s1 then v else undefined)\<rightarrow> s2"
 apply (case_tac "s", case_tac "a = None")
 by (auto intro!: eval.Cond)
 
 lemma IfI: "\<lbrakk>G\<turnstile>s \<midarrow>e-\<succ>v\<rightarrow> s1; G\<turnstile>s1 \<midarrow>(if the_Bool v then c1 else c2)\<rightarrow> s2\<rbrakk>
                  \<Longrightarrow> G\<turnstile>s \<midarrow>If(e) c1 Else c2\<rightarrow> s2"
 apply (case_tac "s", case_tac "a = None")
 by (auto intro!: eval.If)
 
 lemma MethdI: "G\<turnstile>s \<midarrow>body G C sig-\<succ>v\<rightarrow> s' 
                 \<Longrightarrow> G\<turnstile>s \<midarrow>Methd C sig-\<succ>v\<rightarrow> s'"
 apply (case_tac "s", case_tac "a = None")
 by (auto intro!: eval.Methd)
 
 lemma eval_Call: 
    "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e-\<succ>a'\<rightarrow> s1; G\<turnstile>s1 \<midarrow>ps\<doteq>\<succ>pvs\<rightarrow> s2;  
      D = invocation_declclass G mode (store s2) a' statT \<lparr>name=mn,parTs=pTs\<rparr>;
      s3 = init_lvars G D \<lparr>name=mn,parTs=pTs\<rparr> mode a' pvs s2;
      s3' = check_method_access G accC statT mode \<lparr>name=mn,parTs=pTs\<rparr> a' s3;
      G\<turnstile>s3'\<midarrow>Methd D \<lparr>name=mn,parTs=pTs\<rparr>-\<succ> v\<rightarrow> s4; 
        s4' = restore_lvars s2 s4\<rbrakk> \<Longrightarrow>  
        G\<turnstile>Norm s0 \<midarrow>{accC,statT,mode}e\<cdot>mn({pTs}ps)-\<succ>v\<rightarrow> s4'"
 apply (drule eval.Call, assumption)
 apply (rule HOL.refl)
 apply simp+
 done
 
 lemma eval_Init: 
 "\<lbrakk>if inited C (globs s0) then s3 = Norm s0 
   else G\<turnstile>Norm (init_class_obj G C s0)  
          \<midarrow>(if C = Object then Skip else Init (super (the (class G C))))\<rightarrow> s1 \<and>
        G\<turnstile>set_lvars Map.empty s1 \<midarrow>(init (the (class G C)))\<rightarrow> s2 \<and> 
       s3 = restore_lvars s1 s2\<rbrakk> \<Longrightarrow>  
   G\<turnstile>Norm s0 \<midarrow>Init C\<rightarrow> s3"
 apply (rule eval.Init)
 apply auto
 done
 
 lemma init_done: "initd C s \<Longrightarrow> G\<turnstile>s \<midarrow>Init C\<rightarrow> s"
 apply (case_tac "s", simp)
 apply (case_tac "a")
 apply  safe
 apply (rule eval_Init)
 apply   auto
 done
 
 lemma eval_StatRef: 
 "G\<turnstile>s \<midarrow>StatRef rt-\<succ>(if abrupt s=None then Null else undefined)\<rightarrow> s"
 apply (case_tac "s", simp)
 apply (case_tac "a = None")
 apply (auto del: eval.Abrupt intro!: eval.intros)
 done
 
 
 lemma SkipD [dest!]: "G\<turnstile>s \<midarrow>Skip\<rightarrow> s' \<Longrightarrow> s' = s" 
 apply (erule eval_cases)
 by auto
 
 lemma Skip_eq [simp]: "G\<turnstile>s \<midarrow>Skip\<rightarrow> s' = (s = s')"
 by auto
 
 (*unused*)
 lemma init_retains_locals [rule_format (no_asm)]: "G\<turnstile>s \<midarrow>t\<succ>\<rightarrow> (w,s') \<Longrightarrow>  
   (\<forall>C. t=In1r (Init C) \<longrightarrow> locals (store s) = locals (store s'))"
 apply (erule eval.induct)
 apply (simp (no_asm_use) split del: if_split_asm option.split_asm)+
 apply auto
 done
 
 lemma halloc_xcpt [dest!]: 
   "\<And>s'. G\<turnstile>(Some xc,s) \<midarrow>halloc oi\<succ>a\<rightarrow> s' \<Longrightarrow> s'=(Some xc,s)"
 apply (erule_tac halloc_elim_cases)
 by auto
 
 (*
 G\<turnstile>(x,(h,l)) \<midarrow>e\<succ>v\<rightarrow> (x',(h',l'))) \<Longrightarrow> l This = l' This"
 G\<turnstile>(x,(h,l)) \<midarrow>s  \<rightarrow> (x',(h',l'))) \<Longrightarrow> l This = l' This"
 *)
 
 lemma eval_Methd: 
   "G\<turnstile>s \<midarrow>In1l(body G C sig)\<succ>\<rightarrow> (w,s') 
    \<Longrightarrow> G\<turnstile>s \<midarrow>In1l(Methd C sig)\<succ>\<rightarrow> (w,s')"
 apply (case_tac "s")
 apply (case_tac "a")
 apply clarsimp+
 apply (erule eval.Methd)
 apply (drule eval_abrupt_lemma)
 apply force
 done
 
 lemma eval_Body: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>Init D\<rightarrow> s1; G\<turnstile>s1 \<midarrow>c\<rightarrow> s2;
                    res=the (locals (store s2) Result);
                    s3 = (if (\<exists> l. abrupt s2 = Some (Jump (Break l)) \<or>
                                   abrupt s2 = Some (Jump (Cont l))) 
                    then abupd (\<lambda> x. Some (Error CrossMethodJump)) s2 
                    else s2);
                    s4=abupd (absorb Ret) s3\<rbrakk> \<Longrightarrow>
  G\<turnstile>Norm s0 \<midarrow>Body D c-\<succ>res\<rightarrow>s4"
 by (auto elim: eval.Body)
 
 lemma eval_binop_arg2_indep:
 "\<not> need_second_arg binop v1 \<Longrightarrow> eval_binop binop v1 x = eval_binop binop v1 y"
 by (cases binop)
    (simp_all add: need_second_arg_def)
 
 
 lemma eval_BinOp_arg2_indepI:
   assumes eval_e1: "G\<turnstile>Norm s0 \<midarrow>e1-\<succ>v1\<rightarrow> s1" and
           no_need: "\<not> need_second_arg binop v1" 
   shows "G\<turnstile>Norm s0 \<midarrow>BinOp binop e1 e2-\<succ>(eval_binop binop v1 v2)\<rightarrow> s1"
          (is "?EvalBinOp v2")
 proof -
   from eval_e1 
   have "?EvalBinOp Unit" 
     by (rule eval.BinOp)
        (simp add: no_need)
   moreover
   from no_need 
   have "eval_binop binop v1 Unit = eval_binop binop v1 v2"
     by (simp add: eval_binop_arg2_indep)
   ultimately
   show ?thesis
     by simp
 qed
 
 
 subsubsection "single valued"
 
 lemma unique_halloc [rule_format (no_asm)]: 
   "G\<turnstile>s \<midarrow>halloc oi\<succ>a \<rightarrow> s' \<Longrightarrow> G\<turnstile>s \<midarrow>halloc oi\<succ>a' \<rightarrow> s'' \<longrightarrow> a' = a \<and> s'' = s'"
 apply (erule halloc.induct)
 apply  (auto elim!: halloc_elim_cases split del: if_split if_split_asm)
 apply (drule trans [THEN sym], erule sym) 
 defer
 apply (drule trans [THEN sym], erule sym)
 apply auto
 done
 
 
 lemma single_valued_halloc: 
   "single_valued {((s,oi),(a,s')). G\<turnstile>s \<midarrow>halloc oi\<succ>a \<rightarrow> s'}"
 apply (unfold single_valued_def)
 by (clarsimp, drule (1) unique_halloc, auto)
 
 
 lemma unique_sxalloc [rule_format (no_asm)]: 
   "G\<turnstile>s \<midarrow>sxalloc\<rightarrow> s' \<Longrightarrow> G\<turnstile>s \<midarrow>sxalloc\<rightarrow> s'' \<longrightarrow> s'' = s'"
 apply (erule sxalloc.induct)
 apply   (auto dest: unique_halloc elim!: sxalloc_elim_cases 
               split del: if_split if_split_asm)
 done
 
 lemma single_valued_sxalloc: "single_valued {(s,s'). G\<turnstile>s \<midarrow>sxalloc\<rightarrow> s'}"
 apply (unfold single_valued_def)
 apply (blast dest: unique_sxalloc)
 done
 
 lemma split_pairD: "(x,y) = p \<Longrightarrow> x = fst p & y = snd p"
 by auto
 
 
 
 lemma unique_eval [rule_format (no_asm)]: 
   "G\<turnstile>s \<midarrow>t\<succ>\<rightarrow> (w, s') \<Longrightarrow> (\<forall>w' s''. G\<turnstile>s \<midarrow>t\<succ>\<rightarrow> (w', s'') \<longrightarrow> w' = w \<and> s'' = s')"
 apply (erule eval_induct)
 apply (tactic \<open>ALLGOALS (EVERY'
       [strip_tac \<^context>, rotate_tac ~1, eresolve_tac \<^context> @{thms eval_elim_cases}])\<close>)
 (* 31 subgoals *)
 prefer 28 (* Try *) 
 apply (simp (no_asm_use) only: split: if_split_asm)
 (* 34 subgoals *)
 prefer 30 (* Init *)
 apply (case_tac "inited C (globs s0)", (simp only: if_True if_False simp_thms)+)
 prefer 26 (* While *)
 apply (simp (no_asm_use) only: split: if_split_asm, blast)
 (* 36 subgoals *)
 apply (blast dest: unique_sxalloc unique_halloc split_pairD)+
 done
 
 (* unused *)
 lemma single_valued_eval: 
  "single_valued {((s, t), (v, s')). G\<turnstile>s \<midarrow>t\<succ>\<rightarrow> (v, s')}"
 apply (unfold single_valued_def)
 by (clarify, drule (1) unique_eval, auto)
 
 end
diff --git a/src/HOL/Bali/Evaln.thy b/src/HOL/Bali/Evaln.thy
--- a/src/HOL/Bali/Evaln.thy
+++ b/src/HOL/Bali/Evaln.thy
@@ -1,832 +1,832 @@
 (*  Title:      HOL/Bali/Evaln.thy
     Author:     David von Oheimb and Norbert Schirmer
 *)
 subsection \<open>Operational evaluation (big-step) semantics of Java expressions and 
           statements
 \<close>
 
 theory Evaln imports TypeSafe begin
 
 
 text \<open>
 Variant of \<^term>\<open>eval\<close> relation with counter for bounded recursive depth. 
 In principal \<^term>\<open>evaln\<close> could replace \<^term>\<open>eval\<close>.
 
 Validity of the axiomatic semantics builds on \<^term>\<open>evaln\<close>. 
 For recursive method calls the axiomatic semantics rule assumes the method ok 
 to derive a proof for the body. To prove the method rule sound we need to 
 perform induction on the recursion depth. 
 For the completeness proof of the axiomatic semantics the notion of the most
 general formula is used. The most general formula right now builds on the 
 ordinary evaluation relation \<^term>\<open>eval\<close>. 
 So sometimes we have to switch between \<^term>\<open>evaln\<close> and \<^term>\<open>eval\<close> and vice 
 versa. To make
 this switch easy \<^term>\<open>evaln\<close> also does all the technical accessibility tests 
 \<^term>\<open>check_field_access\<close> and \<^term>\<open>check_method_access\<close> like \<^term>\<open>eval\<close>. 
 If it would omit them \<^term>\<open>evaln\<close> and \<^term>\<open>eval\<close> would only be equivalent 
 for welltyped, and definitely assigned terms.
 \<close>
 
 inductive
   evaln :: "[prog, state, term, nat, vals, state] \<Rightarrow> bool"
     ("_\<turnstile>_ \<midarrow>_\<succ>\<midarrow>_\<rightarrow> '(_, _')" [61,61,80,61,0,0] 60)
   and evarn :: "[prog, state, var, vvar, nat, state] \<Rightarrow> bool"
     ("_\<turnstile>_ \<midarrow>_=\<succ>_\<midarrow>_\<rightarrow> _" [61,61,90,61,61,61] 60)
   and eval_n:: "[prog, state, expr, val, nat, state] \<Rightarrow> bool"
     ("_\<turnstile>_ \<midarrow>_-\<succ>_\<midarrow>_\<rightarrow> _" [61,61,80,61,61,61] 60)
   and evalsn :: "[prog, state, expr list, val  list, nat, state] \<Rightarrow> bool"
     ("_\<turnstile>_ \<midarrow>_\<doteq>\<succ>_\<midarrow>_\<rightarrow> _" [61,61,61,61,61,61] 60)
   and execn     :: "[prog, state, stmt, nat, state] \<Rightarrow> bool"
     ("_\<turnstile>_ \<midarrow>_\<midarrow>_\<rightarrow> _"     [61,61,65,   61,61] 60)
   for G :: prog
 where
 
   "G\<turnstile>s \<midarrow>c     \<midarrow>n\<rightarrow>    s' \<equiv> G\<turnstile>s \<midarrow>In1r  c\<succ>\<midarrow>n\<rightarrow> (\<diamondsuit>    ,  s')"
 | "G\<turnstile>s \<midarrow>e-\<succ>v  \<midarrow>n\<rightarrow>    s' \<equiv> G\<turnstile>s \<midarrow>In1l e\<succ>\<midarrow>n\<rightarrow> (In1 v ,  s')"
 | "G\<turnstile>s \<midarrow>e=\<succ>vf \<midarrow>n\<rightarrow>    s' \<equiv> G\<turnstile>s \<midarrow>In2  e\<succ>\<midarrow>n\<rightarrow> (In2 vf,  s')"
 | "G\<turnstile>s \<midarrow>e\<doteq>\<succ>v  \<midarrow>n\<rightarrow>    s' \<equiv> G\<turnstile>s \<midarrow>In3  e\<succ>\<midarrow>n\<rightarrow> (In3 v ,  s')"
 
 \<comment> \<open>propagation of abrupt completion\<close>
 
 | Abrupt:   "G\<turnstile>(Some xc,s) \<midarrow>t\<succ>\<midarrow>n\<rightarrow> (undefined3 t,(Some xc,s))"
 
 
 \<comment> \<open>evaluation of variables\<close>
 
 | LVar: "G\<turnstile>Norm s \<midarrow>LVar vn=\<succ>lvar vn s\<midarrow>n\<rightarrow> Norm s"
 
 | FVar: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>Init statDeclC\<midarrow>n\<rightarrow> s1; G\<turnstile>s1 \<midarrow>e-\<succ>a\<midarrow>n\<rightarrow> s2;
           (v,s2') = fvar statDeclC stat fn a s2;
           s3 = check_field_access G accC statDeclC fn stat a s2'\<rbrakk> \<Longrightarrow>
           G\<turnstile>Norm s0 \<midarrow>{accC,statDeclC,stat}e..fn=\<succ>v\<midarrow>n\<rightarrow> s3"
 
 | AVar: "\<lbrakk>G\<turnstile> Norm s0 \<midarrow>e1-\<succ>a\<midarrow>n\<rightarrow> s1 ; G\<turnstile>s1 \<midarrow>e2-\<succ>i\<midarrow>n\<rightarrow> s2; 
           (v,s2') = avar G i a s2\<rbrakk> \<Longrightarrow>
                       G\<turnstile>Norm s0 \<midarrow>e1.[e2]=\<succ>v\<midarrow>n\<rightarrow> s2'"
 
 
 
 
 \<comment> \<open>evaluation of expressions\<close>
 
 | NewC: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>Init C\<midarrow>n\<rightarrow> s1;
           G\<turnstile>     s1 \<midarrow>halloc (CInst C)\<succ>a\<rightarrow> s2\<rbrakk> \<Longrightarrow>
                                   G\<turnstile>Norm s0 \<midarrow>NewC C-\<succ>Addr a\<midarrow>n\<rightarrow> s2"
 
 | NewA: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>init_comp_ty T\<midarrow>n\<rightarrow> s1; G\<turnstile>s1 \<midarrow>e-\<succ>i'\<midarrow>n\<rightarrow> s2; 
           G\<turnstile>abupd (check_neg i') s2 \<midarrow>halloc (Arr T (the_Intg i'))\<succ>a\<rightarrow> s3\<rbrakk> \<Longrightarrow>
                                 G\<turnstile>Norm s0 \<midarrow>New T[e]-\<succ>Addr a\<midarrow>n\<rightarrow> s3"
 
 | Cast: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e-\<succ>v\<midarrow>n\<rightarrow> s1;
           s2 = abupd (raise_if (\<not>G,snd s1\<turnstile>v fits T) ClassCast) s1\<rbrakk> \<Longrightarrow>
                                 G\<turnstile>Norm s0 \<midarrow>Cast T e-\<succ>v\<midarrow>n\<rightarrow> s2"
 
 | Inst: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e-\<succ>v\<midarrow>n\<rightarrow> s1;
           b = (v\<noteq>Null \<and> G,store s1\<turnstile>v fits RefT T)\<rbrakk> \<Longrightarrow>
                               G\<turnstile>Norm s0 \<midarrow>e InstOf T-\<succ>Bool b\<midarrow>n\<rightarrow> s1"
 
 | Lit:                     "G\<turnstile>Norm s \<midarrow>Lit v-\<succ>v\<midarrow>n\<rightarrow> Norm s"
 
 | UnOp: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e-\<succ>v\<midarrow>n\<rightarrow> s1\<rbrakk> 
          \<Longrightarrow> G\<turnstile>Norm s0 \<midarrow>UnOp unop e-\<succ>(eval_unop unop v)\<midarrow>n\<rightarrow> s1"
 
 | BinOp: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e1-\<succ>v1\<midarrow>n\<rightarrow> s1; 
            G\<turnstile>s1 \<midarrow>(if need_second_arg binop v1 then (In1l e2) else (In1r Skip))
             \<succ>\<midarrow>n\<rightarrow> (In1 v2,s2)\<rbrakk> 
          \<Longrightarrow> G\<turnstile>Norm s0 \<midarrow>BinOp binop e1 e2-\<succ>(eval_binop binop v1 v2)\<midarrow>n\<rightarrow> s2"
 
 | Super:                   "G\<turnstile>Norm s \<midarrow>Super-\<succ>val_this s\<midarrow>n\<rightarrow> Norm s"
 
 | Acc:  "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>va=\<succ>(v,f)\<midarrow>n\<rightarrow> s1\<rbrakk> \<Longrightarrow>
                                   G\<turnstile>Norm s0 \<midarrow>Acc va-\<succ>v\<midarrow>n\<rightarrow> s1"
 
 | Ass:  "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>va=\<succ>(w,f)\<midarrow>n\<rightarrow> s1;
           G\<turnstile>     s1 \<midarrow>e-\<succ>v     \<midarrow>n\<rightarrow> s2\<rbrakk> \<Longrightarrow>
                                    G\<turnstile>Norm s0 \<midarrow>va:=e-\<succ>v\<midarrow>n\<rightarrow> assign f v s2"
 
 | Cond: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e0-\<succ>b\<midarrow>n\<rightarrow> s1;
           G\<turnstile>     s1 \<midarrow>(if the_Bool b then e1 else e2)-\<succ>v\<midarrow>n\<rightarrow> s2\<rbrakk> \<Longrightarrow>
                             G\<turnstile>Norm s0 \<midarrow>e0 ? e1 : e2-\<succ>v\<midarrow>n\<rightarrow> s2"
 
 | Call: 
   "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e-\<succ>a'\<midarrow>n\<rightarrow> s1; G\<turnstile>s1 \<midarrow>args\<doteq>\<succ>vs\<midarrow>n\<rightarrow> s2;
     D = invocation_declclass G mode (store s2) a' statT \<lparr>name=mn,parTs=pTs\<rparr>; 
     s3=init_lvars G D \<lparr>name=mn,parTs=pTs\<rparr> mode a' vs s2;
     s3' = check_method_access G accC statT mode \<lparr>name=mn,parTs=pTs\<rparr> a' s3;
     G\<turnstile>s3'\<midarrow>Methd D \<lparr>name=mn,parTs=pTs\<rparr>-\<succ>v\<midarrow>n\<rightarrow> s4
    \<rbrakk>
    \<Longrightarrow> 
     G\<turnstile>Norm s0 \<midarrow>{accC,statT,mode}e\<cdot>mn({pTs}args)-\<succ>v\<midarrow>n\<rightarrow> (restore_lvars s2 s4)"
 
 | Methd:"\<lbrakk>G\<turnstile>Norm s0 \<midarrow>body G D sig-\<succ>v\<midarrow>n\<rightarrow> s1\<rbrakk> \<Longrightarrow>
                                 G\<turnstile>Norm s0 \<midarrow>Methd D sig-\<succ>v\<midarrow>Suc n\<rightarrow> s1"
 
 | Body: "\<lbrakk>G\<turnstile>Norm s0\<midarrow>Init D\<midarrow>n\<rightarrow> s1; G\<turnstile>s1 \<midarrow>c\<midarrow>n\<rightarrow> s2;
           s3 = (if (\<exists> l. abrupt s2 = Some (Jump (Break l)) \<or>  
                          abrupt s2 = Some (Jump (Cont l)))
                   then abupd (\<lambda> x. Some (Error CrossMethodJump)) s2 
                   else s2)\<rbrakk>\<Longrightarrow>
          G\<turnstile>Norm s0 \<midarrow>Body D c
           -\<succ>the (locals (store s2) Result)\<midarrow>n\<rightarrow>abupd (absorb Ret) s3"
 
 \<comment> \<open>evaluation of expression lists\<close>
 
 | Nil:
                                 "G\<turnstile>Norm s0 \<midarrow>[]\<doteq>\<succ>[]\<midarrow>n\<rightarrow> Norm s0"
 
 | Cons: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e -\<succ> v \<midarrow>n\<rightarrow> s1;
           G\<turnstile>     s1 \<midarrow>es\<doteq>\<succ>vs\<midarrow>n\<rightarrow> s2\<rbrakk> \<Longrightarrow>
                              G\<turnstile>Norm s0 \<midarrow>e#es\<doteq>\<succ>v#vs\<midarrow>n\<rightarrow> s2"
 
 
 \<comment> \<open>execution of statements\<close>
 
 | Skip:                             "G\<turnstile>Norm s \<midarrow>Skip\<midarrow>n\<rightarrow> Norm s"
 
 | Expr: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e-\<succ>v\<midarrow>n\<rightarrow> s1\<rbrakk> \<Longrightarrow>
                                   G\<turnstile>Norm s0 \<midarrow>Expr e\<midarrow>n\<rightarrow> s1"
 
 | Lab:  "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>c \<midarrow>n\<rightarrow> s1\<rbrakk> \<Longrightarrow>
                              G\<turnstile>Norm s0 \<midarrow>l\<bullet> c\<midarrow>n\<rightarrow> abupd (absorb l) s1"
 
 | Comp: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>c1 \<midarrow>n\<rightarrow> s1;
           G\<turnstile>     s1 \<midarrow>c2 \<midarrow>n\<rightarrow> s2\<rbrakk> \<Longrightarrow>
                                  G\<turnstile>Norm s0 \<midarrow>c1;; c2\<midarrow>n\<rightarrow> s2"
 
 | If:   "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e-\<succ>b\<midarrow>n\<rightarrow> s1;
           G\<turnstile>     s1\<midarrow>(if the_Bool b then c1 else c2)\<midarrow>n\<rightarrow> s2\<rbrakk> \<Longrightarrow>
                        G\<turnstile>Norm s0 \<midarrow>If(e) c1 Else c2 \<midarrow>n\<rightarrow> s2"
 
 | Loop: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e-\<succ>b\<midarrow>n\<rightarrow> s1;
           if the_Bool b 
              then (G\<turnstile>s1 \<midarrow>c\<midarrow>n\<rightarrow> s2 \<and> 
                    G\<turnstile>(abupd (absorb (Cont l)) s2) \<midarrow>l\<bullet> While(e) c\<midarrow>n\<rightarrow> s3)
              else s3 = s1\<rbrakk> \<Longrightarrow>
                               G\<turnstile>Norm s0 \<midarrow>l\<bullet> While(e) c\<midarrow>n\<rightarrow> s3"
   
 | Jmp: "G\<turnstile>Norm s \<midarrow>Jmp j\<midarrow>n\<rightarrow> (Some (Jump j), s)"
   
 | Throw:"\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e-\<succ>a'\<midarrow>n\<rightarrow> s1\<rbrakk> \<Longrightarrow>
                                  G\<turnstile>Norm s0 \<midarrow>Throw e\<midarrow>n\<rightarrow> abupd (throw a') s1"
 
 | Try:  "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>c1\<midarrow>n\<rightarrow> s1; G\<turnstile>s1 \<midarrow>sxalloc\<rightarrow> s2;
           if G,s2\<turnstile>catch tn then G\<turnstile>new_xcpt_var vn s2 \<midarrow>c2\<midarrow>n\<rightarrow> s3 else s3 = s2\<rbrakk>
           \<Longrightarrow>
                   G\<turnstile>Norm s0 \<midarrow>Try c1 Catch(tn vn) c2\<midarrow>n\<rightarrow> s3"
 
 | Fin:  "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>c1\<midarrow>n\<rightarrow> (x1,s1);
           G\<turnstile>Norm s1 \<midarrow>c2\<midarrow>n\<rightarrow> s2;
           s3=(if (\<exists> err. x1=Some (Error err)) 
               then (x1,s1) 
               else abupd (abrupt_if (x1\<noteq>None) x1) s2)\<rbrakk> \<Longrightarrow>
               G\<turnstile>Norm s0 \<midarrow>c1 Finally c2\<midarrow>n\<rightarrow> s3"
   
 | Init: "\<lbrakk>the (class G C) = c;
           if inited C (globs s0) then s3 = Norm s0
           else (G\<turnstile>Norm (init_class_obj G C s0)
                   \<midarrow>(if C = Object then Skip else Init (super c))\<midarrow>n\<rightarrow> s1 \<and>
                 G\<turnstile>set_lvars Map.empty s1 \<midarrow>init c\<midarrow>n\<rightarrow> s2 \<and> 
                 s3 = restore_lvars s1 s2)\<rbrakk>
           \<Longrightarrow>
                  G\<turnstile>Norm s0 \<midarrow>Init C\<midarrow>n\<rightarrow> s3"
 monos
   if_bool_eq_conj
 
 
 declare if_split     [split del] if_split_asm     [split del]
         option.split [split del] option.split_asm [split del]
         not_None_eq [simp del] 
         split_paired_All [simp del] split_paired_Ex [simp del]
 setup \<open>map_theory_simpset (fn ctxt => ctxt delloop "split_all_tac")\<close>
 
 inductive_cases evaln_cases: "G\<turnstile>s \<midarrow>t\<succ>\<midarrow>n\<rightarrow> (v, s')"
 
 inductive_cases evaln_elim_cases:
         "G\<turnstile>(Some xc, s) \<midarrow>t                        \<succ>\<midarrow>n\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1r Skip                      \<succ>\<midarrow>n\<rightarrow> (x, s')"
         "G\<turnstile>Norm s \<midarrow>In1r (Jmp j)                   \<succ>\<midarrow>n\<rightarrow> (x, s')"
         "G\<turnstile>Norm s \<midarrow>In1r (l\<bullet> c)                    \<succ>\<midarrow>n\<rightarrow> (x, s')"
         "G\<turnstile>Norm s \<midarrow>In3  ([])                      \<succ>\<midarrow>n\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In3  (e#es)                    \<succ>\<midarrow>n\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1l (Lit w)                   \<succ>\<midarrow>n\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1l (UnOp unop e)             \<succ>\<midarrow>n\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1l (BinOp binop e1 e2)       \<succ>\<midarrow>n\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In2  (LVar vn)                 \<succ>\<midarrow>n\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1l (Cast T e)                \<succ>\<midarrow>n\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1l (e InstOf T)              \<succ>\<midarrow>n\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1l (Super)                   \<succ>\<midarrow>n\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1l (Acc va)                  \<succ>\<midarrow>n\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1r (Expr e)                  \<succ>\<midarrow>n\<rightarrow> (x, s')"
         "G\<turnstile>Norm s \<midarrow>In1r (c1;; c2)                 \<succ>\<midarrow>n\<rightarrow> (x, s')"
         "G\<turnstile>Norm s \<midarrow>In1l (Methd C sig)             \<succ>\<midarrow>n\<rightarrow> (x, s')"
         "G\<turnstile>Norm s \<midarrow>In1l (Body D c)                \<succ>\<midarrow>n\<rightarrow> (x, s')"
         "G\<turnstile>Norm s \<midarrow>In1l (e0 ? e1 : e2)            \<succ>\<midarrow>n\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1r (If(e) c1 Else c2)        \<succ>\<midarrow>n\<rightarrow> (x, s')"
         "G\<turnstile>Norm s \<midarrow>In1r (l\<bullet> While(e) c)           \<succ>\<midarrow>n\<rightarrow> (x, s')"
         "G\<turnstile>Norm s \<midarrow>In1r (c1 Finally c2)           \<succ>\<midarrow>n\<rightarrow> (x, s')"
         "G\<turnstile>Norm s \<midarrow>In1r (Throw e)                 \<succ>\<midarrow>n\<rightarrow> (x, s')"
         "G\<turnstile>Norm s \<midarrow>In1l (NewC C)                  \<succ>\<midarrow>n\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1l (New T[e])                \<succ>\<midarrow>n\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1l (Ass va e)                \<succ>\<midarrow>n\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1r (Try c1 Catch(tn vn) c2)  \<succ>\<midarrow>n\<rightarrow> (x, s')"
         "G\<turnstile>Norm s \<midarrow>In2  ({accC,statDeclC,stat}e..fn) \<succ>\<midarrow>n\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In2  (e1.[e2])                 \<succ>\<midarrow>n\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1l ({accC,statT,mode}e\<cdot>mn({pT}p)) \<succ>\<midarrow>n\<rightarrow> (v, s')"
         "G\<turnstile>Norm s \<midarrow>In1r (Init C)                  \<succ>\<midarrow>n\<rightarrow> (x, s')"
 
 declare if_split     [split] if_split_asm     [split] 
         option.split [split] option.split_asm [split]
         not_None_eq [simp] 
         split_paired_All [simp] split_paired_Ex [simp]
 declaration \<open>K (Simplifier.map_ss (fn ss => ss addloop ("split_all_tac", split_all_tac)))\<close>
 
 lemma evaln_Inj_elim: "G\<turnstile>s \<midarrow>t\<succ>\<midarrow>n\<rightarrow> (w,s') \<Longrightarrow> case t of In1 ec \<Rightarrow>  
   (case ec of Inl e \<Rightarrow> (\<exists>v. w = In1 v) | Inr c \<Rightarrow> w = \<diamondsuit>)  
   | In2 e \<Rightarrow> (\<exists>v. w = In2 v) | In3 e \<Rightarrow> (\<exists>v. w = In3 v)"
 apply (erule evaln_cases , auto)
 apply (induct_tac "t")
 apply   (rename_tac a, induct_tac "a")
 apply auto
 done
 
 text \<open>The following simplification procedures set up the proper injections of
  terms and their corresponding values in the evaluation relation:
  E.g. an expression 
  (injection \<^term>\<open>In1l\<close> into terms) always evaluates to ordinary values 
  (injection \<^term>\<open>In1\<close> into generalised values \<^term>\<open>vals\<close>). 
 \<close>
 
 lemma evaln_expr_eq: "G\<turnstile>s \<midarrow>In1l t\<succ>\<midarrow>n\<rightarrow> (w, s') = (\<exists>v. w=In1 v \<and> G\<turnstile>s \<midarrow>t-\<succ>v \<midarrow>n\<rightarrow> s')"
   by (auto, frule evaln_Inj_elim, auto)
 
 lemma evaln_var_eq: "G\<turnstile>s \<midarrow>In2 t\<succ>\<midarrow>n\<rightarrow> (w, s') = (\<exists>vf. w=In2 vf \<and> G\<turnstile>s \<midarrow>t=\<succ>vf\<midarrow>n\<rightarrow> s')"
   by (auto, frule evaln_Inj_elim, auto)
 
 lemma evaln_exprs_eq: "G\<turnstile>s \<midarrow>In3 t\<succ>\<midarrow>n\<rightarrow> (w, s') = (\<exists>vs. w=In3 vs \<and> G\<turnstile>s \<midarrow>t\<doteq>\<succ>vs\<midarrow>n\<rightarrow> s')"
   by (auto, frule evaln_Inj_elim, auto)
 
 lemma evaln_stmt_eq: "G\<turnstile>s \<midarrow>In1r t\<succ>\<midarrow>n\<rightarrow> (w, s') = (w=\<diamondsuit> \<and> G\<turnstile>s \<midarrow>t \<midarrow>n\<rightarrow> s')"
   by (auto, frule evaln_Inj_elim, auto, frule evaln_Inj_elim, auto)
 
 simproc_setup evaln_expr ("G\<turnstile>s \<midarrow>In1l t\<succ>\<midarrow>n\<rightarrow> (w, s')") = \<open>
-  fn _ => fn _ => fn ct =>
-    (case Thm.term_of ct of
-      (_ $ _ $ _ $ _ $ _ $ (Const _ $ _) $ _) => NONE
-    | _ => SOME (mk_meta_eq @{thm evaln_expr_eq}))\<close>
-
-simproc_setup evaln_var ("G\<turnstile>s \<midarrow>In2 t\<succ>\<midarrow>n\<rightarrow> (w, s')") = \<open>
-  fn _ => fn _ => fn ct =>
+  K (K (fn ct =>
     (case Thm.term_of ct of
       (_ $ _ $ _ $ _ $ _ $ (Const _ $ _) $ _) => NONE
-    | _ => SOME (mk_meta_eq @{thm evaln_var_eq}))\<close>
+    | _ => SOME (mk_meta_eq @{thm evaln_expr_eq}))))\<close>
 
-simproc_setup evaln_exprs ("G\<turnstile>s \<midarrow>In3 t\<succ>\<midarrow>n\<rightarrow> (w, s')") = \<open>
-  fn _ => fn _ => fn ct =>
+simproc_setup evaln_var ("G\<turnstile>s \<midarrow>In2 t\<succ>\<midarrow>n\<rightarrow> (w, s')") = \<open>
+  K (K (fn ct =>
     (case Thm.term_of ct of
       (_ $ _ $ _ $ _ $ _ $ (Const _ $ _) $ _) => NONE
-    | _ => SOME (mk_meta_eq @{thm evaln_exprs_eq}))\<close>
+    | _ => SOME (mk_meta_eq @{thm evaln_var_eq}))))\<close>
+
+simproc_setup evaln_exprs ("G\<turnstile>s \<midarrow>In3 t\<succ>\<midarrow>n\<rightarrow> (w, s')") = \<open>
+  K (K (fn ct =>
+    (case Thm.term_of ct of
+      (_ $ _ $ _ $ _ $ _ $ (Const _ $ _) $ _) => NONE
+    | _ => SOME (mk_meta_eq @{thm evaln_exprs_eq}))))\<close>
 
 simproc_setup evaln_stmt ("G\<turnstile>s \<midarrow>In1r t\<succ>\<midarrow>n\<rightarrow> (w, s')") = \<open>
-  fn _ => fn _ => fn ct =>
+  K (K (fn ct =>
     (case Thm.term_of ct of
       (_ $ _ $ _ $ _ $ _ $ (Const _ $ _) $ _) => NONE
-    | _ => SOME (mk_meta_eq @{thm evaln_stmt_eq}))\<close>
+    | _ => SOME (mk_meta_eq @{thm evaln_stmt_eq}))))\<close>
 
 ML \<open>ML_Thms.bind_thms ("evaln_AbruptIs", sum3_instantiate \<^context> @{thm evaln.Abrupt})\<close>
 declare evaln_AbruptIs [intro!]
 
 lemma evaln_Callee: "G\<turnstile>Norm s\<midarrow>In1l (Callee l e)\<succ>\<midarrow>n\<rightarrow> (v,s') = False"
 proof -
   { fix s t v s'
     assume eval: "G\<turnstile>s \<midarrow>t\<succ>\<midarrow>n\<rightarrow> (v,s')" and
          normal: "normal s" and
          callee: "t=In1l (Callee l e)"
     then have "False" by induct auto
   }
   then show ?thesis
     by (cases s') fastforce 
 qed
 
 lemma evaln_InsInitE: "G\<turnstile>Norm s\<midarrow>In1l (InsInitE c e)\<succ>\<midarrow>n\<rightarrow> (v,s') = False"
 proof -
   { fix s t v s'
     assume eval: "G\<turnstile>s \<midarrow>t\<succ>\<midarrow>n\<rightarrow> (v,s')" and
          normal: "normal s" and
          callee: "t=In1l (InsInitE c e)"
     then have "False" by induct auto
   }
   then show ?thesis
     by (cases s') fastforce
 qed
 
 lemma evaln_InsInitV: "G\<turnstile>Norm s\<midarrow>In2 (InsInitV c w)\<succ>\<midarrow>n\<rightarrow> (v,s') = False"
 proof -
   { fix s t v s'
     assume eval: "G\<turnstile>s \<midarrow>t\<succ>\<midarrow>n\<rightarrow> (v,s')" and
          normal: "normal s" and
          callee: "t=In2 (InsInitV c w)"
     then have "False" by induct auto
   }  
   then show ?thesis
     by (cases s') fastforce
 qed
 
 lemma evaln_FinA: "G\<turnstile>Norm s\<midarrow>In1r (FinA a c)\<succ>\<midarrow>n\<rightarrow> (v,s') = False"
 proof -
   { fix s t v s'
     assume eval: "G\<turnstile>s \<midarrow>t\<succ>\<midarrow>n\<rightarrow> (v,s')" and
          normal: "normal s" and
          callee: "t=In1r (FinA a c)"
     then have "False" by induct auto
   } 
   then show ?thesis
     by (cases s') fastforce
 qed
 
 lemma evaln_abrupt_lemma: "G\<turnstile>s \<midarrow>e\<succ>\<midarrow>n\<rightarrow> (v,s') \<Longrightarrow> 
  fst s = Some xc \<longrightarrow> s' = s \<and> v = undefined3 e"
 apply (erule evaln_cases , auto)
 done
 
 lemma evaln_abrupt: 
  "\<And>s'. G\<turnstile>(Some xc,s) \<midarrow>e\<succ>\<midarrow>n\<rightarrow> (w,s') = (s' = (Some xc,s) \<and>  
   w=undefined3 e \<and> G\<turnstile>(Some xc,s) \<midarrow>e\<succ>\<midarrow>n\<rightarrow> (undefined3 e,(Some xc,s)))"
 apply auto
 apply (frule evaln_abrupt_lemma, auto)+
 done
 
 simproc_setup evaln_abrupt ("G\<turnstile>(Some xc,s) \<midarrow>e\<succ>\<midarrow>n\<rightarrow> (w,s')") = \<open>
-  fn _ => fn _ => fn ct =>
+  K (K (fn ct =>
     (case Thm.term_of ct of
       (_ $ _ $ _ $ _ $ _ $ _ $ (Const (\<^const_name>\<open>Pair\<close>, _) $ (Const (\<^const_name>\<open>Some\<close>,_) $ _)$ _))
         => NONE
-    | _ => SOME (mk_meta_eq @{thm evaln_abrupt}))
+    | _ => SOME (mk_meta_eq @{thm evaln_abrupt}))))
 \<close>
 
 lemma evaln_LitI: "G\<turnstile>s \<midarrow>Lit v-\<succ>(if normal s then v else undefined)\<midarrow>n\<rightarrow> s"
 apply (case_tac "s", case_tac "a = None")
 by (auto intro!: evaln.Lit)
 
 lemma CondI: 
  "\<And>s1. \<lbrakk>G\<turnstile>s \<midarrow>e-\<succ>b\<midarrow>n\<rightarrow> s1; G\<turnstile>s1 \<midarrow>(if the_Bool b then e1 else e2)-\<succ>v\<midarrow>n\<rightarrow> s2\<rbrakk> \<Longrightarrow> 
   G\<turnstile>s \<midarrow>e ? e1 : e2-\<succ>(if normal s1 then v else undefined)\<midarrow>n\<rightarrow> s2"
 apply (case_tac "s", case_tac "a = None")
 by (auto intro!: evaln.Cond)
 
 lemma evaln_SkipI [intro!]: "G\<turnstile>s \<midarrow>Skip\<midarrow>n\<rightarrow> s"
 apply (case_tac "s", case_tac "a = None")
 by (auto intro!: evaln.Skip)
 
 lemma evaln_ExprI: "G\<turnstile>s \<midarrow>e-\<succ>v\<midarrow>n\<rightarrow> s' \<Longrightarrow> G\<turnstile>s \<midarrow>Expr e\<midarrow>n\<rightarrow> s'"
 apply (case_tac "s", case_tac "a = None")
 by (auto intro!: evaln.Expr)
 
 lemma evaln_CompI: "\<lbrakk>G\<turnstile>s \<midarrow>c1\<midarrow>n\<rightarrow> s1; G\<turnstile>s1 \<midarrow>c2\<midarrow>n\<rightarrow> s2\<rbrakk> \<Longrightarrow> G\<turnstile>s \<midarrow>c1;; c2\<midarrow>n\<rightarrow> s2"
 apply (case_tac "s", case_tac "a = None")
 by (auto intro!: evaln.Comp)
 
 lemma evaln_IfI: 
  "\<lbrakk>G\<turnstile>s \<midarrow>e-\<succ>v\<midarrow>n\<rightarrow> s1; G\<turnstile>s1 \<midarrow>(if the_Bool v then c1 else c2)\<midarrow>n\<rightarrow> s2\<rbrakk> \<Longrightarrow> 
   G\<turnstile>s \<midarrow>If(e) c1 Else c2\<midarrow>n\<rightarrow> s2"
 apply (case_tac "s", case_tac "a = None")
 by (auto intro!: evaln.If)
 
 lemma evaln_SkipD [dest!]: "G\<turnstile>s \<midarrow>Skip\<midarrow>n\<rightarrow> s' \<Longrightarrow> s' = s" 
 by (erule evaln_cases, auto)
 
 lemma evaln_Skip_eq [simp]: "G\<turnstile>s \<midarrow>Skip\<midarrow>n\<rightarrow> s' = (s = s')"
 apply auto
 done
 
 
 
 
 subsubsection \<open>evaln implies eval\<close>
 
 lemma evaln_eval:  
   assumes evaln: "G\<turnstile>s0 \<midarrow>t\<succ>\<midarrow>n\<rightarrow> (v,s1)" 
   shows "G\<turnstile>s0 \<midarrow>t\<succ>\<rightarrow> (v,s1)"
 using evaln 
 proof (induct)
   case (Loop s0 e b n s1 c s2 l s3)
   note \<open>G\<turnstile>Norm s0 \<midarrow>e-\<succ>b\<rightarrow> s1\<close>
   moreover
   have "if the_Bool b
         then (G\<turnstile>s1 \<midarrow>c\<rightarrow> s2) \<and> 
              G\<turnstile>abupd (absorb (Cont l)) s2 \<midarrow>l\<bullet> While(e) c\<rightarrow> s3
         else s3 = s1"
     using Loop.hyps by simp
   ultimately show ?case by (rule eval.Loop)
 next
   case (Try s0 c1 n s1 s2 C vn c2 s3)
   note \<open>G\<turnstile>Norm s0 \<midarrow>c1\<rightarrow> s1\<close>
   moreover
   note \<open>G\<turnstile>s1 \<midarrow>sxalloc\<rightarrow> s2\<close>
   moreover
   have "if G,s2\<turnstile>catch C then G\<turnstile>new_xcpt_var vn s2 \<midarrow>c2\<rightarrow> s3 else s3 = s2"
     using Try.hyps by simp
   ultimately show ?case by (rule eval.Try)
 next
   case (Init C c s0 s3 n s1 s2)
   note \<open>the (class G C) = c\<close>
   moreover
   have "if inited C (globs s0) 
            then s3 = Norm s0
            else G\<turnstile>Norm ((init_class_obj G C) s0) 
                   \<midarrow>(if C = Object then Skip else Init (super c))\<rightarrow> s1 \<and>
                 G\<turnstile>(set_lvars Map.empty) s1 \<midarrow>init c\<rightarrow> s2 \<and>
                 s3 = (set_lvars (locals (store s1))) s2"
     using Init.hyps by simp
   ultimately show ?case by (rule eval.Init)
 qed (rule eval.intros,(assumption+ | assumption?))+
 
 lemma Suc_le_D_lemma: "\<lbrakk>Suc n <= m'; (\<And>m. n <= m \<Longrightarrow> P (Suc m)) \<rbrakk> \<Longrightarrow> P m'"
 apply (frule Suc_le_D)
 apply fast
 done
 
 lemma evaln_nonstrict [rule_format (no_asm), elim]: 
   "G\<turnstile>s \<midarrow>t\<succ>\<midarrow>n\<rightarrow> (w, s') \<Longrightarrow> \<forall>m. n\<le>m \<longrightarrow> G\<turnstile>s \<midarrow>t\<succ>\<midarrow>m\<rightarrow> (w, s')"
 apply (erule evaln.induct)
 apply (tactic \<open>ALLGOALS (EVERY' [strip_tac \<^context>,
   TRY o eresolve_tac \<^context> @{thms Suc_le_D_lemma},
   REPEAT o smp_tac \<^context> 1, 
   resolve_tac \<^context> @{thms evaln.intros} THEN_ALL_NEW TRY o assume_tac \<^context>])\<close>)
 (* 3 subgoals *)
 apply (auto split del: if_split)
 done
 
 lemmas evaln_nonstrict_Suc = evaln_nonstrict [OF _ le_refl [THEN le_SucI]]
 
 lemma evaln_max2: "\<lbrakk>G\<turnstile>s1 \<midarrow>t1\<succ>\<midarrow>n1\<rightarrow> (w1, s1'); G\<turnstile>s2 \<midarrow>t2\<succ>\<midarrow>n2\<rightarrow> (w2, s2')\<rbrakk> \<Longrightarrow> 
              G\<turnstile>s1 \<midarrow>t1\<succ>\<midarrow>max n1 n2\<rightarrow> (w1, s1') \<and> G\<turnstile>s2 \<midarrow>t2\<succ>\<midarrow>max n1 n2\<rightarrow> (w2, s2')"
 by (fast intro: max.cobounded1 max.cobounded2)
 
 corollary evaln_max2E [consumes 2]:
   "\<lbrakk>G\<turnstile>s1 \<midarrow>t1\<succ>\<midarrow>n1\<rightarrow> (w1, s1'); G\<turnstile>s2 \<midarrow>t2\<succ>\<midarrow>n2\<rightarrow> (w2, s2'); 
     \<lbrakk>G\<turnstile>s1 \<midarrow>t1\<succ>\<midarrow>max n1 n2\<rightarrow> (w1, s1');G\<turnstile>s2 \<midarrow>t2\<succ>\<midarrow>max n1 n2\<rightarrow> (w2, s2') \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
 by (drule (1) evaln_max2) simp
 
 
 lemma evaln_max3: 
 "\<lbrakk>G\<turnstile>s1 \<midarrow>t1\<succ>\<midarrow>n1\<rightarrow> (w1, s1'); G\<turnstile>s2 \<midarrow>t2\<succ>\<midarrow>n2\<rightarrow> (w2, s2'); G\<turnstile>s3 \<midarrow>t3\<succ>\<midarrow>n3\<rightarrow> (w3, s3')\<rbrakk> \<Longrightarrow>
  G\<turnstile>s1 \<midarrow>t1\<succ>\<midarrow>max (max n1 n2) n3\<rightarrow> (w1, s1') \<and>
  G\<turnstile>s2 \<midarrow>t2\<succ>\<midarrow>max (max n1 n2) n3\<rightarrow> (w2, s2') \<and> 
  G\<turnstile>s3 \<midarrow>t3\<succ>\<midarrow>max (max n1 n2) n3\<rightarrow> (w3, s3')"
 apply (drule (1) evaln_max2, erule thin_rl)
 apply (fast intro!: max.cobounded1 max.cobounded2)
 done
 
 corollary evaln_max3E: 
 "\<lbrakk>G\<turnstile>s1 \<midarrow>t1\<succ>\<midarrow>n1\<rightarrow> (w1, s1'); G\<turnstile>s2 \<midarrow>t2\<succ>\<midarrow>n2\<rightarrow> (w2, s2'); G\<turnstile>s3 \<midarrow>t3\<succ>\<midarrow>n3\<rightarrow> (w3, s3');
    \<lbrakk>G\<turnstile>s1 \<midarrow>t1\<succ>\<midarrow>max (max n1 n2) n3\<rightarrow> (w1, s1');
     G\<turnstile>s2 \<midarrow>t2\<succ>\<midarrow>max (max n1 n2) n3\<rightarrow> (w2, s2'); 
     G\<turnstile>s3 \<midarrow>t3\<succ>\<midarrow>max (max n1 n2) n3\<rightarrow> (w3, s3')
    \<rbrakk> \<Longrightarrow> P
   \<rbrakk> \<Longrightarrow> P"
 by (drule (2) evaln_max3) simp
 
 
 lemma le_max3I1: "(n2::nat) \<le> max n1 (max n2 n3)"
 proof -
   have "n2 \<le> max n2 n3"
     by (rule max.cobounded1)
   also
   have "max n2 n3 \<le> max n1 (max n2 n3)"
     by (rule max.cobounded2)
   finally
   show ?thesis .
 qed
 
 lemma le_max3I2: "(n3::nat) \<le> max n1 (max n2 n3)"
 proof -
   have "n3 \<le> max n2 n3"
     by (rule max.cobounded2)
   also
   have "max n2 n3 \<le> max n1 (max n2 n3)"
     by (rule max.cobounded2)
   finally
   show ?thesis .
 qed
 
 declare [[simproc del: wt_expr wt_var wt_exprs wt_stmt]]
 
 subsubsection \<open>eval implies evaln\<close>
 lemma eval_evaln: 
   assumes eval: "G\<turnstile>s0 \<midarrow>t\<succ>\<rightarrow> (v,s1)"
   shows  "\<exists>n. G\<turnstile>s0 \<midarrow>t\<succ>\<midarrow>n\<rightarrow> (v,s1)"
 using eval 
 proof (induct)
   case (Abrupt xc s t)
   obtain n where
     "G\<turnstile>(Some xc, s) \<midarrow>t\<succ>\<midarrow>n\<rightarrow> (undefined3 t, (Some xc, s))"
     by (iprover intro: evaln.Abrupt)
   then show ?case ..
 next
   case Skip
   show ?case by (blast intro: evaln.Skip)
 next
   case (Expr s0 e v s1)
   then obtain n where
     "G\<turnstile>Norm s0 \<midarrow>e-\<succ>v\<midarrow>n\<rightarrow> s1"
     by (iprover)
   then have "G\<turnstile>Norm s0 \<midarrow>Expr e\<midarrow>n\<rightarrow> s1"
     by (rule evaln.Expr) 
   then show ?case ..
 next
   case (Lab s0 c s1 l)
   then obtain n where
     "G\<turnstile>Norm s0 \<midarrow>c\<midarrow>n\<rightarrow> s1"
     by (iprover)
   then have "G\<turnstile>Norm s0 \<midarrow>l\<bullet> c\<midarrow>n\<rightarrow> abupd (absorb l) s1"
     by (rule evaln.Lab)
   then show ?case ..
 next
   case (Comp s0 c1 s1 c2 s2)
   then obtain n1 n2 where
     "G\<turnstile>Norm s0 \<midarrow>c1\<midarrow>n1\<rightarrow> s1"
     "G\<turnstile>s1 \<midarrow>c2\<midarrow>n2\<rightarrow> s2"
     by (iprover)
   then have "G\<turnstile>Norm s0 \<midarrow>c1;; c2\<midarrow>max n1 n2\<rightarrow> s2"
     by (blast intro: evaln.Comp dest: evaln_max2 )
   then show ?case ..
 next
   case (If s0 e b s1 c1 c2 s2)
   then obtain n1 n2 where
     "G\<turnstile>Norm s0 \<midarrow>e-\<succ>b\<midarrow>n1\<rightarrow> s1"
     "G\<turnstile>s1 \<midarrow>(if the_Bool b then c1 else c2)\<midarrow>n2\<rightarrow> s2"
     by (iprover)
   then have "G\<turnstile>Norm s0 \<midarrow>If(e) c1 Else c2\<midarrow>max n1 n2\<rightarrow> s2"
     by (blast intro: evaln.If dest: evaln_max2)
   then show ?case ..
 next
   case (Loop s0 e b s1 c s2 l s3)
   from Loop.hyps obtain n1 where
     "G\<turnstile>Norm s0 \<midarrow>e-\<succ>b\<midarrow>n1\<rightarrow> s1"
     by (iprover)
   moreover from Loop.hyps obtain n2 where
     "if the_Bool b 
         then (G\<turnstile>s1 \<midarrow>c\<midarrow>n2\<rightarrow> s2 \<and> 
               G\<turnstile>(abupd (absorb (Cont l)) s2)\<midarrow>l\<bullet> While(e) c\<midarrow>n2\<rightarrow> s3)
         else s3 = s1"
     by simp (iprover intro: evaln_nonstrict max.cobounded1 max.cobounded2)
   ultimately
   have "G\<turnstile>Norm s0 \<midarrow>l\<bullet> While(e) c\<midarrow>max n1 n2\<rightarrow> s3"
     apply -
     apply (rule evaln.Loop)
     apply   (iprover intro: evaln_nonstrict intro: max.cobounded1)
     apply   (auto intro: evaln_nonstrict intro: max.cobounded2)
     done
   then show ?case ..
 next
   case (Jmp s j)
   fix n have "G\<turnstile>Norm s \<midarrow>Jmp j\<midarrow>n\<rightarrow> (Some (Jump j), s)"
     by (rule evaln.Jmp)
   then show ?case ..
 next
   case (Throw s0 e a s1)
   then obtain n where
     "G\<turnstile>Norm s0 \<midarrow>e-\<succ>a\<midarrow>n\<rightarrow> s1"
     by (iprover)
   then have "G\<turnstile>Norm s0 \<midarrow>Throw e\<midarrow>n\<rightarrow> abupd (throw a) s1"
     by (rule evaln.Throw)
   then show ?case ..
 next 
   case (Try s0 c1 s1 s2 catchC vn c2 s3)
   from Try.hyps obtain n1 where
     "G\<turnstile>Norm s0 \<midarrow>c1\<midarrow>n1\<rightarrow> s1"
     by (iprover)
   moreover 
   note sxalloc = \<open>G\<turnstile>s1 \<midarrow>sxalloc\<rightarrow> s2\<close>
   moreover
   from Try.hyps obtain n2 where
     "if G,s2\<turnstile>catch catchC then G\<turnstile>new_xcpt_var vn s2 \<midarrow>c2\<midarrow>n2\<rightarrow> s3 else s3 = s2"
     by fastforce 
   ultimately
   have "G\<turnstile>Norm s0 \<midarrow>Try c1 Catch(catchC vn) c2\<midarrow>max n1 n2\<rightarrow> s3"
     by (auto intro!: evaln.Try max.cobounded1 max.cobounded2)
   then show ?case ..
 next
   case (Fin s0 c1 x1 s1 c2 s2 s3)
   from Fin obtain n1 n2 where 
     "G\<turnstile>Norm s0 \<midarrow>c1\<midarrow>n1\<rightarrow> (x1, s1)"
     "G\<turnstile>Norm s1 \<midarrow>c2\<midarrow>n2\<rightarrow> s2"
     by iprover
   moreover
   note s3 = \<open>s3 = (if \<exists>err. x1 = Some (Error err) 
                    then (x1, s1)
                    else abupd (abrupt_if (x1 \<noteq> None) x1) s2)\<close>
   ultimately 
   have 
     "G\<turnstile>Norm s0 \<midarrow>c1 Finally c2\<midarrow>max n1 n2\<rightarrow> s3"
     by (blast intro: evaln.Fin dest: evaln_max2)
   then show ?case ..
 next
   case (Init C c s0 s3 s1 s2)
   note cls = \<open>the (class G C) = c\<close>
   moreover from Init.hyps obtain n where
       "if inited C (globs s0) then s3 = Norm s0
        else (G\<turnstile>Norm (init_class_obj G C s0)
               \<midarrow>(if C = Object then Skip else Init (super c))\<midarrow>n\<rightarrow> s1 \<and>
                    G\<turnstile>set_lvars Map.empty s1 \<midarrow>init c\<midarrow>n\<rightarrow> s2 \<and> 
                    s3 = restore_lvars s1 s2)"
     by (auto intro: evaln_nonstrict max.cobounded1 max.cobounded2)
   ultimately have "G\<turnstile>Norm s0 \<midarrow>Init C\<midarrow>n\<rightarrow> s3"
     by (rule evaln.Init)
   then show ?case ..
 next
   case (NewC s0 C s1 a s2)
   then obtain n where 
     "G\<turnstile>Norm s0 \<midarrow>Init C\<midarrow>n\<rightarrow> s1"
     by (iprover)
   with NewC 
   have "G\<turnstile>Norm s0 \<midarrow>NewC C-\<succ>Addr a\<midarrow>n\<rightarrow> s2"
     by (iprover intro: evaln.NewC)
   then show ?case ..
 next
   case (NewA s0 T s1 e i s2 a s3)
   then obtain n1 n2 where 
     "G\<turnstile>Norm s0 \<midarrow>init_comp_ty T\<midarrow>n1\<rightarrow> s1"
     "G\<turnstile>s1 \<midarrow>e-\<succ>i\<midarrow>n2\<rightarrow> s2"      
     by (iprover)
   moreover
   note \<open>G\<turnstile>abupd (check_neg i) s2 \<midarrow>halloc Arr T (the_Intg i)\<succ>a\<rightarrow> s3\<close>
   ultimately
   have "G\<turnstile>Norm s0 \<midarrow>New T[e]-\<succ>Addr a\<midarrow>max n1 n2\<rightarrow> s3"
     by (blast intro: evaln.NewA dest: evaln_max2)
   then show ?case ..
 next
   case (Cast s0 e v s1 s2 castT)
   then obtain n where
     "G\<turnstile>Norm s0 \<midarrow>e-\<succ>v\<midarrow>n\<rightarrow> s1"
     by (iprover)
   moreover 
   note \<open>s2 = abupd (raise_if (\<not> G,snd s1\<turnstile>v fits castT) ClassCast) s1\<close>
   ultimately
   have "G\<turnstile>Norm s0 \<midarrow>Cast castT e-\<succ>v\<midarrow>n\<rightarrow> s2"
     by (rule evaln.Cast)
   then show ?case ..
 next
   case (Inst s0 e v s1 b T)
   then obtain n where
     "G\<turnstile>Norm s0 \<midarrow>e-\<succ>v\<midarrow>n\<rightarrow> s1"
     by (iprover)
   moreover 
   note \<open>b = (v \<noteq> Null \<and> G,snd s1\<turnstile>v fits RefT T)\<close>
   ultimately
   have "G\<turnstile>Norm s0 \<midarrow>e InstOf T-\<succ>Bool b\<midarrow>n\<rightarrow> s1"
     by (rule evaln.Inst)
   then show ?case ..
 next
   case (Lit s v)
   fix n have "G\<turnstile>Norm s \<midarrow>Lit v-\<succ>v\<midarrow>n\<rightarrow> Norm s"
     by (rule evaln.Lit)
   then show ?case ..
 next
   case (UnOp s0 e v s1 unop)
   then obtain n where
     "G\<turnstile>Norm s0 \<midarrow>e-\<succ>v\<midarrow>n\<rightarrow> s1"
     by (iprover)
   hence "G\<turnstile>Norm s0 \<midarrow>UnOp unop e-\<succ>eval_unop unop v\<midarrow>n\<rightarrow> s1"
     by (rule evaln.UnOp)
   then show ?case ..
 next
   case (BinOp s0 e1 v1 s1 binop e2 v2 s2)
   then obtain n1 n2 where 
     "G\<turnstile>Norm s0 \<midarrow>e1-\<succ>v1\<midarrow>n1\<rightarrow> s1"
     "G\<turnstile>s1 \<midarrow>(if need_second_arg binop v1 then In1l e2
                else In1r Skip)\<succ>\<midarrow>n2\<rightarrow> (In1 v2, s2)"    
     by (iprover)
   hence "G\<turnstile>Norm s0 \<midarrow>BinOp binop e1 e2-\<succ>(eval_binop binop v1 v2)\<midarrow>max n1 n2
           \<rightarrow> s2"
     by (blast intro!: evaln.BinOp dest: evaln_max2)
   then show ?case ..
 next
   case (Super s )
   fix n have "G\<turnstile>Norm s \<midarrow>Super-\<succ>val_this s\<midarrow>n\<rightarrow> Norm s"
     by (rule evaln.Super)
   then show ?case ..
 next
   case (Acc s0 va v f s1)
   then obtain n where
     "G\<turnstile>Norm s0 \<midarrow>va=\<succ>(v, f)\<midarrow>n\<rightarrow> s1"
     by (iprover)
   then
   have "G\<turnstile>Norm s0 \<midarrow>Acc va-\<succ>v\<midarrow>n\<rightarrow> s1"
     by (rule evaln.Acc)
   then show ?case ..
 next
   case (Ass s0 var w f s1 e v s2)
   then obtain n1 n2 where 
     "G\<turnstile>Norm s0 \<midarrow>var=\<succ>(w, f)\<midarrow>n1\<rightarrow> s1"
     "G\<turnstile>s1 \<midarrow>e-\<succ>v\<midarrow>n2\<rightarrow> s2"      
     by (iprover)
   then
   have "G\<turnstile>Norm s0 \<midarrow>var:=e-\<succ>v\<midarrow>max n1 n2\<rightarrow> assign f v s2"
     by (blast intro: evaln.Ass dest: evaln_max2)
   then show ?case ..
 next
   case (Cond s0 e0 b s1 e1 e2 v s2)
   then obtain n1 n2 where 
     "G\<turnstile>Norm s0 \<midarrow>e0-\<succ>b\<midarrow>n1\<rightarrow> s1"
     "G\<turnstile>s1 \<midarrow>(if the_Bool b then e1 else e2)-\<succ>v\<midarrow>n2\<rightarrow> s2"
     by (iprover)
   then
   have "G\<turnstile>Norm s0 \<midarrow>e0 ? e1 : e2-\<succ>v\<midarrow>max n1 n2\<rightarrow> s2"
     by (blast intro: evaln.Cond dest: evaln_max2)
   then show ?case ..
 next
   case (Call s0 e a' s1 args vs s2 invDeclC mode statT mn pTs' s3 s3' accC' v s4)
   then obtain n1 n2 where
     "G\<turnstile>Norm s0 \<midarrow>e-\<succ>a'\<midarrow>n1\<rightarrow> s1"
     "G\<turnstile>s1 \<midarrow>args\<doteq>\<succ>vs\<midarrow>n2\<rightarrow> s2"
     by iprover
   moreover
   note \<open>invDeclC = invocation_declclass G mode (store s2) a' statT 
                        \<lparr>name=mn,parTs=pTs'\<rparr>\<close>
   moreover
   note \<open>s3 = init_lvars G invDeclC \<lparr>name=mn,parTs=pTs'\<rparr> mode a' vs s2\<close>
   moreover
   note \<open>s3'=check_method_access G accC' statT mode \<lparr>name=mn,parTs=pTs'\<rparr> a' s3\<close>
   moreover 
   from Call.hyps
   obtain m where 
     "G\<turnstile>s3' \<midarrow>Methd invDeclC \<lparr>name=mn, parTs=pTs'\<rparr>-\<succ>v\<midarrow>m\<rightarrow> s4"
     by iprover
   ultimately
   have "G\<turnstile>Norm s0 \<midarrow>{accC',statT,mode}e\<cdot>mn( {pTs'}args)-\<succ>v\<midarrow>max n1 (max n2 m)\<rightarrow> 
             (set_lvars (locals (store s2))) s4"
     by (auto intro!: evaln.Call max.cobounded1 le_max3I1 le_max3I2)
   thus ?case ..
 next
   case (Methd s0 D sig v s1)
   then obtain n where
     "G\<turnstile>Norm s0 \<midarrow>body G D sig-\<succ>v\<midarrow>n\<rightarrow> s1"
     by iprover
   then have "G\<turnstile>Norm s0 \<midarrow>Methd D sig-\<succ>v\<midarrow>Suc n\<rightarrow> s1"
     by (rule evaln.Methd)
   then show ?case ..
 next
   case (Body s0 D s1 c s2 s3)
   from Body.hyps obtain n1 n2 where 
     evaln_init: "G\<turnstile>Norm s0 \<midarrow>Init D\<midarrow>n1\<rightarrow> s1" and
     evaln_c: "G\<turnstile>s1 \<midarrow>c\<midarrow>n2\<rightarrow> s2"
     by (iprover)
   moreover
   note \<open>s3 = (if \<exists>l. fst s2 = Some (Jump (Break l)) \<or> 
                      fst s2 = Some (Jump (Cont l))
               then abupd (\<lambda>x. Some (Error CrossMethodJump)) s2 
               else s2)\<close>
   ultimately
   have
      "G\<turnstile>Norm s0 \<midarrow>Body D c-\<succ>the (locals (store s2) Result)\<midarrow>max n1 n2
        \<rightarrow> abupd (absorb Ret) s3"
     by (iprover intro: evaln.Body dest: evaln_max2)
   then show ?case ..
 next
   case (LVar s vn )
   obtain n where
     "G\<turnstile>Norm s \<midarrow>LVar vn=\<succ>lvar vn s\<midarrow>n\<rightarrow> Norm s"
     by (iprover intro: evaln.LVar)
   then show ?case ..
 next
   case (FVar s0 statDeclC s1 e a s2 v s2' stat fn s3 accC)
   then obtain n1 n2 where
     "G\<turnstile>Norm s0 \<midarrow>Init statDeclC\<midarrow>n1\<rightarrow> s1"
     "G\<turnstile>s1 \<midarrow>e-\<succ>a\<midarrow>n2\<rightarrow> s2"
     by iprover
   moreover
   note \<open>s3 = check_field_access G accC statDeclC fn stat a s2'\<close>
     and \<open>(v, s2') = fvar statDeclC stat fn a s2\<close>
   ultimately
   have "G\<turnstile>Norm s0 \<midarrow>{accC,statDeclC,stat}e..fn=\<succ>v\<midarrow>max n1 n2\<rightarrow> s3"
     by (iprover intro: evaln.FVar dest: evaln_max2)
   then show ?case ..
 next
   case (AVar s0 e1 a s1 e2 i s2 v s2')
   then obtain n1 n2 where 
     "G\<turnstile>Norm s0 \<midarrow>e1-\<succ>a\<midarrow>n1\<rightarrow> s1"
     "G\<turnstile>s1 \<midarrow>e2-\<succ>i\<midarrow>n2\<rightarrow> s2"      
     by iprover
   moreover 
   note \<open>(v, s2') = avar G i a s2\<close>
   ultimately 
   have "G\<turnstile>Norm s0 \<midarrow>e1.[e2]=\<succ>v\<midarrow>max n1 n2\<rightarrow> s2'"
     by (blast intro!: evaln.AVar dest: evaln_max2)
   then show ?case ..
 next
   case (Nil s0)
   show ?case by (iprover intro: evaln.Nil)
 next
   case (Cons s0 e v s1 es vs s2)
   then obtain n1 n2 where 
     "G\<turnstile>Norm s0 \<midarrow>e-\<succ>v\<midarrow>n1\<rightarrow> s1"
     "G\<turnstile>s1 \<midarrow>es\<doteq>\<succ>vs\<midarrow>n2\<rightarrow> s2"      
     by iprover
   then
   have "G\<turnstile>Norm s0 \<midarrow>e # es\<doteq>\<succ>v # vs\<midarrow>max n1 n2\<rightarrow> s2"
     by (blast intro!: evaln.Cons dest: evaln_max2)
   then show ?case ..
 qed
 
 end
diff --git a/src/HOL/Bali/WellType.thy b/src/HOL/Bali/WellType.thy
--- a/src/HOL/Bali/WellType.thy
+++ b/src/HOL/Bali/WellType.thy
@@ -1,686 +1,686 @@
 (*  Title:      HOL/Bali/WellType.thy
     Author:     David von Oheimb
 *)
 subsection \<open>Well-typedness of Java programs\<close>
 
 theory WellType
 imports DeclConcepts
 begin
 
 text \<open>
 improvements over Java Specification 1.0:
 \begin{itemize}
 \item methods of Object can be called upon references of interface or array type
 \end{itemize}
 simplifications:
 \begin{itemize}
 \item the type rules include all static checks on statements and expressions, 
       e.g. definedness of names (of parameters, locals, fields, methods)
 \end{itemize}
 design issues:
 \begin{itemize}
 \item unified type judgment for statements, variables, expressions, 
       expression lists
 \item statements are typed like expressions with dummy type Void
 \item the typing rules take an extra argument that is capable of determining 
   the dynamic type of objects. Therefore, they can be used for both 
   checking static types and determining runtime types in transition semantics.
 \end{itemize}
 \<close>
 
 type_synonym lenv
         = "(lname, ty) table"  \<comment> \<open>local variables, including This and Result\<close>
 
 record env = 
          prg:: "prog"    \<comment> \<open>program\<close>
          cls:: "qtname"  \<comment> \<open>current package and class name\<close>
          lcl:: "lenv"    \<comment> \<open>local environment\<close>     
   
 translations
   (type) "lenv" <= (type) "(lname, ty) table"
   (type) "lenv" <= (type) "lname \<Rightarrow> ty option"
   (type) "env" <= (type) "\<lparr>prg::prog,cls::qtname,lcl::lenv\<rparr>"
   (type) "env" <= (type) "\<lparr>prg::prog,cls::qtname,lcl::lenv,\<dots>::'a\<rparr>"
 
 
 abbreviation
   pkg :: "env \<Rightarrow> pname" \<comment> \<open>select the current package from an environment\<close>
   where "pkg e == pid (cls e)"
 
 subsubsection "Static overloading: maximally specific methods "
 
 type_synonym
   emhead = "ref_ty \<times> mhead"
 
 \<comment> \<open>Some mnemotic selectors for emhead\<close>
 definition
   "declrefT" :: "emhead \<Rightarrow> ref_ty"
   where "declrefT = fst"
 
 definition
   "mhd" :: "emhead \<Rightarrow> mhead"
   where "mhd \<equiv> snd"
 
 lemma declrefT_simp[simp]:"declrefT (r,m) = r"
 by (simp add: declrefT_def)
 
 lemma mhd_simp[simp]:"mhd (r,m) = m"
 by (simp add: mhd_def)
 
 lemma static_mhd_simp[simp]: "static (mhd m) = is_static m"
 by (cases m) (simp add: member_is_static_simp mhd_def)
 
 lemma mhd_resTy_simp [simp]: "resTy (mhd m) = resTy m"
 by (cases m) simp
 
 lemma mhd_is_static_simp [simp]: "is_static (mhd m) = is_static m"
 by (cases m) simp
 
 lemma mhd_accmodi_simp [simp]: "accmodi (mhd m) = accmodi m"
 by (cases m) simp
 
 definition
   cmheads :: "prog \<Rightarrow> qtname \<Rightarrow> qtname \<Rightarrow> sig \<Rightarrow> emhead set"
   where "cmheads G S C = (\<lambda>sig. (\<lambda>(Cls,mthd). (ClassT Cls,(mhead mthd))) ` set_option (accmethd G S C sig))"
 
 definition
   Objectmheads :: "prog \<Rightarrow> qtname \<Rightarrow> sig \<Rightarrow> emhead set" where
   "Objectmheads G S =
     (\<lambda>sig. (\<lambda>(Cls,mthd). (ClassT Cls,(mhead mthd))) 
       ` set_option (filter_tab (\<lambda>sig m. accmodi m \<noteq> Private) (accmethd G S Object) sig))"
 
 definition
   accObjectmheads :: "prog \<Rightarrow> qtname \<Rightarrow> ref_ty \<Rightarrow> sig \<Rightarrow> emhead set"
 where
   "accObjectmheads G S T =
     (if G\<turnstile>RefT T accessible_in (pid S)
      then Objectmheads G S
      else (\<lambda>sig. {}))"
 
 primrec mheads :: "prog \<Rightarrow> qtname \<Rightarrow> ref_ty \<Rightarrow> sig \<Rightarrow> emhead set"
 where
   "mheads G S  NullT     = (\<lambda>sig. {})"
 | "mheads G S (IfaceT I) = (\<lambda>sig. (\<lambda>(I,h).(IfaceT I,h)) 
                            ` accimethds G (pid S) I sig \<union> 
                              accObjectmheads G S (IfaceT I) sig)"
 | "mheads G S (ClassT C) = cmheads G S C"
 | "mheads G S (ArrayT T) = accObjectmheads G S (ArrayT T)"
 
 definition
   \<comment> \<open>applicable methods, cf. 15.11.2.1\<close>
   appl_methds :: "prog \<Rightarrow> qtname \<Rightarrow>  ref_ty \<Rightarrow> sig \<Rightarrow> (emhead \<times> ty list) set" where
   "appl_methds G S rt = (\<lambda> sig. 
       {(mh,pTs') |mh pTs'. mh \<in> mheads G S rt \<lparr>name=name sig,parTs=pTs'\<rparr> \<and> 
                            G\<turnstile>(parTs sig)[\<preceq>]pTs'})"
 
 definition
   \<comment> \<open>more specific methods, cf. 15.11.2.2\<close>
   more_spec :: "prog \<Rightarrow> emhead \<times> ty list \<Rightarrow> emhead \<times> ty list \<Rightarrow> bool" where
   "more_spec G = (\<lambda>(mh,pTs). \<lambda>(mh',pTs'). G\<turnstile>pTs[\<preceq>]pTs')"
 (*more_spec G \<equiv>\<lambda>((d,h),pTs). \<lambda>((d',h'),pTs'). G\<turnstile>RefT d\<preceq>RefT d'\<and>G\<turnstile>pTs[\<preceq>]pTs'*)
 
 definition
   \<comment> \<open>maximally specific methods, cf. 15.11.2.2\<close>
   max_spec :: "prog \<Rightarrow> qtname \<Rightarrow> ref_ty \<Rightarrow> sig \<Rightarrow> (emhead \<times> ty list) set" where
   "max_spec G S rt sig = {m. m \<in>appl_methds G S rt sig \<and>
                           (\<forall>m'\<in>appl_methds G S rt sig. more_spec G m' m \<longrightarrow> m'=m)}"
 
 
 lemma max_spec2appl_meths: 
   "x \<in> max_spec G S T sig \<Longrightarrow> x \<in> appl_methds G S T sig" 
 by (auto simp: max_spec_def)
 
 lemma appl_methsD: "(mh,pTs')\<in>appl_methds G S T \<lparr>name=mn,parTs=pTs\<rparr> \<Longrightarrow>  
    mh \<in> mheads G S T \<lparr>name=mn,parTs=pTs'\<rparr> \<and> G\<turnstile>pTs[\<preceq>]pTs'"
 by (auto simp: appl_methds_def)
 
 lemma max_spec2mheads: 
 "max_spec G S rt \<lparr>name=mn,parTs=pTs\<rparr> = insert (mh, pTs') A 
  \<Longrightarrow> mh \<in> mheads G S rt \<lparr>name=mn,parTs=pTs'\<rparr> \<and> G\<turnstile>pTs[\<preceq>]pTs'"
 apply (auto dest: equalityD2 subsetD max_spec2appl_meths appl_methsD)
 done
 
 
 definition
   empty_dt :: "dyn_ty"
   where "empty_dt = (\<lambda>a. None)"
 
 definition
   invmode :: "('a::type)member_scheme \<Rightarrow> expr \<Rightarrow> inv_mode" where
   "invmode m e = (if is_static m 
                   then Static 
                   else if e=Super then SuperM else IntVir)"
 
 lemma invmode_nonstatic [simp]: 
   "invmode \<lparr>access=a,static=False,\<dots>=x\<rparr> (Acc (LVar e)) = IntVir"
 apply (unfold invmode_def)
 apply (simp (no_asm) add: member_is_static_simp)
 done
 
 
 lemma invmode_Static_eq [simp]: "(invmode m e = Static) = is_static m"
 apply (unfold invmode_def)
 apply (simp (no_asm))
 done
 
 
 lemma invmode_IntVir_eq: "(invmode m e = IntVir) = (\<not>(is_static m) \<and> e\<noteq>Super)"
 apply (unfold invmode_def)
 apply (simp (no_asm))
 done
 
 lemma Null_staticD: 
   "a'=Null \<longrightarrow> (is_static m) \<Longrightarrow> invmode m e = IntVir \<longrightarrow> a' \<noteq> Null"
 apply (clarsimp simp add: invmode_IntVir_eq)
 done
 
 subsubsection "Typing for unary operations"
 
 primrec unop_type :: "unop \<Rightarrow> prim_ty"
 where
   "unop_type UPlus   = Integer"
 | "unop_type UMinus  = Integer"
 | "unop_type UBitNot = Integer"
 | "unop_type UNot    = Boolean"    
 
 primrec wt_unop :: "unop \<Rightarrow> ty \<Rightarrow> bool"
 where
   "wt_unop UPlus   t = (t = PrimT Integer)"
 | "wt_unop UMinus  t = (t = PrimT Integer)"
 | "wt_unop UBitNot t = (t = PrimT Integer)"
 | "wt_unop UNot    t = (t = PrimT Boolean)"
 
 subsubsection "Typing for binary operations"
 
 primrec binop_type :: "binop \<Rightarrow> prim_ty"
 where
   "binop_type Mul      = Integer"     
 | "binop_type Div      = Integer"
 | "binop_type Mod      = Integer"
 | "binop_type Plus     = Integer"
 | "binop_type Minus    = Integer"
 | "binop_type LShift   = Integer"
 | "binop_type RShift   = Integer"
 | "binop_type RShiftU  = Integer"
 | "binop_type Less     = Boolean"
 | "binop_type Le       = Boolean"
 | "binop_type Greater  = Boolean"
 | "binop_type Ge       = Boolean"
 | "binop_type Eq       = Boolean"
 | "binop_type Neq      = Boolean"
 | "binop_type BitAnd   = Integer"
 | "binop_type And      = Boolean"
 | "binop_type BitXor   = Integer"
 | "binop_type Xor      = Boolean"
 | "binop_type BitOr    = Integer"
 | "binop_type Or       = Boolean"
 | "binop_type CondAnd  = Boolean"
 | "binop_type CondOr   = Boolean"
 
 primrec wt_binop :: "prog \<Rightarrow> binop \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool"
 where
   "wt_binop G Mul     t1 t2 = ((t1 = PrimT Integer) \<and> (t2 = PrimT Integer))"
 | "wt_binop G Div     t1 t2 = ((t1 = PrimT Integer) \<and> (t2 = PrimT Integer))"
 | "wt_binop G Mod     t1 t2 = ((t1 = PrimT Integer) \<and> (t2 = PrimT Integer))"
 | "wt_binop G Plus    t1 t2 = ((t1 = PrimT Integer) \<and> (t2 = PrimT Integer))"
 | "wt_binop G Minus   t1 t2 = ((t1 = PrimT Integer) \<and> (t2 = PrimT Integer))"
 | "wt_binop G LShift  t1 t2 = ((t1 = PrimT Integer) \<and> (t2 = PrimT Integer))"
 | "wt_binop G RShift  t1 t2 = ((t1 = PrimT Integer) \<and> (t2 = PrimT Integer))"
 | "wt_binop G RShiftU t1 t2 = ((t1 = PrimT Integer) \<and> (t2 = PrimT Integer))"
 | "wt_binop G Less    t1 t2 = ((t1 = PrimT Integer) \<and> (t2 = PrimT Integer))"
 | "wt_binop G Le      t1 t2 = ((t1 = PrimT Integer) \<and> (t2 = PrimT Integer))"
 | "wt_binop G Greater t1 t2 = ((t1 = PrimT Integer) \<and> (t2 = PrimT Integer))"
 | "wt_binop G Ge      t1 t2 = ((t1 = PrimT Integer) \<and> (t2 = PrimT Integer))"
 | "wt_binop G Eq      t1 t2 = (G\<turnstile>t1\<preceq>t2 \<or> G\<turnstile>t2\<preceq>t1)" 
 | "wt_binop G Neq     t1 t2 = (G\<turnstile>t1\<preceq>t2 \<or> G\<turnstile>t2\<preceq>t1)"
 | "wt_binop G BitAnd  t1 t2 = ((t1 = PrimT Integer) \<and> (t2 = PrimT Integer))"
 | "wt_binop G And     t1 t2 = ((t1 = PrimT Boolean) \<and> (t2 = PrimT Boolean))"
 | "wt_binop G BitXor  t1 t2 = ((t1 = PrimT Integer) \<and> (t2 = PrimT Integer))"
 | "wt_binop G Xor     t1 t2 = ((t1 = PrimT Boolean) \<and> (t2 = PrimT Boolean))"
 | "wt_binop G BitOr   t1 t2 = ((t1 = PrimT Integer) \<and> (t2 = PrimT Integer))"
 | "wt_binop G Or      t1 t2 = ((t1 = PrimT Boolean) \<and> (t2 = PrimT Boolean))"
 | "wt_binop G CondAnd t1 t2 = ((t1 = PrimT Boolean) \<and> (t2 = PrimT Boolean))"
 | "wt_binop G CondOr  t1 t2 = ((t1 = PrimT Boolean) \<and> (t2 = PrimT Boolean))"
 
 subsubsection "Typing for terms"
 
 type_synonym tys  = "ty + ty list"
 translations
   (type) "tys" <= (type) "ty + ty list"
 
 
 inductive wt :: "env \<Rightarrow> dyn_ty \<Rightarrow> [term,tys] \<Rightarrow> bool" ("_,_\<Turnstile>_\<Colon>_"  [51,51,51,51] 50)
   and wt_stmt :: "env \<Rightarrow> dyn_ty \<Rightarrow>  stmt       \<Rightarrow> bool" ("_,_\<Turnstile>_\<Colon>\<surd>"  [51,51,51] 50)
   and ty_expr :: "env \<Rightarrow> dyn_ty \<Rightarrow> [expr ,ty ] \<Rightarrow> bool" ("_,_\<Turnstile>_\<Colon>-_" [51,51,51,51] 50)
   and ty_var :: "env \<Rightarrow> dyn_ty \<Rightarrow> [var  ,ty ] \<Rightarrow> bool" ("_,_\<Turnstile>_\<Colon>=_" [51,51,51,51] 50)
   and ty_exprs :: "env \<Rightarrow> dyn_ty \<Rightarrow> [expr list, ty   list] \<Rightarrow> bool"
     ("_,_\<Turnstile>_\<Colon>\<doteq>_" [51,51,51,51] 50)
 where
 
   "E,dt\<Turnstile>s\<Colon>\<surd> \<equiv> E,dt\<Turnstile>In1r s\<Colon>Inl (PrimT Void)"
 | "E,dt\<Turnstile>e\<Colon>-T \<equiv> E,dt\<Turnstile>In1l e\<Colon>Inl T"
 | "E,dt\<Turnstile>e\<Colon>=T \<equiv> E,dt\<Turnstile>In2  e\<Colon>Inl T"
 | "E,dt\<Turnstile>e\<Colon>\<doteq>T \<equiv> E,dt\<Turnstile>In3  e\<Colon>Inr T"
 
 \<comment> \<open>well-typed statements\<close>
 
 | Skip:                                 "E,dt\<Turnstile>Skip\<Colon>\<surd>"
 
 | Expr: "\<lbrakk>E,dt\<Turnstile>e\<Colon>-T\<rbrakk> \<Longrightarrow>
                                          E,dt\<Turnstile>Expr e\<Colon>\<surd>"
   \<comment> \<open>cf. 14.6\<close>
 | Lab:  "E,dt\<Turnstile>c\<Colon>\<surd> \<Longrightarrow>                   
                                          E,dt\<Turnstile>l\<bullet> c\<Colon>\<surd>" 
 
 | Comp: "\<lbrakk>E,dt\<Turnstile>c1\<Colon>\<surd>; 
           E,dt\<Turnstile>c2\<Colon>\<surd>\<rbrakk> \<Longrightarrow>
                                          E,dt\<Turnstile>c1;; c2\<Colon>\<surd>"
 
   \<comment> \<open>cf. 14.8\<close>
 | If:   "\<lbrakk>E,dt\<Turnstile>e\<Colon>-PrimT Boolean;
           E,dt\<Turnstile>c1\<Colon>\<surd>;
           E,dt\<Turnstile>c2\<Colon>\<surd>\<rbrakk> \<Longrightarrow>
                                          E,dt\<Turnstile>If(e) c1 Else c2\<Colon>\<surd>"
 
   \<comment> \<open>cf. 14.10\<close>
 | Loop: "\<lbrakk>E,dt\<Turnstile>e\<Colon>-PrimT Boolean;
           E,dt\<Turnstile>c\<Colon>\<surd>\<rbrakk> \<Longrightarrow>
                                          E,dt\<Turnstile>l\<bullet> While(e) c\<Colon>\<surd>"
   \<comment> \<open>cf. 14.13, 14.15, 14.16\<close>
 | Jmp:                                   "E,dt\<Turnstile>Jmp jump\<Colon>\<surd>"
 
   \<comment> \<open>cf. 14.16\<close>
 | Throw: "\<lbrakk>E,dt\<Turnstile>e\<Colon>-Class tn;
           prg E\<turnstile>tn\<preceq>\<^sub>C SXcpt Throwable\<rbrakk> \<Longrightarrow>
                                          E,dt\<Turnstile>Throw e\<Colon>\<surd>"
   \<comment> \<open>cf. 14.18\<close>
 | Try:  "\<lbrakk>E,dt\<Turnstile>c1\<Colon>\<surd>; prg E\<turnstile>tn\<preceq>\<^sub>C SXcpt Throwable;
           lcl E (VName vn)=None; E \<lparr>lcl := (lcl E)(VName vn\<mapsto>Class tn)\<rparr>,dt\<Turnstile>c2\<Colon>\<surd>\<rbrakk>
           \<Longrightarrow>
                                          E,dt\<Turnstile>Try c1 Catch(tn vn) c2\<Colon>\<surd>"
 
   \<comment> \<open>cf. 14.18\<close>
 | Fin:  "\<lbrakk>E,dt\<Turnstile>c1\<Colon>\<surd>; E,dt\<Turnstile>c2\<Colon>\<surd>\<rbrakk> \<Longrightarrow>
                                          E,dt\<Turnstile>c1 Finally c2\<Colon>\<surd>"
 
 | Init: "\<lbrakk>is_class (prg E) C\<rbrakk> \<Longrightarrow>
                                          E,dt\<Turnstile>Init C\<Colon>\<surd>"
   \<comment> \<open>\<^term>\<open>Init\<close> is created on the fly during evaluation (see Eval.thy). 
      The class isn't necessarily accessible from the points \<^term>\<open>Init\<close> 
      is called. Therefor we only demand \<^term>\<open>is_class\<close> and not 
      \<^term>\<open>is_acc_class\<close> here.\<close>
 
 \<comment> \<open>well-typed expressions\<close>
 
   \<comment> \<open>cf. 15.8\<close>
 | NewC: "\<lbrakk>is_acc_class (prg E) (pkg E) C\<rbrakk> \<Longrightarrow>
                                          E,dt\<Turnstile>NewC C\<Colon>-Class C"
   \<comment> \<open>cf. 15.9\<close>
 | NewA: "\<lbrakk>is_acc_type (prg E) (pkg E) T;
           E,dt\<Turnstile>i\<Colon>-PrimT Integer\<rbrakk> \<Longrightarrow>
                                          E,dt\<Turnstile>New T[i]\<Colon>-T.[]"
 
   \<comment> \<open>cf. 15.15\<close>
 | Cast: "\<lbrakk>E,dt\<Turnstile>e\<Colon>-T; is_acc_type (prg E) (pkg E) T';
           prg E\<turnstile>T\<preceq>? T'\<rbrakk> \<Longrightarrow>
                                          E,dt\<Turnstile>Cast T' e\<Colon>-T'"
 
   \<comment> \<open>cf. 15.19.2\<close>
 | Inst: "\<lbrakk>E,dt\<Turnstile>e\<Colon>-RefT T; is_acc_type (prg E) (pkg E) (RefT T');
           prg E\<turnstile>RefT T\<preceq>? RefT T'\<rbrakk> \<Longrightarrow>
                                          E,dt\<Turnstile>e InstOf T'\<Colon>-PrimT Boolean"
 
   \<comment> \<open>cf. 15.7.1\<close>
 | Lit:  "\<lbrakk>typeof dt x = Some T\<rbrakk> \<Longrightarrow>
                                          E,dt\<Turnstile>Lit x\<Colon>-T"
 
 | UnOp: "\<lbrakk>E,dt\<Turnstile>e\<Colon>-Te; wt_unop unop Te; T=PrimT (unop_type unop)\<rbrakk> 
           \<Longrightarrow>
           E,dt\<Turnstile>UnOp unop e\<Colon>-T"
   
 | BinOp: "\<lbrakk>E,dt\<Turnstile>e1\<Colon>-T1; E,dt\<Turnstile>e2\<Colon>-T2; wt_binop (prg E) binop T1 T2; 
            T=PrimT (binop_type binop)\<rbrakk> 
            \<Longrightarrow>
            E,dt\<Turnstile>BinOp binop e1 e2\<Colon>-T"
   
   \<comment> \<open>cf. 15.10.2, 15.11.1\<close>
 | Super: "\<lbrakk>lcl E This = Some (Class C); C \<noteq> Object;
           class (prg E) C = Some c\<rbrakk> \<Longrightarrow>
                                          E,dt\<Turnstile>Super\<Colon>-Class (super c)"
 
   \<comment> \<open>cf. 15.13.1, 15.10.1, 15.12\<close>
 | Acc:  "\<lbrakk>E,dt\<Turnstile>va\<Colon>=T\<rbrakk> \<Longrightarrow>
                                          E,dt\<Turnstile>Acc va\<Colon>-T"
 
   \<comment> \<open>cf. 15.25, 15.25.1\<close>
 | Ass:  "\<lbrakk>E,dt\<Turnstile>va\<Colon>=T; va \<noteq> LVar This;
           E,dt\<Turnstile>v \<Colon>-T';
           prg E\<turnstile>T'\<preceq>T\<rbrakk> \<Longrightarrow>
                                          E,dt\<Turnstile>va:=v\<Colon>-T'"
 
   \<comment> \<open>cf. 15.24\<close>
 | Cond: "\<lbrakk>E,dt\<Turnstile>e0\<Colon>-PrimT Boolean;
           E,dt\<Turnstile>e1\<Colon>-T1; E,dt\<Turnstile>e2\<Colon>-T2;
           prg E\<turnstile>T1\<preceq>T2 \<and> T = T2  \<or>  prg E\<turnstile>T2\<preceq>T1 \<and> T = T1\<rbrakk> \<Longrightarrow>
                                          E,dt\<Turnstile>e0 ? e1 : e2\<Colon>-T"
 
   \<comment> \<open>cf. 15.11.1, 15.11.2, 15.11.3\<close>
 | Call: "\<lbrakk>E,dt\<Turnstile>e\<Colon>-RefT statT;
           E,dt\<Turnstile>ps\<Colon>\<doteq>pTs;
           max_spec (prg E) (cls E) statT \<lparr>name=mn,parTs=pTs\<rparr> 
             = {((statDeclT,m),pTs')}
          \<rbrakk> \<Longrightarrow>
                    E,dt\<Turnstile>{cls E,statT,invmode m e}e\<cdot>mn({pTs'}ps)\<Colon>-(resTy m)"
 
 | Methd: "\<lbrakk>is_class (prg E) C;
           methd (prg E) C sig = Some m;
           E,dt\<Turnstile>Body (declclass m) (stmt (mbody (mthd m)))\<Colon>-T\<rbrakk> \<Longrightarrow>
                                          E,dt\<Turnstile>Methd C sig\<Colon>-T"
  \<comment> \<open>The class \<^term>\<open>C\<close> is the dynamic class of the method call 
     (cf. Eval.thy). 
     It hasn't got to be directly accessible from the current package 
     \<^term>\<open>(pkg E)\<close>. 
     Only the static class must be accessible (enshured indirectly by 
     \<^term>\<open>Call\<close>). 
     Note that l is just a dummy value. It is only used in the smallstep 
     semantics. To proof typesafety directly for the smallstep semantics 
     we would have to assume conformance of l here!\<close>
 
 | Body: "\<lbrakk>is_class (prg E) D;
           E,dt\<Turnstile>blk\<Colon>\<surd>;
           (lcl E) Result = Some T;
           is_type (prg E) T\<rbrakk> \<Longrightarrow>
                                          E,dt\<Turnstile>Body D blk\<Colon>-T"
 \<comment> \<open>The class \<^term>\<open>D\<close> implementing the method must not directly be 
      accessible  from the current package \<^term>\<open>(pkg E)\<close>, but can also 
      be indirectly accessible due to inheritance (enshured in \<^term>\<open>Call\<close>)
     The result type hasn't got to be accessible in Java! (If it is not 
     accessible you can only assign it to Object).
     For dummy value l see rule \<^term>\<open>Methd\<close>.\<close>
 
 \<comment> \<open>well-typed variables\<close>
 
   \<comment> \<open>cf. 15.13.1\<close>
 | LVar: "\<lbrakk>lcl E vn = Some T; is_acc_type (prg E) (pkg E) T\<rbrakk> \<Longrightarrow>
                                          E,dt\<Turnstile>LVar vn\<Colon>=T"
   \<comment> \<open>cf. 15.10.1\<close>
 | FVar: "\<lbrakk>E,dt\<Turnstile>e\<Colon>-Class C; 
           accfield (prg E) (cls E) C fn = Some (statDeclC,f)\<rbrakk> \<Longrightarrow>
                          E,dt\<Turnstile>{cls E,statDeclC,is_static f}e..fn\<Colon>=(type f)"
   \<comment> \<open>cf. 15.12\<close>
 | AVar: "\<lbrakk>E,dt\<Turnstile>e\<Colon>-T.[]; 
           E,dt\<Turnstile>i\<Colon>-PrimT Integer\<rbrakk> \<Longrightarrow>
                                          E,dt\<Turnstile>e.[i]\<Colon>=T"
 
 
 \<comment> \<open>well-typed expression lists\<close>
 
   \<comment> \<open>cf. 15.11.???\<close>
 | Nil:                                  "E,dt\<Turnstile>[]\<Colon>\<doteq>[]"
 
   \<comment> \<open>cf. 15.11.???\<close>
 | Cons: "\<lbrakk>E,dt\<Turnstile>e \<Colon>-T;
           E,dt\<Turnstile>es\<Colon>\<doteq>Ts\<rbrakk> \<Longrightarrow>
                                          E,dt\<Turnstile>e#es\<Colon>\<doteq>T#Ts"
 
 
 (* for purely static typing *)
 abbreviation
   wt_syntax :: "env \<Rightarrow> [term,tys] \<Rightarrow> bool" ("_\<turnstile>_\<Colon>_"  [51,51,51] 50)
   where "E\<turnstile>t\<Colon>T == E,empty_dt\<Turnstile>t\<Colon> T"
 
 abbreviation
   wt_stmt_syntax :: "env \<Rightarrow> stmt \<Rightarrow> bool" ("_\<turnstile>_\<Colon>\<surd>"  [51,51   ] 50)
   where "E\<turnstile>s\<Colon>\<surd> == E\<turnstile>In1r s \<Colon> Inl (PrimT Void)"
 
 abbreviation
   ty_expr_syntax :: "env \<Rightarrow> [expr, ty] \<Rightarrow> bool" ("_\<turnstile>_\<Colon>-_" [51,51,51] 50) 
   where "E\<turnstile>e\<Colon>-T == E\<turnstile>In1l e \<Colon> Inl T"
 
 abbreviation
   ty_var_syntax :: "env \<Rightarrow> [var, ty] \<Rightarrow> bool" ("_\<turnstile>_\<Colon>=_" [51,51,51] 50)
   where "E\<turnstile>e\<Colon>=T == E\<turnstile>In2 e \<Colon> Inl T"
 
 abbreviation
   ty_exprs_syntax :: "env \<Rightarrow> [expr list, ty list] \<Rightarrow> bool" ("_\<turnstile>_\<Colon>\<doteq>_" [51,51,51] 50)
   where "E\<turnstile>e\<Colon>\<doteq>T == E\<turnstile>In3 e \<Colon> Inr T"
 
 notation (ASCII)
   wt_syntax  ("_|-_::_" [51,51,51] 50) and
   wt_stmt_syntax  ("_|-_:<>" [51,51   ] 50) and
   ty_expr_syntax  ("_|-_:-_" [51,51,51] 50) and
   ty_var_syntax  ("_|-_:=_" [51,51,51] 50) and
   ty_exprs_syntax  ("_|-_:#_" [51,51,51] 50)
 
 declare not_None_eq [simp del] 
 declare if_split [split del] if_split_asm [split del]
 declare split_paired_All [simp del] split_paired_Ex [simp del]
 setup \<open>map_theory_simpset (fn ctxt => ctxt delloop "split_all_tac")\<close>
 
 inductive_cases wt_elim_cases [cases set]:
         "E,dt\<Turnstile>In2  (LVar vn)               \<Colon>T"
         "E,dt\<Turnstile>In2  ({accC,statDeclC,s}e..fn)\<Colon>T"
         "E,dt\<Turnstile>In2  (e.[i])                 \<Colon>T"
         "E,dt\<Turnstile>In1l (NewC C)                \<Colon>T"
         "E,dt\<Turnstile>In1l (New T'[i])             \<Colon>T"
         "E,dt\<Turnstile>In1l (Cast T' e)             \<Colon>T"
         "E,dt\<Turnstile>In1l (e InstOf T')           \<Colon>T"
         "E,dt\<Turnstile>In1l (Lit x)                 \<Colon>T"
         "E,dt\<Turnstile>In1l (UnOp unop e)           \<Colon>T"
         "E,dt\<Turnstile>In1l (BinOp binop e1 e2)     \<Colon>T"
         "E,dt\<Turnstile>In1l (Super)                 \<Colon>T"
         "E,dt\<Turnstile>In1l (Acc va)                \<Colon>T"
         "E,dt\<Turnstile>In1l (Ass va v)              \<Colon>T"
         "E,dt\<Turnstile>In1l (e0 ? e1 : e2)          \<Colon>T"
         "E,dt\<Turnstile>In1l ({accC,statT,mode}e\<cdot>mn({pT'}p))\<Colon>T"
         "E,dt\<Turnstile>In1l (Methd C sig)           \<Colon>T"
         "E,dt\<Turnstile>In1l (Body D blk)            \<Colon>T"
         "E,dt\<Turnstile>In3  ([])                    \<Colon>Ts"
         "E,dt\<Turnstile>In3  (e#es)                  \<Colon>Ts"
         "E,dt\<Turnstile>In1r  Skip                   \<Colon>x"
         "E,dt\<Turnstile>In1r (Expr e)                \<Colon>x"
         "E,dt\<Turnstile>In1r (c1;; c2)               \<Colon>x"
         "E,dt\<Turnstile>In1r (l\<bullet> c)                  \<Colon>x" 
         "E,dt\<Turnstile>In1r (If(e) c1 Else c2)      \<Colon>x"
         "E,dt\<Turnstile>In1r (l\<bullet> While(e) c)         \<Colon>x"
         "E,dt\<Turnstile>In1r (Jmp jump)              \<Colon>x"
         "E,dt\<Turnstile>In1r (Throw e)               \<Colon>x"
         "E,dt\<Turnstile>In1r (Try c1 Catch(tn vn) c2)\<Colon>x"
         "E,dt\<Turnstile>In1r (c1 Finally c2)         \<Colon>x"
         "E,dt\<Turnstile>In1r (Init C)                \<Colon>x"
 declare not_None_eq [simp] 
 declare if_split [split] if_split_asm [split]
 declare split_paired_All [simp] split_paired_Ex [simp]
 setup \<open>map_theory_simpset (fn ctxt => ctxt addloop ("split_all_tac", split_all_tac))\<close>
 
 lemma is_acc_class_is_accessible: 
   "is_acc_class G P C \<Longrightarrow> G\<turnstile>(Class C) accessible_in P"
 by (auto simp add: is_acc_class_def)
 
 lemma is_acc_iface_is_iface: "is_acc_iface G P I \<Longrightarrow> is_iface G I"
 by (auto simp add: is_acc_iface_def)
 
 lemma is_acc_iface_Iface_is_accessible: 
   "is_acc_iface G P I \<Longrightarrow> G\<turnstile>(Iface I) accessible_in P"
 by (auto simp add: is_acc_iface_def)
 
 lemma is_acc_type_is_type: "is_acc_type G P T \<Longrightarrow> is_type G T"
 by (auto simp add: is_acc_type_def)
 
 lemma is_acc_iface_is_accessible:
   "is_acc_type G P T \<Longrightarrow> G\<turnstile>T accessible_in P"
 by (auto simp add: is_acc_type_def)
 
 lemma wt_Methd_is_methd: 
   "E\<turnstile>In1l (Methd C sig)\<Colon>T \<Longrightarrow> is_methd (prg E) C sig"
 apply (erule_tac wt_elim_cases)
 apply clarsimp
 apply (erule is_methdI, assumption)
 done
 
 
 text \<open>Special versions of some typing rules, better suited to pattern 
         match the conclusion (no selectors in the conclusion)
 \<close>
 
 lemma wt_Call: 
 "\<lbrakk>E,dt\<Turnstile>e\<Colon>-RefT statT; E,dt\<Turnstile>ps\<Colon>\<doteq>pTs;  
   max_spec (prg E) (cls E) statT \<lparr>name=mn,parTs=pTs\<rparr> 
     = {((statDeclC,m),pTs')};rT=(resTy m);accC=cls E;
  mode = invmode m e\<rbrakk> \<Longrightarrow> E,dt\<Turnstile>{accC,statT,mode}e\<cdot>mn({pTs'}ps)\<Colon>-rT"
 by (auto elim: wt.Call)
 
 
 lemma invocationTypeExpr_noClassD: 
 "\<lbrakk> E\<turnstile>e\<Colon>-RefT statT\<rbrakk>
  \<Longrightarrow> (\<forall> statC. statT \<noteq> ClassT statC) \<longrightarrow> invmode m e \<noteq> SuperM"
 proof -
   assume wt: "E\<turnstile>e\<Colon>-RefT statT"
   show ?thesis
   proof (cases "e=Super")
     case True
     with wt obtain "C" where "statT = ClassT C" by (blast elim: wt_elim_cases)
     then show ?thesis by blast
   next 
     case False then show ?thesis 
       by (auto simp add: invmode_def)
   qed
 qed
 
 lemma wt_Super: 
 "\<lbrakk>lcl E This = Some (Class C); C \<noteq> Object; class (prg E) C = Some c; D=super c\<rbrakk> 
 \<Longrightarrow> E,dt\<Turnstile>Super\<Colon>-Class D"
 by (auto elim: wt.Super)
 
 lemma wt_FVar:  
 "\<lbrakk>E,dt\<Turnstile>e\<Colon>-Class C; accfield (prg E) (cls E) C fn = Some (statDeclC,f);
   sf=is_static f; fT=(type f); accC=cls E\<rbrakk> 
 \<Longrightarrow> E,dt\<Turnstile>{accC,statDeclC,sf}e..fn\<Colon>=fT"
 by (auto dest: wt.FVar)
 
 
 lemma wt_init [iff]: "E,dt\<Turnstile>Init C\<Colon>\<surd> = is_class (prg E) C"
 by (auto elim: wt_elim_cases intro: "wt.Init")
 
 declare wt.Skip [iff]
 
 lemma wt_StatRef: 
   "is_acc_type (prg E) (pkg E) (RefT rt) \<Longrightarrow> E\<turnstile>StatRef rt\<Colon>-RefT rt"
 apply (rule wt.Cast)
 apply  (rule wt.Lit)
 apply   (simp (no_asm))
 apply  (simp (no_asm_simp))
 apply (rule cast.widen)
 apply (simp (no_asm))
 done
 
 lemma wt_Inj_elim: 
   "\<And>E. E,dt\<Turnstile>t\<Colon>U \<Longrightarrow> case t of 
                        In1 ec \<Rightarrow> (case ec of 
                                     Inl e \<Rightarrow> \<exists>T. U=Inl T  
                                   | Inr s \<Rightarrow> U=Inl (PrimT Void))  
                      | In2 e \<Rightarrow> (\<exists>T. U=Inl T) 
                      | In3 e \<Rightarrow> (\<exists>T. U=Inr T)"
 apply (erule wt.induct)
 apply auto
 done
 
 \<comment> \<open>In the special syntax to distinguish the typing judgements for expressions, 
      statements, variables and expression lists the kind of term corresponds
      to the kind of type in the end e.g. An statement (injection \<^term>\<open>In3\<close> 
     into terms, always has type void (injection \<^term>\<open>Inl\<close> into the generalised
     types. The following simplification procedures establish these kinds of
     correlation.\<close>
 
 lemma wt_expr_eq: "E,dt\<Turnstile>In1l t\<Colon>U = (\<exists>T. U=Inl T \<and> E,dt\<Turnstile>t\<Colon>-T)"
   by (auto, frule wt_Inj_elim, auto)
 
 lemma wt_var_eq: "E,dt\<Turnstile>In2 t\<Colon>U = (\<exists>T. U=Inl T \<and> E,dt\<Turnstile>t\<Colon>=T)"
   by (auto, frule wt_Inj_elim, auto)
 
 lemma wt_exprs_eq: "E,dt\<Turnstile>In3 t\<Colon>U = (\<exists>Ts. U=Inr Ts \<and> E,dt\<Turnstile>t\<Colon>\<doteq>Ts)"
   by (auto, frule wt_Inj_elim, auto)
 
 lemma wt_stmt_eq: "E,dt\<Turnstile>In1r t\<Colon>U = (U=Inl(PrimT Void)\<and>E,dt\<Turnstile>t\<Colon>\<surd>)"
   by (auto, frule wt_Inj_elim, auto, frule wt_Inj_elim, auto)
 
 simproc_setup wt_expr ("E,dt\<Turnstile>In1l t\<Colon>U") = \<open>
-  fn _ => fn _ => fn ct =>
-    (case Thm.term_of ct of
-      (_ $ _ $ _ $ _ $ (Const _ $ _)) => NONE
-    | _ => SOME (mk_meta_eq @{thm wt_expr_eq}))\<close>
-
-simproc_setup wt_var ("E,dt\<Turnstile>In2 t\<Colon>U") = \<open>
-  fn _ => fn _ => fn ct =>
+  K (K (fn ct =>
     (case Thm.term_of ct of
       (_ $ _ $ _ $ _ $ (Const _ $ _)) => NONE
-    | _ => SOME (mk_meta_eq @{thm wt_var_eq}))\<close>
+    | _ => SOME (mk_meta_eq @{thm wt_expr_eq}))))\<close>
 
-simproc_setup wt_exprs ("E,dt\<Turnstile>In3 t\<Colon>U") = \<open>
-  fn _ => fn _ => fn ct =>
+simproc_setup wt_var ("E,dt\<Turnstile>In2 t\<Colon>U") = \<open>
+  K (K (fn ct =>
     (case Thm.term_of ct of
       (_ $ _ $ _ $ _ $ (Const _ $ _)) => NONE
-    | _ => SOME (mk_meta_eq @{thm wt_exprs_eq}))\<close>
+    | _ => SOME (mk_meta_eq @{thm wt_var_eq}))))\<close>
+
+simproc_setup wt_exprs ("E,dt\<Turnstile>In3 t\<Colon>U") = \<open>
+  K (K (fn ct =>
+    (case Thm.term_of ct of
+      (_ $ _ $ _ $ _ $ (Const _ $ _)) => NONE
+    | _ => SOME (mk_meta_eq @{thm wt_exprs_eq}))))\<close>
 
 simproc_setup wt_stmt ("E,dt\<Turnstile>In1r t\<Colon>U") = \<open>
-  fn _ => fn _ => fn ct =>
+  K (K (fn ct =>
     (case Thm.term_of ct of
       (_ $ _ $ _ $ _ $ (Const _ $ _)) => NONE
-    | _ => SOME (mk_meta_eq @{thm wt_stmt_eq}))\<close>
+    | _ => SOME (mk_meta_eq @{thm wt_stmt_eq}))))\<close>
 
 lemma wt_elim_BinOp:
   "\<lbrakk>E,dt\<Turnstile>In1l (BinOp binop e1 e2)\<Colon>T;
     \<And>T1 T2 T3.
        \<lbrakk>E,dt\<Turnstile>e1\<Colon>-T1; E,dt\<Turnstile>e2\<Colon>-T2; wt_binop (prg E) binop T1 T2;
           E,dt\<Turnstile>(if b then In1l e2 else In1r Skip)\<Colon>T3;
           T = Inl (PrimT (binop_type binop))\<rbrakk>
        \<Longrightarrow> P\<rbrakk>
 \<Longrightarrow> P"
 apply (erule wt_elim_cases)
 apply (cases b)
 apply auto
 done
 
 lemma Inj_eq_lemma [simp]: 
   "(\<forall>T. (\<exists>T'. T = Inj T' \<and> P T') \<longrightarrow> Q T) = (\<forall>T'. P T' \<longrightarrow> Q (Inj T'))"
 by auto
 
 (* unused *)
 lemma single_valued_tys_lemma [rule_format (no_asm)]: 
   "\<forall>S T. G\<turnstile>S\<preceq>T \<longrightarrow> G\<turnstile>T\<preceq>S \<longrightarrow> S = T \<Longrightarrow> E,dt\<Turnstile>t\<Colon>T \<Longrightarrow>  
      G = prg E \<longrightarrow> (\<forall>T'. E,dt\<Turnstile>t\<Colon>T' \<longrightarrow> T  = T')"
 apply (cases "E", erule wt.induct)
 apply (safe del: disjE)
 apply (simp_all (no_asm_use) split del: if_split_asm)
 apply (safe del: disjE)
 (* 17 subgoals *)
 apply (tactic \<open>ALLGOALS (fn i =>
   if i = 11 then EVERY'
    [Rule_Insts.thin_tac \<^context> "E,dt\<Turnstile>e0\<Colon>-PrimT Boolean" [(\<^binding>\<open>E\<close>, NONE, NoSyn)],
     Rule_Insts.thin_tac \<^context> "E,dt\<Turnstile>e1\<Colon>-T1" [(\<^binding>\<open>E\<close>, NONE, NoSyn), (\<^binding>\<open>T1\<close>, NONE, NoSyn)],
     Rule_Insts.thin_tac \<^context> "E,dt\<Turnstile>e2\<Colon>-T2" [(\<^binding>\<open>E\<close>, NONE, NoSyn), (\<^binding>\<open>T2\<close>, NONE, NoSyn)]] i
   else Rule_Insts.thin_tac \<^context> "All P" [(\<^binding>\<open>P\<close>, NONE, NoSyn)] i)\<close>)
 (*apply (safe del: disjE elim!: wt_elim_cases)*)
 apply (tactic \<open>ALLGOALS (eresolve_tac \<^context> @{thms wt_elim_cases})\<close>)
 apply (simp_all (no_asm_use) split del: if_split_asm)
 apply (erule_tac [12] V = "All P" for P in thin_rl) (* Call *)
 apply (blast del: equalityCE dest: sym [THEN trans])+
 done
 
 (* unused *)
 lemma single_valued_tys: 
 "ws_prog (prg E) \<Longrightarrow> single_valued {(t,T). E,dt\<Turnstile>t\<Colon>T}"
 apply (unfold single_valued_def)
 apply clarsimp
 apply (rule single_valued_tys_lemma)
 apply (auto intro!: widen_antisym)
 done
 
 lemma typeof_empty_is_type: "typeof (\<lambda>a. None) v = Some T \<Longrightarrow> is_type G T"
   by (induct v) auto
 
 (* unused *)
 lemma typeof_is_type: "(\<forall>a. v \<noteq> Addr a) \<Longrightarrow> \<exists>T. typeof dt v = Some T \<and> is_type G T"
   by (induct v) auto
 
 end
diff --git a/src/HOL/Boolean_Algebras.thy b/src/HOL/Boolean_Algebras.thy
--- a/src/HOL/Boolean_Algebras.thy
+++ b/src/HOL/Boolean_Algebras.thy
@@ -1,573 +1,573 @@
 (*  Title:      HOL/Boolean_Algebras.thy
     Author:     Brian Huffman
     Author:     Florian Haftmann
 *)
 
 section \<open>Boolean Algebras\<close>
 
 theory Boolean_Algebras
   imports Lattices
 begin
 
 subsection \<open>Abstract boolean algebra\<close>
 
 locale abstract_boolean_algebra = conj: abel_semigroup \<open>(\<^bold>\<sqinter>)\<close> + disj: abel_semigroup \<open>(\<^bold>\<squnion>)\<close>
   for conj :: \<open>'a \<Rightarrow> 'a \<Rightarrow> 'a\<close>  (infixr \<open>\<^bold>\<sqinter>\<close> 70)
     and disj :: \<open>'a \<Rightarrow> 'a \<Rightarrow> 'a\<close>  (infixr \<open>\<^bold>\<squnion>\<close> 65) +
   fixes compl :: \<open>'a \<Rightarrow> 'a\<close>  (\<open>\<^bold>- _\<close> [81] 80)
     and zero :: \<open>'a\<close>  (\<open>\<^bold>0\<close>)
     and one  :: \<open>'a\<close>  (\<open>\<^bold>1\<close>)
   assumes conj_disj_distrib: \<open>x \<^bold>\<sqinter> (y \<^bold>\<squnion> z) = (x \<^bold>\<sqinter> y) \<^bold>\<squnion> (x \<^bold>\<sqinter> z)\<close>
     and disj_conj_distrib: \<open>x \<^bold>\<squnion> (y \<^bold>\<sqinter> z) = (x \<^bold>\<squnion> y) \<^bold>\<sqinter> (x \<^bold>\<squnion> z)\<close>
     and conj_one_right: \<open>x \<^bold>\<sqinter> \<^bold>1 = x\<close>
     and disj_zero_right: \<open>x \<^bold>\<squnion> \<^bold>0 = x\<close>
     and conj_cancel_right [simp]: \<open>x \<^bold>\<sqinter> \<^bold>- x = \<^bold>0\<close>
     and disj_cancel_right [simp]: \<open>x \<^bold>\<squnion> \<^bold>- x = \<^bold>1\<close>
 begin
 
 sublocale conj: semilattice_neutr \<open>(\<^bold>\<sqinter>)\<close> \<open>\<^bold>1\<close>
 proof
   show "x \<^bold>\<sqinter> \<^bold>1 = x" for x 
     by (fact conj_one_right)
   show "x \<^bold>\<sqinter> x = x" for x
   proof -
     have "x \<^bold>\<sqinter> x = (x \<^bold>\<sqinter> x) \<^bold>\<squnion> \<^bold>0"
       by (simp add: disj_zero_right)
     also have "\<dots> = (x \<^bold>\<sqinter> x) \<^bold>\<squnion> (x \<^bold>\<sqinter> \<^bold>- x)"
       by simp
     also have "\<dots> = x \<^bold>\<sqinter> (x \<^bold>\<squnion> \<^bold>- x)"
       by (simp only: conj_disj_distrib)
     also have "\<dots> = x \<^bold>\<sqinter> \<^bold>1"
       by simp
     also have "\<dots> = x"
       by (simp add: conj_one_right)
     finally show ?thesis .
   qed
 qed
 
 sublocale disj: semilattice_neutr \<open>(\<^bold>\<squnion>)\<close> \<open>\<^bold>0\<close>
 proof
   show "x \<^bold>\<squnion> \<^bold>0 = x" for x
     by (fact disj_zero_right)
   show "x \<^bold>\<squnion> x = x" for x
   proof -
     have "x \<^bold>\<squnion> x = (x \<^bold>\<squnion> x) \<^bold>\<sqinter> \<^bold>1"
       by simp
     also have "\<dots> = (x \<^bold>\<squnion> x) \<^bold>\<sqinter> (x \<^bold>\<squnion> \<^bold>- x)"
       by simp
     also have "\<dots> = x \<^bold>\<squnion> (x \<^bold>\<sqinter> \<^bold>- x)"
       by (simp only: disj_conj_distrib)
     also have "\<dots> = x \<^bold>\<squnion> \<^bold>0"
       by simp
     also have "\<dots> = x"
       by (simp add: disj_zero_right)
     finally show ?thesis .
   qed
 qed
 
 
 subsubsection \<open>Complement\<close>
 
 lemma complement_unique:
   assumes 1: "a \<^bold>\<sqinter> x = \<^bold>0"
   assumes 2: "a \<^bold>\<squnion> x = \<^bold>1"
   assumes 3: "a \<^bold>\<sqinter> y = \<^bold>0"
   assumes 4: "a \<^bold>\<squnion> y = \<^bold>1"
   shows "x = y"
 proof -
   from 1 3 have "(a \<^bold>\<sqinter> x) \<^bold>\<squnion> (x \<^bold>\<sqinter> y) = (a \<^bold>\<sqinter> y) \<^bold>\<squnion> (x \<^bold>\<sqinter> y)"
     by simp
   then have "(x \<^bold>\<sqinter> a) \<^bold>\<squnion> (x \<^bold>\<sqinter> y) = (y \<^bold>\<sqinter> a) \<^bold>\<squnion> (y \<^bold>\<sqinter> x)"
     by (simp add: ac_simps)
   then have "x \<^bold>\<sqinter> (a \<^bold>\<squnion> y) = y \<^bold>\<sqinter> (a \<^bold>\<squnion> x)"
     by (simp add: conj_disj_distrib)
   with 2 4 have "x \<^bold>\<sqinter> \<^bold>1 = y \<^bold>\<sqinter> \<^bold>1"
     by simp
   then show "x = y"
     by simp
 qed
 
 lemma compl_unique: "x \<^bold>\<sqinter> y = \<^bold>0 \<Longrightarrow> x \<^bold>\<squnion> y = \<^bold>1 \<Longrightarrow> \<^bold>- x = y"
   by (rule complement_unique [OF conj_cancel_right disj_cancel_right])
 
 lemma double_compl [simp]: "\<^bold>- (\<^bold>- x) = x"
 proof (rule compl_unique)
   show "\<^bold>- x \<^bold>\<sqinter> x = \<^bold>0"
     by (simp only: conj_cancel_right conj.commute)
   show "\<^bold>- x \<^bold>\<squnion> x = \<^bold>1"
     by (simp only: disj_cancel_right disj.commute)
 qed
 
 lemma compl_eq_compl_iff [simp]: 
   \<open>\<^bold>- x = \<^bold>- y \<longleftrightarrow> x = y\<close>  (is \<open>?P \<longleftrightarrow> ?Q\<close>)
 proof
   assume \<open>?Q\<close>
   then show ?P by simp
 next
   assume \<open>?P\<close>
   then have \<open>\<^bold>- (\<^bold>- x) = \<^bold>- (\<^bold>- y)\<close>
     by simp
   then show ?Q
     by simp
 qed
 
 
 subsubsection \<open>Conjunction\<close>
 
 lemma conj_zero_right [simp]: "x \<^bold>\<sqinter> \<^bold>0 = \<^bold>0"
   using conj.left_idem conj_cancel_right by fastforce
 
 lemma compl_one [simp]: "\<^bold>- \<^bold>1 = \<^bold>0"
   by (rule compl_unique [OF conj_zero_right disj_zero_right])
 
 lemma conj_zero_left [simp]: "\<^bold>0 \<^bold>\<sqinter> x = \<^bold>0"
   by (subst conj.commute) (rule conj_zero_right)
 
 lemma conj_cancel_left [simp]: "\<^bold>- x \<^bold>\<sqinter> x = \<^bold>0"
   by (subst conj.commute) (rule conj_cancel_right)
 
 lemma conj_disj_distrib2: "(y \<^bold>\<squnion> z) \<^bold>\<sqinter> x = (y \<^bold>\<sqinter> x) \<^bold>\<squnion> (z \<^bold>\<sqinter> x)"
   by (simp only: conj.commute conj_disj_distrib)
 
 lemmas conj_disj_distribs = conj_disj_distrib conj_disj_distrib2
 
 
 subsubsection \<open>Disjunction\<close>
 
 context
 begin
 
 interpretation dual: abstract_boolean_algebra \<open>(\<^bold>\<squnion>)\<close> \<open>(\<^bold>\<sqinter>)\<close> compl \<open>\<^bold>1\<close> \<open>\<^bold>0\<close>
   apply standard
        apply (rule disj_conj_distrib)
       apply (rule conj_disj_distrib)
      apply simp_all
   done
 
 lemma disj_one_right [simp]: "x \<^bold>\<squnion> \<^bold>1 = \<^bold>1"
   by (fact dual.conj_zero_right)
 
 lemma compl_zero [simp]: "\<^bold>- \<^bold>0 = \<^bold>1"
   by (fact dual.compl_one)
 
 lemma disj_one_left [simp]: "\<^bold>1 \<^bold>\<squnion> x = \<^bold>1"
   by (fact dual.conj_zero_left)
 
 lemma disj_cancel_left [simp]: "\<^bold>- x \<^bold>\<squnion> x = \<^bold>1"
   by (fact dual.conj_cancel_left)
 
 lemma disj_conj_distrib2: "(y \<^bold>\<sqinter> z) \<^bold>\<squnion> x = (y \<^bold>\<squnion> x) \<^bold>\<sqinter> (z \<^bold>\<squnion> x)"
   by (fact dual.conj_disj_distrib2)
 
 lemmas disj_conj_distribs = disj_conj_distrib disj_conj_distrib2
 
 end
 
 
 subsubsection \<open>De Morgan's Laws\<close>
 
 lemma de_Morgan_conj [simp]: "\<^bold>- (x \<^bold>\<sqinter> y) = \<^bold>- x \<^bold>\<squnion> \<^bold>- y"
 proof (rule compl_unique)
   have "(x \<^bold>\<sqinter> y) \<^bold>\<sqinter> (\<^bold>- x \<^bold>\<squnion> \<^bold>- y) = ((x \<^bold>\<sqinter> y) \<^bold>\<sqinter> \<^bold>- x) \<^bold>\<squnion> ((x \<^bold>\<sqinter> y) \<^bold>\<sqinter> \<^bold>- y)"
     by (rule conj_disj_distrib)
   also have "\<dots> = (y \<^bold>\<sqinter> (x \<^bold>\<sqinter> \<^bold>- x)) \<^bold>\<squnion> (x \<^bold>\<sqinter> (y \<^bold>\<sqinter> \<^bold>- y))"
     by (simp only: ac_simps)
   finally show "(x \<^bold>\<sqinter> y) \<^bold>\<sqinter> (\<^bold>- x \<^bold>\<squnion> \<^bold>- y) = \<^bold>0"
     by (simp only: conj_cancel_right conj_zero_right disj_zero_right)
 next
   have "(x \<^bold>\<sqinter> y) \<^bold>\<squnion> (\<^bold>- x \<^bold>\<squnion> \<^bold>- y) = (x \<^bold>\<squnion> (\<^bold>- x \<^bold>\<squnion> \<^bold>- y)) \<^bold>\<sqinter> (y \<^bold>\<squnion> (\<^bold>- x \<^bold>\<squnion> \<^bold>- y))"
     by (rule disj_conj_distrib2)
   also have "\<dots> = (\<^bold>- y \<^bold>\<squnion> (x \<^bold>\<squnion> \<^bold>- x)) \<^bold>\<sqinter> (\<^bold>- x \<^bold>\<squnion> (y \<^bold>\<squnion> \<^bold>- y))"
     by (simp only: ac_simps)
   finally show "(x \<^bold>\<sqinter> y) \<^bold>\<squnion> (\<^bold>- x \<^bold>\<squnion> \<^bold>- y) = \<^bold>1"
     by (simp only: disj_cancel_right disj_one_right conj_one_right)
 qed
 
 context
 begin
 
 interpretation dual: abstract_boolean_algebra \<open>(\<^bold>\<squnion>)\<close> \<open>(\<^bold>\<sqinter>)\<close> compl \<open>\<^bold>1\<close> \<open>\<^bold>0\<close>
   apply standard
        apply (rule disj_conj_distrib)
       apply (rule conj_disj_distrib)
      apply simp_all
   done
 
 lemma de_Morgan_disj [simp]: "\<^bold>- (x \<^bold>\<squnion> y) = \<^bold>- x \<^bold>\<sqinter> \<^bold>- y"
   by (fact dual.de_Morgan_conj)
 
 end
 
 end
 
 
 subsection \<open>Symmetric Difference\<close>
 
 locale abstract_boolean_algebra_sym_diff = abstract_boolean_algebra +
   fixes xor :: \<open>'a \<Rightarrow> 'a \<Rightarrow> 'a\<close>  (infixr \<open>\<^bold>\<ominus>\<close> 65)
   assumes xor_def : \<open>x \<^bold>\<ominus> y = (x \<^bold>\<sqinter> \<^bold>- y) \<^bold>\<squnion> (\<^bold>- x \<^bold>\<sqinter> y)\<close>
 begin
 
 sublocale xor: comm_monoid xor \<open>\<^bold>0\<close>
 proof
   fix x y z :: 'a
   let ?t = "(x \<^bold>\<sqinter> y \<^bold>\<sqinter> z) \<^bold>\<squnion> (x \<^bold>\<sqinter> \<^bold>- y \<^bold>\<sqinter> \<^bold>- z) \<^bold>\<squnion> (\<^bold>- x \<^bold>\<sqinter> y \<^bold>\<sqinter> \<^bold>- z) \<^bold>\<squnion> (\<^bold>- x \<^bold>\<sqinter> \<^bold>- y \<^bold>\<sqinter> z)"
   have "?t \<^bold>\<squnion> (z \<^bold>\<sqinter> x \<^bold>\<sqinter> \<^bold>- x) \<^bold>\<squnion> (z \<^bold>\<sqinter> y \<^bold>\<sqinter> \<^bold>- y) = ?t \<^bold>\<squnion> (x \<^bold>\<sqinter> y \<^bold>\<sqinter> \<^bold>- y) \<^bold>\<squnion> (x \<^bold>\<sqinter> z \<^bold>\<sqinter> \<^bold>- z)"
     by (simp only: conj_cancel_right conj_zero_right)
   then show "(x \<^bold>\<ominus> y) \<^bold>\<ominus> z = x \<^bold>\<ominus> (y \<^bold>\<ominus> z)"
     by (simp only: xor_def de_Morgan_disj de_Morgan_conj double_compl)
       (simp only: conj_disj_distribs conj_ac ac_simps)
   show "x \<^bold>\<ominus> y = y \<^bold>\<ominus> x"
     by (simp only: xor_def ac_simps)
   show "x \<^bold>\<ominus> \<^bold>0 = x"
     by (simp add: xor_def)
 qed
 
 lemma xor_def2:
   \<open>x \<^bold>\<ominus> y = (x \<^bold>\<squnion> y) \<^bold>\<sqinter> (\<^bold>- x \<^bold>\<squnion> \<^bold>- y)\<close>
 proof -
   note xor_def [of x y]
   also have \<open>x \<^bold>\<sqinter> \<^bold>- y \<^bold>\<squnion> \<^bold>- x \<^bold>\<sqinter> y = ((x \<^bold>\<squnion> \<^bold>- x) \<^bold>\<sqinter> (\<^bold>- y \<^bold>\<squnion> \<^bold>- x)) \<^bold>\<sqinter> (x \<^bold>\<squnion> y) \<^bold>\<sqinter> (\<^bold>- y \<^bold>\<squnion> y)\<close>
     by (simp add: ac_simps disj_conj_distribs)
   also have \<open>\<dots> = (x \<^bold>\<squnion> y) \<^bold>\<sqinter> (\<^bold>- x \<^bold>\<squnion> \<^bold>- y)\<close>
     by (simp add: ac_simps)
   finally show ?thesis .
 qed
 
 lemma xor_one_right [simp]: "x \<^bold>\<ominus> \<^bold>1 = \<^bold>- x"
   by (simp only: xor_def compl_one conj_zero_right conj_one_right disj.left_neutral)
 
 lemma xor_one_left [simp]: "\<^bold>1 \<^bold>\<ominus> x = \<^bold>- x"
   using xor_one_right [of x] by (simp add: ac_simps)
 
 lemma xor_self [simp]: "x \<^bold>\<ominus> x = \<^bold>0"
   by (simp only: xor_def conj_cancel_right conj_cancel_left disj_zero_right)
 
 lemma xor_left_self [simp]: "x \<^bold>\<ominus> (x \<^bold>\<ominus> y) = y"
   by (simp only: xor.assoc [symmetric] xor_self xor.left_neutral)
 
 lemma xor_compl_left [simp]: "\<^bold>- x \<^bold>\<ominus> y = \<^bold>- (x \<^bold>\<ominus> y)"
   by (simp add: ac_simps flip: xor_one_left)
 
 lemma xor_compl_right [simp]: "x \<^bold>\<ominus> \<^bold>- y = \<^bold>- (x \<^bold>\<ominus> y)"
   using xor.commute xor_compl_left by auto
 
 lemma xor_cancel_right [simp]: "x \<^bold>\<ominus> \<^bold>- x = \<^bold>1"
   by (simp only: xor_compl_right xor_self compl_zero)
 
 lemma xor_cancel_left [simp]: "\<^bold>- x \<^bold>\<ominus> x = \<^bold>1"
   by (simp only: xor_compl_left xor_self compl_zero)
 
 lemma conj_xor_distrib: "x \<^bold>\<sqinter> (y \<^bold>\<ominus> z) = (x \<^bold>\<sqinter> y) \<^bold>\<ominus> (x \<^bold>\<sqinter> z)"
 proof -
   have *: "(x \<^bold>\<sqinter> y \<^bold>\<sqinter> \<^bold>- z) \<^bold>\<squnion> (x \<^bold>\<sqinter> \<^bold>- y \<^bold>\<sqinter> z) =
         (y \<^bold>\<sqinter> x \<^bold>\<sqinter> \<^bold>- x) \<^bold>\<squnion> (z \<^bold>\<sqinter> x \<^bold>\<sqinter> \<^bold>- x) \<^bold>\<squnion> (x \<^bold>\<sqinter> y \<^bold>\<sqinter> \<^bold>- z) \<^bold>\<squnion> (x \<^bold>\<sqinter> \<^bold>- y \<^bold>\<sqinter> z)"
     by (simp only: conj_cancel_right conj_zero_right disj.left_neutral)
   then show "x \<^bold>\<sqinter> (y \<^bold>\<ominus> z) = (x \<^bold>\<sqinter> y) \<^bold>\<ominus> (x \<^bold>\<sqinter> z)"
     by (simp (no_asm_use) only:
         xor_def de_Morgan_disj de_Morgan_conj double_compl
         conj_disj_distribs ac_simps)
 qed
 
 lemma conj_xor_distrib2: "(y \<^bold>\<ominus> z) \<^bold>\<sqinter> x = (y \<^bold>\<sqinter> x) \<^bold>\<ominus> (z \<^bold>\<sqinter> x)"
   by (simp add: conj.commute conj_xor_distrib)
 
 lemmas conj_xor_distribs = conj_xor_distrib conj_xor_distrib2
 
 end
 
 
 subsection \<open>Type classes\<close>
 
 class boolean_algebra = distrib_lattice + bounded_lattice + minus + uminus +
   assumes inf_compl_bot: \<open>x \<sqinter> - x = \<bottom>\<close>
     and sup_compl_top: \<open>x \<squnion> - x = \<top>\<close>
   assumes diff_eq: \<open>x - y = x \<sqinter> - y\<close>
 begin
 
 sublocale boolean_algebra: abstract_boolean_algebra \<open>(\<sqinter>)\<close> \<open>(\<squnion>)\<close> uminus \<bottom> \<top>
   apply standard
        apply (rule inf_sup_distrib1)
       apply (rule sup_inf_distrib1)
      apply (simp_all add: ac_simps inf_compl_bot sup_compl_top)
   done
 
 lemma compl_inf_bot: "- x \<sqinter> x = \<bottom>"
   by (fact boolean_algebra.conj_cancel_left)
 
 lemma compl_sup_top: "- x \<squnion> x = \<top>"
   by (fact boolean_algebra.disj_cancel_left)
 
 lemma compl_unique:
   assumes "x \<sqinter> y = \<bottom>"
     and "x \<squnion> y = \<top>"
   shows "- x = y"
   using assms by (rule boolean_algebra.compl_unique)
 
 lemma double_compl: "- (- x) = x"
   by (fact boolean_algebra.double_compl)
 
 lemma compl_eq_compl_iff: "- x = - y \<longleftrightarrow> x = y"
   by (fact boolean_algebra.compl_eq_compl_iff)
 
 lemma compl_bot_eq: "- \<bottom> = \<top>"
   by (fact boolean_algebra.compl_zero)
 
 lemma compl_top_eq: "- \<top> = \<bottom>"
   by (fact boolean_algebra.compl_one)
 
 lemma compl_inf: "- (x \<sqinter> y) = - x \<squnion> - y"
   by (fact boolean_algebra.de_Morgan_conj)
 
 lemma compl_sup: "- (x \<squnion> y) = - x \<sqinter> - y"
   by (fact boolean_algebra.de_Morgan_disj)
 
 lemma compl_mono:
   assumes "x \<le> y"
   shows "- y \<le> - x"
 proof -
   from assms have "x \<squnion> y = y" by (simp only: le_iff_sup)
   then have "- (x \<squnion> y) = - y" by simp
   then have "- x \<sqinter> - y = - y" by simp
   then have "- y \<sqinter> - x = - y" by (simp only: inf_commute)
   then show ?thesis by (simp only: le_iff_inf)
 qed
 
 lemma compl_le_compl_iff [simp]: "- x \<le> - y \<longleftrightarrow> y \<le> x"
   by (auto dest: compl_mono)
 
 lemma compl_le_swap1:
   assumes "y \<le> - x"
   shows "x \<le> -y"
 proof -
   from assms have "- (- x) \<le> - y" by (simp only: compl_le_compl_iff)
   then show ?thesis by simp
 qed
 
 lemma compl_le_swap2:
   assumes "- y \<le> x"
   shows "- x \<le> y"
 proof -
   from assms have "- x \<le> - (- y)" by (simp only: compl_le_compl_iff)
   then show ?thesis by simp
 qed
 
 lemma compl_less_compl_iff [simp]: "- x < - y \<longleftrightarrow> y < x"
   by (auto simp add: less_le)
 
 lemma compl_less_swap1:
   assumes "y < - x"
   shows "x < - y"
 proof -
   from assms have "- (- x) < - y" by (simp only: compl_less_compl_iff)
   then show ?thesis by simp
 qed
 
 lemma compl_less_swap2:
   assumes "- y < x"
   shows "- x < y"
 proof -
   from assms have "- x < - (- y)"
     by (simp only: compl_less_compl_iff)
   then show ?thesis by simp
 qed
 
 lemma sup_cancel_left1: \<open>x \<squnion> a \<squnion> (- x \<squnion> b) = \<top>\<close>
   by (simp add: ac_simps)
 
 lemma sup_cancel_left2: \<open>- x \<squnion> a \<squnion> (x \<squnion> b) = \<top>\<close>
   by (simp add: ac_simps)
 
 lemma inf_cancel_left1: \<open>x \<sqinter> a \<sqinter> (- x \<sqinter> b) = \<bottom>\<close>
   by (simp add: ac_simps)
 
 lemma inf_cancel_left2: \<open>- x \<sqinter> a \<sqinter> (x \<sqinter> b) = \<bottom>\<close>
   by (simp add: ac_simps)
 
 lemma sup_compl_top_left1 [simp]: \<open>- x \<squnion> (x \<squnion> y) = \<top>\<close>
   by (simp add: sup_assoc [symmetric])
 
 lemma sup_compl_top_left2 [simp]: \<open>x \<squnion> (- x \<squnion> y) = \<top>\<close>
   using sup_compl_top_left1 [of "- x" y] by simp
 
 lemma inf_compl_bot_left1 [simp]: \<open>- x \<sqinter> (x \<sqinter> y) = \<bottom>\<close>
   by (simp add: inf_assoc [symmetric])
 
 lemma inf_compl_bot_left2 [simp]: \<open>x \<sqinter> (- x \<sqinter> y) = \<bottom>\<close>
   using inf_compl_bot_left1 [of "- x" y] by simp
 
 lemma inf_compl_bot_right [simp]: \<open>x \<sqinter> (y \<sqinter> - x) = \<bottom>\<close>
   by (subst inf_left_commute) simp
 
 end
 
 
 subsection \<open>Lattice on \<^typ>\<open>bool\<close>\<close>
 
 instantiation bool :: boolean_algebra
 begin
 
 definition bool_Compl_def [simp]: "uminus = Not"
 
 definition bool_diff_def [simp]: "A - B \<longleftrightarrow> A \<and> \<not> B"
 
 definition [simp]: "P \<sqinter> Q \<longleftrightarrow> P \<and> Q"
 
 definition [simp]: "P \<squnion> Q \<longleftrightarrow> P \<or> Q"
 
 instance by standard auto
 
 end
 
 lemma sup_boolI1: "P \<Longrightarrow> P \<squnion> Q"
   by simp
 
 lemma sup_boolI2: "Q \<Longrightarrow> P \<squnion> Q"
   by simp
 
 lemma sup_boolE: "P \<squnion> Q \<Longrightarrow> (P \<Longrightarrow> R) \<Longrightarrow> (Q \<Longrightarrow> R) \<Longrightarrow> R"
   by auto
 
 instance "fun" :: (type, boolean_algebra) boolean_algebra
   by standard (rule ext, simp_all add: inf_compl_bot sup_compl_top diff_eq)+
 
 
 subsection \<open>Lattice on unary and binary predicates\<close>
 
 lemma inf1I: "A x \<Longrightarrow> B x \<Longrightarrow> (A \<sqinter> B) x"
   by (simp add: inf_fun_def)
 
 lemma inf2I: "A x y \<Longrightarrow> B x y \<Longrightarrow> (A \<sqinter> B) x y"
   by (simp add: inf_fun_def)
 
 lemma inf1E: "(A \<sqinter> B) x \<Longrightarrow> (A x \<Longrightarrow> B x \<Longrightarrow> P) \<Longrightarrow> P"
   by (simp add: inf_fun_def)
 
 lemma inf2E: "(A \<sqinter> B) x y \<Longrightarrow> (A x y \<Longrightarrow> B x y \<Longrightarrow> P) \<Longrightarrow> P"
   by (simp add: inf_fun_def)
 
 lemma inf1D1: "(A \<sqinter> B) x \<Longrightarrow> A x"
   by (rule inf1E)
 
 lemma inf2D1: "(A \<sqinter> B) x y \<Longrightarrow> A x y"
   by (rule inf2E)
 
 lemma inf1D2: "(A \<sqinter> B) x \<Longrightarrow> B x"
   by (rule inf1E)
 
 lemma inf2D2: "(A \<sqinter> B) x y \<Longrightarrow> B x y"
   by (rule inf2E)
 
 lemma sup1I1: "A x \<Longrightarrow> (A \<squnion> B) x"
   by (simp add: sup_fun_def)
 
 lemma sup2I1: "A x y \<Longrightarrow> (A \<squnion> B) x y"
   by (simp add: sup_fun_def)
 
 lemma sup1I2: "B x \<Longrightarrow> (A \<squnion> B) x"
   by (simp add: sup_fun_def)
 
 lemma sup2I2: "B x y \<Longrightarrow> (A \<squnion> B) x y"
   by (simp add: sup_fun_def)
 
 lemma sup1E: "(A \<squnion> B) x \<Longrightarrow> (A x \<Longrightarrow> P) \<Longrightarrow> (B x \<Longrightarrow> P) \<Longrightarrow> P"
   by (simp add: sup_fun_def) iprover
 
 lemma sup2E: "(A \<squnion> B) x y \<Longrightarrow> (A x y \<Longrightarrow> P) \<Longrightarrow> (B x y \<Longrightarrow> P) \<Longrightarrow> P"
   by (simp add: sup_fun_def) iprover
 
 text \<open> \<^medskip> Classical introduction rule: no commitment to \<open>A\<close> vs \<open>B\<close>.\<close>
 
 lemma sup1CI: "(\<not> B x \<Longrightarrow> A x) \<Longrightarrow> (A \<squnion> B) x"
   by (auto simp add: sup_fun_def)
 
 lemma sup2CI: "(\<not> B x y \<Longrightarrow> A x y) \<Longrightarrow> (A \<squnion> B) x y"
   by (auto simp add: sup_fun_def)
 
 
 subsection \<open>Simproc setup\<close>
 
 locale boolean_algebra_cancel
 begin
 
 lemma sup1: "(A::'a::semilattice_sup) \<equiv> sup k a \<Longrightarrow> sup A b \<equiv> sup k (sup a b)"
   by (simp only: ac_simps)
 
 lemma sup2: "(B::'a::semilattice_sup) \<equiv> sup k b \<Longrightarrow> sup a B \<equiv> sup k (sup a b)"
   by (simp only: ac_simps)
 
 lemma sup0: "(a::'a::bounded_semilattice_sup_bot) \<equiv> sup a bot"
   by simp
 
 lemma inf1: "(A::'a::semilattice_inf) \<equiv> inf k a \<Longrightarrow> inf A b \<equiv> inf k (inf a b)"
   by (simp only: ac_simps)
 
 lemma inf2: "(B::'a::semilattice_inf) \<equiv> inf k b \<Longrightarrow> inf a B \<equiv> inf k (inf a b)"
   by (simp only: ac_simps)
 
 lemma inf0: "(a::'a::bounded_semilattice_inf_top) \<equiv> inf a top"
   by simp
 
 end
 
 ML_file \<open>Tools/boolean_algebra_cancel.ML\<close>
 
 simproc_setup boolean_algebra_cancel_sup ("sup a b::'a::boolean_algebra") =
-  \<open>fn phi => fn ss => try Boolean_Algebra_Cancel.cancel_sup_conv\<close>
+  \<open>K (K (try Boolean_Algebra_Cancel.cancel_sup_conv))\<close>
 
 simproc_setup boolean_algebra_cancel_inf ("inf a b::'a::boolean_algebra") =
-  \<open>fn phi => fn ss => try Boolean_Algebra_Cancel.cancel_inf_conv\<close>
+  \<open>K (K (try Boolean_Algebra_Cancel.cancel_inf_conv))\<close>
 
 
 context boolean_algebra
 begin
     
 lemma shunt1: "(x \<sqinter> y \<le> z) \<longleftrightarrow> (x \<le> -y \<squnion> z)"
 proof
   assume "x \<sqinter> y \<le> z"
   hence  "-y \<squnion> (x \<sqinter> y) \<le> -y \<squnion> z"
     using sup.mono by blast
   hence "-y \<squnion> x \<le> -y \<squnion> z"
     by (simp add: sup_inf_distrib1)
   thus "x \<le> -y \<squnion> z"
     by simp
 next
   assume "x \<le> -y \<squnion> z"
   hence "x \<sqinter> y \<le> (-y \<squnion> z) \<sqinter> y"
     using inf_mono by auto
   thus  "x \<sqinter> y \<le> z"
     using inf.boundedE inf_sup_distrib2 by auto
 qed
 
 lemma shunt2: "(x \<sqinter> -y \<le> z) \<longleftrightarrow> (x \<le> y \<squnion> z)"
   by (simp add: shunt1)
 
 lemma inf_shunt: "(x \<sqinter> y = \<bottom>) \<longleftrightarrow> (x \<le> - y)"
   by (simp add: order.eq_iff shunt1)
   
 lemma sup_shunt: "(x \<squnion> y = \<top>) \<longleftrightarrow> (- x \<le> y)"
   using inf_shunt [of \<open>- x\<close> \<open>- y\<close>, symmetric] 
   by (simp flip: compl_sup compl_top_eq)
 
 lemma diff_shunt_var: "(x - y = \<bottom>) \<longleftrightarrow> (x \<le> y)"
   by (simp add: diff_eq inf_shunt)
 
 lemma sup_neg_inf:
   \<open>p \<le> q \<squnion> r \<longleftrightarrow> p \<sqinter> -q \<le> r\<close>  (is \<open>?P \<longleftrightarrow> ?Q\<close>)
 proof
   assume ?P
   then have \<open>p \<sqinter> - q \<le> (q \<squnion> r) \<sqinter> - q\<close>
     by (rule inf_mono) simp
   then show ?Q
     by (simp add: inf_sup_distrib2)
 next
   assume ?Q
   then have \<open>p \<sqinter> - q \<squnion> q \<le> r \<squnion> q\<close>
     by (rule sup_mono) simp
   then show ?P
     by (simp add: sup_inf_distrib ac_simps)
 qed
 
 end
 
 end
diff --git a/src/HOL/Data_Structures/Less_False.thy b/src/HOL/Data_Structures/Less_False.thy
--- a/src/HOL/Data_Structures/Less_False.thy
+++ b/src/HOL/Data_Structures/Less_False.thy
@@ -1,31 +1,31 @@
 (* Author: Tobias Nipkow *)
 
 section \<open>Improved Simproc for $<$\<close>
 
 theory Less_False
 imports Main
 begin
 
-simproc_setup less_False ("(x::'a::order) < y") = \<open>fn _ => fn ctxt => fn ct =>
+simproc_setup less_False ("(x::'a::order) < y") = \<open>K (fn ctxt => fn ct =>
   let
     fun prp t thm = Thm.full_prop_of thm aconv t;
 
     val eq_False_if_not = @{thm eq_False} RS iffD2
 
     fun prove_less_False ((less as Const(_,T)) $ r $ s) =
       let val prems = Simplifier.prems_of ctxt;
           val le = Const (\<^const_name>\<open>less_eq\<close>, T);
           val t = HOLogic.mk_Trueprop(le $ s $ r);
       in case find_first (prp t) prems of
            NONE =>
              let val t = HOLogic.mk_Trueprop(less $ s $ r)
              in case find_first (prp t) prems of
                   NONE => NONE
                 | SOME thm => SOME(mk_meta_eq((thm RS @{thm less_not_sym}) RS eq_False_if_not))
              end
          | SOME thm => NONE
       end;
-  in prove_less_False (Thm.term_of ct) end
+  in prove_less_False (Thm.term_of ct) end)
 \<close>
 
 end
diff --git a/src/HOL/Enum.thy b/src/HOL/Enum.thy
--- a/src/HOL/Enum.thy
+++ b/src/HOL/Enum.thy
@@ -1,1160 +1,1160 @@
 (* Author: Florian Haftmann, TU Muenchen *)
 
 section \<open>Finite types as explicit enumerations\<close>
 
 theory Enum
 imports Map Groups_List
 begin
 
 subsection \<open>Class \<open>enum\<close>\<close>
 
 class enum =
   fixes enum :: "'a list"
   fixes enum_all :: "('a \<Rightarrow> bool) \<Rightarrow> bool"
   fixes enum_ex :: "('a \<Rightarrow> bool) \<Rightarrow> bool"
   assumes UNIV_enum: "UNIV = set enum"
     and enum_distinct: "distinct enum"
   assumes enum_all_UNIV: "enum_all P \<longleftrightarrow> Ball UNIV P"
   assumes enum_ex_UNIV: "enum_ex P \<longleftrightarrow> Bex UNIV P" 
    \<comment> \<open>tailored towards simple instantiation\<close>
 begin
 
 subclass finite proof
 qed (simp add: UNIV_enum)
 
 lemma enum_UNIV:
   "set enum = UNIV"
   by (simp only: UNIV_enum)
 
 lemma in_enum: "x \<in> set enum"
   by (simp add: enum_UNIV)
 
 lemma enum_eq_I:
   assumes "\<And>x. x \<in> set xs"
   shows "set enum = set xs"
 proof -
   from assms UNIV_eq_I have "UNIV = set xs" by auto
   with enum_UNIV show ?thesis by simp
 qed
 
 lemma card_UNIV_length_enum:
   "card (UNIV :: 'a set) = length enum"
   by (simp add: UNIV_enum distinct_card enum_distinct)
 
 lemma enum_all [simp]:
   "enum_all = HOL.All"
   by (simp add: fun_eq_iff enum_all_UNIV)
 
 lemma enum_ex [simp]:
   "enum_ex = HOL.Ex" 
   by (simp add: fun_eq_iff enum_ex_UNIV)
 
 end
 
 
 subsection \<open>Implementations using \<^class>\<open>enum\<close>\<close>
 
 subsubsection \<open>Unbounded operations and quantifiers\<close>
 
 lemma Collect_code [code]:
   "Collect P = set (filter P enum)"
   by (simp add: enum_UNIV)
 
 lemma vimage_code [code]:
   "f -` B = set (filter (\<lambda>x. f x \<in> B) enum_class.enum)"
   unfolding vimage_def Collect_code ..
 
 definition card_UNIV :: "'a itself \<Rightarrow> nat"
 where
   [code del]: "card_UNIV TYPE('a) = card (UNIV :: 'a set)"
 
 lemma [code]:
   "card_UNIV TYPE('a :: enum) = card (set (Enum.enum :: 'a list))"
   by (simp only: card_UNIV_def enum_UNIV)
 
 lemma all_code [code]: "(\<forall>x. P x) \<longleftrightarrow> enum_all P"
   by simp
 
 lemma exists_code [code]: "(\<exists>x. P x) \<longleftrightarrow> enum_ex P"
   by simp
 
 lemma exists1_code [code]: "(\<exists>!x. P x) \<longleftrightarrow> list_ex1 P enum"
   by (auto simp add: list_ex1_iff enum_UNIV)
 
 
 subsubsection \<open>An executable choice operator\<close>
 
 definition
   [code del]: "enum_the = The"
 
 lemma [code]:
   "The P = (case filter P enum of [x] \<Rightarrow> x | _ \<Rightarrow> enum_the P)"
 proof -
   {
     fix a
     assume filter_enum: "filter P enum = [a]"
     have "The P = a"
     proof (rule the_equality)
       fix x
       assume "P x"
       show "x = a"
       proof (rule ccontr)
         assume "x \<noteq> a"
         from filter_enum obtain us vs
           where enum_eq: "enum = us @ [a] @ vs"
           and "\<forall> x \<in> set us. \<not> P x"
           and "\<forall> x \<in> set vs. \<not> P x"
           and "P a"
           by (auto simp add: filter_eq_Cons_iff) (simp only: filter_empty_conv[symmetric])
         with \<open>P x\<close> in_enum[of x, unfolded enum_eq] \<open>x \<noteq> a\<close> show "False" by auto
       qed
     next
       from filter_enum show "P a" by (auto simp add: filter_eq_Cons_iff)
     qed
   }
   from this show ?thesis
     unfolding enum_the_def by (auto split: list.split)
 qed
 
 declare [[code abort: enum_the]]
 
 code_printing
   constant enum_the \<rightharpoonup> (Eval) "(fn '_ => raise Match)"
 
 
 subsubsection \<open>Equality and order on functions\<close>
 
 instantiation "fun" :: (enum, equal) equal
 begin
 
 definition
   "HOL.equal f g \<longleftrightarrow> (\<forall>x \<in> set enum. f x = g x)"
 
 instance proof
 qed (simp_all add: equal_fun_def fun_eq_iff enum_UNIV)
 
 end
 
 lemma [code]:
   "HOL.equal f g \<longleftrightarrow> enum_all (%x. f x = g x)"
   by (auto simp add: equal fun_eq_iff)
 
 lemma [code nbe]:
   "HOL.equal (f :: _ \<Rightarrow> _) f \<longleftrightarrow> True"
   by (fact equal_refl)
 
 lemma order_fun [code]:
   fixes f g :: "'a::enum \<Rightarrow> 'b::order"
   shows "f \<le> g \<longleftrightarrow> enum_all (\<lambda>x. f x \<le> g x)"
     and "f < g \<longleftrightarrow> f \<le> g \<and> enum_ex (\<lambda>x. f x \<noteq> g x)"
   by (simp_all add: fun_eq_iff le_fun_def order_less_le)
 
 
 subsubsection \<open>Operations on relations\<close>
 
 lemma [code]:
   "Id = image (\<lambda>x. (x, x)) (set Enum.enum)"
   by (auto intro: imageI in_enum)
 
 lemma tranclp_unfold [code]:
   "tranclp r a b \<longleftrightarrow> (a, b) \<in> trancl {(x, y). r x y}"
   by (simp add: trancl_def)
 
 lemma rtranclp_rtrancl_eq [code]:
   "rtranclp r x y \<longleftrightarrow> (x, y) \<in> rtrancl {(x, y). r x y}"
   by (simp add: rtrancl_def)
 
 lemma max_ext_eq [code]:
   "max_ext R = {(X, Y). finite X \<and> finite Y \<and> Y \<noteq> {} \<and> (\<forall>x. x \<in> X \<longrightarrow> (\<exists>xa \<in> Y. (x, xa) \<in> R))}"
   by (auto simp add: max_ext.simps)
 
 lemma max_extp_eq [code]:
   "max_extp r x y \<longleftrightarrow> (x, y) \<in> max_ext {(x, y). r x y}"
   by (simp add: max_ext_def)
 
 lemma mlex_eq [code]:
   "f <*mlex*> R = {(x, y). f x < f y \<or> (f x \<le> f y \<and> (x, y) \<in> R)}"
   by (auto simp add: mlex_prod_def)
 
 
 subsubsection \<open>Bounded accessible part\<close>
 
 primrec bacc :: "('a \<times> 'a) set \<Rightarrow> nat \<Rightarrow> 'a set" 
 where
   "bacc r 0 = {x. \<forall> y. (y, x) \<notin> r}"
 | "bacc r (Suc n) = (bacc r n \<union> {x. \<forall>y. (y, x) \<in> r \<longrightarrow> y \<in> bacc r n})"
 
 lemma bacc_subseteq_acc:
   "bacc r n \<subseteq> Wellfounded.acc r"
   by (induct n) (auto intro: acc.intros)
 
 lemma bacc_mono:
   "n \<le> m \<Longrightarrow> bacc r n \<subseteq> bacc r m"
   by (induct rule: dec_induct) auto
   
 lemma bacc_upper_bound:
   "bacc (r :: ('a \<times> 'a) set)  (card (UNIV :: 'a::finite set)) = (\<Union>n. bacc r n)"
 proof -
   have "mono (bacc r)" unfolding mono_def by (simp add: bacc_mono)
   moreover have "\<forall>n. bacc r n = bacc r (Suc n) \<longrightarrow> bacc r (Suc n) = bacc r (Suc (Suc n))" by auto
   moreover have "finite (range (bacc r))" by auto
   ultimately show ?thesis
    by (intro finite_mono_strict_prefix_implies_finite_fixpoint)
      (auto intro: finite_mono_remains_stable_implies_strict_prefix)
 qed
 
 lemma acc_subseteq_bacc:
   assumes "finite r"
   shows "Wellfounded.acc r \<subseteq> (\<Union>n. bacc r n)"
 proof
   fix x
   assume "x \<in> Wellfounded.acc r"
   then have "\<exists>n. x \<in> bacc r n"
   proof (induct x arbitrary: rule: acc.induct)
     case (accI x)
     then have "\<forall>y. \<exists> n. (y, x) \<in> r \<longrightarrow> y \<in> bacc r n" by simp
     from choice[OF this] obtain n where n: "\<forall>y. (y, x) \<in> r \<longrightarrow> y \<in> bacc r (n y)" ..
     obtain n where "\<And>y. (y, x) \<in> r \<Longrightarrow> y \<in> bacc r n"
     proof
       fix y assume y: "(y, x) \<in> r"
       with n have "y \<in> bacc r (n y)" by auto
       moreover have "n y <= Max ((\<lambda>(y, x). n y) ` r)"
         using y \<open>finite r\<close> by (auto intro!: Max_ge)
       note bacc_mono[OF this, of r]
       ultimately show "y \<in> bacc r (Max ((\<lambda>(y, x). n y) ` r))" by auto
     qed
     then show ?case
       by (auto simp add: Let_def intro!: exI[of _ "Suc n"])
   qed
   then show "x \<in> (\<Union>n. bacc r n)" by auto
 qed
 
 lemma acc_bacc_eq:
   fixes A :: "('a :: finite \<times> 'a) set"
   assumes "finite A"
   shows "Wellfounded.acc A = bacc A (card (UNIV :: 'a set))"
   using assms by (metis acc_subseteq_bacc bacc_subseteq_acc bacc_upper_bound order_eq_iff)
 
 lemma [code]:
   fixes xs :: "('a::finite \<times> 'a) list"
   shows "Wellfounded.acc (set xs) = bacc (set xs) (card_UNIV TYPE('a))"
   by (simp add: card_UNIV_def acc_bacc_eq)
 
 
 subsection \<open>Default instances for \<^class>\<open>enum\<close>\<close>
 
 lemma map_of_zip_enum_is_Some:
   assumes "length ys = length (enum :: 'a::enum list)"
   shows "\<exists>y. map_of (zip (enum :: 'a::enum list) ys) x = Some y"
 proof -
   from assms have "x \<in> set (enum :: 'a::enum list) \<longleftrightarrow>
     (\<exists>y. map_of (zip (enum :: 'a::enum list) ys) x = Some y)"
     by (auto intro!: map_of_zip_is_Some)
   then show ?thesis using enum_UNIV by auto
 qed
 
 lemma map_of_zip_enum_inject:
   fixes xs ys :: "'b::enum list"
   assumes length: "length xs = length (enum :: 'a::enum list)"
       "length ys = length (enum :: 'a::enum list)"
     and map_of: "the \<circ> map_of (zip (enum :: 'a::enum list) xs) = the \<circ> map_of (zip (enum :: 'a::enum list) ys)"
   shows "xs = ys"
 proof -
   have "map_of (zip (enum :: 'a list) xs) = map_of (zip (enum :: 'a list) ys)"
   proof
     fix x :: 'a
     from length map_of_zip_enum_is_Some obtain y1 y2
       where "map_of (zip (enum :: 'a list) xs) x = Some y1"
         and "map_of (zip (enum :: 'a list) ys) x = Some y2" by blast
     moreover from map_of
       have "the (map_of (zip (enum :: 'a::enum list) xs) x) = the (map_of (zip (enum :: 'a::enum list) ys) x)"
       by (auto dest: fun_cong)
     ultimately show "map_of (zip (enum :: 'a::enum list) xs) x = map_of (zip (enum :: 'a::enum list) ys) x"
       by simp
   qed
   with length enum_distinct show "xs = ys" by (rule map_of_zip_inject)
 qed
 
 definition all_n_lists :: "(('a :: enum) list \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> bool"
 where
   "all_n_lists P n \<longleftrightarrow> (\<forall>xs \<in> set (List.n_lists n enum). P xs)"
 
 lemma [code]:
   "all_n_lists P n \<longleftrightarrow> (if n = 0 then P [] else enum_all (%x. all_n_lists (%xs. P (x # xs)) (n - 1)))"
   unfolding all_n_lists_def enum_all
   by (cases n) (auto simp add: enum_UNIV)
 
 definition ex_n_lists :: "(('a :: enum) list \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> bool"
 where
   "ex_n_lists P n \<longleftrightarrow> (\<exists>xs \<in> set (List.n_lists n enum). P xs)"
 
 lemma [code]:
   "ex_n_lists P n \<longleftrightarrow> (if n = 0 then P [] else enum_ex (%x. ex_n_lists (%xs. P (x # xs)) (n - 1)))"
   unfolding ex_n_lists_def enum_ex
   by (cases n) (auto simp add: enum_UNIV)
 
 instantiation "fun" :: (enum, enum) enum
 begin
 
 definition
   "enum = map (\<lambda>ys. the \<circ> map_of (zip (enum::'a list) ys)) (List.n_lists (length (enum::'a::enum list)) enum)"
 
 definition
   "enum_all P = all_n_lists (\<lambda>bs. P (the \<circ> map_of (zip enum bs))) (length (enum :: 'a list))"
 
 definition
   "enum_ex P = ex_n_lists (\<lambda>bs. P (the \<circ> map_of (zip enum bs))) (length (enum :: 'a list))"
 
 instance proof
   show "UNIV = set (enum :: ('a \<Rightarrow> 'b) list)"
   proof (rule UNIV_eq_I)
     fix f :: "'a \<Rightarrow> 'b"
     have "f = the \<circ> map_of (zip (enum :: 'a::enum list) (map f enum))"
       by (auto simp add: map_of_zip_map fun_eq_iff intro: in_enum)
     then show "f \<in> set enum"
       by (auto simp add: enum_fun_def set_n_lists intro: in_enum)
   qed
 next
   from map_of_zip_enum_inject
   show "distinct (enum :: ('a \<Rightarrow> 'b) list)"
     by (auto intro!: inj_onI simp add: enum_fun_def
       distinct_map distinct_n_lists enum_distinct set_n_lists)
 next
   fix P
   show "enum_all (P :: ('a \<Rightarrow> 'b) \<Rightarrow> bool) = Ball UNIV P"
   proof
     assume "enum_all P"
     show "Ball UNIV P"
     proof
       fix f :: "'a \<Rightarrow> 'b"
       have f: "f = the \<circ> map_of (zip (enum :: 'a::enum list) (map f enum))"
         by (auto simp add: map_of_zip_map fun_eq_iff intro: in_enum)
       from \<open>enum_all P\<close> have "P (the \<circ> map_of (zip enum (map f enum)))"
         unfolding enum_all_fun_def all_n_lists_def
         apply (simp add: set_n_lists)
         apply (erule_tac x="map f enum" in allE)
         apply (auto intro!: in_enum)
         done
       from this f show "P f" by auto
     qed
   next
     assume "Ball UNIV P"
     from this show "enum_all P"
       unfolding enum_all_fun_def all_n_lists_def by auto
   qed
 next
   fix P
   show "enum_ex (P :: ('a \<Rightarrow> 'b) \<Rightarrow> bool) = Bex UNIV P"
   proof
     assume "enum_ex P"
     from this show "Bex UNIV P"
       unfolding enum_ex_fun_def ex_n_lists_def by auto
   next
     assume "Bex UNIV P"
     from this obtain f where "P f" ..
     have f: "f = the \<circ> map_of (zip (enum :: 'a::enum list) (map f enum))"
       by (auto simp add: map_of_zip_map fun_eq_iff intro: in_enum) 
     from \<open>P f\<close> this have "P (the \<circ> map_of (zip (enum :: 'a::enum list) (map f enum)))"
       by auto
     from  this show "enum_ex P"
       unfolding enum_ex_fun_def ex_n_lists_def
       apply (auto simp add: set_n_lists)
       apply (rule_tac x="map f enum" in exI)
       apply (auto intro!: in_enum)
       done
   qed
 qed
 
 end
 
 lemma enum_fun_code [code]: "enum = (let enum_a = (enum :: 'a::{enum, equal} list)
   in map (\<lambda>ys. the \<circ> map_of (zip enum_a ys)) (List.n_lists (length enum_a) enum))"
   by (simp add: enum_fun_def Let_def)
 
 lemma enum_all_fun_code [code]:
   "enum_all P = (let enum_a = (enum :: 'a::{enum, equal} list)
    in all_n_lists (\<lambda>bs. P (the \<circ> map_of (zip enum_a bs))) (length enum_a))"
   by (simp only: enum_all_fun_def Let_def)
 
 lemma enum_ex_fun_code [code]:
   "enum_ex P = (let enum_a = (enum :: 'a::{enum, equal} list)
    in ex_n_lists (\<lambda>bs. P (the \<circ> map_of (zip enum_a bs))) (length enum_a))"
   by (simp only: enum_ex_fun_def Let_def)
 
 instantiation set :: (enum) enum
 begin
 
 definition
   "enum = map set (subseqs enum)"
 
 definition
   "enum_all P \<longleftrightarrow> (\<forall>A\<in>set enum. P (A::'a set))"
 
 definition
   "enum_ex P \<longleftrightarrow> (\<exists>A\<in>set enum. P (A::'a set))"
 
 instance proof
 qed (simp_all add: enum_set_def enum_all_set_def enum_ex_set_def subseqs_powset distinct_set_subseqs
   enum_distinct enum_UNIV)
 
 end
 
 instantiation unit :: enum
 begin
 
 definition
   "enum = [()]"
 
 definition
   "enum_all P = P ()"
 
 definition
   "enum_ex P = P ()"
 
 instance proof
 qed (auto simp add: enum_unit_def enum_all_unit_def enum_ex_unit_def)
 
 end
 
 instantiation bool :: enum
 begin
 
 definition
   "enum = [False, True]"
 
 definition
   "enum_all P \<longleftrightarrow> P False \<and> P True"
 
 definition
   "enum_ex P \<longleftrightarrow> P False \<or> P True"
 
 instance proof
 qed (simp_all only: enum_bool_def enum_all_bool_def enum_ex_bool_def UNIV_bool, simp_all)
 
 end
 
 instantiation prod :: (enum, enum) enum
 begin
 
 definition
   "enum = List.product enum enum"
 
 definition
   "enum_all P = enum_all (%x. enum_all (%y. P (x, y)))"
 
 definition
   "enum_ex P = enum_ex (%x. enum_ex (%y. P (x, y)))"
 
  
 instance
   by standard
     (simp_all add: enum_prod_def distinct_product
       enum_UNIV enum_distinct enum_all_prod_def enum_ex_prod_def)
 
 end
 
 instantiation sum :: (enum, enum) enum
 begin
 
 definition
   "enum = map Inl enum @ map Inr enum"
 
 definition
   "enum_all P \<longleftrightarrow> enum_all (\<lambda>x. P (Inl x)) \<and> enum_all (\<lambda>x. P (Inr x))"
 
 definition
   "enum_ex P \<longleftrightarrow> enum_ex (\<lambda>x. P (Inl x)) \<or> enum_ex (\<lambda>x. P (Inr x))"
 
 instance proof
 qed (simp_all only: enum_sum_def enum_all_sum_def enum_ex_sum_def UNIV_sum,
   auto simp add: enum_UNIV distinct_map enum_distinct)
 
 end
 
 instantiation option :: (enum) enum
 begin
 
 definition
   "enum = None # map Some enum"
 
 definition
   "enum_all P \<longleftrightarrow> P None \<and> enum_all (\<lambda>x. P (Some x))"
 
 definition
   "enum_ex P \<longleftrightarrow> P None \<or> enum_ex (\<lambda>x. P (Some x))"
 
 instance proof
 qed (simp_all only: enum_option_def enum_all_option_def enum_ex_option_def UNIV_option_conv,
   auto simp add: distinct_map enum_UNIV enum_distinct)
 
 end
 
 
 subsection \<open>Small finite types\<close>
 
 text \<open>We define small finite types for use in Quickcheck\<close>
 
 datatype (plugins only: code "quickcheck" extraction) finite_1 =
   a\<^sub>1
 
 notation (output) a\<^sub>1  ("a\<^sub>1")
 
 lemma UNIV_finite_1:
   "UNIV = {a\<^sub>1}"
   by (auto intro: finite_1.exhaust)
 
 instantiation finite_1 :: enum
 begin
 
 definition
   "enum = [a\<^sub>1]"
 
 definition
   "enum_all P = P a\<^sub>1"
 
 definition
   "enum_ex P = P a\<^sub>1"
 
 instance proof
 qed (simp_all only: enum_finite_1_def enum_all_finite_1_def enum_ex_finite_1_def UNIV_finite_1, simp_all)
 
 end
 
 instantiation finite_1 :: linorder
 begin
 
 definition less_finite_1 :: "finite_1 \<Rightarrow> finite_1 \<Rightarrow> bool"
 where
   "x < (y :: finite_1) \<longleftrightarrow> False"
 
 definition less_eq_finite_1 :: "finite_1 \<Rightarrow> finite_1 \<Rightarrow> bool"
 where
   "x \<le> (y :: finite_1) \<longleftrightarrow> True"
 
 instance
 apply (intro_classes)
 apply (auto simp add: less_finite_1_def less_eq_finite_1_def)
 apply (metis (full_types) finite_1.exhaust)
 done
 
 end
 
 instance finite_1 :: "{dense_linorder, wellorder}"
 by intro_classes (simp_all add: less_finite_1_def)
 
 instantiation finite_1 :: complete_lattice
 begin
 
 definition [simp]: "Inf = (\<lambda>_. a\<^sub>1)"
 definition [simp]: "Sup = (\<lambda>_. a\<^sub>1)"
 definition [simp]: "bot = a\<^sub>1"
 definition [simp]: "top = a\<^sub>1"
 definition [simp]: "inf = (\<lambda>_ _. a\<^sub>1)"
 definition [simp]: "sup = (\<lambda>_ _. a\<^sub>1)"
 
 instance by intro_classes(simp_all add: less_eq_finite_1_def)
 end
 
 instance finite_1 :: complete_distrib_lattice
   by standard simp_all
 
 instance finite_1 :: complete_linorder ..
 
 lemma finite_1_eq: "x = a\<^sub>1"
 by(cases x) simp
 
 simproc_setup finite_1_eq ("x::finite_1") = \<open>
-  fn _ => fn _ => fn ct =>
+  K (K (fn ct =>
     (case Thm.term_of ct of
       Const (\<^const_name>\<open>a\<^sub>1\<close>, _) => NONE
-    | _ => SOME (mk_meta_eq @{thm finite_1_eq}))
+    | _ => SOME (mk_meta_eq @{thm finite_1_eq}))))
 \<close>
 
 instantiation finite_1 :: complete_boolean_algebra
 begin
 definition [simp]: "(-) = (\<lambda>_ _. a\<^sub>1)"
 definition [simp]: "uminus = (\<lambda>_. a\<^sub>1)"
 instance by intro_classes simp_all
 end
 
 instantiation finite_1 :: 
   "{linordered_ring_strict, linordered_comm_semiring_strict, ordered_comm_ring,
     ordered_cancel_comm_monoid_diff, comm_monoid_mult, ordered_ring_abs,
     one, modulo, sgn, inverse}"
 begin
 definition [simp]: "Groups.zero = a\<^sub>1"
 definition [simp]: "Groups.one = a\<^sub>1"
 definition [simp]: "(+) = (\<lambda>_ _. a\<^sub>1)"
 definition [simp]: "(*) = (\<lambda>_ _. a\<^sub>1)"
 definition [simp]: "(mod) = (\<lambda>_ _. a\<^sub>1)" 
 definition [simp]: "abs = (\<lambda>_. a\<^sub>1)"
 definition [simp]: "sgn = (\<lambda>_. a\<^sub>1)"
 definition [simp]: "inverse = (\<lambda>_. a\<^sub>1)"
 definition [simp]: "divide = (\<lambda>_ _. a\<^sub>1)"
 
 instance by intro_classes(simp_all add: less_finite_1_def)
 end
 
 declare [[simproc del: finite_1_eq]]
 hide_const (open) a\<^sub>1
 
 datatype (plugins only: code "quickcheck" extraction) finite_2 =
   a\<^sub>1 | a\<^sub>2
 
 notation (output) a\<^sub>1  ("a\<^sub>1")
 notation (output) a\<^sub>2  ("a\<^sub>2")
 
 lemma UNIV_finite_2:
   "UNIV = {a\<^sub>1, a\<^sub>2}"
   by (auto intro: finite_2.exhaust)
 
 instantiation finite_2 :: enum
 begin
 
 definition
   "enum = [a\<^sub>1, a\<^sub>2]"
 
 definition
   "enum_all P \<longleftrightarrow> P a\<^sub>1 \<and> P a\<^sub>2"
 
 definition
   "enum_ex P \<longleftrightarrow> P a\<^sub>1 \<or> P a\<^sub>2"
 
 instance proof
 qed (simp_all only: enum_finite_2_def enum_all_finite_2_def enum_ex_finite_2_def UNIV_finite_2, simp_all)
 
 end
 
 instantiation finite_2 :: linorder
 begin
 
 definition less_finite_2 :: "finite_2 \<Rightarrow> finite_2 \<Rightarrow> bool"
 where
   "x < y \<longleftrightarrow> x = a\<^sub>1 \<and> y = a\<^sub>2"
 
 definition less_eq_finite_2 :: "finite_2 \<Rightarrow> finite_2 \<Rightarrow> bool"
 where
   "x \<le> y \<longleftrightarrow> x = y \<or> x < (y :: finite_2)"
 
 instance
 apply (intro_classes)
 apply (auto simp add: less_finite_2_def less_eq_finite_2_def)
 apply (metis finite_2.nchotomy)+
 done
 
 end
 
 instance finite_2 :: wellorder
 by(rule wf_wellorderI)(simp add: less_finite_2_def, intro_classes)
 
 instantiation finite_2 :: complete_lattice
 begin
 
 definition "\<Sqinter>A = (if a\<^sub>1 \<in> A then a\<^sub>1 else a\<^sub>2)"
 definition "\<Squnion>A = (if a\<^sub>2 \<in> A then a\<^sub>2 else a\<^sub>1)"
 definition [simp]: "bot = a\<^sub>1"
 definition [simp]: "top = a\<^sub>2"
 definition "x \<sqinter> y = (if x = a\<^sub>1 \<or> y = a\<^sub>1 then a\<^sub>1 else a\<^sub>2)"
 definition "x \<squnion> y = (if x = a\<^sub>2 \<or> y = a\<^sub>2 then a\<^sub>2 else a\<^sub>1)"
 
 lemma neq_finite_2_a\<^sub>1_iff [simp]: "x \<noteq> a\<^sub>1 \<longleftrightarrow> x = a\<^sub>2"
 by(cases x) simp_all
 
 lemma neq_finite_2_a\<^sub>1_iff' [simp]: "a\<^sub>1 \<noteq> x \<longleftrightarrow> x = a\<^sub>2"
 by(cases x) simp_all
 
 lemma neq_finite_2_a\<^sub>2_iff [simp]: "x \<noteq> a\<^sub>2 \<longleftrightarrow> x = a\<^sub>1"
 by(cases x) simp_all
 
 lemma neq_finite_2_a\<^sub>2_iff' [simp]: "a\<^sub>2 \<noteq> x \<longleftrightarrow> x = a\<^sub>1"
 by(cases x) simp_all
 
 instance
 proof
   fix x :: finite_2 and A
   assume "x \<in> A"
   then show "\<Sqinter>A \<le> x" "x \<le> \<Squnion>A"
     by(cases x; auto simp add: less_eq_finite_2_def less_finite_2_def Inf_finite_2_def Sup_finite_2_def)+
 qed(auto simp add: less_eq_finite_2_def less_finite_2_def inf_finite_2_def sup_finite_2_def Inf_finite_2_def Sup_finite_2_def)
 end
 
 instance finite_2 :: complete_linorder ..
 
 instance finite_2 :: complete_distrib_lattice ..
 
 instantiation finite_2 :: "{field, idom_abs_sgn, idom_modulo}" begin
 definition [simp]: "0 = a\<^sub>1"
 definition [simp]: "1 = a\<^sub>2"
 definition "x + y = (case (x, y) of (a\<^sub>1, a\<^sub>1) \<Rightarrow> a\<^sub>1 | (a\<^sub>2, a\<^sub>2) \<Rightarrow> a\<^sub>1 | _ \<Rightarrow> a\<^sub>2)"
 definition "uminus = (\<lambda>x :: finite_2. x)"
 definition "(-) = ((+) :: finite_2 \<Rightarrow> _)"
 definition "x * y = (case (x, y) of (a\<^sub>2, a\<^sub>2) \<Rightarrow> a\<^sub>2 | _ \<Rightarrow> a\<^sub>1)"
 definition "inverse = (\<lambda>x :: finite_2. x)"
 definition "divide = ((*) :: finite_2 \<Rightarrow> _)"
 definition "x mod y = (case (x, y) of (a\<^sub>2, a\<^sub>1) \<Rightarrow> a\<^sub>2 | _ \<Rightarrow> a\<^sub>1)"
 definition "abs = (\<lambda>x :: finite_2. x)"
 definition "sgn = (\<lambda>x :: finite_2. x)"
 instance
   by standard
     (subproofs
       \<open>simp_all add: plus_finite_2_def uminus_finite_2_def minus_finite_2_def
         times_finite_2_def
         inverse_finite_2_def divide_finite_2_def modulo_finite_2_def
         abs_finite_2_def sgn_finite_2_def
         split: finite_2.splits\<close>)
 end
 
 lemma two_finite_2 [simp]:
   "2 = a\<^sub>1"
   by (simp add: numeral.simps plus_finite_2_def)
 
 lemma dvd_finite_2_unfold:
   "x dvd y \<longleftrightarrow> x = a\<^sub>2 \<or> y = a\<^sub>1"
   by (auto simp add: dvd_def times_finite_2_def split: finite_2.splits)
 
 instantiation finite_2 :: "{normalization_semidom, unique_euclidean_semiring}" begin
 definition [simp]: "normalize = (id :: finite_2 \<Rightarrow> _)"
 definition [simp]: "unit_factor = (id :: finite_2 \<Rightarrow> _)"
 definition [simp]: "euclidean_size x = (case x of a\<^sub>1 \<Rightarrow> 0 | a\<^sub>2 \<Rightarrow> 1)"
 definition [simp]: "division_segment (x :: finite_2) = 1"
 instance
   by standard
     (subproofs
       \<open>auto simp add: divide_finite_2_def times_finite_2_def dvd_finite_2_unfold
         split: finite_2.splits\<close>)
 end
 
  
 hide_const (open) a\<^sub>1 a\<^sub>2
 
 datatype (plugins only: code "quickcheck" extraction) finite_3 =
   a\<^sub>1 | a\<^sub>2 | a\<^sub>3
 
 notation (output) a\<^sub>1  ("a\<^sub>1")
 notation (output) a\<^sub>2  ("a\<^sub>2")
 notation (output) a\<^sub>3  ("a\<^sub>3")
 
 lemma UNIV_finite_3:
   "UNIV = {a\<^sub>1, a\<^sub>2, a\<^sub>3}"
   by (auto intro: finite_3.exhaust)
 
 instantiation finite_3 :: enum
 begin
 
 definition
   "enum = [a\<^sub>1, a\<^sub>2, a\<^sub>3]"
 
 definition
   "enum_all P \<longleftrightarrow> P a\<^sub>1 \<and> P a\<^sub>2 \<and> P a\<^sub>3"
 
 definition
   "enum_ex P \<longleftrightarrow> P a\<^sub>1 \<or> P a\<^sub>2 \<or> P a\<^sub>3"
 
 instance proof
 qed (simp_all only: enum_finite_3_def enum_all_finite_3_def enum_ex_finite_3_def UNIV_finite_3, simp_all)
 
 end
 
 lemma finite_3_not_eq_unfold:
   "x \<noteq> a\<^sub>1 \<longleftrightarrow> x \<in> {a\<^sub>2, a\<^sub>3}"
   "x \<noteq> a\<^sub>2 \<longleftrightarrow> x \<in> {a\<^sub>1, a\<^sub>3}"
   "x \<noteq> a\<^sub>3 \<longleftrightarrow> x \<in> {a\<^sub>1, a\<^sub>2}"
   by (cases x; simp)+
 
 instantiation finite_3 :: linorder
 begin
 
 definition less_finite_3 :: "finite_3 \<Rightarrow> finite_3 \<Rightarrow> bool"
 where
   "x < y = (case x of a\<^sub>1 \<Rightarrow> y \<noteq> a\<^sub>1 | a\<^sub>2 \<Rightarrow> y = a\<^sub>3 | a\<^sub>3 \<Rightarrow> False)"
 
 definition less_eq_finite_3 :: "finite_3 \<Rightarrow> finite_3 \<Rightarrow> bool"
 where
   "x \<le> y \<longleftrightarrow> x = y \<or> x < (y :: finite_3)"
 
 instance proof (intro_classes)
 qed (auto simp add: less_finite_3_def less_eq_finite_3_def split: finite_3.split_asm)
 
 end
 
 instance finite_3 :: wellorder
 proof(rule wf_wellorderI)
   have "inv_image less_than (case_finite_3 0 1 2) = {(x, y). x < y}"
     by(auto simp add: less_finite_3_def split: finite_3.splits)
   from this[symmetric] show "wf \<dots>" by simp
 qed intro_classes
 
 class finite_lattice = finite +  lattice + Inf + Sup  + bot + top +
   assumes Inf_finite_empty: "Inf {} = Sup UNIV"
   assumes Inf_finite_insert: "Inf (insert a A) = a \<sqinter> Inf A"
   assumes Sup_finite_empty: "Sup {} = Inf UNIV"
   assumes Sup_finite_insert: "Sup (insert a A) = a \<squnion> Sup A"
   assumes bot_finite_def: "bot = Inf UNIV"
   assumes top_finite_def: "top = Sup UNIV"
 begin
 
 subclass complete_lattice
 proof
   fix x A
   show "x \<in> A \<Longrightarrow> \<Sqinter>A \<le> x"
     by (metis Set.set_insert abel_semigroup.commute local.Inf_finite_insert local.inf.abel_semigroup_axioms local.inf.left_idem local.inf.orderI)
   show "x \<in> A \<Longrightarrow> x \<le> \<Squnion>A"
     by (metis Set.set_insert insert_absorb2 local.Sup_finite_insert local.sup.absorb_iff2)
 next
   fix A z
   have "\<Squnion> UNIV = z \<squnion> \<Squnion>UNIV"
     by (subst Sup_finite_insert [symmetric], simp add: insert_UNIV)
   from this have [simp]: "z \<le> \<Squnion>UNIV"
     using local.le_iff_sup by auto
   have "(\<forall> x. x \<in> A \<longrightarrow> z \<le> x) \<longrightarrow> z \<le> \<Sqinter>A"
     by (rule finite_induct [of A "\<lambda> A . (\<forall> x. x \<in> A \<longrightarrow> z \<le> x) \<longrightarrow> z \<le> \<Sqinter>A"])
       (simp_all add: Inf_finite_empty Inf_finite_insert)
   from this show "(\<And>x. x \<in> A \<Longrightarrow> z \<le> x) \<Longrightarrow> z \<le> \<Sqinter>A"
     by simp
 
   have "\<Sqinter> UNIV = z \<sqinter> \<Sqinter>UNIV"
     by (subst Inf_finite_insert [symmetric], simp add: insert_UNIV)
   from this have [simp]: "\<Sqinter>UNIV \<le> z"
     by (simp add: local.inf.absorb_iff2)
   have "(\<forall> x. x \<in> A \<longrightarrow> x \<le> z) \<longrightarrow> \<Squnion>A \<le> z"
     by (rule finite_induct [of A "\<lambda> A . (\<forall> x. x \<in> A \<longrightarrow> x \<le> z) \<longrightarrow> \<Squnion>A \<le> z" ], simp_all add: Sup_finite_empty Sup_finite_insert)
   from this show " (\<And>x. x \<in> A \<Longrightarrow> x \<le> z) \<Longrightarrow> \<Squnion>A \<le> z"
     by blast
 next
   show "\<Sqinter>{} = \<top>"
     by (simp add: Inf_finite_empty top_finite_def)
   show " \<Squnion>{} = \<bottom>"
     by (simp add: Sup_finite_empty bot_finite_def)
 qed
 end
 
 class finite_distrib_lattice = finite_lattice + distrib_lattice 
 begin
 lemma finite_inf_Sup: "a \<sqinter> (Sup A) = Sup {a \<sqinter> b | b . b \<in> A}"
 proof (rule finite_induct [of A "\<lambda> A . a \<sqinter> (Sup A) = Sup {a \<sqinter> b | b . b \<in> A}"], simp_all)
   fix x::"'a"
   fix F
   assume "x \<notin> F"
   assume [simp]: "a \<sqinter> \<Squnion>F = \<Squnion>{a \<sqinter> b |b. b \<in> F}"
   have [simp]: " insert (a \<sqinter> x) {a \<sqinter> b |b. b \<in> F} = {a \<sqinter> b |b. b = x \<or> b \<in> F}"
     by blast
   have "a \<sqinter> (x \<squnion> \<Squnion>F) = a \<sqinter> x \<squnion> a \<sqinter> \<Squnion>F"
     by (simp add: inf_sup_distrib1)
   also have "... = a \<sqinter> x \<squnion> \<Squnion>{a \<sqinter> b |b. b \<in> F}"
     by simp
   also have "... = \<Squnion>{a \<sqinter> b |b. b = x \<or> b \<in> F}"
     by (unfold Sup_insert[THEN sym], simp)
   finally show "a \<sqinter> (x \<squnion> \<Squnion>F) = \<Squnion>{a \<sqinter> b |b. b = x \<or> b \<in> F}"
     by simp
 qed
 
 lemma finite_Inf_Sup: "\<Sqinter>(Sup ` A) \<le> \<Squnion>(Inf ` {f ` A |f. \<forall>Y\<in>A. f Y \<in> Y})"
 proof (rule finite_induct [of A "\<lambda>A. \<Sqinter>(Sup ` A) \<le> \<Squnion>(Inf ` {f ` A |f. \<forall>Y\<in>A. f Y \<in> Y})"], simp_all add: finite_UnionD)
   fix x::"'a set"
   fix F
   assume "x \<notin> F"
   have [simp]: "{\<Squnion>x \<sqinter> b |b . b \<in> Inf ` {f ` F |f. \<forall>Y\<in>F. f Y \<in> Y} } = {\<Squnion>x \<sqinter> (Inf (f ` F)) |f  . (\<forall>Y\<in>F. f Y \<in> Y)}"
     by auto
   define fa where "fa = (\<lambda> (b::'a) f Y . (if Y = x then b else f Y))"
   have "\<And>f b. \<forall>Y\<in>F. f Y \<in> Y \<Longrightarrow> b \<in> x \<Longrightarrow> insert b (f ` (F \<inter> {Y. Y \<noteq> x})) = insert (fa b f x) (fa b f ` F) \<and> fa b f x \<in> x \<and> (\<forall>Y\<in>F. fa b f Y \<in> Y)"
     by (auto simp add: fa_def)
   from this have B: "\<And>f b. \<forall>Y\<in>F. f Y \<in> Y \<Longrightarrow> b \<in> x \<Longrightarrow> fa b f ` ({x} \<union> F) \<in> {insert (f x) (f ` F) |f. f x \<in> x \<and> (\<forall>Y\<in>F. f Y \<in> Y)}"
     by blast
   have [simp]: "\<And>f b. \<forall>Y\<in>F. f Y \<in> Y \<Longrightarrow> b \<in> x \<Longrightarrow> b \<sqinter> (\<Sqinter>x\<in>F. f x)  \<le> \<Squnion>(Inf ` {insert (f x) (f ` F) |f. f x \<in> x \<and> (\<forall>Y\<in>F. f Y \<in> Y)})"
     using B apply (rule SUP_upper2)
     using \<open>x \<notin> F\<close> apply (simp_all add: fa_def Inf_union_distrib)
     apply (simp add: image_mono Inf_superset_mono inf.coboundedI2)
     done
   assume "\<Sqinter>(Sup ` F) \<le> \<Squnion>(Inf ` {f ` F |f. \<forall>Y\<in>F. f Y \<in> Y})"
 
   from this have "\<Squnion>x \<sqinter> \<Sqinter>(Sup ` F) \<le> \<Squnion>x \<sqinter> \<Squnion>(Inf ` {f ` F |f. \<forall>Y\<in>F. f Y \<in> Y})"
     using inf.coboundedI2 by auto
   also have "... = Sup {\<Squnion>x \<sqinter> (Inf (f ` F)) |f  .  (\<forall>Y\<in>F. f Y \<in> Y)}"
     by (simp add: finite_inf_Sup)
 
   also have "... = Sup {Sup {Inf (f ` F) \<sqinter> b | b . b \<in> x} |f  .  (\<forall>Y\<in>F. f Y \<in> Y)}"
     by (subst inf_commute) (simp add: finite_inf_Sup)
 
   also have "... \<le> \<Squnion>(Inf ` {insert (f x) (f ` F) |f. f x \<in> x \<and> (\<forall>Y\<in>F. f Y \<in> Y)})"
     apply (rule Sup_least, clarsimp)+
     apply (subst inf_commute, simp)
     done
 
   finally show "\<Squnion>x \<sqinter> \<Sqinter>(Sup ` F) \<le> \<Squnion>(Inf ` {insert (f x) (f ` F) |f. f x \<in> x \<and> (\<forall>Y\<in>F. f Y \<in> Y)})"
     by simp
 qed
 
 subclass complete_distrib_lattice
   by (standard, rule finite_Inf_Sup)
 end
 
 instantiation finite_3 :: finite_lattice
 begin
 
 definition "\<Sqinter>A = (if a\<^sub>1 \<in> A then a\<^sub>1 else if a\<^sub>2 \<in> A then a\<^sub>2 else a\<^sub>3)"
 definition "\<Squnion>A = (if a\<^sub>3 \<in> A then a\<^sub>3 else if a\<^sub>2 \<in> A then a\<^sub>2 else a\<^sub>1)"
 definition [simp]: "bot = a\<^sub>1"
 definition [simp]: "top = a\<^sub>3"
 definition [simp]: "inf = (min :: finite_3 \<Rightarrow> _)"
 definition [simp]: "sup = (max :: finite_3 \<Rightarrow> _)"
 
 instance
 proof
 qed (auto simp add: Inf_finite_3_def Sup_finite_3_def max_def min_def less_eq_finite_3_def less_finite_3_def split: finite_3.split)
 end
 
 instance finite_3 :: complete_lattice ..
 
 instance finite_3 :: finite_distrib_lattice
 proof 
 qed (auto simp add: min_def max_def)
 
 instance finite_3 :: complete_distrib_lattice ..
 
 instance finite_3 :: complete_linorder ..
 
 instantiation finite_3 :: "{field, idom_abs_sgn, idom_modulo}" begin
 definition [simp]: "0 = a\<^sub>1"
 definition [simp]: "1 = a\<^sub>2"
 definition
   "x + y = (case (x, y) of
      (a\<^sub>1, a\<^sub>1) \<Rightarrow> a\<^sub>1 | (a\<^sub>2, a\<^sub>3) \<Rightarrow> a\<^sub>1 | (a\<^sub>3, a\<^sub>2) \<Rightarrow> a\<^sub>1
    | (a\<^sub>1, a\<^sub>2) \<Rightarrow> a\<^sub>2 | (a\<^sub>2, a\<^sub>1) \<Rightarrow> a\<^sub>2 | (a\<^sub>3, a\<^sub>3) \<Rightarrow> a\<^sub>2
    | _ \<Rightarrow> a\<^sub>3)"
 definition "- x = (case x of a\<^sub>1 \<Rightarrow> a\<^sub>1 | a\<^sub>2 \<Rightarrow> a\<^sub>3 | a\<^sub>3 \<Rightarrow> a\<^sub>2)"
 definition "x - y = x + (- y :: finite_3)"
 definition "x * y = (case (x, y) of (a\<^sub>2, a\<^sub>2) \<Rightarrow> a\<^sub>2 | (a\<^sub>3, a\<^sub>3) \<Rightarrow> a\<^sub>2 | (a\<^sub>2, a\<^sub>3) \<Rightarrow> a\<^sub>3 | (a\<^sub>3, a\<^sub>2) \<Rightarrow> a\<^sub>3 | _ \<Rightarrow> a\<^sub>1)"
 definition "inverse = (\<lambda>x :: finite_3. x)" 
 definition "x div y = x * inverse (y :: finite_3)"
 definition "x mod y = (case y of a\<^sub>1 \<Rightarrow> x | _ \<Rightarrow> a\<^sub>1)"
 definition "abs = (\<lambda>x. case x of a\<^sub>3 \<Rightarrow> a\<^sub>2 | _ \<Rightarrow> x)"
 definition "sgn = (\<lambda>x :: finite_3. x)"
 instance
   by standard
     (subproofs
       \<open>simp_all add: plus_finite_3_def uminus_finite_3_def minus_finite_3_def
         times_finite_3_def
         inverse_finite_3_def divide_finite_3_def modulo_finite_3_def
         abs_finite_3_def sgn_finite_3_def
         less_finite_3_def
         split: finite_3.splits\<close>)
 end
 
 lemma two_finite_3 [simp]:
   "2 = a\<^sub>3"
   by (simp add: numeral.simps plus_finite_3_def)
 
 lemma dvd_finite_3_unfold:
   "x dvd y \<longleftrightarrow> x = a\<^sub>2 \<or> x = a\<^sub>3 \<or> y = a\<^sub>1"
   by (cases x) (auto simp add: dvd_def times_finite_3_def split: finite_3.splits)
 
 instantiation finite_3 :: "{normalization_semidom, unique_euclidean_semiring}" begin
 definition [simp]: "normalize x = (case x of a\<^sub>3 \<Rightarrow> a\<^sub>2 | _ \<Rightarrow> x)"
 definition [simp]: "unit_factor = (id :: finite_3 \<Rightarrow> _)"
 definition [simp]: "euclidean_size x = (case x of a\<^sub>1 \<Rightarrow> 0 | _ \<Rightarrow> 1)"
 definition [simp]: "division_segment (x :: finite_3) = 1"
 instance
 proof
   fix x :: finite_3
   assume "x \<noteq> 0"
   then show "is_unit (unit_factor x)"
     by (cases x) (simp_all add: dvd_finite_3_unfold)
 qed
   (subproofs
     \<open>auto simp add: divide_finite_3_def times_finite_3_def
       dvd_finite_3_unfold inverse_finite_3_def plus_finite_3_def
       split: finite_3.splits\<close>)
 end
 
 hide_const (open) a\<^sub>1 a\<^sub>2 a\<^sub>3
 
 datatype (plugins only: code "quickcheck" extraction) finite_4 =
   a\<^sub>1 | a\<^sub>2 | a\<^sub>3 | a\<^sub>4
 
 notation (output) a\<^sub>1  ("a\<^sub>1")
 notation (output) a\<^sub>2  ("a\<^sub>2")
 notation (output) a\<^sub>3  ("a\<^sub>3")
 notation (output) a\<^sub>4  ("a\<^sub>4")
 
 lemma UNIV_finite_4:
   "UNIV = {a\<^sub>1, a\<^sub>2, a\<^sub>3, a\<^sub>4}"
   by (auto intro: finite_4.exhaust)
 
 instantiation finite_4 :: enum
 begin
 
 definition
   "enum = [a\<^sub>1, a\<^sub>2, a\<^sub>3, a\<^sub>4]"
 
 definition
   "enum_all P \<longleftrightarrow> P a\<^sub>1 \<and> P a\<^sub>2 \<and> P a\<^sub>3 \<and> P a\<^sub>4"
 
 definition
   "enum_ex P \<longleftrightarrow> P a\<^sub>1 \<or> P a\<^sub>2 \<or> P a\<^sub>3 \<or> P a\<^sub>4"
 
 instance proof
 qed (simp_all only: enum_finite_4_def enum_all_finite_4_def enum_ex_finite_4_def UNIV_finite_4, simp_all)
 
 end
 
 instantiation finite_4 :: finite_distrib_lattice begin
 
 text \<open>\<^term>\<open>a\<^sub>1\<close> $<$ \<^term>\<open>a\<^sub>2\<close>,\<^term>\<open>a\<^sub>3\<close> $<$ \<^term>\<open>a\<^sub>4\<close>,
   but \<^term>\<open>a\<^sub>2\<close> and \<^term>\<open>a\<^sub>3\<close> are incomparable.\<close>
 
 definition
   "x < y \<longleftrightarrow> (case (x, y) of
      (a\<^sub>1, a\<^sub>1) \<Rightarrow> False | (a\<^sub>1, _) \<Rightarrow> True
    |  (a\<^sub>2, a\<^sub>4) \<Rightarrow> True
    |  (a\<^sub>3, a\<^sub>4) \<Rightarrow> True  | _ \<Rightarrow> False)"
 
 definition 
   "x \<le> y \<longleftrightarrow> (case (x, y) of
      (a\<^sub>1, _) \<Rightarrow> True
    | (a\<^sub>2, a\<^sub>2) \<Rightarrow> True | (a\<^sub>2, a\<^sub>4) \<Rightarrow> True
    | (a\<^sub>3, a\<^sub>3) \<Rightarrow> True | (a\<^sub>3, a\<^sub>4) \<Rightarrow> True
    | (a\<^sub>4, a\<^sub>4) \<Rightarrow> True | _ \<Rightarrow> False)"
 
 definition
   "\<Sqinter>A = (if a\<^sub>1 \<in> A \<or> a\<^sub>2 \<in> A \<and> a\<^sub>3 \<in> A then a\<^sub>1 else if a\<^sub>2 \<in> A then a\<^sub>2 else if a\<^sub>3 \<in> A then a\<^sub>3 else a\<^sub>4)"
 definition
   "\<Squnion>A = (if a\<^sub>4 \<in> A \<or> a\<^sub>2 \<in> A \<and> a\<^sub>3 \<in> A then a\<^sub>4 else if a\<^sub>2 \<in> A then a\<^sub>2 else if a\<^sub>3 \<in> A then a\<^sub>3 else a\<^sub>1)"
 definition [simp]: "bot = a\<^sub>1"
 definition [simp]: "top = a\<^sub>4"
 definition
   "x \<sqinter> y = (case (x, y) of
      (a\<^sub>1, _) \<Rightarrow> a\<^sub>1 | (_, a\<^sub>1) \<Rightarrow> a\<^sub>1 | (a\<^sub>2, a\<^sub>3) \<Rightarrow> a\<^sub>1 | (a\<^sub>3, a\<^sub>2) \<Rightarrow> a\<^sub>1
    | (a\<^sub>2, _) \<Rightarrow> a\<^sub>2 | (_, a\<^sub>2) \<Rightarrow> a\<^sub>2
    | (a\<^sub>3, _) \<Rightarrow> a\<^sub>3 | (_, a\<^sub>3) \<Rightarrow> a\<^sub>3
    | _ \<Rightarrow> a\<^sub>4)"
 definition
   "x \<squnion> y = (case (x, y) of
      (a\<^sub>4, _) \<Rightarrow> a\<^sub>4 | (_, a\<^sub>4) \<Rightarrow> a\<^sub>4 | (a\<^sub>2, a\<^sub>3) \<Rightarrow> a\<^sub>4 | (a\<^sub>3, a\<^sub>2) \<Rightarrow> a\<^sub>4
   | (a\<^sub>2, _) \<Rightarrow> a\<^sub>2 | (_, a\<^sub>2) \<Rightarrow> a\<^sub>2
   | (a\<^sub>3, _) \<Rightarrow> a\<^sub>3 | (_, a\<^sub>3) \<Rightarrow> a\<^sub>3
   | _ \<Rightarrow> a\<^sub>1)"
 
 instance
   by standard
     (subproofs
       \<open>auto simp add: less_finite_4_def less_eq_finite_4_def Inf_finite_4_def Sup_finite_4_def 
         inf_finite_4_def sup_finite_4_def split: finite_4.splits\<close>)
 end
 
 instance finite_4 :: complete_lattice ..
 
 instance finite_4 :: complete_distrib_lattice ..
 
 instantiation finite_4 :: complete_boolean_algebra begin
 definition "- x = (case x of a\<^sub>1 \<Rightarrow> a\<^sub>4 | a\<^sub>2 \<Rightarrow> a\<^sub>3 | a\<^sub>3 \<Rightarrow> a\<^sub>2 | a\<^sub>4 \<Rightarrow> a\<^sub>1)"
 definition "x - y = x \<sqinter> - (y :: finite_4)"
 instance
   by standard
     (subproofs
       \<open>simp_all add: inf_finite_4_def sup_finite_4_def uminus_finite_4_def minus_finite_4_def 
         split: finite_4.splits\<close>)
 end
 
 hide_const (open) a\<^sub>1 a\<^sub>2 a\<^sub>3 a\<^sub>4
 
 datatype (plugins only: code "quickcheck" extraction) finite_5 =
   a\<^sub>1 | a\<^sub>2 | a\<^sub>3 | a\<^sub>4 | a\<^sub>5
 
 notation (output) a\<^sub>1  ("a\<^sub>1")
 notation (output) a\<^sub>2  ("a\<^sub>2")
 notation (output) a\<^sub>3  ("a\<^sub>3")
 notation (output) a\<^sub>4  ("a\<^sub>4")
 notation (output) a\<^sub>5  ("a\<^sub>5")
 
 lemma UNIV_finite_5:
   "UNIV = {a\<^sub>1, a\<^sub>2, a\<^sub>3, a\<^sub>4, a\<^sub>5}"
   by (auto intro: finite_5.exhaust)
 
 instantiation finite_5 :: enum
 begin
 
 definition
   "enum = [a\<^sub>1, a\<^sub>2, a\<^sub>3, a\<^sub>4, a\<^sub>5]"
 
 definition
   "enum_all P \<longleftrightarrow> P a\<^sub>1 \<and> P a\<^sub>2 \<and> P a\<^sub>3 \<and> P a\<^sub>4 \<and> P a\<^sub>5"
 
 definition
   "enum_ex P \<longleftrightarrow> P a\<^sub>1 \<or> P a\<^sub>2 \<or> P a\<^sub>3 \<or> P a\<^sub>4 \<or> P a\<^sub>5"
 
 instance proof
 qed (simp_all only: enum_finite_5_def enum_all_finite_5_def enum_ex_finite_5_def UNIV_finite_5, simp_all)
 
 end
 
 instantiation finite_5 :: finite_lattice
 begin
 
 text \<open>The non-distributive pentagon lattice $N_5$\<close>
 
 definition
   "x < y \<longleftrightarrow> (case (x, y) of
      (a\<^sub>1, a\<^sub>1) \<Rightarrow> False | (a\<^sub>1, _) \<Rightarrow> True
    | (a\<^sub>2, a\<^sub>3) \<Rightarrow> True  | (a\<^sub>2, a\<^sub>5) \<Rightarrow> True
    | (a\<^sub>3, a\<^sub>5) \<Rightarrow> True
    | (a\<^sub>4, a\<^sub>5) \<Rightarrow> True  | _ \<Rightarrow> False)"
 
 definition
   "x \<le> y \<longleftrightarrow> (case (x, y) of
      (a\<^sub>1, _) \<Rightarrow> True
    | (a\<^sub>2, a\<^sub>2) \<Rightarrow> True | (a\<^sub>2, a\<^sub>3) \<Rightarrow> True | (a\<^sub>2, a\<^sub>5) \<Rightarrow> True
    | (a\<^sub>3, a\<^sub>3) \<Rightarrow> True | (a\<^sub>3, a\<^sub>5) \<Rightarrow> True
    | (a\<^sub>4, a\<^sub>4) \<Rightarrow> True | (a\<^sub>4, a\<^sub>5) \<Rightarrow> True
    | (a\<^sub>5, a\<^sub>5) \<Rightarrow> True | _ \<Rightarrow> False)"
 
 definition
   "\<Sqinter>A = 
   (if a\<^sub>1 \<in> A \<or> a\<^sub>4 \<in> A \<and> (a\<^sub>2 \<in> A \<or> a\<^sub>3 \<in> A) then a\<^sub>1
    else if a\<^sub>2 \<in> A then a\<^sub>2
    else if a\<^sub>3 \<in> A then a\<^sub>3
    else if a\<^sub>4 \<in> A then a\<^sub>4
    else a\<^sub>5)"
 definition
   "\<Squnion>A = 
   (if a\<^sub>5 \<in> A \<or> a\<^sub>4 \<in> A \<and> (a\<^sub>2 \<in> A \<or> a\<^sub>3 \<in> A) then a\<^sub>5
    else if a\<^sub>3 \<in> A then a\<^sub>3
    else if a\<^sub>2 \<in> A then a\<^sub>2
    else if a\<^sub>4 \<in> A then a\<^sub>4
    else a\<^sub>1)"
 definition [simp]: "bot = a\<^sub>1"
 definition [simp]: "top = a\<^sub>5"
 definition
   "x \<sqinter> y = (case (x, y) of
      (a\<^sub>1, _) \<Rightarrow> a\<^sub>1 | (_, a\<^sub>1) \<Rightarrow> a\<^sub>1 | (a\<^sub>2, a\<^sub>4) \<Rightarrow> a\<^sub>1 | (a\<^sub>4, a\<^sub>2) \<Rightarrow> a\<^sub>1 | (a\<^sub>3, a\<^sub>4) \<Rightarrow> a\<^sub>1 | (a\<^sub>4, a\<^sub>3) \<Rightarrow> a\<^sub>1
    | (a\<^sub>2, _) \<Rightarrow> a\<^sub>2 | (_, a\<^sub>2) \<Rightarrow> a\<^sub>2
    | (a\<^sub>3, _) \<Rightarrow> a\<^sub>3 | (_, a\<^sub>3) \<Rightarrow> a\<^sub>3
    | (a\<^sub>4, _) \<Rightarrow> a\<^sub>4 | (_, a\<^sub>4) \<Rightarrow> a\<^sub>4
    | _ \<Rightarrow> a\<^sub>5)"
 definition
   "x \<squnion> y = (case (x, y) of
      (a\<^sub>5, _) \<Rightarrow> a\<^sub>5 | (_, a\<^sub>5) \<Rightarrow> a\<^sub>5 | (a\<^sub>2, a\<^sub>4) \<Rightarrow> a\<^sub>5 | (a\<^sub>4, a\<^sub>2) \<Rightarrow> a\<^sub>5 | (a\<^sub>3, a\<^sub>4) \<Rightarrow> a\<^sub>5 | (a\<^sub>4, a\<^sub>3) \<Rightarrow> a\<^sub>5
    | (a\<^sub>3, _) \<Rightarrow> a\<^sub>3 | (_, a\<^sub>3) \<Rightarrow> a\<^sub>3
    | (a\<^sub>2, _) \<Rightarrow> a\<^sub>2 | (_, a\<^sub>2) \<Rightarrow> a\<^sub>2
    | (a\<^sub>4, _) \<Rightarrow> a\<^sub>4 | (_, a\<^sub>4) \<Rightarrow> a\<^sub>4
    | _ \<Rightarrow> a\<^sub>1)"
 
 instance
   by standard
     (subproofs
       \<open>auto simp add: less_eq_finite_5_def less_finite_5_def inf_finite_5_def sup_finite_5_def 
         Inf_finite_5_def Sup_finite_5_def split: finite_5.splits if_split_asm\<close>)
 end
 
 
 instance  finite_5 :: complete_lattice ..
 
 
 hide_const (open) a\<^sub>1 a\<^sub>2 a\<^sub>3 a\<^sub>4 a\<^sub>5
 
 
 subsection \<open>Closing up\<close>
 
 hide_type (open) finite_1 finite_2 finite_3 finite_4 finite_5
 hide_const (open) enum enum_all enum_ex all_n_lists ex_n_lists ntrancl
 
 end
diff --git a/src/HOL/Finite_Set.thy b/src/HOL/Finite_Set.thy
--- a/src/HOL/Finite_Set.thy
+++ b/src/HOL/Finite_Set.thy
@@ -1,3044 +1,3044 @@
 (*  Title:      HOL/Finite_Set.thy
     Author:     Tobias Nipkow
     Author:     Lawrence C Paulson
     Author:     Markus Wenzel
     Author:     Jeremy Avigad
     Author:     Andrei Popescu
 *)
 
 section \<open>Finite sets\<close>
 
 theory Finite_Set
   imports Product_Type Sum_Type Fields Relation
 begin
 
 subsection \<open>Predicate for finite sets\<close>
 
 context notes [[inductive_internals]]
 begin
 
 inductive finite :: "'a set \<Rightarrow> bool"
   where
     emptyI [simp, intro!]: "finite {}"
   | insertI [simp, intro!]: "finite A \<Longrightarrow> finite (insert a A)"
 
 end
 
 simproc_setup finite_Collect ("finite (Collect P)") = \<open>K Set_Comprehension_Pointfree.simproc\<close>
 
 declare [[simproc del: finite_Collect]]
 
 lemma finite_induct [case_names empty insert, induct set: finite]:
   \<comment> \<open>Discharging \<open>x \<notin> F\<close> entails extra work.\<close>
   assumes "finite F"
   assumes "P {}"
     and insert: "\<And>x F. finite F \<Longrightarrow> x \<notin> F \<Longrightarrow> P F \<Longrightarrow> P (insert x F)"
   shows "P F"
   using \<open>finite F\<close>
 proof induct
   show "P {}" by fact
 next
   fix x F
   assume F: "finite F" and P: "P F"
   show "P (insert x F)"
   proof cases
     assume "x \<in> F"
     then have "insert x F = F" by (rule insert_absorb)
     with P show ?thesis by (simp only:)
   next
     assume "x \<notin> F"
     from F this P show ?thesis by (rule insert)
   qed
 qed
 
 lemma infinite_finite_induct [case_names infinite empty insert]:
   assumes infinite: "\<And>A. \<not> finite A \<Longrightarrow> P A"
     and empty: "P {}"
     and insert: "\<And>x F. finite F \<Longrightarrow> x \<notin> F \<Longrightarrow> P F \<Longrightarrow> P (insert x F)"
   shows "P A"
 proof (cases "finite A")
   case False
   with infinite show ?thesis .
 next
   case True
   then show ?thesis by (induct A) (fact empty insert)+
 qed
 
 
 subsubsection \<open>Choice principles\<close>
 
 lemma ex_new_if_finite: \<comment> \<open>does not depend on def of finite at all\<close>
   assumes "\<not> finite (UNIV :: 'a set)" and "finite A"
   shows "\<exists>a::'a. a \<notin> A"
 proof -
   from assms have "A \<noteq> UNIV" by blast
   then show ?thesis by blast
 qed
 
 text \<open>A finite choice principle. Does not need the SOME choice operator.\<close>
 
 lemma finite_set_choice: "finite A \<Longrightarrow> \<forall>x\<in>A. \<exists>y. P x y \<Longrightarrow> \<exists>f. \<forall>x\<in>A. P x (f x)"
 proof (induct rule: finite_induct)
   case empty
   then show ?case by simp
 next
   case (insert a A)
   then obtain f b where f: "\<forall>x\<in>A. P x (f x)" and ab: "P a b"
     by auto
   show ?case (is "\<exists>f. ?P f")
   proof
     show "?P (\<lambda>x. if x = a then b else f x)"
       using f ab by auto
   qed
 qed
 
 
 subsubsection \<open>Finite sets are the images of initial segments of natural numbers\<close>
 
 lemma finite_imp_nat_seg_image_inj_on:
   assumes "finite A"
   shows "\<exists>(n::nat) f. A = f ` {i. i < n} \<and> inj_on f {i. i < n}"
   using assms
 proof induct
   case empty
   show ?case
   proof
     show "\<exists>f. {} = f ` {i::nat. i < 0} \<and> inj_on f {i. i < 0}"
       by simp
   qed
 next
   case (insert a A)
   have notinA: "a \<notin> A" by fact
   from insert.hyps obtain n f where "A = f ` {i::nat. i < n}" "inj_on f {i. i < n}"
     by blast
   then have "insert a A = f(n:=a) ` {i. i < Suc n}" and "inj_on (f(n:=a)) {i. i < Suc n}"
     using notinA by (auto simp add: image_def Ball_def inj_on_def less_Suc_eq)
   then show ?case by blast
 qed
 
 lemma nat_seg_image_imp_finite: "A = f ` {i::nat. i < n} \<Longrightarrow> finite A"
 proof (induct n arbitrary: A)
   case 0
   then show ?case by simp
 next
   case (Suc n)
   let ?B = "f ` {i. i < n}"
   have finB: "finite ?B" by (rule Suc.hyps[OF refl])
   show ?case
   proof (cases "\<exists>k<n. f n = f k")
     case True
     then have "A = ?B"
       using Suc.prems by (auto simp:less_Suc_eq)
     then show ?thesis
       using finB by simp
   next
     case False
     then have "A = insert (f n) ?B"
       using Suc.prems by (auto simp:less_Suc_eq)
     then show ?thesis using finB by simp
   qed
 qed
 
 lemma finite_conv_nat_seg_image: "finite A \<longleftrightarrow> (\<exists>n f. A = f ` {i::nat. i < n})"
   by (blast intro: nat_seg_image_imp_finite dest: finite_imp_nat_seg_image_inj_on)
 
 lemma finite_imp_inj_to_nat_seg:
   assumes "finite A"
   shows "\<exists>f n. f ` A = {i::nat. i < n} \<and> inj_on f A"
 proof -
   from finite_imp_nat_seg_image_inj_on [OF \<open>finite A\<close>]
   obtain f and n :: nat where bij: "bij_betw f {i. i<n} A"
     by (auto simp: bij_betw_def)
   let ?f = "the_inv_into {i. i<n} f"
   have "inj_on ?f A \<and> ?f ` A = {i. i<n}"
     by (fold bij_betw_def) (rule bij_betw_the_inv_into[OF bij])
   then show ?thesis by blast
 qed
 
 lemma finite_Collect_less_nat [iff]: "finite {n::nat. n < k}"
   by (fastforce simp: finite_conv_nat_seg_image)
 
 lemma finite_Collect_le_nat [iff]: "finite {n::nat. n \<le> k}"
   by (simp add: le_eq_less_or_eq Collect_disj_eq)
 
 
 subsection \<open>Finiteness and common set operations\<close>
 
 lemma rev_finite_subset: "finite B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> finite A"
 proof (induct arbitrary: A rule: finite_induct)
   case empty
   then show ?case by simp
 next
   case (insert x F A)
   have A: "A \<subseteq> insert x F" and r: "A - {x} \<subseteq> F \<Longrightarrow> finite (A - {x})"
     by fact+
   show "finite A"
   proof cases
     assume x: "x \<in> A"
     with A have "A - {x} \<subseteq> F" by (simp add: subset_insert_iff)
     with r have "finite (A - {x})" .
     then have "finite (insert x (A - {x}))" ..
     also have "insert x (A - {x}) = A"
       using x by (rule insert_Diff)
     finally show ?thesis .
   next
     show ?thesis when "A \<subseteq> F"
       using that by fact
     assume "x \<notin> A"
     with A show "A \<subseteq> F"
       by (simp add: subset_insert_iff)
   qed
 qed
 
 lemma finite_subset: "A \<subseteq> B \<Longrightarrow> finite B \<Longrightarrow> finite A"
   by (rule rev_finite_subset)
 
-simproc_setup finite ("finite A") = \<open>fn _ =>
+simproc_setup finite ("finite A") = \<open>
 let
   val finite_subset = @{thm finite_subset}
   val Eq_TrueI = @{thm Eq_TrueI}
 
   fun is_subset A th = case Thm.prop_of th of
         (_ $ (Const (\<^const_name>\<open>less_eq\<close>, Type (\<^type_name>\<open>fun\<close>, [Type (\<^type_name>\<open>set\<close>, _), _])) $ A' $ B))
         => if A aconv A' then SOME(B,th) else NONE
       | _ => NONE;
 
   fun is_finite th = case Thm.prop_of th of
         (_ $ (Const (\<^const_name>\<open>finite\<close>, _) $ A)) => SOME(A,th)
       |  _ => NONE;
 
   fun comb (A,sub_th) (A',fin_th) ths = if A aconv A' then (sub_th,fin_th) :: ths else ths
 
-  fun proc ss ct =
+  fun proc ctxt ct =
     (let
        val _ $ A = Thm.term_of ct
-       val prems = Simplifier.prems_of ss
+       val prems = Simplifier.prems_of ctxt
        val fins = map_filter is_finite prems
        val subsets = map_filter (is_subset A) prems
      in case fold_product comb subsets fins [] of
           (sub_th,fin_th) :: _ => SOME((fin_th RS (sub_th RS finite_subset)) RS Eq_TrueI)
         | _ => NONE
      end)
-in proc end
+in K proc end
 \<close>
 
 (* Needs to be used with care *)
 declare [[simproc del: finite]]
 
 lemma finite_UnI:
   assumes "finite F" and "finite G"
   shows "finite (F \<union> G)"
   using assms by induct simp_all
 
 lemma finite_Un [iff]: "finite (F \<union> G) \<longleftrightarrow> finite F \<and> finite G"
   by (blast intro: finite_UnI finite_subset [of _ "F \<union> G"])
 
 lemma finite_insert [simp]: "finite (insert a A) \<longleftrightarrow> finite A"
 proof -
   have "finite {a} \<and> finite A \<longleftrightarrow> finite A" by simp
   then have "finite ({a} \<union> A) \<longleftrightarrow> finite A" by (simp only: finite_Un)
   then show ?thesis by simp
 qed
 
 lemma finite_Int [simp, intro]: "finite F \<or> finite G \<Longrightarrow> finite (F \<inter> G)"
   by (blast intro: finite_subset)
 
 lemma finite_Collect_conjI [simp, intro]:
   "finite {x. P x} \<or> finite {x. Q x} \<Longrightarrow> finite {x. P x \<and> Q x}"
   by (simp add: Collect_conj_eq)
 
 lemma finite_Collect_disjI [simp]:
   "finite {x. P x \<or> Q x} \<longleftrightarrow> finite {x. P x} \<and> finite {x. Q x}"
   by (simp add: Collect_disj_eq)
 
 lemma finite_Diff [simp, intro]: "finite A \<Longrightarrow> finite (A - B)"
   by (rule finite_subset, rule Diff_subset)
 
 lemma finite_Diff2 [simp]:
   assumes "finite B"
   shows "finite (A - B) \<longleftrightarrow> finite A"
 proof -
   have "finite A \<longleftrightarrow> finite ((A - B) \<union> (A \<inter> B))"
     by (simp add: Un_Diff_Int)
   also have "\<dots> \<longleftrightarrow> finite (A - B)"
     using \<open>finite B\<close> by simp
   finally show ?thesis ..
 qed
 
 lemma finite_Diff_insert [iff]: "finite (A - insert a B) \<longleftrightarrow> finite (A - B)"
 proof -
   have "finite (A - B) \<longleftrightarrow> finite (A - B - {a})" by simp
   moreover have "A - insert a B = A - B - {a}" by auto
   ultimately show ?thesis by simp
 qed
 
 lemma finite_compl [simp]:
   "finite (A :: 'a set) \<Longrightarrow> finite (- A) \<longleftrightarrow> finite (UNIV :: 'a set)"
   by (simp add: Compl_eq_Diff_UNIV)
 
 lemma finite_Collect_not [simp]:
   "finite {x :: 'a. P x} \<Longrightarrow> finite {x. \<not> P x} \<longleftrightarrow> finite (UNIV :: 'a set)"
   by (simp add: Collect_neg_eq)
 
 lemma finite_Union [simp, intro]:
   "finite A \<Longrightarrow> (\<And>M. M \<in> A \<Longrightarrow> finite M) \<Longrightarrow> finite (\<Union>A)"
   by (induct rule: finite_induct) simp_all
 
 lemma finite_UN_I [intro]:
   "finite A \<Longrightarrow> (\<And>a. a \<in> A \<Longrightarrow> finite (B a)) \<Longrightarrow> finite (\<Union>a\<in>A. B a)"
   by (induct rule: finite_induct) simp_all
 
 lemma finite_UN [simp]: "finite A \<Longrightarrow> finite (\<Union>(B ` A)) \<longleftrightarrow> (\<forall>x\<in>A. finite (B x))"
   by (blast intro: finite_subset)
 
 lemma finite_Inter [intro]: "\<exists>A\<in>M. finite A \<Longrightarrow> finite (\<Inter>M)"
   by (blast intro: Inter_lower finite_subset)
 
 lemma finite_INT [intro]: "\<exists>x\<in>I. finite (A x) \<Longrightarrow> finite (\<Inter>x\<in>I. A x)"
   by (blast intro: INT_lower finite_subset)
 
 lemma finite_imageI [simp, intro]: "finite F \<Longrightarrow> finite (h ` F)"
   by (induct rule: finite_induct) simp_all
 
 lemma finite_image_set [simp]: "finite {x. P x} \<Longrightarrow> finite {f x |x. P x}"
   by (simp add: image_Collect [symmetric])
 
 lemma finite_image_set2:
   "finite {x. P x} \<Longrightarrow> finite {y. Q y} \<Longrightarrow> finite {f x y |x y. P x \<and> Q y}"
   by (rule finite_subset [where B = "\<Union>x \<in> {x. P x}. \<Union>y \<in> {y. Q y}. {f x y}"]) auto
 
 lemma finite_imageD:
   assumes "finite (f ` A)" and "inj_on f A"
   shows "finite A"
   using assms
 proof (induct "f ` A" arbitrary: A)
   case empty
   then show ?case by simp
 next
   case (insert x B)
   then have B_A: "insert x B = f ` A"
     by simp
   then obtain y where "x = f y" and "y \<in> A"
     by blast
   from B_A \<open>x \<notin> B\<close> have "B = f ` A - {x}"
     by blast
   with B_A \<open>x \<notin> B\<close> \<open>x = f y\<close> \<open>inj_on f A\<close> \<open>y \<in> A\<close> have "B = f ` (A - {y})"
     by (simp add: inj_on_image_set_diff)
   moreover from \<open>inj_on f A\<close> have "inj_on f (A - {y})"
     by (rule inj_on_diff)
   ultimately have "finite (A - {y})"
     by (rule insert.hyps)
   then show "finite A"
     by simp
 qed
 
 lemma finite_image_iff: "inj_on f A \<Longrightarrow> finite (f ` A) \<longleftrightarrow> finite A"
   using finite_imageD by blast
 
 lemma finite_surj: "finite A \<Longrightarrow> B \<subseteq> f ` A \<Longrightarrow> finite B"
   by (erule finite_subset) (rule finite_imageI)
 
 lemma finite_range_imageI: "finite (range g) \<Longrightarrow> finite (range (\<lambda>x. f (g x)))"
   by (drule finite_imageI) (simp add: range_composition)
 
 lemma finite_subset_image:
   assumes "finite B"
   shows "B \<subseteq> f ` A \<Longrightarrow> \<exists>C\<subseteq>A. finite C \<and> B = f ` C"
   using assms
 proof induct
   case empty
   then show ?case by simp
 next
   case insert
   then show ?case
     by (clarsimp simp del: image_insert simp add: image_insert [symmetric]) blast
 qed
 
 lemma all_subset_image: "(\<forall>B. B \<subseteq> f ` A \<longrightarrow> P B) \<longleftrightarrow> (\<forall>B. B \<subseteq> A \<longrightarrow> P(f ` B))"
   by (safe elim!: subset_imageE) (use image_mono in \<open>blast+\<close>) (* slow *)
 
 lemma all_finite_subset_image:
   "(\<forall>B. finite B \<and> B \<subseteq> f ` A \<longrightarrow> P B) \<longleftrightarrow> (\<forall>B. finite B \<and> B \<subseteq> A \<longrightarrow> P (f ` B))"
 proof safe
   fix B :: "'a set"
   assume B: "finite B" "B \<subseteq> f ` A" and P: "\<forall>B. finite B \<and> B \<subseteq> A \<longrightarrow> P (f ` B)"
   show "P B"
     using finite_subset_image [OF B] P by blast
 qed blast
 
 lemma ex_finite_subset_image:
   "(\<exists>B. finite B \<and> B \<subseteq> f ` A \<and> P B) \<longleftrightarrow> (\<exists>B. finite B \<and> B \<subseteq> A \<and> P (f ` B))"
 proof safe
   fix B :: "'a set"
   assume B: "finite B" "B \<subseteq> f ` A" and "P B"
   show "\<exists>B. finite B \<and> B \<subseteq> A \<and> P (f ` B)"
     using finite_subset_image [OF B] \<open>P B\<close> by blast
 qed blast
 
 lemma finite_vimage_IntI: "finite F \<Longrightarrow> inj_on h A \<Longrightarrow> finite (h -` F \<inter> A)"
 proof (induct rule: finite_induct)
   case (insert x F)
   then show ?case
     by (simp add: vimage_insert [of h x F] finite_subset [OF inj_on_vimage_singleton] Int_Un_distrib2)
 qed simp
 
 lemma finite_finite_vimage_IntI:
   assumes "finite F"
     and "\<And>y. y \<in> F \<Longrightarrow> finite ((h -` {y}) \<inter> A)"
   shows "finite (h -` F \<inter> A)"
 proof -
   have *: "h -` F \<inter> A = (\<Union> y\<in>F. (h -` {y}) \<inter> A)"
     by blast
   show ?thesis
     by (simp only: * assms finite_UN_I)
 qed
 
 lemma finite_vimageI: "finite F \<Longrightarrow> inj h \<Longrightarrow> finite (h -` F)"
   using finite_vimage_IntI[of F h UNIV] by auto
 
 lemma finite_vimageD': "finite (f -` A) \<Longrightarrow> A \<subseteq> range f \<Longrightarrow> finite A"
   by (auto simp add: subset_image_iff intro: finite_subset[rotated])
 
 lemma finite_vimageD: "finite (h -` F) \<Longrightarrow> surj h \<Longrightarrow> finite F"
   by (auto dest: finite_vimageD')
 
 lemma finite_vimage_iff: "bij h \<Longrightarrow> finite (h -` F) \<longleftrightarrow> finite F"
   unfolding bij_def by (auto elim: finite_vimageD finite_vimageI)
 
 lemma finite_inverse_image_gen:
   assumes "finite A" "inj_on f D"
   shows "finite {j\<in>D. f j \<in> A}"
   using finite_vimage_IntI [OF assms]
   by (simp add: Collect_conj_eq inf_commute vimage_def)
 
 lemma finite_inverse_image:
   assumes "finite A" "inj f"
   shows "finite {j. f j \<in> A}"
   using finite_inverse_image_gen [OF assms] by simp
 
 lemma finite_Collect_bex [simp]:
   assumes "finite A"
   shows "finite {x. \<exists>y\<in>A. Q x y} \<longleftrightarrow> (\<forall>y\<in>A. finite {x. Q x y})"
 proof -
   have "{x. \<exists>y\<in>A. Q x y} = (\<Union>y\<in>A. {x. Q x y})" by auto
   with assms show ?thesis by simp
 qed
 
 lemma finite_Collect_bounded_ex [simp]:
   assumes "finite {y. P y}"
   shows "finite {x. \<exists>y. P y \<and> Q x y} \<longleftrightarrow> (\<forall>y. P y \<longrightarrow> finite {x. Q x y})"
 proof -
   have "{x. \<exists>y. P y \<and> Q x y} = (\<Union>y\<in>{y. P y}. {x. Q x y})"
     by auto
   with assms show ?thesis
     by simp
 qed
 
 lemma finite_Plus: "finite A \<Longrightarrow> finite B \<Longrightarrow> finite (A <+> B)"
   by (simp add: Plus_def)
 
 lemma finite_PlusD:
   fixes A :: "'a set" and B :: "'b set"
   assumes fin: "finite (A <+> B)"
   shows "finite A" "finite B"
 proof -
   have "Inl ` A \<subseteq> A <+> B"
     by auto
   then have "finite (Inl ` A :: ('a + 'b) set)"
     using fin by (rule finite_subset)
   then show "finite A"
     by (rule finite_imageD) (auto intro: inj_onI)
 next
   have "Inr ` B \<subseteq> A <+> B"
     by auto
   then have "finite (Inr ` B :: ('a + 'b) set)"
     using fin by (rule finite_subset)
   then show "finite B"
     by (rule finite_imageD) (auto intro: inj_onI)
 qed
 
 lemma finite_Plus_iff [simp]: "finite (A <+> B) \<longleftrightarrow> finite A \<and> finite B"
   by (auto intro: finite_PlusD finite_Plus)
 
 lemma finite_Plus_UNIV_iff [simp]:
   "finite (UNIV :: ('a + 'b) set) \<longleftrightarrow> finite (UNIV :: 'a set) \<and> finite (UNIV :: 'b set)"
   by (subst UNIV_Plus_UNIV [symmetric]) (rule finite_Plus_iff)
 
 lemma finite_SigmaI [simp, intro]:
   "finite A \<Longrightarrow> (\<And>a. a\<in>A \<Longrightarrow> finite (B a)) \<Longrightarrow> finite (SIGMA a:A. B a)"
   unfolding Sigma_def by blast
 
 lemma finite_SigmaI2:
   assumes "finite {x\<in>A. B x \<noteq> {}}"
   and "\<And>a. a \<in> A \<Longrightarrow> finite (B a)"
   shows "finite (Sigma A B)"
 proof -
   from assms have "finite (Sigma {x\<in>A. B x \<noteq> {}} B)"
     by auto
   also have "Sigma {x:A. B x \<noteq> {}} B = Sigma A B"
     by auto
   finally show ?thesis .
 qed
 
 lemma finite_cartesian_product: "finite A \<Longrightarrow> finite B \<Longrightarrow> finite (A \<times> B)"
   by (rule finite_SigmaI)
 
 lemma finite_Prod_UNIV:
   "finite (UNIV :: 'a set) \<Longrightarrow> finite (UNIV :: 'b set) \<Longrightarrow> finite (UNIV :: ('a \<times> 'b) set)"
   by (simp only: UNIV_Times_UNIV [symmetric] finite_cartesian_product)
 
 lemma finite_cartesian_productD1:
   assumes "finite (A \<times> B)" and "B \<noteq> {}"
   shows "finite A"
 proof -
   from assms obtain n f where "A \<times> B = f ` {i::nat. i < n}"
     by (auto simp add: finite_conv_nat_seg_image)
   then have "fst ` (A \<times> B) = fst ` f ` {i::nat. i < n}"
     by simp
   with \<open>B \<noteq> {}\<close> have "A = (fst \<circ> f) ` {i::nat. i < n}"
     by (simp add: image_comp)
   then have "\<exists>n f. A = f ` {i::nat. i < n}"
     by blast
   then show ?thesis
     by (auto simp add: finite_conv_nat_seg_image)
 qed
 
 lemma finite_cartesian_productD2:
   assumes "finite (A \<times> B)" and "A \<noteq> {}"
   shows "finite B"
 proof -
   from assms obtain n f where "A \<times> B = f ` {i::nat. i < n}"
     by (auto simp add: finite_conv_nat_seg_image)
   then have "snd ` (A \<times> B) = snd ` f ` {i::nat. i < n}"
     by simp
   with \<open>A \<noteq> {}\<close> have "B = (snd \<circ> f) ` {i::nat. i < n}"
     by (simp add: image_comp)
   then have "\<exists>n f. B = f ` {i::nat. i < n}"
     by blast
   then show ?thesis
     by (auto simp add: finite_conv_nat_seg_image)
 qed
 
 lemma finite_cartesian_product_iff:
   "finite (A \<times> B) \<longleftrightarrow> (A = {} \<or> B = {} \<or> (finite A \<and> finite B))"
   by (auto dest: finite_cartesian_productD1 finite_cartesian_productD2 finite_cartesian_product)
 
 lemma finite_prod:
   "finite (UNIV :: ('a \<times> 'b) set) \<longleftrightarrow> finite (UNIV :: 'a set) \<and> finite (UNIV :: 'b set)"
   using finite_cartesian_product_iff[of UNIV UNIV] by simp
 
 lemma finite_Pow_iff [iff]: "finite (Pow A) \<longleftrightarrow> finite A"
 proof
   assume "finite (Pow A)"
   then have "finite ((\<lambda>x. {x}) ` A)"
     by (blast intro: finite_subset)  (* somewhat slow *)
   then show "finite A"
     by (rule finite_imageD [unfolded inj_on_def]) simp
 next
   assume "finite A"
   then show "finite (Pow A)"
     by induct (simp_all add: Pow_insert)
 qed
 
 corollary finite_Collect_subsets [simp, intro]: "finite A \<Longrightarrow> finite {B. B \<subseteq> A}"
   by (simp add: Pow_def [symmetric])
 
 lemma finite_set: "finite (UNIV :: 'a set set) \<longleftrightarrow> finite (UNIV :: 'a set)"
   by (simp only: finite_Pow_iff Pow_UNIV[symmetric])
 
 lemma finite_UnionD: "finite (\<Union>A) \<Longrightarrow> finite A"
   by (blast intro: finite_subset [OF subset_Pow_Union])
 
 lemma finite_bind:
   assumes "finite S"
   assumes "\<forall>x \<in> S. finite (f x)"
   shows "finite (Set.bind S f)"
 using assms by (simp add: bind_UNION)
 
 lemma finite_filter [simp]: "finite S \<Longrightarrow> finite (Set.filter P S)"
 unfolding Set.filter_def by simp
 
 lemma finite_set_of_finite_funs:
   assumes "finite A" "finite B"
   shows "finite {f. \<forall>x. (x \<in> A \<longrightarrow> f x \<in> B) \<and> (x \<notin> A \<longrightarrow> f x = d)}" (is "finite ?S")
 proof -
   let ?F = "\<lambda>f. {(a,b). a \<in> A \<and> b = f a}"
   have "?F ` ?S \<subseteq> Pow(A \<times> B)"
     by auto
   from finite_subset[OF this] assms have 1: "finite (?F ` ?S)"
     by simp
   have 2: "inj_on ?F ?S"
     by (fastforce simp add: inj_on_def set_eq_iff fun_eq_iff)  (* somewhat slow *)
   show ?thesis
     by (rule finite_imageD [OF 1 2])
 qed
 
 lemma not_finite_existsD:
   assumes "\<not> finite {a. P a}"
   shows "\<exists>a. P a"
 proof (rule classical)
   assume "\<not> ?thesis"
   with assms show ?thesis by auto
 qed
 
 lemma finite_converse [iff]: "finite (r\<inverse>) \<longleftrightarrow> finite r"
   unfolding converse_def conversep_iff
   using [[simproc add: finite_Collect]]
   by (auto elim: finite_imageD simp: inj_on_def)
 
 lemma finite_Domain: "finite r \<Longrightarrow> finite (Domain r)"
   by (induct set: finite) auto
 
 lemma finite_Range: "finite r \<Longrightarrow> finite (Range r)"
   by (induct set: finite) auto
 
 lemma finite_Field: "finite r \<Longrightarrow> finite (Field r)"
   by (simp add: Field_def finite_Domain finite_Range)
 
 lemma finite_Image[simp]: "finite R \<Longrightarrow> finite (R `` A)"
   by(rule finite_subset[OF _ finite_Range]) auto
 
 
 subsection \<open>Further induction rules on finite sets\<close>
 
 lemma finite_ne_induct [case_names singleton insert, consumes 2]:
   assumes "finite F" and "F \<noteq> {}"
   assumes "\<And>x. P {x}"
     and "\<And>x F. finite F \<Longrightarrow> F \<noteq> {} \<Longrightarrow> x \<notin> F \<Longrightarrow> P F  \<Longrightarrow> P (insert x F)"
   shows "P F"
   using assms
 proof induct
   case empty
   then show ?case by simp
 next
   case (insert x F)
   then show ?case by cases auto
 qed
 
 lemma finite_subset_induct [consumes 2, case_names empty insert]:
   assumes "finite F" and "F \<subseteq> A"
     and empty: "P {}"
     and insert: "\<And>a F. finite F \<Longrightarrow> a \<in> A \<Longrightarrow> a \<notin> F \<Longrightarrow> P F \<Longrightarrow> P (insert a F)"
   shows "P F"
   using \<open>finite F\<close> \<open>F \<subseteq> A\<close>
 proof induct
   show "P {}" by fact
 next
   fix x F
   assume "finite F" and "x \<notin> F" and P: "F \<subseteq> A \<Longrightarrow> P F" and i: "insert x F \<subseteq> A"
   show "P (insert x F)"
   proof (rule insert)
     from i show "x \<in> A" by blast
     from i have "F \<subseteq> A" by blast
     with P show "P F" .
     show "finite F" by fact
     show "x \<notin> F" by fact
   qed
 qed
 
 lemma finite_empty_induct:
   assumes "finite A"
     and "P A"
     and remove: "\<And>a A. finite A \<Longrightarrow> a \<in> A \<Longrightarrow> P A \<Longrightarrow> P (A - {a})"
   shows "P {}"
 proof -
   have "P (A - B)" if "B \<subseteq> A" for B :: "'a set"
   proof -
     from \<open>finite A\<close> that have "finite B"
       by (rule rev_finite_subset)
     from this \<open>B \<subseteq> A\<close> show "P (A - B)"
     proof induct
       case empty
       from \<open>P A\<close> show ?case by simp
     next
       case (insert b B)
       have "P (A - B - {b})"
       proof (rule remove)
         from \<open>finite A\<close> show "finite (A - B)"
           by induct auto
         from insert show "b \<in> A - B"
           by simp
         from insert show "P (A - B)"
           by simp
       qed
       also have "A - B - {b} = A - insert b B"
         by (rule Diff_insert [symmetric])
       finally show ?case .
     qed
   qed
   then have "P (A - A)" by blast
   then show ?thesis by simp
 qed
 
 lemma finite_update_induct [consumes 1, case_names const update]:
   assumes finite: "finite {a. f a \<noteq> c}"
     and const: "P (\<lambda>a. c)"
     and update: "\<And>a b f. finite {a. f a \<noteq> c} \<Longrightarrow> f a = c \<Longrightarrow> b \<noteq> c \<Longrightarrow> P f \<Longrightarrow> P (f(a := b))"
   shows "P f"
   using finite
 proof (induct "{a. f a \<noteq> c}" arbitrary: f)
   case empty
   with const show ?case by simp
 next
   case (insert a A)
   then have "A = {a'. (f(a := c)) a' \<noteq> c}" and "f a \<noteq> c"
     by auto
   with \<open>finite A\<close> have "finite {a'. (f(a := c)) a' \<noteq> c}"
     by simp
   have "(f(a := c)) a = c"
     by simp
   from insert \<open>A = {a'. (f(a := c)) a' \<noteq> c}\<close> have "P (f(a := c))"
     by simp
   with \<open>finite {a'. (f(a := c)) a' \<noteq> c}\<close> \<open>(f(a := c)) a = c\<close> \<open>f a \<noteq> c\<close>
   have "P ((f(a := c))(a := f a))"
     by (rule update)
   then show ?case by simp
 qed
 
 lemma finite_subset_induct' [consumes 2, case_names empty insert]:
   assumes "finite F" and "F \<subseteq> A"
     and empty: "P {}"
     and insert: "\<And>a F. \<lbrakk>finite F; a \<in> A; F \<subseteq> A; a \<notin> F; P F \<rbrakk> \<Longrightarrow> P (insert a F)"
   shows "P F"
   using assms(1,2)
 proof induct
   show "P {}" by fact
 next
   fix x F
   assume "finite F" and "x \<notin> F" and
     P: "F \<subseteq> A \<Longrightarrow> P F" and i: "insert x F \<subseteq> A"
   show "P (insert x F)"
   proof (rule insert)
     from i show "x \<in> A" by blast
     from i have "F \<subseteq> A" by blast
     with P show "P F" .
     show "finite F" by fact
     show "x \<notin> F" by fact
     show "F \<subseteq> A" by fact
   qed
 qed
 
 
 subsection \<open>Class \<open>finite\<close>\<close>
 
 class finite =
   assumes finite_UNIV: "finite (UNIV :: 'a set)"
 begin
 
 lemma finite [simp]: "finite (A :: 'a set)"
   by (rule subset_UNIV finite_UNIV finite_subset)+
 
 lemma finite_code [code]: "finite (A :: 'a set) \<longleftrightarrow> True"
   by simp
 
 end
 
 instance prod :: (finite, finite) finite
   by standard (simp only: UNIV_Times_UNIV [symmetric] finite_cartesian_product finite)
 
 lemma inj_graph: "inj (\<lambda>f. {(x, y). y = f x})"
   by (rule inj_onI) (auto simp add: set_eq_iff fun_eq_iff)
 
 instance "fun" :: (finite, finite) finite
 proof
   show "finite (UNIV :: ('a \<Rightarrow> 'b) set)"
   proof (rule finite_imageD)
     let ?graph = "\<lambda>f::'a \<Rightarrow> 'b. {(x, y). y = f x}"
     have "range ?graph \<subseteq> Pow UNIV"
       by simp
     moreover have "finite (Pow (UNIV :: ('a * 'b) set))"
       by (simp only: finite_Pow_iff finite)
     ultimately show "finite (range ?graph)"
       by (rule finite_subset)
     show "inj ?graph"
       by (rule inj_graph)
   qed
 qed
 
 instance bool :: finite
   by standard (simp add: UNIV_bool)
 
 instance set :: (finite) finite
   by standard (simp only: Pow_UNIV [symmetric] finite_Pow_iff finite)
 
 instance unit :: finite
   by standard (simp add: UNIV_unit)
 
 instance sum :: (finite, finite) finite
   by standard (simp only: UNIV_Plus_UNIV [symmetric] finite_Plus finite)
 
 
 subsection \<open>A basic fold functional for finite sets\<close>
 
 text \<open>
   The intended behaviour is \<open>fold f z {x\<^sub>1, \<dots>, x\<^sub>n} = f x\<^sub>1 (\<dots> (f x\<^sub>n z)\<dots>)\<close>
   if \<open>f\<close> is ``left-commutative''.
   The commutativity requirement is relativised to the carrier set \<open>S\<close>:
 \<close>
 
 locale comp_fun_commute_on =
   fixes S :: "'a set"
   fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b"
   assumes comp_fun_commute_on: "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> f y \<circ> f x = f x \<circ> f y"
 begin
 
 lemma fun_left_comm: "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> f y (f x z) = f x (f y z)"
   using comp_fun_commute_on by (simp add: fun_eq_iff)
 
 lemma commute_left_comp: "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> f y \<circ> (f x \<circ> g) = f x \<circ> (f y \<circ> g)"
   by (simp add: o_assoc comp_fun_commute_on)
 
 end
 
 inductive fold_graph :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> bool"
   for f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b" and z :: 'b
   where
     emptyI [intro]: "fold_graph f z {} z"
   | insertI [intro]: "x \<notin> A \<Longrightarrow> fold_graph f z A y \<Longrightarrow> fold_graph f z (insert x A) (f x y)"
 
 inductive_cases empty_fold_graphE [elim!]: "fold_graph f z {} x"
 
 lemma fold_graph_closed_lemma:
   "fold_graph f z A x \<and> x \<in> B"
   if "fold_graph g z A x"
     "\<And>a b. a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> f a b = g a b"
     "\<And>a b. a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> g a b \<in> B"
     "z \<in> B"
   using that(1-3)
 proof (induction rule: fold_graph.induct)
   case (insertI x A y)
   have "fold_graph f z A y" "y \<in> B"
     unfolding atomize_conj
     by (rule insertI.IH) (auto intro: insertI.prems)
   then have "g x y \<in> B" and f_eq: "f x y = g x y"
     by (auto simp: insertI.prems)
   moreover have "fold_graph f z (insert x A) (f x y)"
     by (rule fold_graph.insertI; fact)
   ultimately
   show ?case
     by (simp add: f_eq)
 qed (auto intro!: that)
 
 lemma fold_graph_closed_eq:
   "fold_graph f z A = fold_graph g z A"
   if "\<And>a b. a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> f a b = g a b"
      "\<And>a b. a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> g a b \<in> B"
      "z \<in> B"
   using fold_graph_closed_lemma[of f z A _ B g] fold_graph_closed_lemma[of g z A _ B f] that
   by auto
 
 definition fold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a set \<Rightarrow> 'b"
   where "fold f z A = (if finite A then (THE y. fold_graph f z A y) else z)"
 
 lemma fold_closed_eq: "fold f z A = fold g z A"
   if "\<And>a b. a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> f a b = g a b"
      "\<And>a b. a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> g a b \<in> B"
      "z \<in> B"
   unfolding Finite_Set.fold_def
   by (subst fold_graph_closed_eq[where B=B and g=g]) (auto simp: that)
 
 text \<open>
   A tempting alternative for the definition is
   \<^term>\<open>if finite A then THE y. fold_graph f z A y else e\<close>.
   It allows the removal of finiteness assumptions from the theorems
   \<open>fold_comm\<close>, \<open>fold_reindex\<close> and \<open>fold_distrib\<close>.
   The proofs become ugly. It is not worth the effort. (???)
 \<close>
 
 lemma finite_imp_fold_graph: "finite A \<Longrightarrow> \<exists>x. fold_graph f z A x"
   by (induct rule: finite_induct) auto
 
 
 subsubsection \<open>From \<^const>\<open>fold_graph\<close> to \<^term>\<open>fold\<close>\<close>
 
 context comp_fun_commute_on
 begin
 
 lemma fold_graph_finite:
   assumes "fold_graph f z A y"
   shows "finite A"
   using assms by induct simp_all
 
 lemma fold_graph_insertE_aux:
   assumes "A \<subseteq> S"
   assumes "fold_graph f z A y" "a \<in> A"
   shows "\<exists>y'. y = f a y' \<and> fold_graph f z (A - {a}) y'"
   using assms(2-,1)
 proof (induct set: fold_graph)
   case emptyI
   then show ?case by simp
 next
   case (insertI x A y)
   show ?case
   proof (cases "x = a")
     case True
     with insertI show ?thesis by auto
   next
     case False
     then obtain y' where y: "y = f a y'" and y': "fold_graph f z (A - {a}) y'"
       using insertI by auto
     from insertI have "x \<in> S" "a \<in> S" by auto
     then have "f x y = f a (f x y')"
       unfolding y by (intro fun_left_comm; simp)
     moreover have "fold_graph f z (insert x A - {a}) (f x y')"
       using y' and \<open>x \<noteq> a\<close> and \<open>x \<notin> A\<close>
       by (simp add: insert_Diff_if fold_graph.insertI)
     ultimately show ?thesis
       by fast
   qed
 qed
 
 lemma fold_graph_insertE:
   assumes "insert x A \<subseteq> S"
   assumes "fold_graph f z (insert x A) v" and "x \<notin> A"
   obtains y where "v = f x y" and "fold_graph f z A y"
   using assms by (auto dest: fold_graph_insertE_aux[OF \<open>insert x A \<subseteq> S\<close> _ insertI1])
 
 lemma fold_graph_determ:
   assumes "A \<subseteq> S"
   assumes "fold_graph f z A x" "fold_graph f z A y"
   shows "y = x"
   using assms(2-,1)
 proof (induct arbitrary: y set: fold_graph)
   case emptyI
   then show ?case by fast
 next
   case (insertI x A y v)
   from \<open>insert x A \<subseteq> S\<close> and \<open>fold_graph f z (insert x A) v\<close> and \<open>x \<notin> A\<close>
   obtain y' where "v = f x y'" and "fold_graph f z A y'"
     by (rule fold_graph_insertE)
   from \<open>fold_graph f z A y'\<close> insertI have "y' = y"
     by simp
   with \<open>v = f x y'\<close> show "v = f x y"
     by simp
 qed
 
 lemma fold_equality: "A \<subseteq> S \<Longrightarrow> fold_graph f z A y \<Longrightarrow> fold f z A = y"
   by (cases "finite A") (auto simp add: fold_def intro: fold_graph_determ dest: fold_graph_finite)
 
 lemma fold_graph_fold:
   assumes "A \<subseteq> S"
   assumes "finite A"
   shows "fold_graph f z A (fold f z A)"
 proof -
   from \<open>finite A\<close> have "\<exists>x. fold_graph f z A x"
     by (rule finite_imp_fold_graph)
   moreover note fold_graph_determ[OF \<open>A \<subseteq> S\<close>]
   ultimately have "\<exists>!x. fold_graph f z A x"
     by (rule ex_ex1I)
   then have "fold_graph f z A (The (fold_graph f z A))"
     by (rule theI')
   with assms show ?thesis
     by (simp add: fold_def)
 qed
 
 text \<open>The base case for \<open>fold\<close>:\<close>
 
 lemma (in -) fold_infinite [simp]: "\<not> finite A \<Longrightarrow> fold f z A = z"
   by (auto simp: fold_def)
 
 lemma (in -) fold_empty [simp]: "fold f z {} = z"
   by (auto simp: fold_def)
 
 text \<open>The various recursion equations for \<^const>\<open>fold\<close>:\<close>
 
 lemma fold_insert [simp]:
   assumes "insert x A \<subseteq> S"
   assumes "finite A" and "x \<notin> A"
   shows "fold f z (insert x A) = f x (fold f z A)"
 proof (rule fold_equality[OF \<open>insert x A \<subseteq> S\<close>])
   fix z
   from \<open>insert x A \<subseteq> S\<close> \<open>finite A\<close> have "fold_graph f z A (fold f z A)"
     by (blast intro: fold_graph_fold)
   with \<open>x \<notin> A\<close> have "fold_graph f z (insert x A) (f x (fold f z A))"
     by (rule fold_graph.insertI)
   then show "fold_graph f z (insert x A) (f x (fold f z A))"
     by simp
 qed
 
 declare (in -) empty_fold_graphE [rule del] fold_graph.intros [rule del]
   \<comment> \<open>No more proofs involve these.\<close>
 
 lemma fold_fun_left_comm:
   assumes "insert x A \<subseteq> S" "finite A" 
   shows "f x (fold f z A) = fold f (f x z) A"
   using assms(2,1)
 proof (induct rule: finite_induct)
   case empty
   then show ?case by simp
 next
   case (insert y F)
   then have "fold f (f x z) (insert y F) = f y (fold f (f x z) F)"
     by simp
   also have "\<dots> = f x (f y (fold f z F))"
     using insert by (simp add: fun_left_comm[where ?y=x])
   also have "\<dots> = f x (fold f z (insert y F))"
   proof -
     from insert have "insert y F \<subseteq> S" by simp
     from fold_insert[OF this] insert show ?thesis by simp
   qed
   finally show ?case ..
 qed
 
 lemma fold_insert2:
   "insert x A \<subseteq> S \<Longrightarrow> finite A \<Longrightarrow> x \<notin> A \<Longrightarrow> fold f z (insert x A)  = fold f (f x z) A"
   by (simp add: fold_fun_left_comm)
 
 lemma fold_rec:
   assumes "A \<subseteq> S"
   assumes "finite A" and "x \<in> A"
   shows "fold f z A = f x (fold f z (A - {x}))"
 proof -
   have A: "A = insert x (A - {x})"
     using \<open>x \<in> A\<close> by blast
   then have "fold f z A = fold f z (insert x (A - {x}))"
     by simp
   also have "\<dots> = f x (fold f z (A - {x}))"
     by (rule fold_insert) (use assms in \<open>auto\<close>)
   finally show ?thesis .
 qed
 
 lemma fold_insert_remove:
   assumes "insert x A \<subseteq> S"
   assumes "finite A"
   shows "fold f z (insert x A) = f x (fold f z (A - {x}))"
 proof -
   from \<open>finite A\<close> have "finite (insert x A)"
     by auto
   moreover have "x \<in> insert x A"
     by auto
   ultimately have "fold f z (insert x A) = f x (fold f z (insert x A - {x}))"
     using \<open>insert x A \<subseteq> S\<close> by (blast intro: fold_rec)
   then show ?thesis
     by simp
 qed
 
 lemma fold_set_union_disj:
   assumes "A \<subseteq> S" "B \<subseteq> S"
   assumes "finite A" "finite B" "A \<inter> B = {}"
   shows "Finite_Set.fold f z (A \<union> B) = Finite_Set.fold f (Finite_Set.fold f z A) B"
   using \<open>finite B\<close> assms(1,2,3,5)
 proof induct
   case (insert x F)
   have "fold f z (A \<union> insert x F) = f x (fold f (fold f z A) F)"
     using insert by auto
   also have "\<dots> = fold f (fold f z A) (insert x F)"
     using insert by (blast intro: fold_insert[symmetric])
   finally show ?case .
 qed simp
 
 
 end
 
 text \<open>Other properties of \<^const>\<open>fold\<close>:\<close>
 
 lemma fold_graph_image:
   assumes "inj_on g A"
   shows "fold_graph f z (g ` A) = fold_graph (f \<circ> g) z A"
 proof
   fix w
   show "fold_graph f z (g ` A) w = fold_graph (f o g) z A w"
   proof
     assume "fold_graph f z (g ` A) w"
     then show "fold_graph (f \<circ> g) z A w"
       using assms
     proof (induct "g ` A" w arbitrary: A)
       case emptyI
       then show ?case by (auto intro: fold_graph.emptyI)
     next
       case (insertI x A r B)
       from \<open>inj_on g B\<close> \<open>x \<notin> A\<close> \<open>insert x A = image g B\<close> obtain x' A'
         where "x' \<notin> A'" and [simp]: "B = insert x' A'" "x = g x'" "A = g ` A'"
         by (rule inj_img_insertE)
       from insertI.prems have "fold_graph (f \<circ> g) z A' r"
         by (auto intro: insertI.hyps)
       with \<open>x' \<notin> A'\<close> have "fold_graph (f \<circ> g) z (insert x' A') ((f \<circ> g) x' r)"
         by (rule fold_graph.insertI)
       then show ?case
         by simp
     qed
   next
     assume "fold_graph (f \<circ> g) z A w"
     then show "fold_graph f z (g ` A) w"
       using assms
     proof induct
       case emptyI
       then show ?case
         by (auto intro: fold_graph.emptyI)
     next
       case (insertI x A r)
       from \<open>x \<notin> A\<close> insertI.prems have "g x \<notin> g ` A"
         by auto
       moreover from insertI have "fold_graph f z (g ` A) r"
         by simp
       ultimately have "fold_graph f z (insert (g x) (g ` A)) (f (g x) r)"
         by (rule fold_graph.insertI)
       then show ?case
         by simp
     qed
   qed
 qed
 
 lemma fold_image:
   assumes "inj_on g A"
   shows "fold f z (g ` A) = fold (f \<circ> g) z A"
 proof (cases "finite A")
   case False
   with assms show ?thesis
     by (auto dest: finite_imageD simp add: fold_def)
 next
   case True
   then show ?thesis
     by (auto simp add: fold_def fold_graph_image[OF assms])
 qed
 
 lemma fold_cong:
   assumes "comp_fun_commute_on S f" "comp_fun_commute_on S g"
     and "A \<subseteq> S" "finite A"
     and cong: "\<And>x. x \<in> A \<Longrightarrow> f x = g x"
     and "s = t" and "A = B"
   shows "fold f s A = fold g t B"
 proof -
   have "fold f s A = fold g s A"
     using \<open>finite A\<close> \<open>A \<subseteq> S\<close> cong
   proof (induct A)
     case empty
     then show ?case by simp
   next
     case insert
     interpret f: comp_fun_commute_on S f by (fact \<open>comp_fun_commute_on S f\<close>)
     interpret g: comp_fun_commute_on S g by (fact \<open>comp_fun_commute_on S g\<close>)
     from insert show ?case by simp
   qed
   with assms show ?thesis by simp
 qed
 
 
 text \<open>A simplified version for idempotent functions:\<close>
 
 locale comp_fun_idem_on = comp_fun_commute_on +
   assumes comp_fun_idem_on: "x \<in> S \<Longrightarrow> f x \<circ> f x = f x"
 begin
 
 lemma fun_left_idem: "x \<in> S \<Longrightarrow> f x (f x z) = f x z"
   using comp_fun_idem_on by (simp add: fun_eq_iff)
 
 lemma fold_insert_idem:
   assumes "insert x A \<subseteq> S"
   assumes fin: "finite A"
   shows "fold f z (insert x A)  = f x (fold f z A)"
 proof cases
   assume "x \<in> A"
   then obtain B where "A = insert x B" and "x \<notin> B"
     by (rule set_insert)
   then show ?thesis
     using assms by (simp add: comp_fun_idem_on fun_left_idem)
 next
   assume "x \<notin> A"
   then show ?thesis
     using assms by auto
 qed
 
 declare fold_insert [simp del] fold_insert_idem [simp]
 
 lemma fold_insert_idem2: "insert x A \<subseteq> S \<Longrightarrow> finite A \<Longrightarrow> fold f z (insert x A) = fold f (f x z) A"
   by (simp add: fold_fun_left_comm)
 
 end
 
 
 subsubsection \<open>Liftings to \<open>comp_fun_commute_on\<close> etc.\<close>
                    
 lemma (in comp_fun_commute_on) comp_comp_fun_commute_on:
   "range g \<subseteq> S \<Longrightarrow> comp_fun_commute_on R (f \<circ> g)"
   by standard (force intro: comp_fun_commute_on)
 
 lemma (in comp_fun_idem_on) comp_comp_fun_idem_on:
   assumes "range g \<subseteq> S"
   shows "comp_fun_idem_on R (f \<circ> g)"
 proof
   interpret f_g: comp_fun_commute_on R "f o g"
     by (fact comp_comp_fun_commute_on[OF \<open>range g \<subseteq> S\<close>])
   show "x \<in> R \<Longrightarrow> y \<in> R \<Longrightarrow> (f \<circ> g) y \<circ> (f \<circ> g) x = (f \<circ> g) x \<circ> (f \<circ> g) y" for x y
     by (fact f_g.comp_fun_commute_on)
 qed (use \<open>range g \<subseteq> S\<close> in \<open>force intro: comp_fun_idem_on\<close>)
 
 lemma (in comp_fun_commute_on) comp_fun_commute_on_funpow:
   "comp_fun_commute_on S (\<lambda>x. f x ^^ g x)"
 proof
   fix x y assume "x \<in> S" "y \<in> S"
   show "f y ^^ g y \<circ> f x ^^ g x = f x ^^ g x \<circ> f y ^^ g y"
   proof (cases "x = y")
     case True
     then show ?thesis by simp
   next
     case False
     show ?thesis
     proof (induct "g x" arbitrary: g)
       case 0
       then show ?case by simp
     next
       case (Suc n g)
       have hyp1: "f y ^^ g y \<circ> f x = f x \<circ> f y ^^ g y"
       proof (induct "g y" arbitrary: g)
         case 0
         then show ?case by simp
       next
         case (Suc n g)
         define h where "h z = g z - 1" for z
         with Suc have "n = h y"
           by simp
         with Suc have hyp: "f y ^^ h y \<circ> f x = f x \<circ> f y ^^ h y"
           by auto
         from Suc h_def have "g y = Suc (h y)"
           by simp
         with \<open>x \<in> S\<close> \<open>y \<in> S\<close> show ?case
           by (simp add: comp_assoc hyp) (simp add: o_assoc comp_fun_commute_on)
       qed
       define h where "h z = (if z = x then g x - 1 else g z)" for z
       with Suc have "n = h x"
         by simp
       with Suc have "f y ^^ h y \<circ> f x ^^ h x = f x ^^ h x \<circ> f y ^^ h y"
         by auto
       with False h_def have hyp2: "f y ^^ g y \<circ> f x ^^ h x = f x ^^ h x \<circ> f y ^^ g y"
         by simp
       from Suc h_def have "g x = Suc (h x)"
         by simp
       then show ?case
         by (simp del: funpow.simps add: funpow_Suc_right o_assoc hyp2) (simp add: comp_assoc hyp1)
     qed
   qed
 qed
 
 
 subsubsection \<open>\<^term>\<open>UNIV\<close> as carrier set\<close>
 
 locale comp_fun_commute =
   fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b"
   assumes comp_fun_commute: "f y \<circ> f x = f x \<circ> f y"
 begin
 
 lemma (in -) comp_fun_commute_def': "comp_fun_commute f = comp_fun_commute_on UNIV f"
   unfolding comp_fun_commute_def comp_fun_commute_on_def by blast
 
 text \<open>
   We abuse the \<open>rewrites\<close> functionality of locales to remove trivial assumptions that
   result from instantiating the carrier set to \<^term>\<open>UNIV\<close>.
 \<close>
 sublocale comp_fun_commute_on UNIV f
   rewrites "\<And>X. (X \<subseteq> UNIV) \<equiv> True"
        and "\<And>x. x \<in> UNIV \<equiv> True"
        and "\<And>P. (True \<Longrightarrow> P) \<equiv> Trueprop P"
        and "\<And>P Q. (True \<Longrightarrow> PROP P \<Longrightarrow> PROP Q) \<equiv> (PROP P \<Longrightarrow> True \<Longrightarrow> PROP Q)"
 proof -
   show "comp_fun_commute_on UNIV f"
     by standard  (simp add: comp_fun_commute)
 qed simp_all
 
 end
 
 lemma (in comp_fun_commute) comp_comp_fun_commute: "comp_fun_commute (f o g)"
   unfolding comp_fun_commute_def' by (fact comp_comp_fun_commute_on)
 
 lemma (in comp_fun_commute) comp_fun_commute_funpow: "comp_fun_commute (\<lambda>x. f x ^^ g x)"
   unfolding comp_fun_commute_def' by (fact comp_fun_commute_on_funpow)
 
 locale comp_fun_idem = comp_fun_commute +
   assumes comp_fun_idem: "f x o f x = f x"
 begin
 
 lemma (in -) comp_fun_idem_def': "comp_fun_idem f = comp_fun_idem_on UNIV f"
   unfolding comp_fun_idem_on_def comp_fun_idem_def comp_fun_commute_def'
   unfolding comp_fun_idem_axioms_def comp_fun_idem_on_axioms_def
   by blast
 
 text \<open>
   Again, we abuse the \<open>rewrites\<close> functionality of locales to remove trivial assumptions that
   result from instantiating the carrier set to \<^term>\<open>UNIV\<close>.
 \<close>
 sublocale comp_fun_idem_on UNIV f
   rewrites "\<And>X. (X \<subseteq> UNIV) \<equiv> True"
        and "\<And>x. x \<in> UNIV \<equiv> True"
        and "\<And>P. (True \<Longrightarrow> P) \<equiv> Trueprop P"
        and "\<And>P Q. (True \<Longrightarrow> PROP P \<Longrightarrow> PROP Q) \<equiv> (PROP P \<Longrightarrow> True \<Longrightarrow> PROP Q)"
 proof -
   show "comp_fun_idem_on UNIV f"
     by standard (simp_all add: comp_fun_idem comp_fun_commute)
 qed simp_all
 
 end
 
 lemma (in comp_fun_idem) comp_comp_fun_idem: "comp_fun_idem (f o g)"
   unfolding comp_fun_idem_def' by (fact comp_comp_fun_idem_on)
 
 
 subsubsection \<open>Expressing set operations via \<^const>\<open>fold\<close>\<close>
 
 lemma comp_fun_commute_const: "comp_fun_commute (\<lambda>_. f)"
   by standard (rule refl)
 
 lemma comp_fun_idem_insert: "comp_fun_idem insert"
   by standard auto
 
 lemma comp_fun_idem_remove: "comp_fun_idem Set.remove"
   by standard auto
 
 lemma (in semilattice_inf) comp_fun_idem_inf: "comp_fun_idem inf"
   by standard (auto simp add: inf_left_commute)
 
 lemma (in semilattice_sup) comp_fun_idem_sup: "comp_fun_idem sup"
   by standard (auto simp add: sup_left_commute)
 
 lemma union_fold_insert:
   assumes "finite A"
   shows "A \<union> B = fold insert B A"
 proof -
   interpret comp_fun_idem insert
     by (fact comp_fun_idem_insert)
   from \<open>finite A\<close> show ?thesis
     by (induct A arbitrary: B) simp_all
 qed
 
 lemma minus_fold_remove:
   assumes "finite A"
   shows "B - A = fold Set.remove B A"
 proof -
   interpret comp_fun_idem Set.remove
     by (fact comp_fun_idem_remove)
   from \<open>finite A\<close> have "fold Set.remove B A = B - A"
     by (induct A arbitrary: B) auto  (* slow *)
   then show ?thesis ..
 qed
 
 lemma comp_fun_commute_filter_fold:
   "comp_fun_commute (\<lambda>x A'. if P x then Set.insert x A' else A')"
 proof -
   interpret comp_fun_idem Set.insert by (fact comp_fun_idem_insert)
   show ?thesis by standard (auto simp: fun_eq_iff)
 qed
 
 lemma Set_filter_fold:
   assumes "finite A"
   shows "Set.filter P A = fold (\<lambda>x A'. if P x then Set.insert x A' else A') {} A"
   using assms
 proof -
   interpret commute_insert: comp_fun_commute "(\<lambda>x A'. if P x then Set.insert x A' else A')"
     by (fact comp_fun_commute_filter_fold)
   from \<open>finite A\<close> show ?thesis
     by induct (auto simp add: Set.filter_def)
 qed
 
 lemma inter_Set_filter:
   assumes "finite B"
   shows "A \<inter> B = Set.filter (\<lambda>x. x \<in> A) B"
   using assms
   by induct (auto simp: Set.filter_def)
 
 lemma image_fold_insert:
   assumes "finite A"
   shows "image f A = fold (\<lambda>k A. Set.insert (f k) A) {} A"
 proof -
   interpret comp_fun_commute "\<lambda>k A. Set.insert (f k) A"
     by standard auto
   show ?thesis
     using assms by (induct A) auto
 qed
 
 lemma Ball_fold:
   assumes "finite A"
   shows "Ball A P = fold (\<lambda>k s. s \<and> P k) True A"
 proof -
   interpret comp_fun_commute "\<lambda>k s. s \<and> P k"
     by standard auto
   show ?thesis
     using assms by (induct A) auto
 qed
 
 lemma Bex_fold:
   assumes "finite A"
   shows "Bex A P = fold (\<lambda>k s. s \<or> P k) False A"
 proof -
   interpret comp_fun_commute "\<lambda>k s. s \<or> P k"
     by standard auto
   show ?thesis
     using assms by (induct A) auto
 qed
 
 lemma comp_fun_commute_Pow_fold: "comp_fun_commute (\<lambda>x A. A \<union> Set.insert x ` A)"
   by (clarsimp simp: fun_eq_iff comp_fun_commute_def) blast
 
 lemma Pow_fold:
   assumes "finite A"
   shows "Pow A = fold (\<lambda>x A. A \<union> Set.insert x ` A) {{}} A"
 proof -
   interpret comp_fun_commute "\<lambda>x A. A \<union> Set.insert x ` A"
     by (rule comp_fun_commute_Pow_fold)
   show ?thesis
     using assms by (induct A) (auto simp: Pow_insert)
 qed
 
 lemma fold_union_pair:
   assumes "finite B"
   shows "(\<Union>y\<in>B. {(x, y)}) \<union> A = fold (\<lambda>y. Set.insert (x, y)) A B"
 proof -
   interpret comp_fun_commute "\<lambda>y. Set.insert (x, y)"
     by standard auto
   show ?thesis
     using assms by (induct arbitrary: A) simp_all
 qed
 
 lemma comp_fun_commute_product_fold:
   "finite B \<Longrightarrow> comp_fun_commute (\<lambda>x z. fold (\<lambda>y. Set.insert (x, y)) z B)"
   by standard (auto simp: fold_union_pair [symmetric])
 
 lemma product_fold:
   assumes "finite A" "finite B"
   shows "A \<times> B = fold (\<lambda>x z. fold (\<lambda>y. Set.insert (x, y)) z B) {} A"
 proof -
   interpret commute_product: comp_fun_commute "(\<lambda>x z. fold (\<lambda>y. Set.insert (x, y)) z B)"
     by (fact comp_fun_commute_product_fold[OF \<open>finite B\<close>])
   from assms show ?thesis unfolding Sigma_def
     by (induct A) (simp_all add: fold_union_pair)
 qed
 
 context complete_lattice
 begin
 
 lemma inf_Inf_fold_inf:
   assumes "finite A"
   shows "inf (Inf A) B = fold inf B A"
 proof -
   interpret comp_fun_idem inf
     by (fact comp_fun_idem_inf)
   from \<open>finite A\<close> fold_fun_left_comm show ?thesis
     by (induct A arbitrary: B) (simp_all add: inf_commute fun_eq_iff)
 qed
 
 lemma sup_Sup_fold_sup:
   assumes "finite A"
   shows "sup (Sup A) B = fold sup B A"
 proof -
   interpret comp_fun_idem sup
     by (fact comp_fun_idem_sup)
   from \<open>finite A\<close> fold_fun_left_comm show ?thesis
     by (induct A arbitrary: B) (simp_all add: sup_commute fun_eq_iff)
 qed
 
 lemma Inf_fold_inf: "finite A \<Longrightarrow> Inf A = fold inf top A"
   using inf_Inf_fold_inf [of A top] by (simp add: inf_absorb2)
 
 lemma Sup_fold_sup: "finite A \<Longrightarrow> Sup A = fold sup bot A"
   using sup_Sup_fold_sup [of A bot] by (simp add: sup_absorb2)
 
 lemma inf_INF_fold_inf:
   assumes "finite A"
   shows "inf B (\<Sqinter>(f ` A)) = fold (inf \<circ> f) B A" (is "?inf = ?fold")
 proof -
   interpret comp_fun_idem inf by (fact comp_fun_idem_inf)
   interpret comp_fun_idem "inf \<circ> f" by (fact comp_comp_fun_idem)
   from \<open>finite A\<close> have "?fold = ?inf"
     by (induct A arbitrary: B) (simp_all add: inf_left_commute)
   then show ?thesis ..
 qed
 
 lemma sup_SUP_fold_sup:
   assumes "finite A"
   shows "sup B (\<Squnion>(f ` A)) = fold (sup \<circ> f) B A" (is "?sup = ?fold")
 proof -
   interpret comp_fun_idem sup by (fact comp_fun_idem_sup)
   interpret comp_fun_idem "sup \<circ> f" by (fact comp_comp_fun_idem)
   from \<open>finite A\<close> have "?fold = ?sup"
     by (induct A arbitrary: B) (simp_all add: sup_left_commute)
   then show ?thesis ..
 qed
 
 lemma INF_fold_inf: "finite A \<Longrightarrow> \<Sqinter>(f ` A) = fold (inf \<circ> f) top A"
   using inf_INF_fold_inf [of A top] by simp
 
 lemma SUP_fold_sup: "finite A \<Longrightarrow> \<Squnion>(f ` A) = fold (sup \<circ> f) bot A"
   using sup_SUP_fold_sup [of A bot] by simp
 
 lemma finite_Inf_in:
   assumes "finite A" "A\<noteq>{}" and inf: "\<And>x y. \<lbrakk>x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> inf x y \<in> A"
   shows "Inf A \<in> A"
 proof -
   have "Inf B \<in> A" if "B \<le> A" "B\<noteq>{}" for B
     using finite_subset [OF \<open>B \<subseteq> A\<close> \<open>finite A\<close>] that
   by (induction B) (use inf in \<open>force+\<close>)
   then show ?thesis
     by (simp add: assms)
 qed
 
 lemma finite_Sup_in:
   assumes "finite A" "A\<noteq>{}" and sup: "\<And>x y. \<lbrakk>x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> sup x y \<in> A"
   shows "Sup A \<in> A"
 proof -
   have "Sup B \<in> A" if "B \<le> A" "B\<noteq>{}" for B
     using finite_subset [OF \<open>B \<subseteq> A\<close> \<open>finite A\<close>] that
   by (induction B) (use sup in \<open>force+\<close>)
   then show ?thesis
     by (simp add: assms)
 qed
 
 end
 
 subsubsection \<open>Expressing relation operations via \<^const>\<open>fold\<close>\<close>
 
 lemma Id_on_fold:
   assumes "finite A"
   shows "Id_on A = Finite_Set.fold (\<lambda>x. Set.insert (Pair x x)) {} A"
 proof -
   interpret comp_fun_commute "\<lambda>x. Set.insert (Pair x x)"
     by standard auto
   from assms show ?thesis
     unfolding Id_on_def by (induct A) simp_all
 qed
 
 lemma comp_fun_commute_Image_fold:
   "comp_fun_commute (\<lambda>(x,y) A. if x \<in> S then Set.insert y A else A)"
 proof -
   interpret comp_fun_idem Set.insert
     by (fact comp_fun_idem_insert)
   show ?thesis
     by standard (auto simp: fun_eq_iff comp_fun_commute split: prod.split)
 qed
 
 lemma Image_fold:
   assumes "finite R"
   shows "R `` S = Finite_Set.fold (\<lambda>(x,y) A. if x \<in> S then Set.insert y A else A) {} R"
 proof -
   interpret comp_fun_commute "(\<lambda>(x,y) A. if x \<in> S then Set.insert y A else A)"
     by (rule comp_fun_commute_Image_fold)
   have *: "\<And>x F. Set.insert x F `` S = (if fst x \<in> S then Set.insert (snd x) (F `` S) else (F `` S))"
     by (force intro: rev_ImageI)
   show ?thesis
     using assms by (induct R) (auto simp: * )
 qed
 
 lemma insert_relcomp_union_fold:
   assumes "finite S"
   shows "{x} O S \<union> X = Finite_Set.fold (\<lambda>(w,z) A'. if snd x = w then Set.insert (fst x,z) A' else A') X S"
 proof -
   interpret comp_fun_commute "\<lambda>(w,z) A'. if snd x = w then Set.insert (fst x,z) A' else A'"
   proof -
     interpret comp_fun_idem Set.insert
       by (fact comp_fun_idem_insert)
     show "comp_fun_commute (\<lambda>(w,z) A'. if snd x = w then Set.insert (fst x,z) A' else A')"
       by standard (auto simp add: fun_eq_iff split: prod.split)
   qed
   have *: "{x} O S = {(x', z). x' = fst x \<and> (snd x, z) \<in> S}"
     by (auto simp: relcomp_unfold intro!: exI)
   show ?thesis
     unfolding * using \<open>finite S\<close> by (induct S) (auto split: prod.split)
 qed
 
 lemma insert_relcomp_fold:
   assumes "finite S"
   shows "Set.insert x R O S =
     Finite_Set.fold (\<lambda>(w,z) A'. if snd x = w then Set.insert (fst x,z) A' else A') (R O S) S"
 proof -
   have "Set.insert x R O S = ({x} O S) \<union> (R O S)"
     by auto
   then show ?thesis
     by (auto simp: insert_relcomp_union_fold [OF assms])
 qed
 
 lemma comp_fun_commute_relcomp_fold:
   assumes "finite S"
   shows "comp_fun_commute (\<lambda>(x,y) A.
     Finite_Set.fold (\<lambda>(w,z) A'. if y = w then Set.insert (x,z) A' else A') A S)"
 proof -
   have *: "\<And>a b A.
     Finite_Set.fold (\<lambda>(w, z) A'. if b = w then Set.insert (a, z) A' else A') A S = {(a,b)} O S \<union> A"
     by (auto simp: insert_relcomp_union_fold[OF assms] cong: if_cong)
   show ?thesis
     by standard (auto simp: * )
 qed
 
 lemma relcomp_fold:
   assumes "finite R" "finite S"
   shows "R O S = Finite_Set.fold
     (\<lambda>(x,y) A. Finite_Set.fold (\<lambda>(w,z) A'. if y = w then Set.insert (x,z) A' else A') A S) {} R"
 proof -
   interpret commute_relcomp_fold: comp_fun_commute
     "(\<lambda>(x, y) A. Finite_Set.fold (\<lambda>(w, z) A'. if y = w then insert (x, z) A' else A') A S)"
     by (fact comp_fun_commute_relcomp_fold[OF \<open>finite S\<close>])
   from assms show ?thesis
     by (induct R) (auto simp: comp_fun_commute_relcomp_fold insert_relcomp_fold cong: if_cong)
 qed
 
 
 subsection \<open>Locales as mini-packages for fold operations\<close>
 
 subsubsection \<open>The natural case\<close>
 
 locale folding_on =
   fixes S :: "'a set"
   fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b" and z :: "'b"
   assumes comp_fun_commute_on: "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> f y o f x = f x o f y"
 begin
 
 interpretation fold?: comp_fun_commute_on S f
   by standard (simp add: comp_fun_commute_on)
 
 definition F :: "'a set \<Rightarrow> 'b"
   where eq_fold: "F A = Finite_Set.fold f z A"
 
 lemma empty [simp]: "F {} = z"
   by (simp add: eq_fold)
 
 lemma infinite [simp]: "\<not> finite A \<Longrightarrow> F A = z"
   by (simp add: eq_fold)
 
 lemma insert [simp]:
   assumes "insert x A \<subseteq> S" and "finite A" and "x \<notin> A"
   shows "F (insert x A) = f x (F A)"
 proof -
   from fold_insert assms
   have "Finite_Set.fold f z (insert x A) 
       = f x (Finite_Set.fold f z A)"
     by simp
   with \<open>finite A\<close> show ?thesis by (simp add: eq_fold fun_eq_iff)
 qed
 
 lemma remove:
   assumes "A \<subseteq> S" and "finite A" and "x \<in> A"
   shows "F A = f x (F (A - {x}))"
 proof -
   from \<open>x \<in> A\<close> obtain B where A: "A = insert x B" and "x \<notin> B"
     by (auto dest: mk_disjoint_insert)
   moreover from \<open>finite A\<close> A have "finite B" by simp
   ultimately show ?thesis
     using \<open>A \<subseteq> S\<close> by auto
 qed
 
 lemma insert_remove:
   assumes "insert x A \<subseteq> S" and "finite A"
   shows "F (insert x A) = f x (F (A - {x}))"
   using assms by (cases "x \<in> A") (simp_all add: remove insert_absorb)
 
 end
 
 
 subsubsection \<open>With idempotency\<close>
 
 locale folding_idem_on = folding_on +
   assumes comp_fun_idem_on: "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> f x \<circ> f x = f x"
 begin
 
 declare insert [simp del]
 
 interpretation fold?: comp_fun_idem_on S f
   by standard (simp_all add: comp_fun_commute_on comp_fun_idem_on)
 
 lemma insert_idem [simp]:
   assumes "insert x A \<subseteq> S" and "finite A"
   shows "F (insert x A) = f x (F A)"
 proof -
   from fold_insert_idem assms
   have "fold f z (insert x A) = f x (fold f z A)" by simp
   with \<open>finite A\<close> show ?thesis by (simp add: eq_fold fun_eq_iff)
 qed
 
 end
 
 subsubsection \<open>\<^term>\<open>UNIV\<close> as the carrier set\<close>
 
 locale folding =
   fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b" and z :: "'b"
   assumes comp_fun_commute: "f y \<circ> f x = f x \<circ> f y"
 begin
 
 lemma (in -) folding_def': "folding f = folding_on UNIV f"
   unfolding folding_def folding_on_def by blast
 
 text \<open>
   Again, we abuse the \<open>rewrites\<close> functionality of locales to remove trivial assumptions that
   result from instantiating the carrier set to \<^term>\<open>UNIV\<close>.
 \<close>
 sublocale folding_on UNIV f
   rewrites "\<And>X. (X \<subseteq> UNIV) \<equiv> True"
        and "\<And>x. x \<in> UNIV \<equiv> True"
        and "\<And>P. (True \<Longrightarrow> P) \<equiv> Trueprop P"
        and "\<And>P Q. (True \<Longrightarrow> PROP P \<Longrightarrow> PROP Q) \<equiv> (PROP P \<Longrightarrow> True \<Longrightarrow> PROP Q)"
 proof -
   show "folding_on UNIV f"
     by standard (simp add: comp_fun_commute)
 qed simp_all
 
 end
 
 locale folding_idem = folding +
   assumes comp_fun_idem: "f x \<circ> f x = f x"
 begin
 
 lemma (in -) folding_idem_def': "folding_idem f = folding_idem_on UNIV f"
   unfolding folding_idem_def folding_def' folding_idem_on_def
   unfolding folding_idem_axioms_def folding_idem_on_axioms_def
   by blast
 
 text \<open>
   Again, we abuse the \<open>rewrites\<close> functionality of locales to remove trivial assumptions that
   result from instantiating the carrier set to \<^term>\<open>UNIV\<close>.
 \<close>
 sublocale folding_idem_on UNIV f
   rewrites "\<And>X. (X \<subseteq> UNIV) \<equiv> True"
        and "\<And>x. x \<in> UNIV \<equiv> True"
        and "\<And>P. (True \<Longrightarrow> P) \<equiv> Trueprop P"
        and "\<And>P Q. (True \<Longrightarrow> PROP P \<Longrightarrow> PROP Q) \<equiv> (PROP P \<Longrightarrow> True \<Longrightarrow> PROP Q)"
 proof -
   show "folding_idem_on UNIV f"
     by standard (simp add: comp_fun_idem)
 qed simp_all
 
 end
 
 
 subsection \<open>Finite cardinality\<close>
 
 text \<open>
   The traditional definition
   \<^prop>\<open>card A \<equiv> LEAST n. \<exists>f. A = {f i |i. i < n}\<close>
   is ugly to work with.
   But now that we have \<^const>\<open>fold\<close> things are easy:
 \<close>
 
 global_interpretation card: folding "\<lambda>_. Suc" 0
   defines card = "folding_on.F (\<lambda>_. Suc) 0"
   by standard (rule refl)
 
 lemma card_insert_disjoint: "finite A \<Longrightarrow> x \<notin> A \<Longrightarrow> card (insert x A) = Suc (card A)"
   by (fact card.insert)
 
 lemma card_insert_if: "finite A \<Longrightarrow> card (insert x A) = (if x \<in> A then card A else Suc (card A))"
   by auto (simp add: card.insert_remove card.remove)
 
 lemma card_ge_0_finite: "card A > 0 \<Longrightarrow> finite A"
   by (rule ccontr) simp
 
 lemma card_0_eq [simp]: "finite A \<Longrightarrow> card A = 0 \<longleftrightarrow> A = {}"
   by (auto dest: mk_disjoint_insert)
 
 lemma finite_UNIV_card_ge_0: "finite (UNIV :: 'a set) \<Longrightarrow> card (UNIV :: 'a set) > 0"
   by (rule ccontr) simp
 
 lemma card_eq_0_iff: "card A = 0 \<longleftrightarrow> A = {} \<or> \<not> finite A"
   by auto
 
 lemma card_range_greater_zero: "finite (range f) \<Longrightarrow> card (range f) > 0"
   by (rule ccontr) (simp add: card_eq_0_iff)
 
 lemma card_gt_0_iff: "0 < card A \<longleftrightarrow> A \<noteq> {} \<and> finite A"
   by (simp add: neq0_conv [symmetric] card_eq_0_iff)
 
 lemma card_Suc_Diff1:
   assumes "finite A" "x \<in> A" shows "Suc (card (A - {x})) = card A"
 proof -
   have "Suc (card (A - {x})) = card (insert x (A - {x}))"
     using assms by (simp add: card.insert_remove)
   also have "... = card A"
     using assms by (simp add: card_insert_if)
   finally show ?thesis .
 qed
 
 lemma card_insert_le_m1:
   assumes "n > 0" "card y \<le> n - 1" shows  "card (insert x y) \<le> n"
   using assms
   by (cases "finite y") (auto simp: card_insert_if)
 
 lemma card_Diff_singleton:
   assumes "x \<in> A" shows "card (A - {x}) = card A - 1"
 proof (cases "finite A")
   case True
   with assms show ?thesis
     by (simp add: card_Suc_Diff1 [symmetric])
 qed auto
 
 lemma card_Diff_singleton_if:
   "card (A - {x}) = (if x \<in> A then card A - 1 else card A)"
   by (simp add: card_Diff_singleton)
 
 lemma card_Diff_insert[simp]:
   assumes "a \<in> A" and "a \<notin> B"
   shows "card (A - insert a B) = card (A - B) - 1"
 proof -
   have "A - insert a B = (A - B) - {a}"
     using assms by blast
   then show ?thesis
     using assms by (simp add: card_Diff_singleton)
 qed
 
 lemma card_insert_le: "card A \<le> card (insert x A)"
 proof (cases "finite A")
   case True
   then show ?thesis   by (simp add: card_insert_if)
 qed auto
 
 lemma card_Collect_less_nat[simp]: "card {i::nat. i < n} = n"
   by (induct n) (simp_all add:less_Suc_eq Collect_disj_eq)
 
 lemma card_Collect_le_nat[simp]: "card {i::nat. i \<le> n} = Suc n"
   using card_Collect_less_nat[of "Suc n"] by (simp add: less_Suc_eq_le)
 
 lemma card_mono:
   assumes "finite B" and "A \<subseteq> B"
   shows "card A \<le> card B"
 proof -
   from assms have "finite A"
     by (auto intro: finite_subset)
   then show ?thesis
     using assms
   proof (induct A arbitrary: B)
     case empty
     then show ?case by simp
   next
     case (insert x A)
     then have "x \<in> B"
       by simp
     from insert have "A \<subseteq> B - {x}" and "finite (B - {x})"
       by auto
     with insert.hyps have "card A \<le> card (B - {x})"
       by auto
     with \<open>finite A\<close> \<open>x \<notin> A\<close> \<open>finite B\<close> \<open>x \<in> B\<close> show ?case
       by simp (simp only: card.remove)
   qed
 qed
 
 lemma card_seteq: 
   assumes "finite B" and A: "A \<subseteq> B" "card B \<le> card A"
   shows "A = B"
   using assms
 proof (induction arbitrary: A rule: finite_induct)
   case (insert b B)
   then have A: "finite A" "A - {b} \<subseteq> B" 
     by force+
   then have "card B \<le> card (A - {b})"
     using insert by (auto simp add: card_Diff_singleton_if)
   then have "A - {b} = B"
     using A insert.IH by auto
   then show ?case 
     using insert.hyps insert.prems by auto
 qed auto
 
 lemma psubset_card_mono: "finite B \<Longrightarrow> A < B \<Longrightarrow> card A < card B"
   using card_seteq [of B A] by (auto simp add: psubset_eq)
 
 lemma card_Un_Int:
   assumes "finite A" "finite B"
   shows "card A + card B = card (A \<union> B) + card (A \<inter> B)"
   using assms
 proof (induct A)
   case empty
   then show ?case by simp
 next
   case insert
   then show ?case
     by (auto simp add: insert_absorb Int_insert_left)
 qed
 
 lemma card_Un_disjoint: "finite A \<Longrightarrow> finite B \<Longrightarrow> A \<inter> B = {} \<Longrightarrow> card (A \<union> B) = card A + card B"
   using card_Un_Int [of A B] by simp
 
 lemma card_Un_disjnt: "\<lbrakk>finite A; finite B; disjnt A B\<rbrakk> \<Longrightarrow> card (A \<union> B) = card A + card B"
   by (simp add: card_Un_disjoint disjnt_def)
 
 lemma card_Un_le: "card (A \<union> B) \<le> card A + card B"
 proof (cases "finite A \<and> finite B")
   case True
   then show ?thesis
     using le_iff_add card_Un_Int [of A B] by auto
 qed auto
 
 lemma card_Diff_subset:
   assumes "finite B"
     and "B \<subseteq> A"
   shows "card (A - B) = card A - card B"
   using assms
 proof (cases "finite A")
   case False
   with assms show ?thesis
     by simp
 next
   case True
   with assms show ?thesis
     by (induct B arbitrary: A) simp_all
 qed
 
 lemma card_Diff_subset_Int:
   assumes "finite (A \<inter> B)"
   shows "card (A - B) = card A - card (A \<inter> B)"
 proof -
   have "A - B = A - A \<inter> B" by auto
   with assms show ?thesis
     by (simp add: card_Diff_subset)
 qed
 
 lemma diff_card_le_card_Diff:
   assumes "finite B"
   shows "card A - card B \<le> card (A - B)"
 proof -
   have "card A - card B \<le> card A - card (A \<inter> B)"
     using card_mono[OF assms Int_lower2, of A] by arith
   also have "\<dots> = card (A - B)"
     using assms by (simp add: card_Diff_subset_Int)
   finally show ?thesis .
 qed
 
 lemma card_le_sym_Diff:
   assumes "finite A" "finite B" "card A \<le> card B"
   shows "card(A - B) \<le> card(B - A)"
 proof -
   have "card(A - B) = card A - card (A \<inter> B)" using assms(1,2) by(simp add: card_Diff_subset_Int)
   also have "\<dots> \<le> card B - card (A \<inter> B)" using assms(3) by linarith
   also have "\<dots> = card(B - A)" using assms(1,2) by(simp add: card_Diff_subset_Int Int_commute)
   finally show ?thesis .
 qed
 
 lemma card_less_sym_Diff:
   assumes "finite A" "finite B" "card A < card B"
   shows "card(A - B) < card(B - A)"
 proof -
   have "card(A - B) = card A - card (A \<inter> B)" using assms(1,2) by(simp add: card_Diff_subset_Int)
   also have "\<dots> < card B - card (A \<inter> B)" using assms(1,3) by (simp add: card_mono diff_less_mono)
   also have "\<dots> = card(B - A)" using assms(1,2) by(simp add: card_Diff_subset_Int Int_commute)
   finally show ?thesis .
 qed
 
 lemma card_Diff1_less_iff: "card (A - {x}) < card A \<longleftrightarrow> finite A \<and> x \<in> A"
 proof (cases "finite A \<and> x \<in> A")
   case True
   then show ?thesis
     by (auto simp: card_gt_0_iff intro: diff_less)
 qed auto
 
 lemma card_Diff1_less: "finite A \<Longrightarrow> x \<in> A \<Longrightarrow> card (A - {x}) < card A"
   unfolding card_Diff1_less_iff by auto
 
 lemma card_Diff2_less:
   assumes "finite A" "x \<in> A" "y \<in> A" shows "card (A - {x} - {y}) < card A"
 proof (cases "x = y")
   case True
   with assms show ?thesis
     by (simp add: card_Diff1_less del: card_Diff_insert)
 next
   case False
   then have "card (A - {x} - {y}) < card (A - {x})" "card (A - {x}) < card A"
     using assms by (intro card_Diff1_less; simp)+
   then show ?thesis
     by (blast intro: less_trans)
 qed
 
 lemma card_Diff1_le: "card (A - {x}) \<le> card A"
 proof (cases "finite A")
   case True
   then show ?thesis  
     by (cases "x \<in> A") (simp_all add: card_Diff1_less less_imp_le)
 qed auto
 
 lemma card_psubset: "finite B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> card A < card B \<Longrightarrow> A < B"
   by (erule psubsetI) blast
 
 lemma card_le_inj:
   assumes fA: "finite A"
     and fB: "finite B"
     and c: "card A \<le> card B"
   shows "\<exists>f. f ` A \<subseteq> B \<and> inj_on f A"
   using fA fB c
 proof (induct arbitrary: B rule: finite_induct)
   case empty
   then show ?case by simp
 next
   case (insert x s t)
   then show ?case
   proof (induct rule: finite_induct [OF insert.prems(1)])
     case 1
     then show ?case by simp
   next
     case (2 y t)
     from "2.prems"(1,2,5) "2.hyps"(1,2) have cst: "card s \<le> card t"
       by simp
     from "2.prems"(3) [OF "2.hyps"(1) cst]
     obtain f where *: "f ` s \<subseteq> t" "inj_on f s"
       by blast
     let ?g = "(\<lambda>a. if a = x then y else f a)"
     have "?g ` insert x s \<subseteq> insert y t \<and> inj_on ?g (insert x s)"
       using * "2.prems"(2) "2.hyps"(2) unfolding inj_on_def by auto
     then show ?case by (rule exI[where ?x="?g"])
   qed
 qed
 
 lemma card_subset_eq:
   assumes fB: "finite B"
     and AB: "A \<subseteq> B"
     and c: "card A = card B"
   shows "A = B"
 proof -
   from fB AB have fA: "finite A"
     by (auto intro: finite_subset)
   from fA fB have fBA: "finite (B - A)"
     by auto
   have e: "A \<inter> (B - A) = {}"
     by blast
   have eq: "A \<union> (B - A) = B"
     using AB by blast
   from card_Un_disjoint[OF fA fBA e, unfolded eq c] have "card (B - A) = 0"
     by arith
   then have "B - A = {}"
     unfolding card_eq_0_iff using fA fB by simp
   with AB show "A = B"
     by blast
 qed
 
 lemma insert_partition:
   "x \<notin> F \<Longrightarrow> \<forall>c1 \<in> insert x F. \<forall>c2 \<in> insert x F. c1 \<noteq> c2 \<longrightarrow> c1 \<inter> c2 = {} \<Longrightarrow> x \<inter> \<Union>F = {}"
   by auto
 
 lemma finite_psubset_induct [consumes 1, case_names psubset]:
   assumes finite: "finite A"
     and major: "\<And>A. finite A \<Longrightarrow> (\<And>B. B \<subset> A \<Longrightarrow> P B) \<Longrightarrow> P A"
   shows "P A"
   using finite
 proof (induct A taking: card rule: measure_induct_rule)
   case (less A)
   have fin: "finite A" by fact
   have ih: "card B < card A \<Longrightarrow> finite B \<Longrightarrow> P B" for B by fact
   have "P B" if "B \<subset> A" for B
   proof -
     from that have "card B < card A"
       using psubset_card_mono fin by blast
     moreover
     from that have "B \<subseteq> A"
       by auto
     then have "finite B"
       using fin finite_subset by blast
     ultimately show ?thesis using ih by simp
   qed
   with fin show "P A" using major by blast
 qed
 
 lemma finite_induct_select [consumes 1, case_names empty select]:
   assumes "finite S"
     and "P {}"
     and select: "\<And>T. T \<subset> S \<Longrightarrow> P T \<Longrightarrow> \<exists>s\<in>S - T. P (insert s T)"
   shows "P S"
 proof -
   have "0 \<le> card S" by simp
   then have "\<exists>T \<subseteq> S. card T = card S \<and> P T"
   proof (induct rule: dec_induct)
     case base with \<open>P {}\<close>
     show ?case
       by (intro exI[of _ "{}"]) auto
   next
     case (step n)
     then obtain T where T: "T \<subseteq> S" "card T = n" "P T"
       by auto
     with \<open>n < card S\<close> have "T \<subset> S" "P T"
       by auto
     with select[of T] obtain s where "s \<in> S" "s \<notin> T" "P (insert s T)"
       by auto
     with step(2) T \<open>finite S\<close> show ?case
       by (intro exI[of _ "insert s T"]) (auto dest: finite_subset)
   qed
   with \<open>finite S\<close> show "P S"
     by (auto dest: card_subset_eq)
 qed
 
 lemma remove_induct [case_names empty infinite remove]:
   assumes empty: "P ({} :: 'a set)"
     and infinite: "\<not> finite B \<Longrightarrow> P B"
     and remove: "\<And>A. finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow> A \<subseteq> B \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> P (A - {x})) \<Longrightarrow> P A"
   shows "P B"
 proof (cases "finite B")
   case False
   then show ?thesis by (rule infinite)
 next
   case True
   define A where "A = B"
   with True have "finite A" "A \<subseteq> B"
     by simp_all
   then show "P A"
   proof (induct "card A" arbitrary: A)
     case 0
     then have "A = {}" by auto
     with empty show ?case by simp
   next
     case (Suc n A)
     from \<open>A \<subseteq> B\<close> and \<open>finite B\<close> have "finite A"
       by (rule finite_subset)
     moreover from Suc.hyps have "A \<noteq> {}" by auto
     moreover note \<open>A \<subseteq> B\<close>
     moreover have "P (A - {x})" if x: "x \<in> A" for x
       using x Suc.prems \<open>Suc n = card A\<close> by (intro Suc) auto
     ultimately show ?case by (rule remove)
   qed
 qed
 
 lemma finite_remove_induct [consumes 1, case_names empty remove]:
   fixes P :: "'a set \<Rightarrow> bool"
   assumes "finite B"
     and "P {}"
     and "\<And>A. finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow> A \<subseteq> B \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> P (A - {x})) \<Longrightarrow> P A"
   defines "B' \<equiv> B"
   shows "P B'"
   by (induct B' rule: remove_induct) (simp_all add: assms)
 
 
 text \<open>Main cardinality theorem.\<close>
 lemma card_partition [rule_format]:
   "finite C \<Longrightarrow> finite (\<Union>C) \<Longrightarrow> (\<forall>c\<in>C. card c = k) \<Longrightarrow>
     (\<forall>c1 \<in> C. \<forall>c2 \<in> C. c1 \<noteq> c2 \<longrightarrow> c1 \<inter> c2 = {}) \<Longrightarrow>
     k * card C = card (\<Union>C)"
 proof (induct rule: finite_induct)
   case empty
   then show ?case by simp
 next
   case (insert x F)
   then show ?case
     by (simp add: card_Un_disjoint insert_partition finite_subset [of _ "\<Union>(insert _ _)"])
 qed
 
 lemma card_eq_UNIV_imp_eq_UNIV:
   assumes fin: "finite (UNIV :: 'a set)"
     and card: "card A = card (UNIV :: 'a set)"
   shows "A = (UNIV :: 'a set)"
 proof
   show "A \<subseteq> UNIV" by simp
   show "UNIV \<subseteq> A"
   proof
     show "x \<in> A" for x
     proof (rule ccontr)
       assume "x \<notin> A"
       then have "A \<subset> UNIV" by auto
       with fin have "card A < card (UNIV :: 'a set)"
         by (fact psubset_card_mono)
       with card show False by simp
     qed
   qed
 qed
 
 text \<open>The form of a finite set of given cardinality\<close>
 
 lemma card_eq_SucD:
   assumes "card A = Suc k"
   shows "\<exists>b B. A = insert b B \<and> b \<notin> B \<and> card B = k \<and> (k = 0 \<longrightarrow> B = {})"
 proof -
   have fin: "finite A"
     using assms by (auto intro: ccontr)
   moreover have "card A \<noteq> 0"
     using assms by auto
   ultimately obtain b where b: "b \<in> A"
     by auto
   show ?thesis
   proof (intro exI conjI)
     show "A = insert b (A - {b})"
       using b by blast
     show "b \<notin> A - {b}"
       by blast
     show "card (A - {b}) = k" and "k = 0 \<longrightarrow> A - {b} = {}"
       using assms b fin by (fastforce dest: mk_disjoint_insert)+
   qed
 qed
 
 lemma card_Suc_eq:
   "card A = Suc k \<longleftrightarrow>
     (\<exists>b B. A = insert b B \<and> b \<notin> B \<and> card B = k \<and> (k = 0 \<longrightarrow> B = {}))"
   by (auto simp: card_insert_if card_gt_0_iff elim!: card_eq_SucD)
 
 lemma card_Suc_eq_finite:
   "card A = Suc k \<longleftrightarrow> (\<exists>b B. A = insert b B \<and> b \<notin> B \<and> card B = k \<and> finite B)"
   unfolding card_Suc_eq using card_gt_0_iff by fastforce
 
 lemma card_1_singletonE:
   assumes "card A = 1"
   obtains x where "A = {x}"
   using assms by (auto simp: card_Suc_eq)
 
 lemma is_singleton_altdef: "is_singleton A \<longleftrightarrow> card A = 1"
   unfolding is_singleton_def
   by (auto elim!: card_1_singletonE is_singletonE simp del: One_nat_def)
 
 lemma card_1_singleton_iff: "card A = Suc 0 \<longleftrightarrow> (\<exists>x. A = {x})"
   by (simp add: card_Suc_eq)
 
 lemma card_le_Suc0_iff_eq:
   assumes "finite A"
   shows "card A \<le> Suc 0 \<longleftrightarrow> (\<forall>a1 \<in> A. \<forall>a2 \<in> A. a1 = a2)" (is "?C = ?A")
 proof
   assume ?C thus ?A using assms by (auto simp: le_Suc_eq dest: card_eq_SucD)
 next
   assume ?A
   show ?C
   proof cases
     assume "A = {}" thus ?C using \<open>?A\<close> by simp
   next
     assume "A \<noteq> {}"
     then obtain a where "A = {a}" using \<open>?A\<close> by blast
     thus ?C by simp
   qed
 qed
 
 lemma card_le_Suc_iff:
   "Suc n \<le> card A = (\<exists>a B. A = insert a B \<and> a \<notin> B \<and> n \<le> card B \<and> finite B)"
 proof (cases "finite A")
   case True
   then show ?thesis
     by (fastforce simp: card_Suc_eq less_eq_nat.simps split: nat.splits)
 qed auto
 
 lemma finite_fun_UNIVD2:
   assumes fin: "finite (UNIV :: ('a \<Rightarrow> 'b) set)"
   shows "finite (UNIV :: 'b set)"
 proof -
   from fin have "finite (range (\<lambda>f :: 'a \<Rightarrow> 'b. f arbitrary))" for arbitrary
     by (rule finite_imageI)
   moreover have "UNIV = range (\<lambda>f :: 'a \<Rightarrow> 'b. f arbitrary)" for arbitrary
     by (rule UNIV_eq_I) auto
   ultimately show "finite (UNIV :: 'b set)"
     by simp
 qed
 
 lemma card_UNIV_unit [simp]: "card (UNIV :: unit set) = 1"
   unfolding UNIV_unit by simp
 
 lemma infinite_arbitrarily_large:
   assumes "\<not> finite A"
   shows "\<exists>B. finite B \<and> card B = n \<and> B \<subseteq> A"
 proof (induction n)
   case 0
   show ?case by (intro exI[of _ "{}"]) auto
 next
   case (Suc n)
   then obtain B where B: "finite B \<and> card B = n \<and> B \<subseteq> A" ..
   with \<open>\<not> finite A\<close> have "A \<noteq> B" by auto
   with B have "B \<subset> A" by auto
   then have "\<exists>x. x \<in> A - B"
     by (elim psubset_imp_ex_mem)
   then obtain x where x: "x \<in> A - B" ..
   with B have "finite (insert x B) \<and> card (insert x B) = Suc n \<and> insert x B \<subseteq> A"
     by auto
   then show "\<exists>B. finite B \<and> card B = Suc n \<and> B \<subseteq> A" ..
 qed
 
 text \<open>Sometimes, to prove that a set is finite, it is convenient to work with finite subsets
 and to show that their cardinalities are uniformly bounded. This possibility is formalized in
 the next criterion.\<close>
 
 lemma finite_if_finite_subsets_card_bdd:
   assumes "\<And>G. G \<subseteq> F \<Longrightarrow> finite G \<Longrightarrow> card G \<le> C"
   shows "finite F \<and> card F \<le> C"
 proof (cases "finite F")
   case False
   obtain n::nat where n: "n > max C 0" by auto
   obtain G where G: "G \<subseteq> F" "card G = n" using infinite_arbitrarily_large[OF False] by auto
   hence "finite G" using \<open>n > max C 0\<close> using card.infinite gr_implies_not0 by blast
   hence False using assms G n not_less by auto
   thus ?thesis ..
 next
   case True thus ?thesis using assms[of F] by auto
 qed
 
 lemma obtain_subset_with_card_n:
   assumes "n \<le> card S"
   obtains T where "T \<subseteq> S" "card T = n" "finite T"
 proof -
   obtain n' where "card S = n + n'"
     using le_Suc_ex[OF assms] by blast
   with that show thesis
   proof (induct n' arbitrary: S)
     case 0 
     thus ?case by (cases "finite S") auto
   next
     case Suc 
     thus ?case by (auto simp add: card_Suc_eq)
   qed
 qed
 
 lemma exists_subset_between: 
   assumes 
     "card A \<le> n" 
     "n \<le> card C"
     "A \<subseteq> C"
     "finite C"
   shows "\<exists>B. A \<subseteq> B \<and> B \<subseteq> C \<and> card B = n" 
   using assms 
 proof (induct n arbitrary: A C)
   case 0
   thus ?case using finite_subset[of A C] by (intro exI[of _ "{}"], auto)
 next
   case (Suc n A C)
   show ?case
   proof (cases "A = {}")
     case True
     from obtain_subset_with_card_n[OF Suc(3)]
     obtain B where "B \<subseteq> C" "card B = Suc n" by blast
     thus ?thesis unfolding True by blast
   next
     case False
     then obtain a where a: "a \<in> A" by auto
     let ?A = "A - {a}" 
     let ?C = "C - {a}" 
     have 1: "card ?A \<le> n" using Suc(2-) a 
       using finite_subset by fastforce 
     have 2: "card ?C \<ge> n" using Suc(2-) a by auto
     from Suc(1)[OF 1 2 _ finite_subset[OF _ Suc(5)]] Suc(2-)
     obtain B where "?A \<subseteq> B" "B \<subseteq> ?C" "card B = n" by blast
     thus ?thesis using a Suc(2-) 
       by (intro exI[of _ "insert a B"], auto intro!: card_insert_disjoint finite_subset[of B C])
   qed
 qed
 
 
 subsubsection \<open>Cardinality of image\<close>
 
 lemma card_image_le: "finite A \<Longrightarrow> card (f ` A) \<le> card A"
   by (induct rule: finite_induct) (simp_all add: le_SucI card_insert_if)
 
 lemma card_image: "inj_on f A \<Longrightarrow> card (f ` A) = card A"
 proof (induct A rule: infinite_finite_induct)
   case (infinite A)
   then have "\<not> finite (f ` A)" by (auto dest: finite_imageD)
   with infinite show ?case by simp
 qed simp_all
 
 lemma bij_betw_same_card: "bij_betw f A B \<Longrightarrow> card A = card B"
   by (auto simp: card_image bij_betw_def)
 
 lemma endo_inj_surj: "finite A \<Longrightarrow> f ` A \<subseteq> A \<Longrightarrow> inj_on f A \<Longrightarrow> f ` A = A"
   by (simp add: card_seteq card_image)
 
 lemma eq_card_imp_inj_on:
   assumes "finite A" "card(f ` A) = card A"
   shows "inj_on f A"
   using assms
 proof (induct rule:finite_induct)
   case empty
   show ?case by simp
 next
   case (insert x A)
   then show ?case
     using card_image_le [of A f] by (simp add: card_insert_if split: if_splits)
 qed
 
 lemma inj_on_iff_eq_card: "finite A \<Longrightarrow> inj_on f A \<longleftrightarrow> card (f ` A) = card A"
   by (blast intro: card_image eq_card_imp_inj_on)
 
 lemma card_inj_on_le:
   assumes "inj_on f A" "f ` A \<subseteq> B" "finite B"
   shows "card A \<le> card B"
 proof -
   have "finite A"
     using assms by (blast intro: finite_imageD dest: finite_subset)
   then show ?thesis
     using assms by (force intro: card_mono simp: card_image [symmetric])
 qed
 
 lemma inj_on_iff_card_le:
   "\<lbrakk> finite A; finite B \<rbrakk> \<Longrightarrow> (\<exists>f. inj_on f A \<and> f ` A \<le> B) = (card A \<le> card B)"
 using card_inj_on_le[of _ A B] card_le_inj[of A B] by blast
 
 lemma surj_card_le: "finite A \<Longrightarrow> B \<subseteq> f ` A \<Longrightarrow> card B \<le> card A"
   by (blast intro: card_image_le card_mono le_trans)
 
 lemma card_bij_eq:
   "inj_on f A \<Longrightarrow> f ` A \<subseteq> B \<Longrightarrow> inj_on g B \<Longrightarrow> g ` B \<subseteq> A \<Longrightarrow> finite A \<Longrightarrow> finite B
     \<Longrightarrow> card A = card B"
   by (auto intro: le_antisym card_inj_on_le)
 
 lemma bij_betw_finite: "bij_betw f A B \<Longrightarrow> finite A \<longleftrightarrow> finite B"
   unfolding bij_betw_def using finite_imageD [of f A] by auto
 
 lemma inj_on_finite: "inj_on f A \<Longrightarrow> f ` A \<le> B \<Longrightarrow> finite B \<Longrightarrow> finite A"
   using finite_imageD finite_subset by blast
 
 lemma card_vimage_inj_on_le:
   assumes "inj_on f D" "finite A"
   shows "card (f-`A \<inter> D) \<le> card A"
 proof (rule card_inj_on_le)
   show "inj_on f (f -` A \<inter> D)"
     by (blast intro: assms inj_on_subset)
 qed (use assms in auto)
 
 lemma card_vimage_inj: "inj f \<Longrightarrow> A \<subseteq> range f \<Longrightarrow> card (f -` A) = card A"
   by (auto 4 3 simp: subset_image_iff inj_vimage_image_eq
       intro: card_image[symmetric, OF subset_inj_on])
 
 lemma card_inverse[simp]: "card (R\<inverse>) = card R"
 proof -
   have *: "\<And>R. prod.swap ` R = R\<inverse>" by auto
   {
     assume "\<not>finite R"
     hence ?thesis
       by auto
   } moreover {
     assume "finite R"
     with card_image_le[of R prod.swap] card_image_le[of "R\<inverse>" prod.swap]
     have ?thesis by (auto simp: * )
   } ultimately show ?thesis by blast
 qed
 
 subsubsection \<open>Pigeonhole Principles\<close>
 
 lemma pigeonhole: "card A > card (f ` A) \<Longrightarrow> \<not> inj_on f A "
   by (auto dest: card_image less_irrefl_nat)
 
 lemma pigeonhole_infinite:
   assumes "\<not> finite A" and "finite (f`A)"
   shows "\<exists>a0\<in>A. \<not> finite {a\<in>A. f a = f a0}"
   using assms(2,1)
 proof (induct "f`A" arbitrary: A rule: finite_induct)
   case empty
   then show ?case by simp
 next
   case (insert b F)
   show ?case
   proof (cases "finite {a\<in>A. f a = b}")
     case True
     with \<open>\<not> finite A\<close> have "\<not> finite (A - {a\<in>A. f a = b})"
       by simp
     also have "A - {a\<in>A. f a = b} = {a\<in>A. f a \<noteq> b}"
       by blast
     finally have "\<not> finite {a\<in>A. f a \<noteq> b}" .
     from insert(3)[OF _ this] insert(2,4) show ?thesis
       by simp (blast intro: rev_finite_subset)
   next
     case False
     then have "{a \<in> A. f a = b} \<noteq> {}" by force
     with False show ?thesis by blast
   qed
 qed
 
 lemma pigeonhole_infinite_rel:
   assumes "\<not> finite A"
     and "finite B"
     and "\<forall>a\<in>A. \<exists>b\<in>B. R a b"
   shows "\<exists>b\<in>B. \<not> finite {a:A. R a b}"
 proof -
   let ?F = "\<lambda>a. {b\<in>B. R a b}"
   from finite_Pow_iff[THEN iffD2, OF \<open>finite B\<close>] have "finite (?F ` A)"
     by (blast intro: rev_finite_subset)
   from pigeonhole_infinite [where f = ?F, OF assms(1) this]
   obtain a0 where "a0 \<in> A" and infinite: "\<not> finite {a\<in>A. ?F a = ?F a0}" ..
   obtain b0 where "b0 \<in> B" and "R a0 b0"
     using \<open>a0 \<in> A\<close> assms(3) by blast
   have "finite {a\<in>A. ?F a = ?F a0}" if "finite {a\<in>A. R a b0}"
     using \<open>b0 \<in> B\<close> \<open>R a0 b0\<close> that by (blast intro: rev_finite_subset)
   with infinite \<open>b0 \<in> B\<close> show ?thesis
     by blast
 qed
 
 
 subsubsection \<open>Cardinality of sums\<close>
 
 lemma card_Plus:
   assumes "finite A" "finite B"
   shows "card (A <+> B) = card A + card B"
 proof -
   have "Inl`A \<inter> Inr`B = {}" by fast
   with assms show ?thesis
     by (simp add: Plus_def card_Un_disjoint card_image)
 qed
 
 lemma card_Plus_conv_if:
   "card (A <+> B) = (if finite A \<and> finite B then card A + card B else 0)"
   by (auto simp add: card_Plus)
 
 text \<open>Relates to equivalence classes.  Based on a theorem of F. Kammüller.\<close>
 
 lemma dvd_partition:
   assumes f: "finite (\<Union>C)"
     and "\<forall>c\<in>C. k dvd card c" "\<forall>c1\<in>C. \<forall>c2\<in>C. c1 \<noteq> c2 \<longrightarrow> c1 \<inter> c2 = {}"
   shows "k dvd card (\<Union>C)"
 proof -
   have "finite C"
     by (rule finite_UnionD [OF f])
   then show ?thesis
     using assms
   proof (induct rule: finite_induct)
     case empty
     show ?case by simp
   next
     case (insert c C)
     then have "c \<inter> \<Union>C = {}"
       by auto
     with insert show ?case
       by (simp add: card_Un_disjoint)
   qed
 qed
 
 
 subsection \<open>Minimal and maximal elements of finite sets\<close>
 
 context begin
 
 qualified lemma
   assumes "finite A" and "asymp_on A R" and "transp_on A R" and "\<exists>x \<in> A. P x"
   shows
     bex_min_element_with_property: "\<exists>x \<in> A. P x \<and> (\<forall>y \<in> A. R y x \<longrightarrow> \<not> P y)" and
     bex_max_element_with_property: "\<exists>x \<in> A. P x \<and> (\<forall>y \<in> A. R x y \<longrightarrow> \<not> P y)"
   unfolding atomize_conj
   using assms
 proof (induction A rule: finite_induct)
   case empty
   hence False
     by simp_all
   thus ?case ..
 next
   case (insert x F)
 
   from insert.prems have "asymp_on F R"
     using asymp_on_subset by blast
 
   from insert.prems have "transp_on F R"
     using transp_on_subset by blast
 
   show ?case
   proof (cases "P x")
     case True
     show ?thesis
     proof (cases "\<exists>a\<in>F. P a")
       case True
       with insert.IH obtain min max where
         "min \<in> F" and "P min" and "\<forall>z \<in> F. R z min \<longrightarrow> \<not> P z"
         "max \<in> F" and "P max" and "\<forall>z \<in> F. R max z \<longrightarrow> \<not> P z"
         using \<open>asymp_on F R\<close> \<open>transp_on F R\<close> by auto
 
       show ?thesis
       proof (rule conjI)
         show "\<exists>y \<in> insert x F. P y \<and> (\<forall>z \<in> insert x F. R y z \<longrightarrow> \<not> P z)"
         proof (cases "R max x")
           case True
           show ?thesis
           proof (intro bexI conjI ballI impI)
             show "x \<in> insert x F"
               by simp
           next
             show "P x"
               using \<open>P x\<close> by simp
           next
             fix z assume "z \<in> insert x F" and "R x z"
             hence "z = x \<or> z \<in> F"
               by simp
             thus "\<not> P z"
             proof (rule disjE)
               assume "z = x"
               hence "R x x"
                 using \<open>R x z\<close> by simp
               moreover have "\<not> R x x"
                 using \<open>asymp_on (insert x F) R\<close>[THEN irreflp_on_if_asymp_on, THEN irreflp_onD]
                 by simp
               ultimately have False
                 by simp
               thus ?thesis ..
             next
               assume "z \<in> F"
               moreover have "R max z"
                 using \<open>R max x\<close> \<open>R x z\<close>
                 using \<open>transp_on (insert x F) R\<close>[THEN transp_onD, of max x z]
                 using \<open>max \<in> F\<close> \<open>z \<in> F\<close> by simp
               ultimately show ?thesis
                 using \<open>\<forall>z \<in> F. R max z \<longrightarrow> \<not> P z\<close> by simp
             qed
           qed
         next
           case False
           show ?thesis
           proof (intro bexI conjI ballI impI)
             show "max \<in> insert x F"
               using \<open>max \<in> F\<close> by simp
           next
             show "P max"
               using \<open>P max\<close> by simp
           next
             fix z assume "z \<in> insert x F" and "R max z"
             hence "z = x \<or> z \<in> F"
               by simp
             thus "\<not> P z"
             proof (rule disjE)
               assume "z = x"
               hence False
                 using \<open>\<not> R max x\<close> \<open>R max z\<close> by simp
               thus ?thesis ..
             next
               assume "z \<in> F"
               thus ?thesis
                 using \<open>R max z\<close> \<open>\<forall>z\<in>F. R max z \<longrightarrow> \<not> P z\<close> by simp
             qed
           qed
         qed
       next
         show "\<exists>y \<in> insert x F. P y \<and> (\<forall>z \<in> insert x F. R z y \<longrightarrow> \<not> P z)"
         proof (cases "R x min")
           case True
           show ?thesis
           proof (intro bexI conjI ballI impI)
             show "x \<in> insert x F"
               by simp
           next
             show "P x"
               using \<open>P x\<close> by simp
           next
             fix z assume "z \<in> insert x F" and "R z x"
             hence "z = x \<or> z \<in> F"
               by simp
             thus "\<not> P z"
             proof (rule disjE)
               assume "z = x"
               hence "R x x"
                 using \<open>R z x\<close> by simp
               moreover have "\<not> R x x"
                 using \<open>asymp_on (insert x F) R\<close>[THEN irreflp_on_if_asymp_on, THEN irreflp_onD]
                 by simp
               ultimately have False
                 by simp
               thus ?thesis ..
             next
               assume "z \<in> F"
               moreover have "R z min"
                 using \<open>R z x\<close> \<open>R x min\<close>
                 using \<open>transp_on (insert x F) R\<close>[THEN transp_onD, of z x min]
                 using \<open>min \<in> F\<close> \<open>z \<in> F\<close> by simp
               ultimately show ?thesis
                 using \<open>\<forall>z \<in> F. R z min \<longrightarrow> \<not> P z\<close> by simp
             qed
           qed
         next
           case False
           show ?thesis
           proof (intro bexI conjI ballI impI)
             show "min \<in> insert x F"
               using \<open>min \<in> F\<close> by simp
           next
             show "P min"
               using \<open>P min\<close> by simp
           next
             fix z assume "z \<in> insert x F" and "R z min"
             hence "z = x \<or> z \<in> F"
               by simp
             thus "\<not> P z"
             proof (rule disjE)
               assume "z = x"
               hence False
                 using \<open>\<not> R x min\<close> \<open>R z min\<close> by simp
               thus ?thesis ..
             next
               assume "z \<in> F"
               thus ?thesis
                 using \<open>R z min\<close> \<open>\<forall>z\<in>F. R z min \<longrightarrow> \<not> P z\<close> by simp
             qed
           qed
         qed
       qed
     next
       case False
       then show ?thesis
         using \<open>\<exists>a\<in>insert x F. P a\<close>
         using \<open>asymp_on (insert x F) R\<close>[THEN asymp_onD, of x] insert_iff[of _ x F]
         by blast
     qed
   next
     case False
     with insert.prems have "\<exists>x \<in> F. P x"
       by simp
     with insert.IH have
       "\<exists>y \<in> F. P y \<and> (\<forall>z\<in>F. R z y \<longrightarrow> \<not> P z)"
       "\<exists>y \<in> F. P y \<and> (\<forall>z\<in>F. R y z \<longrightarrow> \<not> P z)"
       using \<open>asymp_on F R\<close> \<open>transp_on F R\<close> by auto
     thus ?thesis
       using False by auto
   qed
 qed
 
 qualified lemma
   assumes "finite A" and "asymp_on A R" and "transp_on A R" and "A \<noteq> {}"
   shows
     bex_min_element: "\<exists>m \<in> A. \<forall>x \<in> A. x \<noteq> m \<longrightarrow> \<not> R x m" and
     bex_max_element: "\<exists>m \<in> A. \<forall>x \<in> A. x \<noteq> m \<longrightarrow> \<not> R m x"
   using \<open>A \<noteq> {}\<close>
     bex_min_element_with_property[OF assms(1,2,3), of "\<lambda>_. True", simplified]
     bex_max_element_with_property[OF assms(1,2,3), of "\<lambda>_. True", simplified]
   by blast+
 
 end
 
 text \<open>The following alternative form might sometimes be easier to work with.\<close>
 
 lemma is_min_element_in_set_iff:
   "asymp_on A R \<Longrightarrow> (\<forall>y \<in> A. y \<noteq> x \<longrightarrow> \<not> R y x) \<longleftrightarrow> (\<forall>y. R y x \<longrightarrow> y \<notin> A)"
   by (auto dest: asymp_onD)
 
 lemma is_max_element_in_set_iff:
   "asymp_on A R \<Longrightarrow> (\<forall>y \<in> A. y \<noteq> x \<longrightarrow> \<not> R x y) \<longleftrightarrow> (\<forall>y. R x y \<longrightarrow> y \<notin> A)"
   by (auto dest: asymp_onD)
 
 context begin
 
 qualified lemma
   assumes "finite A" and "A \<noteq> {}" and "transp_on A R" and "totalp_on A R"
   shows
     bex_least_element: "\<exists>l \<in> A. \<forall>x \<in> A. x \<noteq> l \<longrightarrow> R l x" and
     bex_greatest_element: "\<exists>g \<in> A. \<forall>x \<in> A. x \<noteq> g \<longrightarrow> R x g"
   unfolding atomize_conj
   using assms
 proof (induction A rule: finite_induct)
   case empty
   hence False by simp
   thus ?case ..
 next
   case (insert a A')
 
   from insert.prems(2) have transp_on_A': "transp_on A' R"
     by (auto intro: transp_onI dest: transp_onD)
 
   from insert.prems(3) have
     totalp_on_a_A'_raw: "\<forall>y \<in> A'. a \<noteq> y \<longrightarrow> R a y \<or> R y a" and
     totalp_on_A': "totalp_on A' R"
     by (simp_all add: totalp_on_def)
 
   show ?case
   proof (cases "A' = {}")
     case True
     thus ?thesis by simp
   next
     case False
     then obtain least greatest where
       "least \<in> A'" and least_of_A': "\<forall>x\<in>A'. x \<noteq> least \<longrightarrow> R least x" and
       "greatest \<in> A'" and greatest_of_A': "\<forall>x\<in>A'. x \<noteq> greatest \<longrightarrow> R x greatest"
       using insert.IH[OF _ transp_on_A' totalp_on_A'] by auto
 
     show ?thesis
     proof (rule conjI)
       show "\<exists>l\<in>insert a A'. \<forall>x\<in>insert a A'. x \<noteq> l \<longrightarrow> R l x"
       proof (cases "R a least")
         case True
         show ?thesis
         proof (intro bexI ballI impI)
           show "a \<in> insert a A'"
             by simp
         next
           fix x
           show "\<And>x. x \<in> insert a A' \<Longrightarrow> x \<noteq> a \<Longrightarrow> R a x"
             using True \<open>least \<in> A'\<close> least_of_A'
             using insert.prems(2)[THEN transp_onD, of a least]
             by auto
         qed
       next
         case False
         show ?thesis
         proof (intro bexI ballI impI)
           show "least \<in> insert a A'"
             using \<open>least \<in> A'\<close> by simp
         next
           fix x
           show "x \<in> insert a A' \<Longrightarrow> x \<noteq> least \<Longrightarrow> R least x"
             using False \<open>least \<in> A'\<close> least_of_A' totalp_on_a_A'_raw
             by (cases "x = a") auto
         qed
       qed
     next
       show "\<exists>g \<in> insert a A'. \<forall>x \<in> insert a A'. x \<noteq> g \<longrightarrow> R x g"
       proof (cases "R greatest a")
         case True
         show ?thesis
         proof (intro bexI ballI impI)
           show "a \<in> insert a A'"
             by simp
         next
           fix x
           show "\<And>x. x \<in> insert a A' \<Longrightarrow> x \<noteq> a \<Longrightarrow> R x a"
             using True \<open>greatest \<in> A'\<close> greatest_of_A'
             using insert.prems(2)[THEN transp_onD, of _ greatest a]
             by auto
         qed
       next
         case False
         show ?thesis
         proof (intro bexI ballI impI)
           show "greatest \<in> insert a A'"
             using \<open>greatest \<in> A'\<close> by simp
         next
           fix x
           show "x \<in> insert a A' \<Longrightarrow> x \<noteq> greatest \<Longrightarrow> R x greatest"
             using False \<open>greatest \<in> A'\<close> greatest_of_A' totalp_on_a_A'_raw
             by (cases "x = a") auto
         qed
       qed
     qed
   qed
 qed
 
 end
 
 subsubsection \<open>Finite orders\<close>
 
 context order
 begin
 
 lemma finite_has_maximal:
   assumes "finite A" and "A \<noteq> {}"
   shows "\<exists> m \<in> A. \<forall> b \<in> A. m \<le> b \<longrightarrow> m = b"
 proof -
   obtain m where "m \<in> A" and m_is_max: "\<forall>x\<in>A. x \<noteq> m \<longrightarrow> \<not> m < x"
     using Finite_Set.bex_max_element[OF \<open>finite A\<close> _ _ \<open>A \<noteq> {}\<close>, of "(<)"] by auto
   moreover have "\<forall>b \<in> A. m \<le> b \<longrightarrow> m = b"
     using m_is_max by (auto simp: le_less)
   ultimately show ?thesis
     by auto
 qed
 
 lemma finite_has_maximal2:
   "\<lbrakk> finite A; a \<in> A \<rbrakk> \<Longrightarrow> \<exists> m \<in> A. a \<le> m \<and> (\<forall> b \<in> A. m \<le> b \<longrightarrow> m = b)"
 using finite_has_maximal[of "{b \<in> A. a \<le> b}"] by fastforce
 
 lemma finite_has_minimal:
   assumes "finite A" and "A \<noteq> {}"
   shows "\<exists> m \<in> A. \<forall> b \<in> A. b \<le> m \<longrightarrow> m = b"
 proof -
   obtain m where "m \<in> A" and m_is_min: "\<forall>x\<in>A. x \<noteq> m \<longrightarrow> \<not> x < m"
     using Finite_Set.bex_min_element[OF \<open>finite A\<close> _ _ \<open>A \<noteq> {}\<close>, of "(<)"] by auto
   moreover have "\<forall>b \<in> A. b \<le> m \<longrightarrow> m = b"
     using m_is_min by (auto simp: le_less)
   ultimately show ?thesis
     by auto
 qed
 
 lemma finite_has_minimal2:
   "\<lbrakk> finite A; a \<in> A \<rbrakk> \<Longrightarrow> \<exists> m \<in> A. m \<le> a \<and> (\<forall> b \<in> A. b \<le> m \<longrightarrow> m = b)"
 using finite_has_minimal[of "{b \<in> A. b \<le> a}"] by fastforce
 
 end
 
 subsubsection \<open>Relating injectivity and surjectivity\<close>
 
 lemma finite_surj_inj:
   assumes "finite A" "A \<subseteq> f ` A"
   shows "inj_on f A"
 proof -
   have "f ` A = A"
     by (rule card_seteq [THEN sym]) (auto simp add: assms card_image_le)
   then show ?thesis using assms
     by (simp add: eq_card_imp_inj_on)
 qed
 
 lemma finite_UNIV_surj_inj: "finite(UNIV:: 'a set) \<Longrightarrow> surj f \<Longrightarrow> inj f"
   for f :: "'a \<Rightarrow> 'a"
   by (blast intro: finite_surj_inj subset_UNIV)
 
 lemma finite_UNIV_inj_surj: "finite(UNIV:: 'a set) \<Longrightarrow> inj f \<Longrightarrow> surj f"
   for f :: "'a \<Rightarrow> 'a"
   by (fastforce simp:surj_def dest!: endo_inj_surj)
 
 lemma surjective_iff_injective_gen:
   assumes fS: "finite S"
     and fT: "finite T"
     and c: "card S = card T"
     and ST: "f ` S \<subseteq> T"
   shows "(\<forall>y \<in> T. \<exists>x \<in> S. f x = y) \<longleftrightarrow> inj_on f S"
   (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume h: "?lhs"
   {
     fix x y
     assume x: "x \<in> S"
     assume y: "y \<in> S"
     assume f: "f x = f y"
     from x fS have S0: "card S \<noteq> 0"
       by auto
     have "x = y"
     proof (rule ccontr)
       assume xy: "\<not> ?thesis"
       have th: "card S \<le> card (f ` (S - {y}))"
         unfolding c
       proof (rule card_mono)
         show "finite (f ` (S - {y}))"
           by (simp add: fS)
         have "\<lbrakk>x \<noteq> y; x \<in> S; z \<in> S; f x = f y\<rbrakk>
          \<Longrightarrow> \<exists>x \<in> S. x \<noteq> y \<and> f z = f x" for z
           by (cases "z = y \<longrightarrow> z = x") auto
         then show "T \<subseteq> f ` (S - {y})"
           using h xy x y f by fastforce
       qed
       also have " \<dots> \<le> card (S - {y})"
         by (simp add: card_image_le fS)
       also have "\<dots> \<le> card S - 1" using y fS by simp
       finally show False using S0 by arith
     qed
   }
   then show ?rhs
     unfolding inj_on_def by blast
 next
   assume h: ?rhs
   have "f ` S = T"
     by (simp add: ST c card_image card_subset_eq fT h)
   then show ?lhs by blast
 qed
 
 hide_const (open) Finite_Set.fold
 
 
 subsection \<open>Infinite Sets\<close>
 
 text \<open>
   Some elementary facts about infinite sets, mostly by Stephan Merz.
   Beware! Because "infinite" merely abbreviates a negation, these
   lemmas may not work well with \<open>blast\<close>.
 \<close>
 
 abbreviation infinite :: "'a set \<Rightarrow> bool"
   where "infinite S \<equiv> \<not> finite S"
 
 text \<open>
   Infinite sets are non-empty, and if we remove some elements from an
   infinite set, the result is still infinite.
 \<close>
 
 lemma infinite_UNIV_nat [iff]: "infinite (UNIV :: nat set)"
 proof
   assume "finite (UNIV :: nat set)"
   with finite_UNIV_inj_surj [of Suc] show False
     by simp (blast dest: Suc_neq_Zero surjD)
 qed
 
 lemma infinite_UNIV_char_0: "infinite (UNIV :: 'a::semiring_char_0 set)"
 proof
   assume "finite (UNIV :: 'a set)"
   with subset_UNIV have "finite (range of_nat :: 'a set)"
     by (rule finite_subset)
   moreover have "inj (of_nat :: nat \<Rightarrow> 'a)"
     by (simp add: inj_on_def)
   ultimately have "finite (UNIV :: nat set)"
     by (rule finite_imageD)
   then show False
     by simp
 qed
 
 lemma infinite_imp_nonempty: "infinite S \<Longrightarrow> S \<noteq> {}"
   by auto
 
 lemma infinite_remove: "infinite S \<Longrightarrow> infinite (S - {a})"
   by simp
 
 lemma Diff_infinite_finite:
   assumes "finite T" "infinite S"
   shows "infinite (S - T)"
   using \<open>finite T\<close>
 proof induct
   from \<open>infinite S\<close> show "infinite (S - {})"
     by auto
 next
   fix T x
   assume ih: "infinite (S - T)"
   have "S - (insert x T) = (S - T) - {x}"
     by (rule Diff_insert)
   with ih show "infinite (S - (insert x T))"
     by (simp add: infinite_remove)
 qed
 
 lemma Un_infinite: "infinite S \<Longrightarrow> infinite (S \<union> T)"
   by simp
 
 lemma infinite_Un: "infinite (S \<union> T) \<longleftrightarrow> infinite S \<or> infinite T"
   by simp
 
 lemma infinite_super:
   assumes "S \<subseteq> T"
     and "infinite S"
   shows "infinite T"
 proof
   assume "finite T"
   with \<open>S \<subseteq> T\<close> have "finite S" by (simp add: finite_subset)
   with \<open>infinite S\<close> show False by simp
 qed
 
 proposition infinite_coinduct [consumes 1, case_names infinite]:
   assumes "X A"
     and step: "\<And>A. X A \<Longrightarrow> \<exists>x\<in>A. X (A - {x}) \<or> infinite (A - {x})"
   shows "infinite A"
 proof
   assume "finite A"
   then show False
     using \<open>X A\<close>
   proof (induction rule: finite_psubset_induct)
     case (psubset A)
     then obtain x where "x \<in> A" "X (A - {x}) \<or> infinite (A - {x})"
       using local.step psubset.prems by blast
     then have "X (A - {x})"
       using psubset.hyps by blast
     show False
     proof (rule psubset.IH [where B = "A - {x}"])
       show "A - {x} \<subset> A"
         using \<open>x \<in> A\<close> by blast
     qed fact
   qed
 qed
 
 text \<open>
   For any function with infinite domain and finite range there is some
   element that is the image of infinitely many domain elements.  In
   particular, any infinite sequence of elements from a finite set
   contains some element that occurs infinitely often.
 \<close>
 
 lemma inf_img_fin_dom':
   assumes img: "finite (f ` A)"
     and dom: "infinite A"
   shows "\<exists>y \<in> f ` A. infinite (f -` {y} \<inter> A)"
 proof (rule ccontr)
   have "A \<subseteq> (\<Union>y\<in>f ` A. f -` {y} \<inter> A)" by auto
   moreover assume "\<not> ?thesis"
   with img have "finite (\<Union>y\<in>f ` A. f -` {y} \<inter> A)" by blast
   ultimately have "finite A" by (rule finite_subset)
   with dom show False by contradiction
 qed
 
 lemma inf_img_fin_domE':
   assumes "finite (f ` A)" and "infinite A"
   obtains y where "y \<in> f`A" and "infinite (f -` {y} \<inter> A)"
   using assms by (blast dest: inf_img_fin_dom')
 
 lemma inf_img_fin_dom:
   assumes img: "finite (f`A)" and dom: "infinite A"
   shows "\<exists>y \<in> f`A. infinite (f -` {y})"
   using inf_img_fin_dom'[OF assms] by auto
 
 lemma inf_img_fin_domE:
   assumes "finite (f`A)" and "infinite A"
   obtains y where "y \<in> f`A" and "infinite (f -` {y})"
   using assms by (blast dest: inf_img_fin_dom)
 
 proposition finite_image_absD: "finite (abs ` S) \<Longrightarrow> finite S"
   for S :: "'a::linordered_ring set"
   by (rule ccontr) (auto simp: abs_eq_iff vimage_def dest: inf_img_fin_dom)
 
 
 subsection \<open>The finite powerset operator\<close>
 
 definition Fpow :: "'a set \<Rightarrow> 'a set set"
 where "Fpow A \<equiv> {X. X \<subseteq> A \<and> finite X}"
 
 lemma Fpow_mono: "A \<subseteq> B \<Longrightarrow> Fpow A \<subseteq> Fpow B"
 unfolding Fpow_def by auto
 
 lemma empty_in_Fpow: "{} \<in> Fpow A"
 unfolding Fpow_def by auto
 
 lemma Fpow_not_empty: "Fpow A \<noteq> {}"
 using empty_in_Fpow by blast
 
 lemma Fpow_subset_Pow: "Fpow A \<subseteq> Pow A"
 unfolding Fpow_def by auto
 
 lemma Fpow_Pow_finite: "Fpow A = Pow A Int {A. finite A}"
 unfolding Fpow_def Pow_def by blast
 
 lemma inj_on_image_Fpow:
   assumes "inj_on f A"
   shows "inj_on (image f) (Fpow A)"
   using assms Fpow_subset_Pow[of A] subset_inj_on[of "image f" "Pow A"]
     inj_on_image_Pow by blast
 
 lemma image_Fpow_mono:
   assumes "f ` A \<subseteq> B"
   shows "(image f) ` (Fpow A) \<subseteq> Fpow B"
   using assms by(unfold Fpow_def, auto)
 
 end
diff --git a/src/HOL/Fun.thy b/src/HOL/Fun.thy
--- a/src/HOL/Fun.thy
+++ b/src/HOL/Fun.thy
@@ -1,1410 +1,1410 @@
 (*  Title:      HOL/Fun.thy
     Author:     Tobias Nipkow, Cambridge University Computer Laboratory
     Author:     Andrei Popescu, TU Muenchen
     Copyright   1994, 2012
 *)
 
 section \<open>Notions about functions\<close>
 
 theory Fun
   imports Set
   keywords "functor" :: thy_goal_defn
 begin
 
 lemma apply_inverse: "f x = u \<Longrightarrow> (\<And>x. P x \<Longrightarrow> g (f x) = x) \<Longrightarrow> P x \<Longrightarrow> x = g u"
   by auto
 
 text \<open>Uniqueness, so NOT the axiom of choice.\<close>
 lemma uniq_choice: "\<forall>x. \<exists>!y. Q x y \<Longrightarrow> \<exists>f. \<forall>x. Q x (f x)"
   by (force intro: theI')
 
 lemma b_uniq_choice: "\<forall>x\<in>S. \<exists>!y. Q x y \<Longrightarrow> \<exists>f. \<forall>x\<in>S. Q x (f x)"
   by (force intro: theI')
 
 
 subsection \<open>The Identity Function \<open>id\<close>\<close>
 
 definition id :: "'a \<Rightarrow> 'a"
   where "id = (\<lambda>x. x)"
 
 lemma id_apply [simp]: "id x = x"
   by (simp add: id_def)
 
 lemma image_id [simp]: "image id = id"
   by (simp add: id_def fun_eq_iff)
 
 lemma vimage_id [simp]: "vimage id = id"
   by (simp add: id_def fun_eq_iff)
 
 lemma eq_id_iff: "(\<forall>x. f x = x) \<longleftrightarrow> f = id"
   by auto
 
 code_printing
   constant id \<rightharpoonup> (Haskell) "id"
 
 
 subsection \<open>The Composition Operator \<open>f \<circ> g\<close>\<close>
 
 definition comp :: "('b \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'c"  (infixl "\<circ>" 55)
   where "f \<circ> g = (\<lambda>x. f (g x))"
 
 notation (ASCII)
   comp  (infixl "o" 55)
 
 lemma comp_apply [simp]: "(f \<circ> g) x = f (g x)"
   by (simp add: comp_def)
 
 lemma comp_assoc: "(f \<circ> g) \<circ> h = f \<circ> (g \<circ> h)"
   by (simp add: fun_eq_iff)
 
 lemma id_comp [simp]: "id \<circ> g = g"
   by (simp add: fun_eq_iff)
 
 lemma comp_id [simp]: "f \<circ> id = f"
   by (simp add: fun_eq_iff)
 
 lemma comp_eq_dest: "a \<circ> b = c \<circ> d \<Longrightarrow> a (b v) = c (d v)"
   by (simp add: fun_eq_iff)
 
 lemma comp_eq_elim: "a \<circ> b = c \<circ> d \<Longrightarrow> ((\<And>v. a (b v) = c (d v)) \<Longrightarrow> R) \<Longrightarrow> R"
   by (simp add: fun_eq_iff)
 
 lemma comp_eq_dest_lhs: "a \<circ> b = c \<Longrightarrow> a (b v) = c v"
   by clarsimp
 
 lemma comp_eq_id_dest: "a \<circ> b = id \<circ> c \<Longrightarrow> a (b v) = c v"
   by clarsimp
 
 lemma image_comp: "f ` (g ` r) = (f \<circ> g) ` r"
   by auto
 
 lemma vimage_comp: "f -` (g -` x) = (g \<circ> f) -` x"
   by auto
 
 lemma image_eq_imp_comp: "f ` A = g ` B \<Longrightarrow> (h \<circ> f) ` A = (h \<circ> g) ` B"
   by (auto simp: comp_def elim!: equalityE)
 
 lemma image_bind: "f ` (Set.bind A g) = Set.bind A ((`) f \<circ> g)"
   by (auto simp add: Set.bind_def)
 
 lemma bind_image: "Set.bind (f ` A) g = Set.bind A (g \<circ> f)"
   by (auto simp add: Set.bind_def)
 
 lemma (in group_add) minus_comp_minus [simp]: "uminus \<circ> uminus = id"
   by (simp add: fun_eq_iff)
 
 lemma (in boolean_algebra) minus_comp_minus [simp]: "uminus \<circ> uminus = id"
   by (simp add: fun_eq_iff)
 
 code_printing
   constant comp \<rightharpoonup> (SML) infixl 5 "o" and (Haskell) infixr 9 "."
 
 
 subsection \<open>The Forward Composition Operator \<open>fcomp\<close>\<close>
 
 definition fcomp :: "('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'c) \<Rightarrow> 'a \<Rightarrow> 'c"  (infixl "\<circ>>" 60)
   where "f \<circ>> g = (\<lambda>x. g (f x))"
 
 lemma fcomp_apply [simp]:  "(f \<circ>> g) x = g (f x)"
   by (simp add: fcomp_def)
 
 lemma fcomp_assoc: "(f \<circ>> g) \<circ>> h = f \<circ>> (g \<circ>> h)"
   by (simp add: fcomp_def)
 
 lemma id_fcomp [simp]: "id \<circ>> g = g"
   by (simp add: fcomp_def)
 
 lemma fcomp_id [simp]: "f \<circ>> id = f"
   by (simp add: fcomp_def)
 
 lemma fcomp_comp: "fcomp f g = comp g f"
   by (simp add: ext)
 
 code_printing
   constant fcomp \<rightharpoonup> (Eval) infixl 1 "#>"
 
 no_notation fcomp (infixl "\<circ>>" 60)
 
 
 subsection \<open>Mapping functions\<close>
 
 definition map_fun :: "('c \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> 'd) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'c \<Rightarrow> 'd"
   where "map_fun f g h = g \<circ> h \<circ> f"
 
 lemma map_fun_apply [simp]: "map_fun f g h x = g (h (f x))"
   by (simp add: map_fun_def)
 
 
 subsection \<open>Injectivity and Bijectivity\<close>
 
 definition inj_on :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> bool"  \<comment> \<open>injective\<close>
   where "inj_on f A \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>A. f x = f y \<longrightarrow> x = y)"
 
 definition bij_betw :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> bool"  \<comment> \<open>bijective\<close>
   where "bij_betw f A B \<longleftrightarrow> inj_on f A \<and> f ` A = B"
 
 text \<open>
   A common special case: functions injective, surjective or bijective over
   the entire domain type.
 \<close>
 
 abbreviation inj :: "('a \<Rightarrow> 'b) \<Rightarrow> bool"
   where "inj f \<equiv> inj_on f UNIV"
 
 abbreviation surj :: "('a \<Rightarrow> 'b) \<Rightarrow> bool"
   where "surj f \<equiv> range f = UNIV"
 
 translations \<comment> \<open>The negated case:\<close>
   "\<not> CONST surj f" \<leftharpoondown> "CONST range f \<noteq> CONST UNIV"
 
 abbreviation bij :: "('a \<Rightarrow> 'b) \<Rightarrow> bool"
   where "bij f \<equiv> bij_betw f UNIV UNIV"
 
 lemma inj_def: "inj f \<longleftrightarrow> (\<forall>x y. f x = f y \<longrightarrow> x = y)"
   unfolding inj_on_def by blast
 
 lemma injI: "(\<And>x y. f x = f y \<Longrightarrow> x = y) \<Longrightarrow> inj f"
   unfolding inj_def by blast
 
 theorem range_ex1_eq: "inj f \<Longrightarrow> b \<in> range f \<longleftrightarrow> (\<exists>!x. b = f x)"
   unfolding inj_def by blast
 
 lemma injD: "inj f \<Longrightarrow> f x = f y \<Longrightarrow> x = y"
   by (simp add: inj_def)
 
 lemma inj_on_eq_iff: "inj_on f A \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> f x = f y \<longleftrightarrow> x = y"
   by (auto simp: inj_on_def)
 
 lemma inj_on_cong: "(\<And>a. a \<in> A \<Longrightarrow> f a = g a) \<Longrightarrow> inj_on f A \<longleftrightarrow> inj_on g A"
   by (auto simp: inj_on_def)
 
 lemma image_strict_mono: "inj_on f B \<Longrightarrow> A \<subset> B \<Longrightarrow> f ` A \<subset> f ` B"
   unfolding inj_on_def by blast
 
 lemma inj_compose: "inj f \<Longrightarrow> inj g \<Longrightarrow> inj (f \<circ> g)"
   by (simp add: inj_def)
 
 lemma inj_fun: "inj f \<Longrightarrow> inj (\<lambda>x y. f x)"
   by (simp add: inj_def fun_eq_iff)
 
 lemma inj_eq: "inj f \<Longrightarrow> f x = f y \<longleftrightarrow> x = y"
   by (simp add: inj_on_eq_iff)
 
 lemma inj_on_iff_Uniq: "inj_on f A \<longleftrightarrow> (\<forall>x\<in>A. \<exists>\<^sub>\<le>\<^sub>1y. y\<in>A \<and> f x = f y)"
   by (auto simp: Uniq_def inj_on_def)
 
 lemma inj_on_id[simp]: "inj_on id A"
   by (simp add: inj_on_def)
 
 lemma inj_on_id2[simp]: "inj_on (\<lambda>x. x) A"
   by (simp add: inj_on_def)
 
 lemma inj_on_Int: "inj_on f A \<or> inj_on f B \<Longrightarrow> inj_on f (A \<inter> B)"
   unfolding inj_on_def by blast
 
 lemma surj_id: "surj id"
   by simp
 
 lemma bij_id[simp]: "bij id"
   by (simp add: bij_betw_def)
 
 lemma bij_uminus: "bij (uminus :: 'a \<Rightarrow> 'a::group_add)"
   unfolding bij_betw_def inj_on_def
   by (force intro: minus_minus [symmetric])
 
 lemma bij_betwE: "bij_betw f A B \<Longrightarrow> \<forall>a\<in>A. f a \<in> B"
   unfolding bij_betw_def by auto
 
 lemma inj_onI [intro?]: "(\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> f x = f y \<Longrightarrow> x = y) \<Longrightarrow> inj_on f A"
   by (simp add: inj_on_def)
 
 lemma inj_on_inverseI: "(\<And>x. x \<in> A \<Longrightarrow> g (f x) = x) \<Longrightarrow> inj_on f A"
   by (auto dest: arg_cong [of concl: g] simp add: inj_on_def)
 
 lemma inj_onD: "inj_on f A \<Longrightarrow> f x = f y \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x = y"
   unfolding inj_on_def by blast
 
 lemma inj_on_subset:
   assumes "inj_on f A"
     and "B \<subseteq> A"
   shows "inj_on f B"
 proof (rule inj_onI)
   fix a b
   assume "a \<in> B" and "b \<in> B"
   with assms have "a \<in> A" and "b \<in> A"
     by auto
   moreover assume "f a = f b"
   ultimately show "a = b"
     using assms by (auto dest: inj_onD)
 qed
 
 lemma comp_inj_on: "inj_on f A \<Longrightarrow> inj_on g (f ` A) \<Longrightarrow> inj_on (g \<circ> f) A"
   by (simp add: comp_def inj_on_def)
 
 lemma inj_on_imageI: "inj_on (g \<circ> f) A \<Longrightarrow> inj_on g (f ` A)"
   by (auto simp add: inj_on_def)
 
 lemma inj_on_image_iff:
   "\<forall>x\<in>A. \<forall>y\<in>A. g (f x) = g (f y) \<longleftrightarrow> g x = g y \<Longrightarrow> inj_on f A \<Longrightarrow> inj_on g (f ` A) \<longleftrightarrow> inj_on g A"
   unfolding inj_on_def by blast
 
 lemma inj_on_contraD: "inj_on f A \<Longrightarrow> x \<noteq> y \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> f x \<noteq> f y"
   unfolding inj_on_def by blast
 
 lemma inj_singleton [simp]: "inj_on (\<lambda>x. {x}) A"
   by (simp add: inj_on_def)
 
 lemma inj_on_empty[iff]: "inj_on f {}"
   by (simp add: inj_on_def)
 
 lemma subset_inj_on: "inj_on f B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> inj_on f A"
   unfolding inj_on_def by blast
 
 lemma inj_on_Un: "inj_on f (A \<union> B) \<longleftrightarrow> inj_on f A \<and> inj_on f B \<and> f ` (A - B) \<inter> f ` (B - A) = {}"
   unfolding inj_on_def by (blast intro: sym)
 
 lemma inj_on_insert [iff]: "inj_on f (insert a A) \<longleftrightarrow> inj_on f A \<and> f a \<notin> f ` (A - {a})"
   unfolding inj_on_def by (blast intro: sym)
 
 lemma inj_on_diff: "inj_on f A \<Longrightarrow> inj_on f (A - B)"
   unfolding inj_on_def by blast
 
 lemma comp_inj_on_iff: "inj_on f A \<Longrightarrow> inj_on f' (f ` A) \<longleftrightarrow> inj_on (f' \<circ> f) A"
   by (auto simp: comp_inj_on inj_on_def)
 
 lemma inj_on_imageI2: "inj_on (f' \<circ> f) A \<Longrightarrow> inj_on f A"
   by (auto simp: comp_inj_on inj_on_def)
 
 lemma inj_img_insertE:
   assumes "inj_on f A"
   assumes "x \<notin> B"
     and "insert x B = f ` A"
   obtains x' A' where "x' \<notin> A'" and "A = insert x' A'" and "x = f x'" and "B = f ` A'"
 proof -
   from assms have "x \<in> f ` A" by auto
   then obtain x' where *: "x' \<in> A" "x = f x'" by auto
   then have A: "A = insert x' (A - {x'})" by auto
   with assms * have B: "B = f ` (A - {x'})" by (auto dest: inj_on_contraD)
   have "x' \<notin> A - {x'}" by simp
   from this A \<open>x = f x'\<close> B show ?thesis ..
 qed
 
 lemma linorder_inj_onI:
   fixes A :: "'a::order set"
   assumes ne: "\<And>x y. \<lbrakk>x < y; x\<in>A; y\<in>A\<rbrakk> \<Longrightarrow> f x \<noteq> f y" and lin: "\<And>x y. \<lbrakk>x\<in>A; y\<in>A\<rbrakk> \<Longrightarrow> x\<le>y \<or> y\<le>x"
   shows "inj_on f A"
 proof (rule inj_onI)
   fix x y
   assume eq: "f x = f y" and "x\<in>A" "y\<in>A"
   then show "x = y"
     using lin [of x y] ne by (force simp: dual_order.order_iff_strict)
 qed
 
 lemma linorder_inj_onI':
   fixes A :: "'a :: linorder set"
   assumes "\<And>i j. i \<in> A \<Longrightarrow> j \<in> A \<Longrightarrow> i < j \<Longrightarrow> f i \<noteq> f j"
   shows   "inj_on f A"
   by (intro linorder_inj_onI) (auto simp add: assms)
 
 lemma linorder_injI:
   assumes "\<And>x y::'a::linorder. x < y \<Longrightarrow> f x \<noteq> f y"
   shows "inj f"
     \<comment> \<open>Courtesy of Stephan Merz\<close>
 using assms by (simp add: linorder_inj_onI')
 
 lemma inj_on_image_Pow: "inj_on f A \<Longrightarrow>inj_on (image f) (Pow A)"
   unfolding Pow_def inj_on_def by blast
 
 lemma bij_betw_image_Pow: "bij_betw f A B \<Longrightarrow> bij_betw (image f) (Pow A) (Pow B)"
   by (auto simp add: bij_betw_def inj_on_image_Pow image_Pow_surj)
 
 lemma surj_def: "surj f \<longleftrightarrow> (\<forall>y. \<exists>x. y = f x)"
   by auto
 
 lemma surjI:
   assumes "\<And>x. g (f x) = x"
   shows "surj g"
   using assms [symmetric] by auto
 
 lemma surjD: "surj f \<Longrightarrow> \<exists>x. y = f x"
   by (simp add: surj_def)
 
 lemma surjE: "surj f \<Longrightarrow> (\<And>x. y = f x \<Longrightarrow> C) \<Longrightarrow> C"
   by (simp add: surj_def) blast
 
 lemma comp_surj: "surj f \<Longrightarrow> surj g \<Longrightarrow> surj (g \<circ> f)"
   using image_comp [of g f UNIV] by simp
 
 lemma bij_betw_imageI: "inj_on f A \<Longrightarrow> f ` A = B \<Longrightarrow> bij_betw f A B"
   unfolding bij_betw_def by clarify
 
 lemma bij_betw_imp_surj_on: "bij_betw f A B \<Longrightarrow> f ` A = B"
   unfolding bij_betw_def by clarify
 
 lemma bij_betw_imp_surj: "bij_betw f A UNIV \<Longrightarrow> surj f"
   unfolding bij_betw_def by auto
 
 lemma bij_betw_empty1: "bij_betw f {} A \<Longrightarrow> A = {}"
   unfolding bij_betw_def by blast
 
 lemma bij_betw_empty2: "bij_betw f A {} \<Longrightarrow> A = {}"
   unfolding bij_betw_def by blast
 
 lemma inj_on_imp_bij_betw: "inj_on f A \<Longrightarrow> bij_betw f A (f ` A)"
   unfolding bij_betw_def by simp
 
 lemma bij_betw_DiffI:
   assumes "bij_betw f A B" "bij_betw f C D" "C \<subseteq> A" "D \<subseteq> B"
   shows   "bij_betw f (A - C) (B - D)"
   using assms unfolding bij_betw_def inj_on_def by auto
 
 lemma bij_betw_singleton_iff [simp]: "bij_betw f {x} {y} \<longleftrightarrow> f x = y"
   by (auto simp: bij_betw_def)
 
 lemma bij_betw_singletonI [intro]: "f x = y \<Longrightarrow> bij_betw f {x} {y}"
   by auto
 
 lemma bij_betw_apply: "\<lbrakk>bij_betw f A B; a \<in> A\<rbrakk> \<Longrightarrow> f a \<in> B"
   unfolding bij_betw_def by auto
 
 lemma bij_def: "bij f \<longleftrightarrow> inj f \<and> surj f"
   by (rule bij_betw_def)
 
 lemma bijI: "inj f \<Longrightarrow> surj f \<Longrightarrow> bij f"
   by (rule bij_betw_imageI)
 
 lemma bij_is_inj: "bij f \<Longrightarrow> inj f"
   by (simp add: bij_def)
 
 lemma bij_is_surj: "bij f \<Longrightarrow> surj f"
   by (simp add: bij_def)
 
 lemma bij_betw_imp_inj_on: "bij_betw f A B \<Longrightarrow> inj_on f A"
   by (simp add: bij_betw_def)
 
 lemma bij_betw_trans: "bij_betw f A B \<Longrightarrow> bij_betw g B C \<Longrightarrow> bij_betw (g \<circ> f) A C"
   by (auto simp add:bij_betw_def comp_inj_on)
 
 lemma bij_comp: "bij f \<Longrightarrow> bij g \<Longrightarrow> bij (g \<circ> f)"
   by (rule bij_betw_trans)
 
 lemma bij_betw_comp_iff: "bij_betw f A A' \<Longrightarrow> bij_betw f' A' A'' \<longleftrightarrow> bij_betw (f' \<circ> f) A A''"
   by (auto simp add: bij_betw_def inj_on_def)
 
 lemma bij_betw_comp_iff2:
   assumes bij: "bij_betw f' A' A''"
     and img: "f ` A \<le> A'"
   shows "bij_betw f A A' \<longleftrightarrow> bij_betw (f' \<circ> f) A A''" (is "?L \<longleftrightarrow> ?R")
 proof
   assume "?L"
   then show "?R"
     using assms by (auto simp add: bij_betw_comp_iff)
   next
     assume *: "?R"
     have "inj_on (f' \<circ> f) A \<Longrightarrow> inj_on f A"
       using inj_on_imageI2 by blast
     moreover have "A' \<subseteq> f ` A"
     proof
       fix a'
       assume **: "a' \<in> A'"
       with bij have "f' a' \<in> A''"
         unfolding bij_betw_def by auto
       with * obtain a where 1: "a \<in> A \<and> f' (f a) = f' a'"
         unfolding bij_betw_def by force
       with img have "f a \<in> A'" by auto
       with bij ** 1 have "f a = a'"
         unfolding bij_betw_def inj_on_def by auto
       with 1 show "a' \<in> f ` A" by auto
     qed
     ultimately show "?L"
       using img * by (auto simp add: bij_betw_def)
 qed
 
 lemma bij_betw_inv:
   assumes "bij_betw f A B"
   shows "\<exists>g. bij_betw g B A"
 proof -
   have i: "inj_on f A" and s: "f ` A = B"
     using assms by (auto simp: bij_betw_def)
   let ?P = "\<lambda>b a. a \<in> A \<and> f a = b"
   let ?g = "\<lambda>b. The (?P b)"
   have g: "?g b = a" if P: "?P b a" for a b
   proof -
     from that s have ex1: "\<exists>a. ?P b a" by blast
     then have uex1: "\<exists>!a. ?P b a" by (blast dest:inj_onD[OF i])
     then show ?thesis
       using the1_equality[OF uex1, OF P] P by simp
   qed
   have "inj_on ?g B"
   proof (rule inj_onI)
     fix x y
     assume "x \<in> B" "y \<in> B" "?g x = ?g y"
     from s \<open>x \<in> B\<close> obtain a1 where a1: "?P x a1" by blast
     from s \<open>y \<in> B\<close> obtain a2 where a2: "?P y a2" by blast
     from g [OF a1] a1 g [OF a2] a2 \<open>?g x = ?g y\<close> show "x = y" by simp
   qed
   moreover have "?g ` B = A"
   proof safe
     fix b
     assume "b \<in> B"
     with s obtain a where P: "?P b a" by blast
     with g[OF P] show "?g b \<in> A" by auto
   next
     fix a
     assume "a \<in> A"
     with s obtain b where P: "?P b a" by blast
     with s have "b \<in> B" by blast
     with g[OF P] have "\<exists>b\<in>B. a = ?g b" by blast
     then show "a \<in> ?g ` B"
       by auto
   qed
   ultimately show ?thesis
     by (auto simp: bij_betw_def)
 qed
 
 lemma bij_betw_cong: "(\<And>a. a \<in> A \<Longrightarrow> f a = g a) \<Longrightarrow> bij_betw f A A' = bij_betw g A A'"
   unfolding bij_betw_def inj_on_def by safe force+  (* somewhat slow *)
 
 lemma bij_betw_id[intro, simp]: "bij_betw id A A"
   unfolding bij_betw_def id_def by auto
 
 lemma bij_betw_id_iff: "bij_betw id A B \<longleftrightarrow> A = B"
   by (auto simp add: bij_betw_def)
 
 lemma bij_betw_combine:
   "bij_betw f A B \<Longrightarrow> bij_betw f C D \<Longrightarrow> B \<inter> D = {} \<Longrightarrow> bij_betw f (A \<union> C) (B \<union> D)"
   unfolding bij_betw_def inj_on_Un image_Un by auto
 
 lemma bij_betw_subset: "bij_betw f A A' \<Longrightarrow> B \<subseteq> A \<Longrightarrow> f ` B = B' \<Longrightarrow> bij_betw f B B'"
   by (auto simp add: bij_betw_def inj_on_def)
 
 lemma bij_betw_ball: "bij_betw f A B \<Longrightarrow> (\<forall>b \<in> B. phi b) = (\<forall>a \<in> A. phi (f a))"
   unfolding bij_betw_def inj_on_def by blast
 
 lemma bij_pointE:
   assumes "bij f"
   obtains x where "y = f x" and "\<And>x'. y = f x' \<Longrightarrow> x' = x"
 proof -
   from assms have "inj f" by (rule bij_is_inj)
   moreover from assms have "surj f" by (rule bij_is_surj)
   then have "y \<in> range f" by simp
   ultimately have "\<exists>!x. y = f x" by (simp add: range_ex1_eq)
   with that show thesis by blast
 qed
 
 lemma bij_iff: \<^marker>\<open>contributor \<open>Amine Chaieb\<close>\<close>
   \<open>bij f \<longleftrightarrow> (\<forall>x. \<exists>!y. f y = x)\<close>  (is \<open>?P \<longleftrightarrow> ?Q\<close>)
 proof
   assume ?P
   then have \<open>inj f\<close> \<open>surj f\<close>
     by (simp_all add: bij_def)
   show ?Q
   proof
     fix y
     from \<open>surj f\<close> obtain x where \<open>y = f x\<close>
       by (auto simp add: surj_def)
     with \<open>inj f\<close> show \<open>\<exists>!x. f x = y\<close>
       by (auto simp add: inj_def)
   qed
 next
   assume ?Q
   then have \<open>inj f\<close>
     by (auto simp add: inj_def)
   moreover have \<open>\<exists>x. y = f x\<close> for y
   proof -
     from \<open>?Q\<close> obtain x where \<open>f x = y\<close>
       by blast
     then have \<open>y = f x\<close>
       by simp
     then show ?thesis ..
   qed
   then have \<open>surj f\<close>
     by (auto simp add: surj_def)
   ultimately show ?P
     by (rule bijI)
 qed
 
 lemma bij_betw_partition:
   \<open>bij_betw f A B\<close>
   if \<open>bij_betw f (A \<union> C) (B \<union> D)\<close> \<open>bij_betw f C D\<close> \<open>A \<inter> C = {}\<close> \<open>B \<inter> D = {}\<close>
 proof -
   from that have \<open>inj_on f (A \<union> C)\<close> \<open>inj_on f C\<close> \<open>f ` (A \<union> C) = B \<union> D\<close> \<open>f ` C = D\<close>
     by (simp_all add: bij_betw_def)
   then have \<open>inj_on f A\<close> and \<open>f ` (A - C) \<inter> f ` (C - A) = {}\<close>
     by (simp_all add: inj_on_Un)
   with \<open>A \<inter> C = {}\<close> have \<open>f ` A \<inter> f ` C = {}\<close>
     by auto
   with \<open>f ` (A \<union> C) = B \<union> D\<close> \<open>f ` C = D\<close>  \<open>B \<inter> D = {}\<close>
   have \<open>f ` A = B\<close>
     by blast
   with \<open>inj_on f A\<close> show ?thesis
     by (simp add: bij_betw_def)
 qed
 
 lemma surj_image_vimage_eq: "surj f \<Longrightarrow> f ` (f -` A) = A"
   by simp
 
 lemma surj_vimage_empty:
   assumes "surj f"
   shows "f -` A = {} \<longleftrightarrow> A = {}"
   using surj_image_vimage_eq [OF \<open>surj f\<close>, of A]
   by (intro iffI) fastforce+
 
 lemma inj_vimage_image_eq: "inj f \<Longrightarrow> f -` (f ` A) = A"
   unfolding inj_def by blast
 
 lemma vimage_subsetD: "surj f \<Longrightarrow> f -` B \<subseteq> A \<Longrightarrow> B \<subseteq> f ` A"
   by (blast intro: sym)
 
 lemma vimage_subsetI: "inj f \<Longrightarrow> B \<subseteq> f ` A \<Longrightarrow> f -` B \<subseteq> A"
   unfolding inj_def by blast
 
 lemma vimage_subset_eq: "bij f \<Longrightarrow> f -` B \<subseteq> A \<longleftrightarrow> B \<subseteq> f ` A"
   unfolding bij_def by (blast del: subsetI intro: vimage_subsetI vimage_subsetD)
 
 lemma inj_on_image_eq_iff: "inj_on f C \<Longrightarrow> A \<subseteq> C \<Longrightarrow> B \<subseteq> C \<Longrightarrow> f ` A = f ` B \<longleftrightarrow> A = B"
   by (fastforce simp: inj_on_def)
 
 lemma inj_on_Un_image_eq_iff: "inj_on f (A \<union> B) \<Longrightarrow> f ` A = f ` B \<longleftrightarrow> A = B"
   by (erule inj_on_image_eq_iff) simp_all
 
 lemma inj_on_image_Int: "inj_on f C \<Longrightarrow> A \<subseteq> C \<Longrightarrow> B \<subseteq> C \<Longrightarrow> f ` (A \<inter> B) = f ` A \<inter> f ` B"
   unfolding inj_on_def by blast
 
 lemma inj_on_image_set_diff: "inj_on f C \<Longrightarrow> A - B \<subseteq> C \<Longrightarrow> B \<subseteq> C \<Longrightarrow> f ` (A - B) = f ` A - f ` B"
   unfolding inj_on_def by blast
 
 lemma image_Int: "inj f \<Longrightarrow> f ` (A \<inter> B) = f ` A \<inter> f ` B"
   unfolding inj_def by blast
 
 lemma image_set_diff: "inj f \<Longrightarrow> f ` (A - B) = f ` A - f ` B"
   unfolding inj_def by blast
 
 lemma inj_on_image_mem_iff: "inj_on f B \<Longrightarrow> a \<in> B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> f a \<in> f ` A \<longleftrightarrow> a \<in> A"
   by (auto simp: inj_on_def)
 
 lemma inj_image_mem_iff: "inj f \<Longrightarrow> f a \<in> f ` A \<longleftrightarrow> a \<in> A"
   by (blast dest: injD)
 
 lemma inj_image_subset_iff: "inj f \<Longrightarrow> f ` A \<subseteq> f ` B \<longleftrightarrow> A \<subseteq> B"
   by (blast dest: injD)
 
 lemma inj_image_eq_iff: "inj f \<Longrightarrow> f ` A = f ` B \<longleftrightarrow> A = B"
   by (blast dest: injD)
 
 lemma surj_Compl_image_subset: "surj f \<Longrightarrow> - (f ` A) \<subseteq> f ` (- A)"
   by auto
 
 lemma inj_image_Compl_subset: "inj f \<Longrightarrow> f ` (- A) \<subseteq> - (f ` A)"
   by (auto simp: inj_def)
 
 lemma bij_image_Compl_eq: "bij f \<Longrightarrow> f ` (- A) = - (f ` A)"
   by (simp add: bij_def inj_image_Compl_subset surj_Compl_image_subset equalityI)
 
 lemma inj_vimage_singleton: "inj f \<Longrightarrow> f -` {a} \<subseteq> {THE x. f x = a}"
   \<comment> \<open>The inverse image of a singleton under an injective function is included in a singleton.\<close>
   by (simp add: inj_def) (blast intro: the_equality [symmetric])
 
 lemma inj_on_vimage_singleton: "inj_on f A \<Longrightarrow> f -` {a} \<inter> A \<subseteq> {THE x. x \<in> A \<and> f x = a}"
   by (auto simp add: inj_on_def intro: the_equality [symmetric])
 
 lemma bij_betw_byWitness:
   assumes left: "\<forall>a \<in> A. f' (f a) = a"
     and right: "\<forall>a' \<in> A'. f (f' a') = a'"
     and "f ` A \<subseteq> A'"
     and img2: "f' ` A' \<subseteq> A"
   shows "bij_betw f A A'"
   using assms
   unfolding bij_betw_def inj_on_def
 proof safe
   fix a b
   assume "a \<in> A" "b \<in> A"
   with left have "a = f' (f a) \<and> b = f' (f b)" by simp
   moreover assume "f a = f b"
   ultimately show "a = b" by simp
 next
   fix a' assume *: "a' \<in> A'"
   with img2 have "f' a' \<in> A" by blast
   moreover from * right have "a' = f (f' a')" by simp
   ultimately show "a' \<in> f ` A" by blast
 qed
 
 corollary notIn_Un_bij_betw:
   assumes "b \<notin> A"
     and "f b \<notin> A'"
     and "bij_betw f A A'"
   shows "bij_betw f (A \<union> {b}) (A' \<union> {f b})"
 proof -
   have "bij_betw f {b} {f b}"
     unfolding bij_betw_def inj_on_def by simp
   with assms show ?thesis
     using bij_betw_combine[of f A A' "{b}" "{f b}"] by blast
 qed
 
 lemma notIn_Un_bij_betw3:
   assumes "b \<notin> A"
     and "f b \<notin> A'"
   shows "bij_betw f A A' = bij_betw f (A \<union> {b}) (A' \<union> {f b})"
 proof
   assume "bij_betw f A A'"
   then show "bij_betw f (A \<union> {b}) (A' \<union> {f b})"
     using assms notIn_Un_bij_betw [of b A f A'] by blast
 next
   assume *: "bij_betw f (A \<union> {b}) (A' \<union> {f b})"
   have "f ` A = A'"
   proof safe
     fix a
     assume **: "a \<in> A"
     then have "f a \<in> A' \<union> {f b}"
       using * unfolding bij_betw_def by blast
     moreover
     have False if "f a = f b"
     proof -
       have "a = b"
         using * ** that unfolding bij_betw_def inj_on_def by blast
       with \<open>b \<notin> A\<close> ** show ?thesis by blast
     qed
     ultimately show "f a \<in> A'" by blast
   next
     fix a'
     assume **: "a' \<in> A'"
     then have "a' \<in> f ` (A \<union> {b})"
       using * by (auto simp add: bij_betw_def)
     then obtain a where 1: "a \<in> A \<union> {b} \<and> f a = a'" by blast
     moreover
     have False if "a = b" using 1 ** \<open>f b \<notin> A'\<close> that by blast
     ultimately have "a \<in> A" by blast
     with 1 show "a' \<in> f ` A" by blast
   qed
   then show "bij_betw f A A'"
     using * bij_betw_subset[of f "A \<union> {b}" _ A] by blast
 qed
 
 lemma inj_on_disjoint_Un:
   assumes "inj_on f A" and "inj_on g B" 
   and "f ` A \<inter> g ` B = {}"
   shows "inj_on (\<lambda>x. if x \<in> A then f x else g x) (A \<union> B)"
   using assms by (simp add: inj_on_def disjoint_iff) (blast)
 
 lemma bij_betw_disjoint_Un:
   assumes "bij_betw f A C" and "bij_betw g B D" 
   and "A \<inter> B = {}"
   and "C \<inter> D = {}"
   shows "bij_betw (\<lambda>x. if x \<in> A then f x else g x) (A \<union> B) (C \<union> D)"
   using assms by (auto simp: inj_on_disjoint_Un bij_betw_def)
 
 lemma involuntory_imp_bij:
   \<open>bij f\<close> if \<open>\<And>x. f (f x) = x\<close>
 proof (rule bijI)
   from that show \<open>surj f\<close>
     by (rule surjI)
   show \<open>inj f\<close>
   proof (rule injI)
     fix x y
     assume \<open>f x = f y\<close>
     then have \<open>f (f x) = f (f y)\<close>
       by simp
     then show \<open>x = y\<close>
       by (simp add: that)
   qed
 qed
 
 
 subsubsection \<open>Inj/surj/bij of Algebraic Operations\<close>
 
 context cancel_semigroup_add
 begin
 
 lemma inj_on_add [simp]:
   "inj_on ((+) a) A"
   by (rule inj_onI) simp
 
 lemma inj_on_add' [simp]:
   "inj_on (\<lambda>b. b + a) A"
   by (rule inj_onI) simp
 
 lemma bij_betw_add [simp]:
   "bij_betw ((+) a) A B \<longleftrightarrow> (+) a ` A = B"
   by (simp add: bij_betw_def)
 
 end
 
 context group_add
 begin
 
 lemma diff_left_imp_eq: "a - b = a - c \<Longrightarrow> b = c"
 unfolding add_uminus_conv_diff[symmetric]
 by(drule local.add_left_imp_eq) simp
 
 lemma inj_uminus[simp, intro]: "inj_on uminus A"
   by (auto intro!: inj_onI)
 
 lemma surj_uminus[simp]: "surj uminus"
 using surjI minus_minus by blast
 
 lemma surj_plus [simp]:
   "surj ((+) a)"
 proof (standard, simp, standard, simp)
   fix x
   have "x = a + (-a + x)" by (simp add: add.assoc)
   thus "x \<in> range ((+) a)" by blast
 qed
 
 lemma surj_plus_right [simp]:
   "surj (\<lambda>b. b+a)"
 proof (standard, simp, standard, simp)
   fix b show "b \<in> range (\<lambda>b. b+a)"
     using diff_add_cancel[of b a, symmetric] by blast
 qed
 
 lemma inj_on_diff_left [simp]:
   \<open>inj_on ((-) a) A\<close>
 by (auto intro: inj_onI dest!: diff_left_imp_eq)
 
 lemma inj_on_diff_right [simp]:
   \<open>inj_on (\<lambda>b. b - a) A\<close>
 by (auto intro: inj_onI simp add: algebra_simps)
 
 lemma surj_diff [simp]:
   "surj ((-) a)"
 proof (standard, simp, standard, simp)
   fix x
   have "x = a - (- x + a)" by (simp add: algebra_simps)
   thus "x \<in> range ((-) a)" by blast
 qed
 
 lemma surj_diff_right [simp]:
   "surj (\<lambda>x. x - a)"
 proof (standard, simp, standard, simp)
   fix x
   have "x = x + a - a" by simp
   thus "x \<in> range (\<lambda>x. x - a)" by fast
 qed
 
 lemma shows bij_plus: "bij ((+) a)" and bij_plus_right: "bij (\<lambda>x. x + a)"
   and bij_uminus: "bij uminus"
   and bij_diff: "bij ((-) a)" and bij_diff_right: "bij (\<lambda>x. x - a)"
 by(simp_all add: bij_def)
 
 lemma translation_subtract_Compl:
   "(\<lambda>x. x - a) ` (- t) = - ((\<lambda>x. x - a) ` t)"
 by(rule bij_image_Compl_eq)
   (auto simp add: bij_def surj_def inj_def diff_eq_eq intro!: add_diff_cancel[symmetric])
 
 lemma translation_diff:
   "(+) a ` (s - t) = ((+) a ` s) - ((+) a ` t)"
   by auto
 
 lemma translation_subtract_diff:
   "(\<lambda>x. x - a) ` (s - t) = ((\<lambda>x. x - a) ` s) - ((\<lambda>x. x - a) ` t)"
 by(rule image_set_diff)(simp add: inj_on_def diff_eq_eq)
 
 lemma translation_Int:
   "(+) a ` (s \<inter> t) = ((+) a ` s) \<inter> ((+) a ` t)"
   by auto
 
 lemma translation_subtract_Int:
   "(\<lambda>x. x - a) ` (s \<inter> t) = ((\<lambda>x. x - a) ` s) \<inter> ((\<lambda>x. x - a) ` t)"
 by(rule image_Int)(simp add: inj_on_def diff_eq_eq)
 
 end
 
 (* TODO: prove in group_add *)
 context ab_group_add
 begin
 
 lemma translation_Compl:
   "(+) a ` (- t) = - ((+) a ` t)"
 proof (rule set_eqI)
   fix b
   show "b \<in> (+) a ` (- t) \<longleftrightarrow> b \<in> - (+) a ` t"
     by (auto simp: image_iff algebra_simps intro!: bexI [of _ "b - a"])
 qed
 
 end
 
 
 subsection \<open>Function Updating\<close>
 
 definition fun_upd :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> 'b)"
   where "fun_upd f a b = (\<lambda>x. if x = a then b else f x)"
 
 nonterminal updbinds and updbind
 
 syntax
   "_updbind" :: "'a \<Rightarrow> 'a \<Rightarrow> updbind"             ("(2_ :=/ _)")
   ""         :: "updbind \<Rightarrow> updbinds"             ("_")
   "_updbinds":: "updbind \<Rightarrow> updbinds \<Rightarrow> updbinds" ("_,/ _")
   "_Update"  :: "'a \<Rightarrow> updbinds \<Rightarrow> 'a"            ("_/'((_)')" [1000, 0] 900)
 
 translations
   "_Update f (_updbinds b bs)" \<rightleftharpoons> "_Update (_Update f b) bs"
   "f(x:=y)" \<rightleftharpoons> "CONST fun_upd f x y"
 
 (* Hint: to define the sum of two functions (or maps), use case_sum.
          A nice infix syntax could be defined by
 notation
   case_sum  (infixr "'(+')"80)
 *)
 
 lemma fun_upd_idem_iff: "f(x:=y) = f \<longleftrightarrow> f x = y"
   unfolding fun_upd_def
   apply safe
    apply (erule subst)
    apply auto
   done
 
 lemma fun_upd_idem: "f x = y \<Longrightarrow> f(x := y) = f"
   by (simp only: fun_upd_idem_iff)
 
 lemma fun_upd_triv [iff]: "f(x := f x) = f"
   by (simp only: fun_upd_idem)
 
 lemma fun_upd_apply [simp]: "(f(x := y)) z = (if z = x then y else f z)"
   by (simp add: fun_upd_def)
 
 (* fun_upd_apply supersedes these two, but they are useful
    if fun_upd_apply is intentionally removed from the simpset *)
 lemma fun_upd_same: "(f(x := y)) x = y"
   by simp
 
 lemma fun_upd_other: "z \<noteq> x \<Longrightarrow> (f(x := y)) z = f z"
   by simp
 
 lemma fun_upd_upd [simp]: "f(x := y, x := z) = f(x := z)"
   by (simp add: fun_eq_iff)
 
 lemma fun_upd_twist: "a \<noteq> c \<Longrightarrow> (m(a := b))(c := d) = (m(c := d))(a := b)"
   by auto
 
 lemma inj_on_fun_updI: "inj_on f A \<Longrightarrow> y \<notin> f ` A \<Longrightarrow> inj_on (f(x := y)) A"
   by (auto simp: inj_on_def)
 
 lemma fun_upd_image: "f(x := y) ` A = (if x \<in> A then insert y (f ` (A - {x})) else f ` A)"
   by auto
 
 lemma fun_upd_comp: "f \<circ> (g(x := y)) = (f \<circ> g)(x := f y)"
   by auto
 
 lemma fun_upd_eqD: "f(x := y) = g(x := z) \<Longrightarrow> y = z"
   by (simp add: fun_eq_iff split: if_split_asm)
 
 
 subsection \<open>\<open>override_on\<close>\<close>
 
 definition override_on :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> 'b"
   where "override_on f g A = (\<lambda>a. if a \<in> A then g a else f a)"
 
 lemma override_on_emptyset[simp]: "override_on f g {} = f"
   by (simp add: override_on_def)
 
 lemma override_on_apply_notin[simp]: "a \<notin> A \<Longrightarrow> (override_on f g A) a = f a"
   by (simp add: override_on_def)
 
 lemma override_on_apply_in[simp]: "a \<in> A \<Longrightarrow> (override_on f g A) a = g a"
   by (simp add: override_on_def)
 
 lemma override_on_insert: "override_on f g (insert x X) = (override_on f g X)(x:=g x)"
   by (simp add: override_on_def fun_eq_iff)
 
 lemma override_on_insert': "override_on f g (insert x X) = (override_on (f(x:=g x)) g X)"
   by (simp add: override_on_def fun_eq_iff)
 
 
 subsection \<open>Inversion of injective functions\<close>
 
 definition the_inv_into :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'a)"
   where "the_inv_into A f = (\<lambda>x. THE y. y \<in> A \<and> f y = x)"
 
 lemma the_inv_into_f_f: "inj_on f A \<Longrightarrow> x \<in> A \<Longrightarrow> the_inv_into A f (f x) = x"
   unfolding the_inv_into_def inj_on_def by blast
 
 lemma f_the_inv_into_f: "inj_on f A \<Longrightarrow> y \<in> f ` A  \<Longrightarrow> f (the_inv_into A f y) = y"
   unfolding the_inv_into_def
   by (rule the1I2; blast dest: inj_onD)
 
 lemma f_the_inv_into_f_bij_betw:
   "bij_betw f A B \<Longrightarrow> (bij_betw f A B \<Longrightarrow> x \<in> B) \<Longrightarrow> f (the_inv_into A f x) = x"
   unfolding bij_betw_def by (blast intro: f_the_inv_into_f)
 
 lemma the_inv_into_into: "inj_on f A \<Longrightarrow> x \<in> f ` A \<Longrightarrow> A \<subseteq> B \<Longrightarrow> the_inv_into A f x \<in> B"
   unfolding the_inv_into_def
   by (rule the1I2; blast dest: inj_onD)
 
 lemma the_inv_into_onto [simp]: "inj_on f A \<Longrightarrow> the_inv_into A f ` (f ` A) = A"
   by (fast intro: the_inv_into_into the_inv_into_f_f [symmetric])
 
 lemma the_inv_into_f_eq: "inj_on f A \<Longrightarrow> f x = y \<Longrightarrow> x \<in> A \<Longrightarrow> the_inv_into A f y = x"
   by (force simp add: the_inv_into_f_f)
 
 lemma the_inv_into_comp:
   "inj_on f (g ` A) \<Longrightarrow> inj_on g A \<Longrightarrow> x \<in> f ` g ` A \<Longrightarrow>
     the_inv_into A (f \<circ> g) x = (the_inv_into A g \<circ> the_inv_into (g ` A) f) x"
   apply (rule the_inv_into_f_eq)
     apply (fast intro: comp_inj_on)
    apply (simp add: f_the_inv_into_f the_inv_into_into)
   apply (simp add: the_inv_into_into)
   done
 
 lemma inj_on_the_inv_into: "inj_on f A \<Longrightarrow> inj_on (the_inv_into A f) (f ` A)"
   by (auto intro: inj_onI simp: the_inv_into_f_f)
 
 lemma bij_betw_the_inv_into: "bij_betw f A B \<Longrightarrow> bij_betw (the_inv_into A f) B A"
   by (auto simp add: bij_betw_def inj_on_the_inv_into the_inv_into_into)
 
 lemma bij_betw_iff_bijections:
   "bij_betw f A B \<longleftrightarrow> (\<exists>g. (\<forall>x \<in> A. f x \<in> B \<and> g(f x) = x) \<and> (\<forall>y \<in> B. g y \<in> A \<and> f(g y) = y))"
   (is "?lhs = ?rhs")
 proof
   show "?lhs \<Longrightarrow> ?rhs"
     by (auto simp: bij_betw_def f_the_inv_into_f the_inv_into_f_f the_inv_into_into
         exI[where ?x="the_inv_into A f"])
 next
   show "?rhs \<Longrightarrow> ?lhs"
     by (force intro: bij_betw_byWitness)
 qed
 
 abbreviation the_inv :: "('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'a)"
   where "the_inv f \<equiv> the_inv_into UNIV f"
 
 lemma the_inv_f_f: "the_inv f (f x) = x" if "inj f"
   using that UNIV_I by (rule the_inv_into_f_f)
 
 
 subsection \<open>Monotonicity\<close>
 
 definition monotone_on :: "'a set \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
   where "monotone_on A orda ordb f \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>A. orda x y \<longrightarrow> ordb (f x) (f y))"
 
 abbreviation monotone :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
   where "monotone \<equiv> monotone_on UNIV"
 
 lemma monotone_def[no_atp]: "monotone orda ordb f \<longleftrightarrow> (\<forall>x y. orda x y \<longrightarrow> ordb (f x) (f y))"
   by (simp add: monotone_on_def)
 
 text \<open>Lemma @{thm [source] monotone_def} is provided for backward compatibility.\<close>
 
 lemma monotone_onI:
   "(\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> orda x y \<Longrightarrow> ordb (f x) (f y)) \<Longrightarrow> monotone_on A orda ordb f"
   by (simp add: monotone_on_def)
 
 lemma monotoneI[intro?]: "(\<And>x y. orda x y \<Longrightarrow> ordb (f x) (f y)) \<Longrightarrow> monotone orda ordb f"
   by (rule monotone_onI)
 
 lemma monotone_onD:
   "monotone_on A orda ordb f \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> orda x y \<Longrightarrow> ordb (f x) (f y)"
   by (simp add: monotone_on_def)
 
 lemma monotoneD[dest?]: "monotone orda ordb f \<Longrightarrow> orda x y \<Longrightarrow> ordb (f x) (f y)"
   by (rule monotone_onD[of UNIV, simplified])
 
 lemma monotone_on_subset: "monotone_on A orda ordb f \<Longrightarrow> B \<subseteq> A \<Longrightarrow> monotone_on B orda ordb f"
   by (auto intro: monotone_onI dest: monotone_onD)
 
 lemma monotone_on_empty[simp]: "monotone_on {} orda ordb f"
   by (auto intro: monotone_onI dest: monotone_onD)
 
 lemma monotone_on_o:
   assumes
     mono_f: "monotone_on A orda ordb f" and
     mono_g: "monotone_on B ordc orda g" and
     "g ` B \<subseteq> A"
   shows "monotone_on B ordc ordb (f \<circ> g)"
 proof (rule monotone_onI)
   fix x y assume "x \<in> B" and "y \<in> B" and "ordc x y"
   hence "orda (g x) (g y)"
     by (rule mono_g[THEN monotone_onD])
   moreover from \<open>g ` B \<subseteq> A\<close> \<open>x \<in> B\<close> \<open>y \<in> B\<close> have "g x \<in> A" and "g y \<in> A"
     unfolding image_subset_iff by simp_all
   ultimately show "ordb ((f \<circ> g) x) ((f \<circ> g) y)"
     using mono_f[THEN monotone_onD] by simp
 qed
 
 
 subsubsection \<open>Specializations For @{class ord} Type Class And More\<close>
 
 context ord begin
 
 abbreviation mono_on :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b :: ord) \<Rightarrow> bool"
   where "mono_on A \<equiv> monotone_on A (\<le>) (\<le>)"
 
 abbreviation strict_mono_on :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b :: ord) \<Rightarrow> bool"
   where "strict_mono_on A \<equiv> monotone_on A (<) (<)"
 
 abbreviation antimono_on :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b :: ord) \<Rightarrow> bool"
   where "antimono_on A \<equiv> monotone_on A (\<le>) (\<ge>)"
 
 abbreviation strict_antimono_on :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b :: ord) \<Rightarrow> bool"
   where "strict_antimono_on A \<equiv> monotone_on A (<) (>)"
 
 lemma mono_on_def[no_atp]: "mono_on A f \<longleftrightarrow> (\<forall>r s. r \<in> A \<and> s \<in> A \<and> r \<le> s \<longrightarrow> f r \<le> f s)"
   by (auto simp add: monotone_on_def)
 
 lemma strict_mono_on_def[no_atp]:
   "strict_mono_on A f \<longleftrightarrow> (\<forall>r s. r \<in> A \<and> s \<in> A \<and> r < s \<longrightarrow> f r < f s)"
   by (auto simp add: monotone_on_def)
 
 text \<open>Lemmas @{thm [source] mono_on_def} and @{thm [source] strict_mono_on_def} are provided for
 backward compatibility.\<close>
 
 lemma mono_onI:
   "(\<And>r s. r \<in> A \<Longrightarrow> s \<in> A \<Longrightarrow> r \<le> s \<Longrightarrow> f r \<le> f s) \<Longrightarrow> mono_on A f"
   by (rule monotone_onI)
 
 lemma strict_mono_onI:
   "(\<And>r s. r \<in> A \<Longrightarrow> s \<in> A \<Longrightarrow> r < s \<Longrightarrow> f r < f s) \<Longrightarrow> strict_mono_on A f"
   by (rule monotone_onI)
 
 lemma mono_onD: "\<lbrakk>mono_on A f; r \<in> A; s \<in> A; r \<le> s\<rbrakk> \<Longrightarrow> f r \<le> f s"
   by (rule monotone_onD)
 
 lemma strict_mono_onD: "\<lbrakk>strict_mono_on A f; r \<in> A; s \<in> A; r < s\<rbrakk> \<Longrightarrow> f r < f s"
   by (rule monotone_onD)
 
 lemma mono_on_subset: "mono_on A f \<Longrightarrow> B \<subseteq> A \<Longrightarrow> mono_on B f"
   by (rule monotone_on_subset)
 
 end
 
 lemma mono_on_greaterD:
   assumes "mono_on A g" "x \<in> A" "y \<in> A" "g x > (g (y::_::linorder) :: _ :: linorder)"
   shows "x > y"
 proof (rule ccontr)
   assume "\<not>x > y"
   hence "x \<le> y" by (simp add: not_less)
   from assms(1-3) and this have "g x \<le> g y" by (rule mono_onD)
   with assms(4) show False by simp
 qed
 
 context order begin
 
 abbreviation mono :: "('a \<Rightarrow> 'b::order) \<Rightarrow> bool"
   where "mono \<equiv> mono_on UNIV"
 
 abbreviation strict_mono :: "('a \<Rightarrow> 'b::order) \<Rightarrow> bool"
   where "strict_mono \<equiv> strict_mono_on UNIV"
 
 abbreviation antimono :: "('a \<Rightarrow> 'b::order) \<Rightarrow> bool"
   where "antimono \<equiv> monotone (\<le>) (\<lambda>x y. y \<le> x)"
 
 lemma mono_def[no_atp]: "mono f \<longleftrightarrow> (\<forall>x y. x \<le> y \<longrightarrow> f x \<le> f y)"
   by (simp add: monotone_on_def)
 
 lemma strict_mono_def[no_atp]: "strict_mono f \<longleftrightarrow> (\<forall>x y. x < y \<longrightarrow> f x < f y)"
   by (simp add: monotone_on_def)
 
 lemma antimono_def[no_atp]: "antimono f \<longleftrightarrow> (\<forall>x y. x \<le> y \<longrightarrow> f x \<ge> f y)"
   by (simp add: monotone_on_def)
 
 text \<open>Lemmas @{thm [source] mono_def}, @{thm [source] strict_mono_def}, and
 @{thm [source] antimono_def} are provided for backward compatibility.\<close>
 
 lemma monoI [intro?]: "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> mono f"
   by (rule monotoneI)
 
 lemma strict_monoI [intro?]: "(\<And>x y. x < y \<Longrightarrow> f x < f y) \<Longrightarrow> strict_mono f"
   by (rule monotoneI)
 
 lemma antimonoI [intro?]: "(\<And>x y. x \<le> y \<Longrightarrow> f x \<ge> f y) \<Longrightarrow> antimono f"
   by (rule monotoneI)
 
 lemma monoD [dest?]: "mono f \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
   by (rule monotoneD)
 
 lemma strict_monoD [dest?]: "strict_mono f \<Longrightarrow> x < y \<Longrightarrow> f x < f y"
   by (rule monotoneD)
 
 lemma antimonoD [dest?]: "antimono f \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<ge> f y"
   by (rule monotoneD)
 
 lemma monoE:
   assumes "mono f"
   assumes "x \<le> y"
   obtains "f x \<le> f y"
 proof
   from assms show "f x \<le> f y" by (simp add: mono_def)
 qed
 
 lemma antimonoE:
   fixes f :: "'a \<Rightarrow> 'b::order"
   assumes "antimono f"
   assumes "x \<le> y"
   obtains "f x \<ge> f y"
 proof
   from assms show "f x \<ge> f y" by (simp add: antimono_def)
 qed
 
 lemma mono_imp_mono_on: "mono f \<Longrightarrow> mono_on A f"
   by (rule monotone_on_subset[OF _ subset_UNIV])
 
 lemma strict_mono_mono [dest?]:
   assumes "strict_mono f"
   shows "mono f"
 proof (rule monoI)
   fix x y
   assume "x \<le> y"
   show "f x \<le> f y"
   proof (cases "x = y")
     case True then show ?thesis by simp
   next
     case False with \<open>x \<le> y\<close> have "x < y" by simp
     with assms strict_monoD have "f x < f y" by auto
     then show ?thesis by simp
 
   qed
 qed
 
 end
 
 context linorder begin
 
 lemma mono_invE:
   fixes f :: "'a \<Rightarrow> 'b::order"
   assumes "mono f"
   assumes "f x < f y"
   obtains "x \<le> y"
 proof
   show "x \<le> y"
   proof (rule ccontr)
     assume "\<not> x \<le> y"
     then have "y \<le> x" by simp
     with \<open>mono f\<close> obtain "f y \<le> f x" by (rule monoE)
     with \<open>f x < f y\<close> show False by simp
   qed
 qed
 
 lemma mono_strict_invE:
   fixes f :: "'a \<Rightarrow> 'b::order"
   assumes "mono f"
   assumes "f x < f y"
   obtains "x < y"
 proof
   show "x < y"
   proof (rule ccontr)
     assume "\<not> x < y"
     then have "y \<le> x" by simp
     with \<open>mono f\<close> obtain "f y \<le> f x" by (rule monoE)
     with \<open>f x < f y\<close> show False by simp
   qed
 qed
 
 lemma strict_mono_eq:
   assumes "strict_mono f"
   shows "f x = f y \<longleftrightarrow> x = y"
 proof
   assume "f x = f y"
   show "x = y" proof (cases x y rule: linorder_cases)
     case less with assms strict_monoD have "f x < f y" by auto
     with \<open>f x = f y\<close> show ?thesis by simp
   next
     case equal then show ?thesis .
   next
     case greater with assms strict_monoD have "f y < f x" by auto
     with \<open>f x = f y\<close> show ?thesis by simp
   qed
 qed simp
 
 lemma strict_mono_less_eq:
   assumes "strict_mono f"
   shows "f x \<le> f y \<longleftrightarrow> x \<le> y"
 proof
   assume "x \<le> y"
   with assms strict_mono_mono monoD show "f x \<le> f y" by auto
 next
   assume "f x \<le> f y"
   show "x \<le> y" proof (rule ccontr)
     assume "\<not> x \<le> y" then have "y < x" by simp
     with assms strict_monoD have "f y < f x" by auto
     with \<open>f x \<le> f y\<close> show False by simp
   qed
 qed
 
 lemma strict_mono_less:
   assumes "strict_mono f"
   shows "f x < f y \<longleftrightarrow> x < y"
   using assms
     by (auto simp add: less_le Orderings.less_le strict_mono_eq strict_mono_less_eq)
 
 end
 
 lemma strict_mono_inv:
   fixes f :: "('a::linorder) \<Rightarrow> ('b::linorder)"
   assumes "strict_mono f" and "surj f" and inv: "\<And>x. g (f x) = x"
   shows "strict_mono g"
 proof
   fix x y :: 'b assume "x < y"
   from \<open>surj f\<close> obtain x' y' where [simp]: "x = f x'" "y = f y'" by blast
   with \<open>x < y\<close> and \<open>strict_mono f\<close> have "x' < y'" by (simp add: strict_mono_less)
   with inv show "g x < g y" by simp
 qed
 
 lemma strict_mono_on_imp_inj_on:
   assumes "strict_mono_on A (f :: (_ :: linorder) \<Rightarrow> (_ :: preorder))"
   shows "inj_on f A"
 proof (rule inj_onI)
   fix x y assume "x \<in> A" "y \<in> A" "f x = f y"
   thus "x = y"
     by (cases x y rule: linorder_cases)
        (auto dest: strict_mono_onD[OF assms, of x y] strict_mono_onD[OF assms, of y x])
 qed
 
 lemma strict_mono_on_leD:
   assumes "strict_mono_on A (f :: (_ :: linorder) \<Rightarrow> _ :: preorder)" "x \<in> A" "y \<in> A" "x \<le> y"
   shows "f x \<le> f y"
 proof (cases "x = y")
   case True
   then show ?thesis by simp
 next
   case False
   with assms have "f x < f y"
     using strict_mono_onD[OF assms(1)] by simp
   then show ?thesis by (rule less_imp_le)
 qed
 
 lemma strict_mono_on_eqD:
   fixes f :: "(_ :: linorder) \<Rightarrow> (_ :: preorder)"
   assumes "strict_mono_on A f" "f x = f y" "x \<in> A" "y \<in> A"
   shows "y = x"
   using assms by (cases rule: linorder_cases) (auto dest: strict_mono_onD)
 
 lemma strict_mono_on_imp_mono_on:
   "strict_mono_on A (f :: (_ :: linorder) \<Rightarrow> _ :: preorder) \<Longrightarrow> mono_on A f"
   by (rule mono_onI, rule strict_mono_on_leD)
 
 lemma mono_imp_strict_mono:
   fixes f :: "'a::order \<Rightarrow> 'b::order"
   shows "\<lbrakk>mono_on S f; inj_on f S\<rbrakk> \<Longrightarrow> strict_mono_on S f"
   by (auto simp add: monotone_on_def order_less_le inj_on_eq_iff)
 
 lemma strict_mono_iff_mono:
   fixes f :: "'a::linorder \<Rightarrow> 'b::order"
   shows "strict_mono_on S f \<longleftrightarrow> mono_on S f \<and> inj_on f S"
 proof
   show "strict_mono_on S f \<Longrightarrow> mono_on S f \<and> inj_on f S"
     by (simp add: strict_mono_on_imp_inj_on strict_mono_on_imp_mono_on)
 qed (auto intro: mono_imp_strict_mono)
 
 lemma antimono_imp_strict_antimono:
   fixes f :: "'a::order \<Rightarrow> 'b::order"
   shows "\<lbrakk>antimono_on S f; inj_on f S\<rbrakk> \<Longrightarrow> strict_antimono_on S f"
   by (auto simp add: monotone_on_def order_less_le inj_on_eq_iff)
 
 lemma strict_antimono_iff_antimono:
   fixes f :: "'a::linorder \<Rightarrow> 'b::order"
   shows "strict_antimono_on S f \<longleftrightarrow> antimono_on S f \<and> inj_on f S"
 proof
   show "strict_antimono_on S f \<Longrightarrow> antimono_on S f \<and> inj_on f S"
     by (force simp add: monotone_on_def intro: linorder_inj_onI)
 qed (auto intro: antimono_imp_strict_antimono)
 
 lemma mono_compose: "mono Q \<Longrightarrow> mono (\<lambda>i x. Q i (f x))"
   unfolding mono_def le_fun_def by auto
 
 lemma mono_add:
   fixes a :: "'a::ordered_ab_semigroup_add" 
   shows "mono ((+) a)"
   by (simp add: add_left_mono monoI)
 
 lemma (in semilattice_inf) mono_inf: "mono f \<Longrightarrow> f (A \<sqinter> B) \<le> f A \<sqinter> f B"
   for f :: "'a \<Rightarrow> 'b::semilattice_inf"
   by (auto simp add: mono_def intro: Lattices.inf_greatest)
 
 lemma (in semilattice_sup) mono_sup: "mono f \<Longrightarrow> f A \<squnion> f B \<le> f (A \<squnion> B)"
   for f :: "'a \<Rightarrow> 'b::semilattice_sup"
   by (auto simp add: mono_def intro: Lattices.sup_least)
 
 lemma (in linorder) min_of_mono: "mono f \<Longrightarrow> min (f m) (f n) = f (min m n)"
   by (auto simp: mono_def Orderings.min_def min_def intro: Orderings.antisym)
 
 lemma (in linorder) max_of_mono: "mono f \<Longrightarrow> max (f m) (f n) = f (max m n)"
   by (auto simp: mono_def Orderings.max_def max_def intro: Orderings.antisym)
 
 lemma (in linorder)
   max_of_antimono: "antimono f \<Longrightarrow> max (f x) (f y) = f (min x y)" and
   min_of_antimono: "antimono f \<Longrightarrow> min (f x) (f y) = f (max x y)"
   by (auto simp: antimono_def Orderings.max_def max_def Orderings.min_def min_def intro!: antisym)
 
 lemma (in linorder) strict_mono_imp_inj_on: "strict_mono f \<Longrightarrow> inj_on f A"
   by (auto intro!: inj_onI dest: strict_mono_eq)
 
 lemma mono_Int: "mono f \<Longrightarrow> f (A \<inter> B) \<subseteq> f A \<inter> f B"
   by (fact mono_inf)
 
 lemma mono_Un: "mono f \<Longrightarrow> f A \<union> f B \<subseteq> f (A \<union> B)"
   by (fact mono_sup)
 
 
 subsubsection \<open>Least value operator\<close>
 
 lemma Least_mono: "mono f \<Longrightarrow> \<exists>x\<in>S. \<forall>y\<in>S. x \<le> y \<Longrightarrow> (LEAST y. y \<in> f ` S) = f (LEAST x. x \<in> S)"
   for f :: "'a::order \<Rightarrow> 'b::order"
   \<comment> \<open>Courtesy of Stephan Merz\<close>
   apply clarify
   apply (erule_tac P = "\<lambda>x. x \<in> S" in LeastI2_order)
    apply fast
   apply (rule LeastI2_order)
     apply (auto elim: monoD intro!: order_antisym)
   done
 
 
 subsection \<open>Setup\<close>
 
 subsubsection \<open>Proof tools\<close>
 
 text \<open>Simplify terms of the form \<open>f(\<dots>,x:=y,\<dots>,x:=z,\<dots>)\<close> to \<open>f(\<dots>,x:=z,\<dots>)\<close>\<close>
 
-simproc_setup fun_upd2 ("f(v := w, x := y)") = \<open>fn _ =>
+simproc_setup fun_upd2 ("f(v := w, x := y)") = \<open>
   let
     fun gen_fun_upd NONE T _ _ = NONE
       | gen_fun_upd (SOME f) T x y = SOME (Const (\<^const_name>\<open>fun_upd\<close>, T) $ f $ x $ y)
     fun dest_fun_T1 (Type (_, T :: Ts)) = T
     fun find_double (t as Const (\<^const_name>\<open>fun_upd\<close>,T) $ f $ x $ y) =
       let
         fun find (Const (\<^const_name>\<open>fun_upd\<close>,T) $ g $ v $ w) =
               if v aconv x then SOME g else gen_fun_upd (find g) T v w
           | find t = NONE
       in (dest_fun_T1 T, gen_fun_upd (find f) T x y) end
 
     val ss = simpset_of \<^context>
 
     fun proc ctxt ct =
       let
         val t = Thm.term_of ct
       in
         (case find_double t of
           (T, NONE) => NONE
         | (T, SOME rhs) =>
             SOME (Goal.prove ctxt [] [] (Logic.mk_equals (t, rhs))
               (fn _ =>
                 resolve_tac ctxt [eq_reflection] 1 THEN
                 resolve_tac ctxt @{thms ext} 1 THEN
                 simp_tac (put_simpset ss ctxt) 1)))
       end
-  in proc end
+  in K proc end
 \<close>
 
 
 subsubsection \<open>Functorial structure of types\<close>
 
 ML_file \<open>Tools/functor.ML\<close>
 
 functor map_fun: map_fun
   by (simp_all add: fun_eq_iff)
 
 functor vimage
   by (simp_all add: fun_eq_iff vimage_comp)
 
 
 text \<open>Legacy theorem names\<close>
 
 lemmas o_def = comp_def
 lemmas o_apply = comp_apply
 lemmas o_assoc = comp_assoc [symmetric]
 lemmas id_o = id_comp
 lemmas o_id = comp_id
 lemmas o_eq_dest = comp_eq_dest
 lemmas o_eq_elim = comp_eq_elim
 lemmas o_eq_dest_lhs = comp_eq_dest_lhs
 lemmas o_eq_id_dest = comp_eq_id_dest
 
 end
diff --git a/src/HOL/Groups.thy b/src/HOL/Groups.thy
--- a/src/HOL/Groups.thy
+++ b/src/HOL/Groups.thy
@@ -1,1495 +1,1495 @@
 (*  Title:      HOL/Groups.thy
     Author:     Gertrud Bauer
     Author:     Steven Obua
     Author:     Lawrence C Paulson
     Author:     Markus Wenzel
     Author:     Jeremy Avigad
 *)
 
 section \<open>Groups, also combined with orderings\<close>
 
 theory Groups
   imports Orderings
 begin
 
 subsection \<open>Dynamic facts\<close>
 
 named_theorems ac_simps "associativity and commutativity simplification rules"
   and algebra_simps "algebra simplification rules for rings"
   and algebra_split_simps "algebra simplification rules for rings, with potential goal splitting"
   and field_simps "algebra simplification rules for fields"
   and field_split_simps "algebra simplification rules for fields, with potential goal splitting"
 
 text \<open>
   The rewrites accumulated in \<open>algebra_simps\<close> deal with the classical
   algebraic structures of groups, rings and family. They simplify terms by
   multiplying everything out (in case of a ring) and bringing sums and
   products into a canonical form (by ordered rewriting). As a result it
   decides group and ring equalities but also helps with inequalities.
 
   Of course it also works for fields, but it knows nothing about
   multiplicative inverses or division. This is catered for by \<open>field_simps\<close>.
 
   Facts in \<open>field_simps\<close> multiply with denominators in (in)equations if they
   can be proved to be non-zero (for equations) or positive/negative (for
   inequalities). Can be too aggressive and is therefore separate from the more
   benign \<open>algebra_simps\<close>.
 
   Collections \<open>algebra_split_simps\<close> and \<open>field_split_simps\<close>
   correspond to \<open>algebra_simps\<close> and \<open>field_simps\<close>
   but contain more aggresive rules that may lead to goal splitting.
 \<close>
 
 
 subsection \<open>Abstract structures\<close>
 
 text \<open>
   These locales provide basic structures for interpretation into bigger
   structures; extensions require careful thinking, otherwise undesired effects
   may occur due to interpretation.
 \<close>
 
 locale semigroup =
   fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl "\<^bold>*" 70)
   assumes assoc [ac_simps]: "a \<^bold>* b \<^bold>* c = a \<^bold>* (b \<^bold>* c)"
 
 locale abel_semigroup = semigroup +
   assumes commute [ac_simps]: "a \<^bold>* b = b \<^bold>* a"
 begin
 
 lemma left_commute [ac_simps]: "b \<^bold>* (a \<^bold>* c) = a \<^bold>* (b \<^bold>* c)"
 proof -
   have "(b \<^bold>* a) \<^bold>* c = (a \<^bold>* b) \<^bold>* c"
     by (simp only: commute)
   then show ?thesis
     by (simp only: assoc)
 qed
 
 end
 
 locale monoid = semigroup +
   fixes z :: 'a ("\<^bold>1")
   assumes left_neutral [simp]: "\<^bold>1 \<^bold>* a = a"
   assumes right_neutral [simp]: "a \<^bold>* \<^bold>1 = a"
 
 locale comm_monoid = abel_semigroup +
   fixes z :: 'a ("\<^bold>1")
   assumes comm_neutral: "a \<^bold>* \<^bold>1 = a"
 begin
 
 sublocale monoid
   by standard (simp_all add: commute comm_neutral)
 
 end
 
 locale group = semigroup +
   fixes z :: 'a ("\<^bold>1")
   fixes inverse :: "'a \<Rightarrow> 'a"
   assumes group_left_neutral: "\<^bold>1 \<^bold>* a = a"
   assumes left_inverse [simp]:  "inverse a \<^bold>* a = \<^bold>1"
 begin
 
 lemma left_cancel: "a \<^bold>* b = a \<^bold>* c \<longleftrightarrow> b = c"
 proof
   assume "a \<^bold>* b = a \<^bold>* c"
   then have "inverse a \<^bold>* (a \<^bold>* b) = inverse a \<^bold>* (a \<^bold>* c)" by simp
   then have "(inverse a \<^bold>* a) \<^bold>* b = (inverse a \<^bold>* a) \<^bold>* c"
     by (simp only: assoc)
   then show "b = c" by (simp add: group_left_neutral)
 qed simp
 
 sublocale monoid
 proof
   fix a
   have "inverse a \<^bold>* a = \<^bold>1" by simp
   then have "inverse a \<^bold>* (a \<^bold>* \<^bold>1) = inverse a \<^bold>* a"
     by (simp add: group_left_neutral assoc [symmetric])
   with left_cancel show "a \<^bold>* \<^bold>1 = a"
     by (simp only: left_cancel)
 qed (fact group_left_neutral)
 
 lemma inverse_unique:
   assumes "a \<^bold>* b = \<^bold>1"
   shows "inverse a = b"
 proof -
   from assms have "inverse a \<^bold>* (a \<^bold>* b) = inverse a"
     by simp
   then show ?thesis
     by (simp add: assoc [symmetric])
 qed
 
 lemma inverse_neutral [simp]: "inverse \<^bold>1 = \<^bold>1"
   by (rule inverse_unique) simp
 
 lemma inverse_inverse [simp]: "inverse (inverse a) = a"
   by (rule inverse_unique) simp
 
 lemma right_inverse [simp]: "a \<^bold>* inverse a = \<^bold>1"
 proof -
   have "a \<^bold>* inverse a = inverse (inverse a) \<^bold>* inverse a"
     by simp
   also have "\<dots> = \<^bold>1"
     by (rule left_inverse)
   then show ?thesis by simp
 qed
 
 lemma inverse_distrib_swap: "inverse (a \<^bold>* b) = inverse b \<^bold>* inverse a"
 proof (rule inverse_unique)
   have "a \<^bold>* b \<^bold>* (inverse b \<^bold>* inverse a) =
     a \<^bold>* (b \<^bold>* inverse b) \<^bold>* inverse a"
     by (simp only: assoc)
   also have "\<dots> = \<^bold>1"
     by simp
   finally show "a \<^bold>* b \<^bold>* (inverse b \<^bold>* inverse a) = \<^bold>1" .
 qed
 
 lemma right_cancel: "b \<^bold>* a = c \<^bold>* a \<longleftrightarrow> b = c"
 proof
   assume "b \<^bold>* a = c \<^bold>* a"
   then have "b \<^bold>* a \<^bold>* inverse a= c \<^bold>* a \<^bold>* inverse a"
     by simp
   then show "b = c"
     by (simp add: assoc)
 qed simp
 
 end
 
 
 subsection \<open>Generic operations\<close>
 
 class zero =
   fixes zero :: 'a  ("0")
 
 class one =
   fixes one  :: 'a  ("1")
 
 hide_const (open) zero one
 
 lemma Let_0 [simp]: "Let 0 f = f 0"
   unfolding Let_def ..
 
 lemma Let_1 [simp]: "Let 1 f = f 1"
   unfolding Let_def ..
 
 setup \<open>
   Reorient_Proc.add
     (fn Const(\<^const_name>\<open>Groups.zero\<close>, _) => true
       | Const(\<^const_name>\<open>Groups.one\<close>, _) => true
       | _ => false)
 \<close>
 
-simproc_setup reorient_zero ("0 = x") = Reorient_Proc.proc
-simproc_setup reorient_one ("1 = x") = Reorient_Proc.proc
+simproc_setup reorient_zero ("0 = x") = \<open>K Reorient_Proc.proc\<close>
+simproc_setup reorient_one ("1 = x") = \<open>K Reorient_Proc.proc\<close>
 
 typed_print_translation \<open>
   let
     fun tr' c = (c, fn ctxt => fn T => fn ts =>
       if null ts andalso Printer.type_emphasis ctxt T then
         Syntax.const \<^syntax_const>\<open>_constrain\<close> $ Syntax.const c $
           Syntax_Phases.term_of_typ ctxt T
       else raise Match);
   in map tr' [\<^const_syntax>\<open>Groups.one\<close>, \<^const_syntax>\<open>Groups.zero\<close>] end
 \<close> \<comment> \<open>show types that are presumably too general\<close>
 
 class plus =
   fixes plus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl "+" 65)
 
 class minus =
   fixes minus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl "-" 65)
 
 class uminus =
   fixes uminus :: "'a \<Rightarrow> 'a"  ("- _" [81] 80)
 
 class times =
   fixes times :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl "*" 70)
 
 
 subsection \<open>Semigroups and Monoids\<close>
 
 class semigroup_add = plus +
   assumes add_assoc [algebra_simps, algebra_split_simps, field_simps, field_split_simps]:
     "(a + b) + c = a + (b + c)"
 begin
 
 sublocale add: semigroup plus
   by standard (fact add_assoc)
 
 end
 
 hide_fact add_assoc
 
 class ab_semigroup_add = semigroup_add +
   assumes add_commute [algebra_simps, algebra_split_simps, field_simps, field_split_simps]:
     "a + b = b + a"
 begin
 
 sublocale add: abel_semigroup plus
   by standard (fact add_commute)
 
 declare add.left_commute [algebra_simps, algebra_split_simps, field_simps, field_split_simps]
 
 lemmas add_ac = add.assoc add.commute add.left_commute
 
 end
 
 hide_fact add_commute
 
 lemmas add_ac = add.assoc add.commute add.left_commute
 
 class semigroup_mult = times +
   assumes mult_assoc [algebra_simps, algebra_split_simps, field_simps, field_split_simps]:
     "(a * b) * c = a * (b * c)"
 begin
 
 sublocale mult: semigroup times
   by standard (fact mult_assoc)
 
 end
 
 hide_fact mult_assoc
 
 class ab_semigroup_mult = semigroup_mult +
   assumes mult_commute [algebra_simps, algebra_split_simps, field_simps, field_split_simps]:
     "a * b = b * a"
 begin
 
 sublocale mult: abel_semigroup times
   by standard (fact mult_commute)
 
 declare mult.left_commute [algebra_simps, algebra_split_simps, field_simps, field_split_simps]
 
 lemmas mult_ac = mult.assoc mult.commute mult.left_commute
 
 end
 
 hide_fact mult_commute
 
 lemmas mult_ac = mult.assoc mult.commute mult.left_commute
 
 class monoid_add = zero + semigroup_add +
   assumes add_0_left: "0 + a = a"
     and add_0_right: "a + 0 = a"
 begin
 
 sublocale add: monoid plus 0
   by standard (fact add_0_left add_0_right)+
 
 end
 
 lemma zero_reorient: "0 = x \<longleftrightarrow> x = 0"
   by (fact eq_commute)
 
 class comm_monoid_add = zero + ab_semigroup_add +
   assumes add_0: "0 + a = a"
 begin
 
 subclass monoid_add
   by standard (simp_all add: add_0 add.commute [of _ 0])
 
 sublocale add: comm_monoid plus 0
   by standard (simp add: ac_simps)
 
 end
 
 class monoid_mult = one + semigroup_mult +
   assumes mult_1_left: "1 * a  = a"
     and mult_1_right: "a * 1 = a"
 begin
 
 sublocale mult: monoid times 1
   by standard (fact mult_1_left mult_1_right)+
 
 end
 
 lemma one_reorient: "1 = x \<longleftrightarrow> x = 1"
   by (fact eq_commute)
 
 class comm_monoid_mult = one + ab_semigroup_mult +
   assumes mult_1: "1 * a = a"
 begin
 
 subclass monoid_mult
   by standard (simp_all add: mult_1 mult.commute [of _ 1])
 
 sublocale mult: comm_monoid times 1
   by standard (simp add: ac_simps)
 
 end
 
 class cancel_semigroup_add = semigroup_add +
   assumes add_left_imp_eq: "a + b = a + c \<Longrightarrow> b = c"
   assumes add_right_imp_eq: "b + a = c + a \<Longrightarrow> b = c"
 begin
 
 lemma add_left_cancel [simp]: "a + b = a + c \<longleftrightarrow> b = c"
   by (blast dest: add_left_imp_eq)
 
 lemma add_right_cancel [simp]: "b + a = c + a \<longleftrightarrow> b = c"
   by (blast dest: add_right_imp_eq)
 
 end
 
 class cancel_ab_semigroup_add = ab_semigroup_add + minus +
   assumes add_diff_cancel_left' [simp]: "(a + b) - a = b"
   assumes diff_diff_add [algebra_simps, algebra_split_simps, field_simps, field_split_simps]:
     "a - b - c = a - (b + c)"
 begin
 
 lemma add_diff_cancel_right' [simp]: "(a + b) - b = a"
   using add_diff_cancel_left' [of b a] by (simp add: ac_simps)
 
 subclass cancel_semigroup_add
 proof
   fix a b c :: 'a
   assume "a + b = a + c"
   then have "a + b - a = a + c - a"
     by simp
   then show "b = c"
     by simp
 next
   fix a b c :: 'a
   assume "b + a = c + a"
   then have "b + a - a = c + a - a"
     by simp
   then show "b = c"
     by simp
 qed
 
 lemma add_diff_cancel_left [simp]: "(c + a) - (c + b) = a - b"
   unfolding diff_diff_add [symmetric] by simp
 
 lemma add_diff_cancel_right [simp]: "(a + c) - (b + c) = a - b"
   using add_diff_cancel_left [symmetric] by (simp add: ac_simps)
 
 lemma diff_right_commute: "a - c - b = a - b - c"
   by (simp add: diff_diff_add add.commute)
 
 end
 
 class cancel_comm_monoid_add = cancel_ab_semigroup_add + comm_monoid_add
 begin
 
 lemma diff_zero [simp]: "a - 0 = a"
   using add_diff_cancel_right' [of a 0] by simp
 
 lemma diff_cancel [simp]: "a - a = 0"
 proof -
   have "(a + 0) - (a + 0) = 0"
     by (simp only: add_diff_cancel_left diff_zero)
   then show ?thesis by simp
 qed
 
 lemma add_implies_diff:
   assumes "c + b = a"
   shows "c = a - b"
 proof -
   from assms have "(b + c) - (b + 0) = a - b"
     by (simp add: add.commute)
   then show "c = a - b" by simp
 qed
 
 lemma add_cancel_right_right [simp]: "a = a + b \<longleftrightarrow> b = 0"
   (is "?P \<longleftrightarrow> ?Q")
 proof
   assume ?Q
   then show ?P by simp
 next
   assume ?P
   then have "a - a = a + b - a" by simp
   then show ?Q by simp
 qed
 
 lemma add_cancel_right_left [simp]: "a = b + a \<longleftrightarrow> b = 0"
   using add_cancel_right_right [of a b] by (simp add: ac_simps)
 
 lemma add_cancel_left_right [simp]: "a + b = a \<longleftrightarrow> b = 0"
   by (auto dest: sym)
 
 lemma add_cancel_left_left [simp]: "b + a = a \<longleftrightarrow> b = 0"
   by (auto dest: sym)
 
 end
 
 class comm_monoid_diff = cancel_comm_monoid_add +
   assumes zero_diff [simp]: "0 - a = 0"
 begin
 
 lemma diff_add_zero [simp]: "a - (a + b) = 0"
 proof -
   have "a - (a + b) = (a + 0) - (a + b)"
     by simp
   also have "\<dots> = 0"
     by (simp only: add_diff_cancel_left zero_diff)
   finally show ?thesis .
 qed
 
 end
 
 
 subsection \<open>Groups\<close>
 
 class group_add = minus + uminus + monoid_add +
   assumes left_minus: "- a + a = 0"
   assumes add_uminus_conv_diff [simp]: "a + (- b) = a - b"
 begin
 
 lemma diff_conv_add_uminus: "a - b = a + (- b)"
   by simp
 
 sublocale add: group plus 0 uminus
   by standard (simp_all add: left_minus)
 
 lemma minus_unique: "a + b = 0 \<Longrightarrow> - a = b"
   by (fact add.inverse_unique)
 
 lemma minus_zero: "- 0 = 0"
   by (fact add.inverse_neutral)
 
 lemma minus_minus: "- (- a) = a"
   by (fact add.inverse_inverse)
 
 lemma right_minus: "a + - a = 0"
   by (fact add.right_inverse)
 
 lemma diff_self [simp]: "a - a = 0"
   using right_minus [of a] by simp
 
 subclass cancel_semigroup_add
   by standard (simp_all add: add.left_cancel add.right_cancel)
 
 lemma minus_add_cancel [simp]: "- a + (a + b) = b"
   by (simp add: add.assoc [symmetric])
 
 lemma add_minus_cancel [simp]: "a + (- a + b) = b"
   by (simp add: add.assoc [symmetric])
 
 lemma diff_add_cancel [simp]: "a - b + b = a"
   by (simp only: diff_conv_add_uminus add.assoc) simp
 
 lemma add_diff_cancel [simp]: "a + b - b = a"
   by (simp only: diff_conv_add_uminus add.assoc) simp
 
 lemma minus_add: "- (a + b) = - b + - a"
   by (fact add.inverse_distrib_swap)
 
 lemma right_minus_eq [simp]: "a - b = 0 \<longleftrightarrow> a = b"
 proof
   assume "a - b = 0"
   have "a = (a - b) + b" by (simp add: add.assoc)
   also have "\<dots> = b" using \<open>a - b = 0\<close> by simp
   finally show "a = b" .
 next
   assume "a = b"
   then show "a - b = 0" by simp
 qed
 
 lemma eq_iff_diff_eq_0: "a = b \<longleftrightarrow> a - b = 0"
   by (fact right_minus_eq [symmetric])
 
 lemma diff_0 [simp]: "0 - a = - a"
   by (simp only: diff_conv_add_uminus add_0_left)
 
 lemma diff_0_right [simp]: "a - 0 = a"
   by (simp only: diff_conv_add_uminus minus_zero add_0_right)
 
 lemma diff_minus_eq_add [simp]: "a - - b = a + b"
   by (simp only: diff_conv_add_uminus minus_minus)
 
 lemma neg_equal_iff_equal [simp]: "- a = - b \<longleftrightarrow> a = b"
 proof
   assume "- a = - b"
   then have "- (- a) = - (- b)" by simp
   then show "a = b" by simp
 next
   assume "a = b"
   then show "- a = - b" by simp
 qed
 
 lemma neg_equal_0_iff_equal [simp]: "- a = 0 \<longleftrightarrow> a = 0"
   by (subst neg_equal_iff_equal [symmetric]) simp
 
 lemma neg_0_equal_iff_equal [simp]: "0 = - a \<longleftrightarrow> 0 = a"
   by (subst neg_equal_iff_equal [symmetric]) simp
 
 text \<open>The next two equations can make the simplifier loop!\<close>
 
 lemma equation_minus_iff: "a = - b \<longleftrightarrow> b = - a"
 proof -
   have "- (- a) = - b \<longleftrightarrow> - a = b"
     by (rule neg_equal_iff_equal)
   then show ?thesis
     by (simp add: eq_commute)
 qed
 
 lemma minus_equation_iff: "- a = b \<longleftrightarrow> - b = a"
 proof -
   have "- a = - (- b) \<longleftrightarrow> a = -b"
     by (rule neg_equal_iff_equal)
   then show ?thesis
     by (simp add: eq_commute)
 qed
 
 lemma eq_neg_iff_add_eq_0: "a = - b \<longleftrightarrow> a + b = 0"
 proof
   assume "a = - b"
   then show "a + b = 0" by simp
 next
   assume "a + b = 0"
   moreover have "a + (b + - b) = (a + b) + - b"
     by (simp only: add.assoc)
   ultimately show "a = - b"
     by simp
 qed
 
 lemma add_eq_0_iff2: "a + b = 0 \<longleftrightarrow> a = - b"
   by (fact eq_neg_iff_add_eq_0 [symmetric])
 
 lemma neg_eq_iff_add_eq_0: "- a = b \<longleftrightarrow> a + b = 0"
   by (auto simp add: add_eq_0_iff2)
 
 lemma add_eq_0_iff: "a + b = 0 \<longleftrightarrow> b = - a"
   by (auto simp add: neg_eq_iff_add_eq_0 [symmetric])
 
 lemma minus_diff_eq [simp]: "- (a - b) = b - a"
   by (simp only: neg_eq_iff_add_eq_0 diff_conv_add_uminus add.assoc minus_add_cancel) simp
 
 lemma add_diff_eq [algebra_simps, algebra_split_simps, field_simps, field_split_simps]:
     "a + (b - c) = (a + b) - c"
   by (simp only: diff_conv_add_uminus add.assoc)
 
 lemma diff_add_eq_diff_diff_swap: "a - (b + c) = a - c - b"
   by (simp only: diff_conv_add_uminus add.assoc minus_add)
 
 lemma diff_eq_eq [algebra_simps, algebra_split_simps, field_simps, field_split_simps]:
   "a - b = c \<longleftrightarrow> a = c + b"
   by auto
 
 lemma eq_diff_eq [algebra_simps, algebra_split_simps, field_simps, field_split_simps]:
   "a = c - b \<longleftrightarrow> a + b = c"
   by auto
 
 lemma diff_diff_eq2 [algebra_simps, algebra_split_simps, field_simps, field_split_simps]:
   "a - (b - c) = (a + c) - b"
   by (simp only: diff_conv_add_uminus add.assoc) simp
 
 lemma diff_eq_diff_eq: "a - b = c - d \<Longrightarrow> a = b \<longleftrightarrow> c = d"
   by (simp only: eq_iff_diff_eq_0 [of a b] eq_iff_diff_eq_0 [of c d])
 
 end
 
 class ab_group_add = minus + uminus + comm_monoid_add +
   assumes ab_left_minus: "- a + a = 0"
   assumes ab_diff_conv_add_uminus: "a - b = a + (- b)"
 begin
 
 subclass group_add
   by standard (simp_all add: ab_left_minus ab_diff_conv_add_uminus)
 
 subclass cancel_comm_monoid_add
 proof
   fix a b c :: 'a
   have "b + a - a = b"
     by simp
   then show "a + b - a = b"
     by (simp add: ac_simps)
   show "a - b - c = a - (b + c)"
     by (simp add: algebra_simps)
 qed
 
 lemma uminus_add_conv_diff [simp]: "- a + b = b - a"
   by (simp add: add.commute)
 
 lemma minus_add_distrib [simp]: "- (a + b) = - a + - b"
   by (simp add: algebra_simps)
 
 lemma diff_add_eq [algebra_simps, algebra_split_simps, field_simps, field_split_simps]:
   "(a - b) + c = (a + c) - b"
   by (simp add: algebra_simps)
 
 lemma minus_diff_commute:
   "- b - a = - a - b"
   by (simp only: diff_conv_add_uminus add.commute)
 
 end
 
 
 subsection \<open>(Partially) Ordered Groups\<close>
 
 text \<open>
   The theory of partially ordered groups is taken from the books:
 
     \<^item> \<^emph>\<open>Lattice Theory\<close> by Garret Birkhoff, American Mathematical Society, 1979
     \<^item> \<^emph>\<open>Partially Ordered Algebraic Systems\<close>, Pergamon Press, 1963
 
   Most of the used notions can also be looked up in
     \<^item> \<^url>\<open>http://www.mathworld.com\<close> by Eric Weisstein et. al.
     \<^item> \<^emph>\<open>Algebra I\<close> by van der Waerden, Springer
 \<close>
 
 class ordered_ab_semigroup_add = order + ab_semigroup_add +
   assumes add_left_mono: "a \<le> b \<Longrightarrow> c + a \<le> c + b"
 begin
 
 lemma add_right_mono: "a \<le> b \<Longrightarrow> a + c \<le> b + c"
   by (simp add: add.commute [of _ c] add_left_mono)
 
 text \<open>non-strict, in both arguments\<close>
 lemma add_mono: "a \<le> b \<Longrightarrow> c \<le> d \<Longrightarrow> a + c \<le> b + d"
   by (simp add: add.commute add_left_mono add_right_mono [THEN order_trans])
 
 end
 
 text \<open>Strict monotonicity in both arguments\<close>
 class strict_ordered_ab_semigroup_add = ordered_ab_semigroup_add +
   assumes add_strict_mono: "a < b \<Longrightarrow> c < d \<Longrightarrow> a + c < b + d"
 
 class ordered_cancel_ab_semigroup_add =
   ordered_ab_semigroup_add + cancel_ab_semigroup_add
 begin
 
 lemma add_strict_left_mono: "a < b \<Longrightarrow> c + a < c + b"
   by (auto simp add: less_le add_left_mono)
 
 lemma add_strict_right_mono: "a < b \<Longrightarrow> a + c < b + c"
   by (simp add: add.commute [of _ c] add_strict_left_mono)
 
 subclass strict_ordered_ab_semigroup_add
 proof
   show "\<And>a b c d. \<lbrakk>a < b; c < d\<rbrakk> \<Longrightarrow> a + c < b + d"
     by (iprover intro: add_strict_left_mono add_strict_right_mono less_trans)
 qed
 
 lemma add_less_le_mono: "a < b \<Longrightarrow> c \<le> d \<Longrightarrow> a + c < b + d"
   by (iprover intro: add_left_mono add_strict_right_mono less_le_trans)
 
 lemma add_le_less_mono: "a \<le> b \<Longrightarrow> c < d \<Longrightarrow> a + c < b + d"
   by (iprover intro: add_strict_left_mono add_right_mono less_le_trans)
 
 end
 
 class ordered_ab_semigroup_add_imp_le = ordered_cancel_ab_semigroup_add +
   assumes add_le_imp_le_left: "c + a \<le> c + b \<Longrightarrow> a \<le> b"
 begin
 
 lemma add_less_imp_less_left:
   assumes less: "c + a < c + b"
   shows "a < b"
 proof -
   from less have le: "c + a \<le> c + b"
     by (simp add: order_le_less)
   have "a \<le> b"
     using add_le_imp_le_left [OF le] .
   moreover have "a \<noteq> b"
   proof (rule ccontr)
     assume "\<not> ?thesis"
     then have "a = b" by simp
     then have "c + a = c + b" by simp
     with less show "False" by simp
   qed
   ultimately show "a < b"
     by (simp add: order_le_less)
 qed
 
 lemma add_less_imp_less_right: "a + c < b + c \<Longrightarrow> a < b"
   by (rule add_less_imp_less_left [of c]) (simp add: add.commute)
 
 lemma add_less_cancel_left [simp]: "c + a < c + b \<longleftrightarrow> a < b"
   by (blast intro: add_less_imp_less_left add_strict_left_mono)
 
 lemma add_less_cancel_right [simp]: "a + c < b + c \<longleftrightarrow> a < b"
   by (blast intro: add_less_imp_less_right add_strict_right_mono)
 
 lemma add_le_cancel_left [simp]: "c + a \<le> c + b \<longleftrightarrow> a \<le> b"
   by (auto simp: dest: add_le_imp_le_left add_left_mono)
 
 lemma add_le_cancel_right [simp]: "a + c \<le> b + c \<longleftrightarrow> a \<le> b"
   by (simp add: add.commute [of a c] add.commute [of b c])
 
 lemma add_le_imp_le_right: "a + c \<le> b + c \<Longrightarrow> a \<le> b"
   by simp
 
 lemma max_add_distrib_left: "max x y + z = max (x + z) (y + z)"
   unfolding max_def by auto
 
 lemma min_add_distrib_left: "min x y + z = min (x + z) (y + z)"
   unfolding min_def by auto
 
 lemma max_add_distrib_right: "x + max y z = max (x + y) (x + z)"
   unfolding max_def by auto
 
 lemma min_add_distrib_right: "x + min y z = min (x + y) (x + z)"
   unfolding min_def by auto
 
 end
 
 subsection \<open>Support for reasoning about signs\<close>
 
 class ordered_comm_monoid_add = comm_monoid_add + ordered_ab_semigroup_add
 begin
 
 lemma add_nonneg_nonneg [simp]: "0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> 0 \<le> a + b"
   using add_mono[of 0 a 0 b] by simp
 
 lemma add_nonpos_nonpos: "a \<le> 0 \<Longrightarrow> b \<le> 0 \<Longrightarrow> a + b \<le> 0"
   using add_mono[of a 0 b 0] by simp
 
 lemma add_nonneg_eq_0_iff: "0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> x + y = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
   using add_left_mono[of 0 y x] add_right_mono[of 0 x y] by auto
 
 lemma add_nonpos_eq_0_iff: "x \<le> 0 \<Longrightarrow> y \<le> 0 \<Longrightarrow> x + y = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
   using add_left_mono[of y 0 x] add_right_mono[of x 0 y] by auto
 
 lemma add_increasing: "0 \<le> a \<Longrightarrow> b \<le> c \<Longrightarrow> b \<le> a + c"
   using add_mono [of 0 a b c] by simp
 
 lemma add_increasing2: "0 \<le> c \<Longrightarrow> b \<le> a \<Longrightarrow> b \<le> a + c"
   by (simp add: add_increasing add.commute [of a])
 
 lemma add_decreasing: "a \<le> 0 \<Longrightarrow> c \<le> b \<Longrightarrow> a + c \<le> b"
   using add_mono [of a 0 c b] by simp
 
 lemma add_decreasing2: "c \<le> 0 \<Longrightarrow> a \<le> b \<Longrightarrow> a + c \<le> b"
   using add_mono[of a b c 0] by simp
 
 lemma add_pos_nonneg: "0 < a \<Longrightarrow> 0 \<le> b \<Longrightarrow> 0 < a + b"
   using less_le_trans[of 0 a "a + b"] by (simp add: add_increasing2)
 
 lemma add_pos_pos: "0 < a \<Longrightarrow> 0 < b \<Longrightarrow> 0 < a + b"
   by (intro add_pos_nonneg less_imp_le)
 
 lemma add_nonneg_pos: "0 \<le> a \<Longrightarrow> 0 < b \<Longrightarrow> 0 < a + b"
   using add_pos_nonneg[of b a] by (simp add: add_commute)
 
 lemma add_neg_nonpos: "a < 0 \<Longrightarrow> b \<le> 0 \<Longrightarrow> a + b < 0"
   using le_less_trans[of "a + b" a 0] by (simp add: add_decreasing2)
 
 lemma add_neg_neg: "a < 0 \<Longrightarrow> b < 0 \<Longrightarrow> a + b < 0"
   by (intro add_neg_nonpos less_imp_le)
 
 lemma add_nonpos_neg: "a \<le> 0 \<Longrightarrow> b < 0 \<Longrightarrow> a + b < 0"
   using add_neg_nonpos[of b a] by (simp add: add_commute)
 
 lemmas add_sign_intros =
   add_pos_nonneg add_pos_pos add_nonneg_pos add_nonneg_nonneg
   add_neg_nonpos add_neg_neg add_nonpos_neg add_nonpos_nonpos
 
 end
 
 class strict_ordered_comm_monoid_add = comm_monoid_add + strict_ordered_ab_semigroup_add
 begin
 
 lemma pos_add_strict: "0 < a \<Longrightarrow> b < c \<Longrightarrow> b < a + c"
   using add_strict_mono [of 0 a b c] by simp
 
 end
 
 class ordered_cancel_comm_monoid_add = ordered_comm_monoid_add + cancel_ab_semigroup_add
 begin
 
 subclass ordered_cancel_ab_semigroup_add ..
 subclass strict_ordered_comm_monoid_add ..
 
 lemma add_strict_increasing: "0 < a \<Longrightarrow> b \<le> c \<Longrightarrow> b < a + c"
   using add_less_le_mono [of 0 a b c] by simp
 
 lemma add_strict_increasing2: "0 \<le> a \<Longrightarrow> b < c \<Longrightarrow> b < a + c"
   using add_le_less_mono [of 0 a b c] by simp
 
 end
 
 class ordered_ab_semigroup_monoid_add_imp_le = monoid_add + ordered_ab_semigroup_add_imp_le
 begin
 
 lemma add_less_same_cancel1 [simp]: "b + a < b \<longleftrightarrow> a < 0"
   using add_less_cancel_left [of _ _ 0] by simp
 
 lemma add_less_same_cancel2 [simp]: "a + b < b \<longleftrightarrow> a < 0"
   using add_less_cancel_right [of _ _ 0] by simp
 
 lemma less_add_same_cancel1 [simp]: "a < a + b \<longleftrightarrow> 0 < b"
   using add_less_cancel_left [of _ 0] by simp
 
 lemma less_add_same_cancel2 [simp]: "a < b + a \<longleftrightarrow> 0 < b"
   using add_less_cancel_right [of 0] by simp
 
 lemma add_le_same_cancel1 [simp]: "b + a \<le> b \<longleftrightarrow> a \<le> 0"
   using add_le_cancel_left [of _ _ 0] by simp
 
 lemma add_le_same_cancel2 [simp]: "a + b \<le> b \<longleftrightarrow> a \<le> 0"
   using add_le_cancel_right [of _ _ 0] by simp
 
 lemma le_add_same_cancel1 [simp]: "a \<le> a + b \<longleftrightarrow> 0 \<le> b"
   using add_le_cancel_left [of _ 0] by simp
 
 lemma le_add_same_cancel2 [simp]: "a \<le> b + a \<longleftrightarrow> 0 \<le> b"
   using add_le_cancel_right [of 0] by simp
 
 subclass cancel_comm_monoid_add
   by standard auto
 
 subclass ordered_cancel_comm_monoid_add
   by standard
 
 end
 
 class ordered_ab_group_add = ab_group_add + ordered_ab_semigroup_add
 begin
 
 subclass ordered_cancel_ab_semigroup_add ..
 
 subclass ordered_ab_semigroup_monoid_add_imp_le
 proof
   fix a b c :: 'a
   assume "c + a \<le> c + b"
   then have "(-c) + (c + a) \<le> (-c) + (c + b)"
     by (rule add_left_mono)
   then have "((-c) + c) + a \<le> ((-c) + c) + b"
     by (simp only: add.assoc)
   then show "a \<le> b" by simp
 qed
 
 lemma max_diff_distrib_left: "max x y - z = max (x - z) (y - z)"
   using max_add_distrib_left [of x y "- z"] by simp
 
 lemma min_diff_distrib_left: "min x y - z = min (x - z) (y - z)"
   using min_add_distrib_left [of x y "- z"] by simp
 
 lemma le_imp_neg_le:
   assumes "a \<le> b"
   shows "- b \<le> - a"
 proof -
   from assms have "- a + a \<le> - a + b"
     by (rule add_left_mono)
   then have "0 \<le> - a + b"
     by simp
   then have "0 + (- b) \<le> (- a + b) + (- b)"
     by (rule add_right_mono)
   then show ?thesis
     by (simp add: algebra_simps)
 qed
 
 lemma neg_le_iff_le [simp]: "- b \<le> - a \<longleftrightarrow> a \<le> b"
 proof
   assume "- b \<le> - a"
   then have "- (- a) \<le> - (- b)"
     by (rule le_imp_neg_le)
   then show "a \<le> b"
     by simp
 next
   assume "a \<le> b"
   then show "- b \<le> - a"
     by (rule le_imp_neg_le)
 qed
 
 lemma neg_le_0_iff_le [simp]: "- a \<le> 0 \<longleftrightarrow> 0 \<le> a"
   by (subst neg_le_iff_le [symmetric]) simp
 
 lemma neg_0_le_iff_le [simp]: "0 \<le> - a \<longleftrightarrow> a \<le> 0"
   by (subst neg_le_iff_le [symmetric]) simp
 
 lemma neg_less_iff_less [simp]: "- b < - a \<longleftrightarrow> a < b"
   by (auto simp add: less_le)
 
 lemma neg_less_0_iff_less [simp]: "- a < 0 \<longleftrightarrow> 0 < a"
   by (subst neg_less_iff_less [symmetric]) simp
 
 lemma neg_0_less_iff_less [simp]: "0 < - a \<longleftrightarrow> a < 0"
   by (subst neg_less_iff_less [symmetric]) simp
 
 text \<open>The next several equations can make the simplifier loop!\<close>
 
 lemma less_minus_iff: "a < - b \<longleftrightarrow> b < - a"
 proof -
   have "- (- a) < - b \<longleftrightarrow> b < - a"
     by (rule neg_less_iff_less)
   then show ?thesis by simp
 qed
 
 lemma minus_less_iff: "- a < b \<longleftrightarrow> - b < a"
 proof -
   have "- a < - (- b) \<longleftrightarrow> - b < a"
     by (rule neg_less_iff_less)
   then show ?thesis by simp
 qed
 
 lemma le_minus_iff: "a \<le> - b \<longleftrightarrow> b \<le> - a"
   by (auto simp: order.order_iff_strict less_minus_iff)
 
 lemma minus_le_iff: "- a \<le> b \<longleftrightarrow> - b \<le> a"
   by (auto simp add: le_less minus_less_iff)
 
 lemma diff_less_0_iff_less [simp]: "a - b < 0 \<longleftrightarrow> a < b"
 proof -
   have "a - b < 0 \<longleftrightarrow> a + (- b) < b + (- b)"
     by simp
   also have "\<dots> \<longleftrightarrow> a < b"
     by (simp only: add_less_cancel_right)
   finally show ?thesis .
 qed
 
 lemmas less_iff_diff_less_0 = diff_less_0_iff_less [symmetric]
 
 lemma diff_less_eq [algebra_simps, algebra_split_simps, field_simps, field_split_simps]:
   "a - b < c \<longleftrightarrow> a < c + b"
 proof (subst less_iff_diff_less_0 [of a])
   show "(a - b < c) = (a - (c + b) < 0)"
     by (simp add: algebra_simps less_iff_diff_less_0 [of _ c])
 qed
 
 lemma less_diff_eq [algebra_simps, algebra_split_simps, field_simps, field_split_simps]:
   "a < c - b \<longleftrightarrow> a + b < c"
 proof (subst less_iff_diff_less_0 [of "a + b"])
   show "(a < c - b) = (a + b - c < 0)"
     by (simp add: algebra_simps less_iff_diff_less_0 [of a])
 qed
 
 lemma diff_gt_0_iff_gt [simp]: "a - b > 0 \<longleftrightarrow> a > b"
   by (simp add: less_diff_eq)
 
 lemma diff_le_eq [algebra_simps, algebra_split_simps, field_simps, field_split_simps]:
   "a - b \<le> c \<longleftrightarrow> a \<le> c + b"
   by (auto simp add: le_less diff_less_eq )
 
 lemma le_diff_eq [algebra_simps, algebra_split_simps, field_simps, field_split_simps]:
   "a \<le> c - b \<longleftrightarrow> a + b \<le> c"
   by (auto simp add: le_less less_diff_eq)
 
 lemma diff_le_0_iff_le [simp]: "a - b \<le> 0 \<longleftrightarrow> a \<le> b"
   by (simp add: algebra_simps)
 
 lemmas le_iff_diff_le_0 = diff_le_0_iff_le [symmetric]
 
 lemma diff_ge_0_iff_ge [simp]: "a - b \<ge> 0 \<longleftrightarrow> a \<ge> b"
   by (simp add: le_diff_eq)
 
 lemma diff_eq_diff_less: "a - b = c - d \<Longrightarrow> a < b \<longleftrightarrow> c < d"
   by (auto simp only: less_iff_diff_less_0 [of a b] less_iff_diff_less_0 [of c d])
 
 lemma diff_eq_diff_less_eq: "a - b = c - d \<Longrightarrow> a \<le> b \<longleftrightarrow> c \<le> d"
   by (auto simp only: le_iff_diff_le_0 [of a b] le_iff_diff_le_0 [of c d])
 
 lemma diff_mono: "a \<le> b \<Longrightarrow> d \<le> c \<Longrightarrow> a - c \<le> b - d"
   by (simp add: field_simps add_mono)
 
 lemma diff_left_mono: "b \<le> a \<Longrightarrow> c - a \<le> c - b"
   by (simp add: field_simps)
 
 lemma diff_right_mono: "a \<le> b \<Longrightarrow> a - c \<le> b - c"
   by (simp add: field_simps)
 
 lemma diff_strict_mono: "a < b \<Longrightarrow> d < c \<Longrightarrow> a - c < b - d"
   by (simp add: field_simps add_strict_mono)
 
 lemma diff_strict_left_mono: "b < a \<Longrightarrow> c - a < c - b"
   by (simp add: field_simps)
 
 lemma diff_strict_right_mono: "a < b \<Longrightarrow> a - c < b - c"
   by (simp add: field_simps)
 
 end
 
 locale group_cancel
 begin
 
 lemma add1: "(A::'a::comm_monoid_add) \<equiv> k + a \<Longrightarrow> A + b \<equiv> k + (a + b)"
   by (simp only: ac_simps)
 
 lemma add2: "(B::'a::comm_monoid_add) \<equiv> k + b \<Longrightarrow> a + B \<equiv> k + (a + b)"
   by (simp only: ac_simps)
 
 lemma sub1: "(A::'a::ab_group_add) \<equiv> k + a \<Longrightarrow> A - b \<equiv> k + (a - b)"
   by (simp only: add_diff_eq)
 
 lemma sub2: "(B::'a::ab_group_add) \<equiv> k + b \<Longrightarrow> a - B \<equiv> - k + (a - b)"
   by (simp only: minus_add diff_conv_add_uminus ac_simps)
 
 lemma neg1: "(A::'a::ab_group_add) \<equiv> k + a \<Longrightarrow> - A \<equiv> - k + - a"
   by (simp only: minus_add_distrib)
 
 lemma rule0: "(a::'a::comm_monoid_add) \<equiv> a + 0"
   by (simp only: add_0_right)
 
 end
 
 ML_file \<open>Tools/group_cancel.ML\<close>
 
 simproc_setup group_cancel_add ("a + b::'a::ab_group_add") =
   \<open>fn phi => fn ss => try Group_Cancel.cancel_add_conv\<close>
 
 simproc_setup group_cancel_diff ("a - b::'a::ab_group_add") =
   \<open>fn phi => fn ss => try Group_Cancel.cancel_diff_conv\<close>
 
 simproc_setup group_cancel_eq ("a = (b::'a::ab_group_add)") =
   \<open>fn phi => fn ss => try Group_Cancel.cancel_eq_conv\<close>
 
 simproc_setup group_cancel_le ("a \<le> (b::'a::ordered_ab_group_add)") =
   \<open>fn phi => fn ss => try Group_Cancel.cancel_le_conv\<close>
 
 simproc_setup group_cancel_less ("a < (b::'a::ordered_ab_group_add)") =
   \<open>fn phi => fn ss => try Group_Cancel.cancel_less_conv\<close>
 
 class linordered_ab_semigroup_add =
   linorder + ordered_ab_semigroup_add
 
 class linordered_cancel_ab_semigroup_add =
   linorder + ordered_cancel_ab_semigroup_add
 begin
 
 subclass linordered_ab_semigroup_add ..
 
 subclass ordered_ab_semigroup_add_imp_le
 proof
   fix a b c :: 'a
   assume le1: "c + a \<le> c + b"
   show "a \<le> b"
   proof (rule ccontr)
     assume *: "\<not> ?thesis"
     then have "b \<le> a" by (simp add: linorder_not_le)
     then have "c + b \<le> c + a" by (rule add_left_mono)
     then have "c + a = c + b"
       using le1 by (iprover intro: order.antisym)
     then have "a = b"
       by simp
     with * show False
       by (simp add: linorder_not_le [symmetric])
   qed
 qed
 
 end
 
 class linordered_ab_group_add = linorder + ordered_ab_group_add
 begin
 
 subclass linordered_cancel_ab_semigroup_add ..
 
 lemma equal_neg_zero [simp]: "a = - a \<longleftrightarrow> a = 0"
 proof
   assume "a = 0"
   then show "a = - a" by simp
 next
   assume A: "a = - a"
   show "a = 0"
   proof (cases "0 \<le> a")
     case True
     with A have "0 \<le> - a" by auto
     with le_minus_iff have "a \<le> 0" by simp
     with True show ?thesis by (auto intro: order_trans)
   next
     case False
     then have B: "a \<le> 0" by auto
     with A have "- a \<le> 0" by auto
     with B show ?thesis by (auto intro: order_trans)
   qed
 qed
 
 lemma neg_equal_zero [simp]: "- a = a \<longleftrightarrow> a = 0"
   by (auto dest: sym)
 
 lemma neg_less_eq_nonneg [simp]: "- a \<le> a \<longleftrightarrow> 0 \<le> a"
 proof
   assume *: "- a \<le> a"
   show "0 \<le> a"
   proof (rule classical)
     assume "\<not> ?thesis"
     then have "a < 0" by auto
     with * have "- a < 0" by (rule le_less_trans)
     then show ?thesis by auto
   qed
 next
   assume *: "0 \<le> a"
   then have "- a \<le> 0" by (simp add: minus_le_iff)
   from this * show "- a \<le> a" by (rule order_trans)
 qed
 
 lemma neg_less_pos [simp]: "- a < a \<longleftrightarrow> 0 < a"
   by (auto simp add: less_le)
 
 lemma less_eq_neg_nonpos [simp]: "a \<le> - a \<longleftrightarrow> a \<le> 0"
   using neg_less_eq_nonneg [of "- a"] by simp
 
 lemma less_neg_neg [simp]: "a < - a \<longleftrightarrow> a < 0"
   using neg_less_pos [of "- a"] by simp
 
 lemma double_zero [simp]: "a + a = 0 \<longleftrightarrow> a = 0"
 proof
   assume "a + a = 0"
   then have a: "- a = a" by (rule minus_unique)
   then show "a = 0" by (simp only: neg_equal_zero)
 next
   assume "a = 0"
   then show "a + a = 0" by simp
 qed
 
 lemma double_zero_sym [simp]: "0 = a + a \<longleftrightarrow> a = 0"
   using double_zero [of a] by (simp only: eq_commute)
 
 lemma zero_less_double_add_iff_zero_less_single_add [simp]: "0 < a + a \<longleftrightarrow> 0 < a"
 proof
   assume "0 < a + a"
   then have "0 - a < a" by (simp only: diff_less_eq)
   then have "- a < a" by simp
   then show "0 < a" by simp
 next
   assume "0 < a"
   with this have "0 + 0 < a + a"
     by (rule add_strict_mono)
   then show "0 < a + a" by simp
 qed
 
 lemma zero_le_double_add_iff_zero_le_single_add [simp]: "0 \<le> a + a \<longleftrightarrow> 0 \<le> a"
   by (auto simp add: le_less)
 
 lemma double_add_less_zero_iff_single_add_less_zero [simp]: "a + a < 0 \<longleftrightarrow> a < 0"
 proof -
   have "\<not> a + a < 0 \<longleftrightarrow> \<not> a < 0"
     by (simp add: not_less)
   then show ?thesis by simp
 qed
 
 lemma double_add_le_zero_iff_single_add_le_zero [simp]: "a + a \<le> 0 \<longleftrightarrow> a \<le> 0"
 proof -
   have "\<not> a + a \<le> 0 \<longleftrightarrow> \<not> a \<le> 0"
     by (simp add: not_le)
   then show ?thesis by simp
 qed
 
 lemma minus_max_eq_min: "- max x y = min (- x) (- y)"
   by (auto simp add: max_def min_def)
 
 lemma minus_min_eq_max: "- min x y = max (- x) (- y)"
   by (auto simp add: max_def min_def)
 
 end
 
 class abs =
   fixes abs :: "'a \<Rightarrow> 'a"  ("\<bar>_\<bar>")
 
 class sgn =
   fixes sgn :: "'a \<Rightarrow> 'a"
 
 class ordered_ab_group_add_abs = ordered_ab_group_add + abs +
   assumes abs_ge_zero [simp]: "\<bar>a\<bar> \<ge> 0"
     and abs_ge_self: "a \<le> \<bar>a\<bar>"
     and abs_leI: "a \<le> b \<Longrightarrow> - a \<le> b \<Longrightarrow> \<bar>a\<bar> \<le> b"
     and abs_minus_cancel [simp]: "\<bar>-a\<bar> = \<bar>a\<bar>"
     and abs_triangle_ineq: "\<bar>a + b\<bar> \<le> \<bar>a\<bar> + \<bar>b\<bar>"
 begin
 
 lemma abs_minus_le_zero: "- \<bar>a\<bar> \<le> 0"
   unfolding neg_le_0_iff_le by simp
 
 lemma abs_of_nonneg [simp]:
   assumes nonneg: "0 \<le> a"
   shows "\<bar>a\<bar> = a"
 proof (rule order.antisym)
   show "a \<le> \<bar>a\<bar>" by (rule abs_ge_self)
   from nonneg le_imp_neg_le have "- a \<le> 0" by simp
   from this nonneg have "- a \<le> a" by (rule order_trans)
   then show "\<bar>a\<bar> \<le> a" by (auto intro: abs_leI)
 qed
 
 lemma abs_idempotent [simp]: "\<bar>\<bar>a\<bar>\<bar> = \<bar>a\<bar>"
   by (rule order.antisym) (auto intro!: abs_ge_self abs_leI order_trans [of "- \<bar>a\<bar>" 0 "\<bar>a\<bar>"])
 
 lemma abs_eq_0 [simp]: "\<bar>a\<bar> = 0 \<longleftrightarrow> a = 0"
 proof -
   have "\<bar>a\<bar> = 0 \<Longrightarrow> a = 0"
   proof (rule order.antisym)
     assume zero: "\<bar>a\<bar> = 0"
     with abs_ge_self show "a \<le> 0" by auto
     from zero have "\<bar>-a\<bar> = 0" by simp
     with abs_ge_self [of "- a"] have "- a \<le> 0" by auto
     with neg_le_0_iff_le show "0 \<le> a" by auto
   qed
   then show ?thesis by auto
 qed
 
 lemma abs_zero [simp]: "\<bar>0\<bar> = 0"
   by simp
 
 lemma abs_0_eq [simp]: "0 = \<bar>a\<bar> \<longleftrightarrow> a = 0"
 proof -
   have "0 = \<bar>a\<bar> \<longleftrightarrow> \<bar>a\<bar> = 0" by (simp only: eq_ac)
   then show ?thesis by simp
 qed
 
 lemma abs_le_zero_iff [simp]: "\<bar>a\<bar> \<le> 0 \<longleftrightarrow> a = 0"
 proof
   assume "\<bar>a\<bar> \<le> 0"
   then have "\<bar>a\<bar> = 0" by (rule order.antisym) simp
   then show "a = 0" by simp
 next
   assume "a = 0"
   then show "\<bar>a\<bar> \<le> 0" by simp
 qed
 
 lemma abs_le_self_iff [simp]: "\<bar>a\<bar> \<le> a \<longleftrightarrow> 0 \<le> a"
 proof -
   have "0 \<le> \<bar>a\<bar>"
     using abs_ge_zero by blast
   then have "\<bar>a\<bar> \<le> a \<Longrightarrow> 0 \<le> a"
     using order.trans by blast
   then show ?thesis
     using abs_of_nonneg eq_refl by blast
 qed
 
 lemma zero_less_abs_iff [simp]: "0 < \<bar>a\<bar> \<longleftrightarrow> a \<noteq> 0"
   by (simp add: less_le)
 
 lemma abs_not_less_zero [simp]: "\<not> \<bar>a\<bar> < 0"
 proof -
   have "x \<le> y \<Longrightarrow> \<not> y < x" for x y by auto
   then show ?thesis by simp
 qed
 
 lemma abs_ge_minus_self: "- a \<le> \<bar>a\<bar>"
 proof -
   have "- a \<le> \<bar>-a\<bar>" by (rule abs_ge_self)
   then show ?thesis by simp
 qed
 
 lemma abs_minus_commute: "\<bar>a - b\<bar> = \<bar>b - a\<bar>"
 proof -
   have "\<bar>a - b\<bar> = \<bar>- (a - b)\<bar>"
     by (simp only: abs_minus_cancel)
   also have "\<dots> = \<bar>b - a\<bar>" by simp
   finally show ?thesis .
 qed
 
 lemma abs_of_pos: "0 < a \<Longrightarrow> \<bar>a\<bar> = a"
   by (rule abs_of_nonneg) (rule less_imp_le)
 
 lemma abs_of_nonpos [simp]:
   assumes "a \<le> 0"
   shows "\<bar>a\<bar> = - a"
 proof -
   let ?b = "- a"
   have "- ?b \<le> 0 \<Longrightarrow> \<bar>- ?b\<bar> = - (- ?b)"
     unfolding abs_minus_cancel [of ?b]
     unfolding neg_le_0_iff_le [of ?b]
     unfolding minus_minus by (erule abs_of_nonneg)
   then show ?thesis using assms by auto
 qed
 
 lemma abs_of_neg: "a < 0 \<Longrightarrow> \<bar>a\<bar> = - a"
   by (rule abs_of_nonpos) (rule less_imp_le)
 
 lemma abs_le_D1: "\<bar>a\<bar> \<le> b \<Longrightarrow> a \<le> b"
   using abs_ge_self by (blast intro: order_trans)
 
 lemma abs_le_D2: "\<bar>a\<bar> \<le> b \<Longrightarrow> - a \<le> b"
   using abs_le_D1 [of "- a"] by simp
 
 lemma abs_le_iff: "\<bar>a\<bar> \<le> b \<longleftrightarrow> a \<le> b \<and> - a \<le> b"
   by (blast intro: abs_leI dest: abs_le_D1 abs_le_D2)
 
 lemma abs_triangle_ineq2: "\<bar>a\<bar> - \<bar>b\<bar> \<le> \<bar>a - b\<bar>"
 proof -
   have "\<bar>a\<bar> = \<bar>b + (a - b)\<bar>"
     by (simp add: algebra_simps)
   then have "\<bar>a\<bar> \<le> \<bar>b\<bar> + \<bar>a - b\<bar>"
     by (simp add: abs_triangle_ineq)
   then show ?thesis
     by (simp add: algebra_simps)
 qed
 
 lemma abs_triangle_ineq2_sym: "\<bar>a\<bar> - \<bar>b\<bar> \<le> \<bar>b - a\<bar>"
   by (simp only: abs_minus_commute [of b] abs_triangle_ineq2)
 
 lemma abs_triangle_ineq3: "\<bar>\<bar>a\<bar> - \<bar>b\<bar>\<bar> \<le> \<bar>a - b\<bar>"
   by (simp add: abs_le_iff abs_triangle_ineq2 abs_triangle_ineq2_sym)
 
 lemma abs_triangle_ineq4: "\<bar>a - b\<bar> \<le> \<bar>a\<bar> + \<bar>b\<bar>"
 proof -
   have "\<bar>a - b\<bar> = \<bar>a + - b\<bar>"
     by (simp add: algebra_simps)
   also have "\<dots> \<le> \<bar>a\<bar> + \<bar>- b\<bar>"
     by (rule abs_triangle_ineq)
   finally show ?thesis by simp
 qed
 
 lemma abs_diff_triangle_ineq: "\<bar>a + b - (c + d)\<bar> \<le> \<bar>a - c\<bar> + \<bar>b - d\<bar>"
 proof -
   have "\<bar>a + b - (c + d)\<bar> = \<bar>(a - c) + (b - d)\<bar>"
     by (simp add: algebra_simps)
   also have "\<dots> \<le> \<bar>a - c\<bar> + \<bar>b - d\<bar>"
     by (rule abs_triangle_ineq)
   finally show ?thesis .
 qed
 
 lemma abs_add_abs [simp]: "\<bar>\<bar>a\<bar> + \<bar>b\<bar>\<bar> = \<bar>a\<bar> + \<bar>b\<bar>"
   (is "?L = ?R")
 proof (rule order.antisym)
   show "?L \<ge> ?R" by (rule abs_ge_self)
   have "?L \<le> \<bar>\<bar>a\<bar>\<bar> + \<bar>\<bar>b\<bar>\<bar>" by (rule abs_triangle_ineq)
   also have "\<dots> = ?R" by simp
   finally show "?L \<le> ?R" .
 qed
 
 end
 
 lemma dense_eq0_I:
   fixes x::"'a::{dense_linorder,ordered_ab_group_add_abs}"
   assumes "\<And>e. 0 < e \<Longrightarrow> \<bar>x\<bar> \<le> e"
   shows "x = 0"
 proof (cases "\<bar>x\<bar> = 0")
   case False
   then have "\<bar>x\<bar> > 0"
     by simp
   then obtain z where "0 < z" "z < \<bar>x\<bar>"
     using dense by force
   then show ?thesis
     using assms by (simp flip: not_less)
 qed auto
 
 hide_fact (open) ab_diff_conv_add_uminus add_0 mult_1 ab_left_minus
 
 lemmas add_0 = add_0_left (* FIXME duplicate *)
 lemmas mult_1 = mult_1_left (* FIXME duplicate *)
 lemmas ab_left_minus = left_minus (* FIXME duplicate *)
 lemmas diff_diff_eq = diff_diff_add (* FIXME duplicate *)
 
 
 subsection \<open>Canonically ordered monoids\<close>
 
 text \<open>Canonically ordered monoids are never groups.\<close>
 
 class canonically_ordered_monoid_add = comm_monoid_add + order +
   assumes le_iff_add: "a \<le> b \<longleftrightarrow> (\<exists>c. b = a + c)"
 begin
 
 lemma zero_le[simp]: "0 \<le> x"
   by (auto simp: le_iff_add)
 
 lemma le_zero_eq[simp]: "n \<le> 0 \<longleftrightarrow> n = 0"
   by (auto intro: order.antisym)
 
 lemma not_less_zero[simp]: "\<not> n < 0"
   by (auto simp: less_le)
 
 lemma zero_less_iff_neq_zero: "0 < n \<longleftrightarrow> n \<noteq> 0"
   by (auto simp: less_le)
 
 text \<open>This theorem is useful with \<open>blast\<close>\<close>
 lemma gr_zeroI: "(n = 0 \<Longrightarrow> False) \<Longrightarrow> 0 < n"
   by (rule zero_less_iff_neq_zero[THEN iffD2]) iprover
 
 lemma not_gr_zero[simp]: "\<not> 0 < n \<longleftrightarrow> n = 0"
   by (simp add: zero_less_iff_neq_zero)
 
 subclass ordered_comm_monoid_add
   proof qed (auto simp: le_iff_add add_ac)
 
 lemma gr_implies_not_zero: "m < n \<Longrightarrow> n \<noteq> 0"
   by auto
 
 lemma add_eq_0_iff_both_eq_0[simp]: "x + y = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
   by (intro add_nonneg_eq_0_iff zero_le)
 
 lemma zero_eq_add_iff_both_eq_0[simp]: "0 = x + y \<longleftrightarrow> x = 0 \<and> y = 0"
   using add_eq_0_iff_both_eq_0[of x y] unfolding eq_commute[of 0] .
 
 lemma less_eqE:
   assumes \<open>a \<le> b\<close>
   obtains c where \<open>b = a + c\<close>
   using assms by (auto simp add: le_iff_add)
 
 lemma lessE:
   assumes \<open>a < b\<close>
   obtains c where \<open>b = a + c\<close> and \<open>c \<noteq> 0\<close>
 proof -
   from assms have \<open>a \<le> b\<close> \<open>a \<noteq> b\<close>
     by simp_all
   from \<open>a \<le> b\<close> obtain c where \<open>b = a + c\<close>
     by (rule less_eqE)
   moreover have \<open>c \<noteq> 0\<close> using \<open>a \<noteq> b\<close> \<open>b = a + c\<close>
     by auto
   ultimately show ?thesis
     by (rule that)
 qed
 
 lemmas zero_order = zero_le le_zero_eq not_less_zero zero_less_iff_neq_zero not_gr_zero
   \<comment> \<open>This should be attributed with \<open>[iff]\<close>, but then \<open>blast\<close> fails in \<open>Set\<close>.\<close>
 
 end
 
 class ordered_cancel_comm_monoid_diff =
   canonically_ordered_monoid_add + comm_monoid_diff + ordered_ab_semigroup_add_imp_le
 begin
 
 context
   fixes a b :: 'a
   assumes le: "a \<le> b"
 begin
 
 lemma add_diff_inverse: "a + (b - a) = b"
   using le by (auto simp add: le_iff_add)
 
 lemma add_diff_assoc: "c + (b - a) = c + b - a"
   using le by (auto simp add: le_iff_add add.left_commute [of c])
 
 lemma add_diff_assoc2: "b - a + c = b + c - a"
   using le by (auto simp add: le_iff_add add.assoc)
 
 lemma diff_add_assoc: "c + b - a = c + (b - a)"
   using le by (simp add: add.commute add_diff_assoc)
 
 lemma diff_add_assoc2: "b + c - a = b - a + c"
   using le by (simp add: add.commute add_diff_assoc)
 
 lemma diff_diff_right: "c - (b - a) = c + a - b"
   by (simp add: add_diff_inverse add_diff_cancel_left [of a c "b - a", symmetric] add.commute)
 
 lemma diff_add: "b - a + a = b"
   by (simp add: add.commute add_diff_inverse)
 
 lemma le_add_diff: "c \<le> b + c - a"
   by (auto simp add: add.commute diff_add_assoc2 le_iff_add)
 
 lemma le_imp_diff_is_add: "a \<le> b \<Longrightarrow> b - a = c \<longleftrightarrow> b = c + a"
   by (auto simp add: add.commute add_diff_inverse)
 
 lemma le_diff_conv2: "c \<le> b - a \<longleftrightarrow> c + a \<le> b"
   (is "?P \<longleftrightarrow> ?Q")
 proof
   assume ?P
   then have "c + a \<le> b - a + a"
     by (rule add_right_mono)
   then show ?Q
     by (simp add: add_diff_inverse add.commute)
 next
   assume ?Q
   then have "a + c \<le> a + (b - a)"
     by (simp add: add_diff_inverse add.commute)
   then show ?P by simp
 qed
 
 end
 
 end
 
 
 subsection \<open>Tools setup\<close>
 
 lemma add_mono_thms_linordered_semiring:
   fixes i j k :: "'a::ordered_ab_semigroup_add"
   shows "i \<le> j \<and> k \<le> l \<Longrightarrow> i + k \<le> j + l"
     and "i = j \<and> k \<le> l \<Longrightarrow> i + k \<le> j + l"
     and "i \<le> j \<and> k = l \<Longrightarrow> i + k \<le> j + l"
     and "i = j \<and> k = l \<Longrightarrow> i + k = j + l"
   by (rule add_mono, clarify+)+
 
 lemma add_mono_thms_linordered_field:
   fixes i j k :: "'a::ordered_cancel_ab_semigroup_add"
   shows "i < j \<and> k = l \<Longrightarrow> i + k < j + l"
     and "i = j \<and> k < l \<Longrightarrow> i + k < j + l"
     and "i < j \<and> k \<le> l \<Longrightarrow> i + k < j + l"
     and "i \<le> j \<and> k < l \<Longrightarrow> i + k < j + l"
     and "i < j \<and> k < l \<Longrightarrow> i + k < j + l"
   by (auto intro: add_strict_right_mono add_strict_left_mono
       add_less_le_mono add_le_less_mono add_strict_mono)
 
 code_identifier
   code_module Groups \<rightharpoonup> (SML) Arith and (OCaml) Arith and (Haskell) Arith
 
 end
diff --git a/src/HOL/HOL.thy b/src/HOL/HOL.thy
--- a/src/HOL/HOL.thy
+++ b/src/HOL/HOL.thy
@@ -1,2177 +1,2177 @@
 (*  Title:      HOL/HOL.thy
     Author:     Tobias Nipkow, Markus Wenzel, and Larry Paulson
 *)
 
 section \<open>The basis of Higher-Order Logic\<close>
 
 theory HOL
 imports Pure Tools.Code_Generator
 keywords
   "try" "solve_direct" "quickcheck" "print_coercions" "print_claset"
     "print_induct_rules" :: diag and
   "quickcheck_params" :: thy_decl
 abbrevs "?<" = "\<exists>\<^sub>\<le>\<^sub>1"
 begin
 
 ML_file \<open>~~/src/Tools/misc_legacy.ML\<close>
 ML_file \<open>~~/src/Tools/try.ML\<close>
 ML_file \<open>~~/src/Tools/quickcheck.ML\<close>
 ML_file \<open>~~/src/Tools/solve_direct.ML\<close>
 ML_file \<open>~~/src/Tools/IsaPlanner/zipper.ML\<close>
 ML_file \<open>~~/src/Tools/IsaPlanner/isand.ML\<close>
 ML_file \<open>~~/src/Tools/IsaPlanner/rw_inst.ML\<close>
 ML_file \<open>~~/src/Provers/hypsubst.ML\<close>
 ML_file \<open>~~/src/Provers/splitter.ML\<close>
 ML_file \<open>~~/src/Provers/classical.ML\<close>
 ML_file \<open>~~/src/Provers/blast.ML\<close>
 ML_file \<open>~~/src/Provers/clasimp.ML\<close>
 ML_file \<open>~~/src/Tools/eqsubst.ML\<close>
 ML_file \<open>~~/src/Provers/quantifier1.ML\<close>
 ML_file \<open>~~/src/Tools/atomize_elim.ML\<close>
 ML_file \<open>~~/src/Tools/cong_tac.ML\<close>
 ML_file \<open>~~/src/Tools/intuitionistic.ML\<close> setup \<open>Intuitionistic.method_setup \<^binding>\<open>iprover\<close>\<close>
 ML_file \<open>~~/src/Tools/project_rule.ML\<close>
 ML_file \<open>~~/src/Tools/subtyping.ML\<close>
 ML_file \<open>~~/src/Tools/case_product.ML\<close>
 
 
 ML \<open>Plugin_Name.declare_setup \<^binding>\<open>extraction\<close>\<close>
 
 ML \<open>
   Plugin_Name.declare_setup \<^binding>\<open>quickcheck_random\<close>;
   Plugin_Name.declare_setup \<^binding>\<open>quickcheck_exhaustive\<close>;
   Plugin_Name.declare_setup \<^binding>\<open>quickcheck_bounded_forall\<close>;
   Plugin_Name.declare_setup \<^binding>\<open>quickcheck_full_exhaustive\<close>;
   Plugin_Name.declare_setup \<^binding>\<open>quickcheck_narrowing\<close>;
 \<close>
 ML \<open>
   Plugin_Name.define_setup \<^binding>\<open>quickcheck\<close>
    [\<^plugin>\<open>quickcheck_exhaustive\<close>,
     \<^plugin>\<open>quickcheck_random\<close>,
     \<^plugin>\<open>quickcheck_bounded_forall\<close>,
     \<^plugin>\<open>quickcheck_full_exhaustive\<close>,
     \<^plugin>\<open>quickcheck_narrowing\<close>]
 \<close>
 
 
 subsection \<open>Primitive logic\<close>
 
 text \<open>
 The definition of the logic is based on Mike Gordon's technical report \<^cite>\<open>"Gordon-TR68"\<close> that
 describes the first implementation of HOL. However, there are a number of differences.
 In particular, we start with the definite description operator and introduce Hilbert's \<open>\<epsilon>\<close> operator
 only much later. Moreover, axiom \<open>(P \<longrightarrow> Q) \<longrightarrow> (Q \<longrightarrow> P) \<longrightarrow> (P = Q)\<close> is derived from the other
 axioms. The fact that this axiom is derivable was first noticed by Bruno Barras (for Mike Gordon's
 line of HOL systems) and later independently by Alexander Maletzky (for Isabelle/HOL).
 \<close>
 
 subsubsection \<open>Core syntax\<close>
 
 setup \<open>Axclass.class_axiomatization (\<^binding>\<open>type\<close>, [])\<close>
 default_sort type
 setup \<open>Object_Logic.add_base_sort \<^sort>\<open>type\<close>\<close>
 
 setup \<open>Proofterm.set_preproc (Proof_Rewrite_Rules.standard_preproc [])\<close>
 
 axiomatization where fun_arity: "OFCLASS('a \<Rightarrow> 'b, type_class)"
 instance "fun" :: (type, type) type by (rule fun_arity)
 
 axiomatization where itself_arity: "OFCLASS('a itself, type_class)"
 instance itself :: (type) type by (rule itself_arity)
 
 typedecl bool
 
 judgment Trueprop :: "bool \<Rightarrow> prop"  ("(_)" 5)
 
 axiomatization implies :: "[bool, bool] \<Rightarrow> bool"  (infixr "\<longrightarrow>" 25)
   and eq :: "['a, 'a] \<Rightarrow> bool"
   and The :: "('a \<Rightarrow> bool) \<Rightarrow> 'a"
 
 notation (input)
   eq  (infixl "=" 50)
 notation (output)
   eq  (infix "=" 50)
 
 text \<open>The input syntax for \<open>eq\<close> is more permissive than the output syntax
 because of the large amount of material that relies on infixl.\<close>
 
 subsubsection \<open>Defined connectives and quantifiers\<close>
 
 definition True :: bool
   where "True \<equiv> ((\<lambda>x::bool. x) = (\<lambda>x. x))"
 
 definition All :: "('a \<Rightarrow> bool) \<Rightarrow> bool"  (binder "\<forall>" 10)
   where "All P \<equiv> (P = (\<lambda>x. True))"
 
 definition Ex :: "('a \<Rightarrow> bool) \<Rightarrow> bool"  (binder "\<exists>" 10)
   where "Ex P \<equiv> \<forall>Q. (\<forall>x. P x \<longrightarrow> Q) \<longrightarrow> Q"
 
 definition False :: bool
   where "False \<equiv> (\<forall>P. P)"
 
 definition Not :: "bool \<Rightarrow> bool"  ("\<not> _" [40] 40)
   where not_def: "\<not> P \<equiv> P \<longrightarrow> False"
 
 definition conj :: "[bool, bool] \<Rightarrow> bool"  (infixr "\<and>" 35)
   where and_def: "P \<and> Q \<equiv> \<forall>R. (P \<longrightarrow> Q \<longrightarrow> R) \<longrightarrow> R"
 
 definition disj :: "[bool, bool] \<Rightarrow> bool"  (infixr "\<or>" 30)
   where or_def: "P \<or> Q \<equiv> \<forall>R. (P \<longrightarrow> R) \<longrightarrow> (Q \<longrightarrow> R) \<longrightarrow> R"
 
 definition Uniq :: "('a \<Rightarrow> bool) \<Rightarrow> bool"
   where "Uniq P \<equiv> (\<forall>x y. P x \<longrightarrow> P y \<longrightarrow> y = x)"
 
 definition Ex1 :: "('a \<Rightarrow> bool) \<Rightarrow> bool"
   where "Ex1 P \<equiv> \<exists>x. P x \<and> (\<forall>y. P y \<longrightarrow> y = x)"
 
 
 subsubsection \<open>Additional concrete syntax\<close>
 
 syntax (ASCII) "_Uniq" :: "pttrn \<Rightarrow> bool \<Rightarrow> bool"  ("(4?< _./ _)" [0, 10] 10)
 syntax "_Uniq" :: "pttrn \<Rightarrow> bool \<Rightarrow> bool"  ("(2\<exists>\<^sub>\<le>\<^sub>1 _./ _)" [0, 10] 10)
 translations "\<exists>\<^sub>\<le>\<^sub>1x. P" \<rightleftharpoons> "CONST Uniq (\<lambda>x. P)"
 
 print_translation \<open>
  [Syntax_Trans.preserve_binder_abs_tr' \<^const_syntax>\<open>Uniq\<close> \<^syntax_const>\<open>_Uniq\<close>]
 \<close> \<comment> \<open>to avoid eta-contraction of body\<close>
 
 
 syntax (ASCII)
   "_Ex1" :: "pttrn \<Rightarrow> bool \<Rightarrow> bool"  ("(3EX! _./ _)" [0, 10] 10)
 syntax (input)
   "_Ex1" :: "pttrn \<Rightarrow> bool \<Rightarrow> bool"  ("(3?! _./ _)" [0, 10] 10)
 syntax "_Ex1" :: "pttrn \<Rightarrow> bool \<Rightarrow> bool"  ("(3\<exists>!_./ _)" [0, 10] 10)
 translations "\<exists>!x. P" \<rightleftharpoons> "CONST Ex1 (\<lambda>x. P)"
 
 print_translation \<open>
  [Syntax_Trans.preserve_binder_abs_tr' \<^const_syntax>\<open>Ex1\<close> \<^syntax_const>\<open>_Ex1\<close>]
 \<close> \<comment> \<open>to avoid eta-contraction of body\<close>
 
 
 syntax
   "_Not_Ex" :: "idts \<Rightarrow> bool \<Rightarrow> bool"  ("(3\<nexists>_./ _)" [0, 10] 10)
   "_Not_Ex1" :: "pttrn \<Rightarrow> bool \<Rightarrow> bool"  ("(3\<nexists>!_./ _)" [0, 10] 10)
 translations
   "\<nexists>x. P" \<rightleftharpoons> "\<not> (\<exists>x. P)"
   "\<nexists>!x. P" \<rightleftharpoons> "\<not> (\<exists>!x. P)"
 
 
 abbreviation not_equal :: "['a, 'a] \<Rightarrow> bool"  (infix "\<noteq>" 50)
   where "x \<noteq> y \<equiv> \<not> (x = y)"
 
 notation (ASCII)
   Not  ("~ _" [40] 40) and
   conj  (infixr "&" 35) and
   disj  (infixr "|" 30) and
   implies  (infixr "-->" 25) and
   not_equal  (infix "~=" 50)
 
 abbreviation (iff)
   iff :: "[bool, bool] \<Rightarrow> bool"  (infixr "\<longleftrightarrow>" 25)
   where "A \<longleftrightarrow> B \<equiv> A = B"
 
 syntax "_The" :: "[pttrn, bool] \<Rightarrow> 'a"  ("(3THE _./ _)" [0, 10] 10)
 translations "THE x. P" \<rightleftharpoons> "CONST The (\<lambda>x. P)"
 print_translation \<open>
   [(\<^const_syntax>\<open>The\<close>, fn _ => fn [Abs abs] =>
       let val (x, t) = Syntax_Trans.atomic_abs_tr' abs
       in Syntax.const \<^syntax_const>\<open>_The\<close> $ x $ t end)]
 \<close>  \<comment> \<open>To avoid eta-contraction of body\<close>
 
 nonterminal letbinds and letbind
 syntax
   "_bind"       :: "[pttrn, 'a] \<Rightarrow> letbind"              ("(2_ =/ _)" 10)
   ""            :: "letbind \<Rightarrow> letbinds"                 ("_")
   "_binds"      :: "[letbind, letbinds] \<Rightarrow> letbinds"     ("_;/ _")
   "_Let"        :: "[letbinds, 'a] \<Rightarrow> 'a"                ("(let (_)/ in (_))" [0, 10] 10)
 
 nonterminal case_syn and cases_syn
 syntax
   "_case_syntax" :: "['a, cases_syn] \<Rightarrow> 'b"  ("(case _ of/ _)" 10)
   "_case1" :: "['a, 'b] \<Rightarrow> case_syn"  ("(2_ \<Rightarrow>/ _)" 10)
   "" :: "case_syn \<Rightarrow> cases_syn"  ("_")
   "_case2" :: "[case_syn, cases_syn] \<Rightarrow> cases_syn"  ("_/ | _")
 syntax (ASCII)
   "_case1" :: "['a, 'b] \<Rightarrow> case_syn"  ("(2_ =>/ _)" 10)
 
 notation (ASCII)
   All  (binder "ALL " 10) and
   Ex  (binder "EX " 10)
 
 notation (input)
   All  (binder "! " 10) and
   Ex  (binder "? " 10)
 
 
 subsubsection \<open>Axioms and basic definitions\<close>
 
 axiomatization where
   refl: "t = (t::'a)" and
   subst: "s = t \<Longrightarrow> P s \<Longrightarrow> P t" and
   ext: "(\<And>x::'a. (f x ::'b) = g x) \<Longrightarrow> (\<lambda>x. f x) = (\<lambda>x. g x)"
     \<comment> \<open>Extensionality is built into the meta-logic, and this rule expresses
          a related property.  It is an eta-expanded version of the traditional
          rule, and similar to the ABS rule of HOL\<close> and
 
   the_eq_trivial: "(THE x. x = a) = (a::'a)"
 
 axiomatization where
   impI: "(P \<Longrightarrow> Q) \<Longrightarrow> P \<longrightarrow> Q" and
   mp: "\<lbrakk>P \<longrightarrow> Q; P\<rbrakk> \<Longrightarrow> Q" and
 
   True_or_False: "(P = True) \<or> (P = False)"
 
 definition If :: "bool \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("(if (_)/ then (_)/ else (_))" [0, 0, 10] 10)
   where "If P x y \<equiv> (THE z::'a. (P = True \<longrightarrow> z = x) \<and> (P = False \<longrightarrow> z = y))"
 
 definition Let :: "'a \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b"
   where "Let s f \<equiv> f s"
 
 translations
   "_Let (_binds b bs) e"  \<rightleftharpoons> "_Let b (_Let bs e)"
   "let x = a in e"        \<rightleftharpoons> "CONST Let a (\<lambda>x. e)"
 
 axiomatization undefined :: 'a
 
 class default = fixes default :: 'a
 
 
 subsection \<open>Fundamental rules\<close>
 
 subsubsection \<open>Equality\<close>
 
 lemma sym: "s = t \<Longrightarrow> t = s"
   by (erule subst) (rule refl)
 
 lemma ssubst: "t = s \<Longrightarrow> P s \<Longrightarrow> P t"
   by (drule sym) (erule subst)
 
 lemma trans: "\<lbrakk>r = s; s = t\<rbrakk> \<Longrightarrow> r = t"
   by (erule subst)
 
 lemma trans_sym [Pure.elim?]: "r = s \<Longrightarrow> t = s \<Longrightarrow> r = t"
   by (rule trans [OF _ sym])
 
 lemma meta_eq_to_obj_eq:
   assumes "A \<equiv> B"
   shows "A = B"
   unfolding assms by (rule refl)
 
 text \<open>Useful with \<open>erule\<close> for proving equalities from known equalities.\<close>
      (* a = b
         |   |
         c = d   *)
 lemma box_equals: "\<lbrakk>a = b; a = c; b = d\<rbrakk> \<Longrightarrow> c = d"
   by (iprover intro: sym trans)
 
 text \<open>For calculational reasoning:\<close>
 
 lemma forw_subst: "a = b \<Longrightarrow> P b \<Longrightarrow> P a"
   by (rule ssubst)
 
 lemma back_subst: "P a \<Longrightarrow> a = b \<Longrightarrow> P b"
   by (rule subst)
 
 
 subsubsection \<open>Congruence rules for application\<close>
 
 text \<open>Similar to \<open>AP_THM\<close> in Gordon's HOL.\<close>
 lemma fun_cong: "(f :: 'a \<Rightarrow> 'b) = g \<Longrightarrow> f x = g x"
   by (iprover intro: refl elim: subst)
 
 text \<open>Similar to \<open>AP_TERM\<close> in Gordon's HOL and FOL's \<open>subst_context\<close>.\<close>
 lemma arg_cong: "x = y \<Longrightarrow> f x = f y"
   by (iprover intro: refl elim: subst)
 
 lemma arg_cong2: "\<lbrakk>a = b; c = d\<rbrakk> \<Longrightarrow> f a c = f b d"
   by (iprover intro: refl elim: subst)
 
 lemma cong: "\<lbrakk>f = g; (x::'a) = y\<rbrakk> \<Longrightarrow> f x = g y"
   by (iprover intro: refl elim: subst)
 
 ML \<open>fun cong_tac ctxt = Cong_Tac.cong_tac ctxt @{thm cong}\<close>
 
 
 subsubsection \<open>Equality of booleans -- iff\<close>
 
 lemma iffD2: "\<lbrakk>P = Q; Q\<rbrakk> \<Longrightarrow> P"
   by (erule ssubst)
 
 lemma rev_iffD2: "\<lbrakk>Q; P = Q\<rbrakk> \<Longrightarrow> P"
   by (erule iffD2)
 
 lemma iffD1: "Q = P \<Longrightarrow> Q \<Longrightarrow> P"
   by (drule sym) (rule iffD2)
 
 lemma rev_iffD1: "Q \<Longrightarrow> Q = P \<Longrightarrow> P"
   by (drule sym) (rule rev_iffD2)
 
 lemma iffE:
   assumes major: "P = Q"
     and minor: "\<lbrakk>P \<longrightarrow> Q; Q \<longrightarrow> P\<rbrakk> \<Longrightarrow> R"
   shows R
   by (iprover intro: minor impI major [THEN iffD2] major [THEN iffD1])
 
 
 subsubsection \<open>True (1)\<close>
 
 lemma TrueI: True
   unfolding True_def by (rule refl)
 
 lemma eqTrueE: "P = True \<Longrightarrow> P"
   by (erule iffD2) (rule TrueI)
 
 
 subsubsection \<open>Universal quantifier (1)\<close>
 
 lemma spec: "\<forall>x::'a. P x \<Longrightarrow> P x"
   unfolding All_def by (iprover intro: eqTrueE fun_cong)
 
 lemma allE:
   assumes major: "\<forall>x. P x" and minor: "P x \<Longrightarrow> R"
   shows R
   by (iprover intro: minor major [THEN spec])
 
 lemma all_dupE:
   assumes major: "\<forall>x. P x" and minor: "\<lbrakk>P x; \<forall>x. P x\<rbrakk> \<Longrightarrow> R"
   shows R
   by (iprover intro: minor major major [THEN spec])
 
 
 subsubsection \<open>False\<close>
 
 text \<open>
   Depends upon \<open>spec\<close>; it is impossible to do propositional
   logic before quantifiers!
 \<close>
 
 lemma FalseE: "False \<Longrightarrow> P"
   unfolding False_def by (erule spec)
 
 lemma False_neq_True: "False = True \<Longrightarrow> P"
   by (erule eqTrueE [THEN FalseE])
 
 
 subsubsection \<open>Negation\<close>
 
 lemma notI:
   assumes "P \<Longrightarrow> False"
   shows "\<not> P"
   unfolding not_def by (iprover intro: impI assms)
 
 lemma False_not_True: "False \<noteq> True"
   by (iprover intro: notI elim: False_neq_True)
 
 lemma True_not_False: "True \<noteq> False"
   by (iprover intro: notI dest: sym elim: False_neq_True)
 
 lemma notE: "\<lbrakk>\<not> P; P\<rbrakk> \<Longrightarrow> R"
   unfolding not_def
   by (iprover intro: mp [THEN FalseE])
 
 
 subsubsection \<open>Implication\<close>
 
 lemma impE:
   assumes "P \<longrightarrow> Q" P "Q \<Longrightarrow> R"
   shows R
   by (iprover intro: assms mp)
 
 text \<open>Reduces \<open>Q\<close> to \<open>P \<longrightarrow> Q\<close>, allowing substitution in \<open>P\<close>.\<close>
 lemma rev_mp: "\<lbrakk>P; P \<longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
   by (rule mp)
 
 lemma contrapos_nn:
   assumes major: "\<not> Q"
     and minor: "P \<Longrightarrow> Q"
   shows "\<not> P"
   by (iprover intro: notI minor major [THEN notE])
 
 text \<open>Not used at all, but we already have the other 3 combinations.\<close>
 lemma contrapos_pn:
   assumes major: "Q"
     and minor: "P \<Longrightarrow> \<not> Q"
   shows "\<not> P"
   by (iprover intro: notI minor major notE)
 
 lemma not_sym: "t \<noteq> s \<Longrightarrow> s \<noteq> t"
   by (erule contrapos_nn) (erule sym)
 
 lemma eq_neq_eq_imp_neq: "\<lbrakk>x = a; a \<noteq> b; b = y\<rbrakk> \<Longrightarrow> x \<noteq> y"
   by (erule subst, erule ssubst, assumption)
 
 
 subsubsection \<open>Disjunction (1)\<close>
 
 lemma disjE:
   assumes major: "P \<or> Q"
     and minorP: "P \<Longrightarrow> R"
     and minorQ: "Q \<Longrightarrow> R"
   shows R
   by (iprover intro: minorP minorQ impI
       major [unfolded or_def, THEN spec, THEN mp, THEN mp])
 
 
 subsubsection \<open>Derivation of \<open>iffI\<close>\<close>
 
 text \<open>In an intuitionistic version of HOL \<open>iffI\<close> needs to be an axiom.\<close>
 
 lemma iffI:
   assumes "P \<Longrightarrow> Q" and "Q \<Longrightarrow> P"
   shows "P = Q"
 proof (rule disjE[OF True_or_False[of P]])
   assume 1: "P = True"
   note Q = assms(1)[OF eqTrueE[OF this]]
   from 1 show ?thesis
   proof (rule ssubst)
     from True_or_False[of Q] show "True = Q"
     proof (rule disjE)
       assume "Q = True"
       thus ?thesis by(rule sym)
     next
       assume "Q = False"
       with Q have False by (rule rev_iffD1)
       thus ?thesis by (rule FalseE)
     qed
   qed
 next
   assume 2: "P = False"
   thus ?thesis
   proof (rule ssubst)
     from True_or_False[of Q] show "False = Q"
     proof (rule disjE)
       assume "Q = True"
       from 2 assms(2)[OF eqTrueE[OF this]] have False by (rule iffD1)
       thus ?thesis by (rule FalseE)
     next
       assume "Q = False"
       thus ?thesis by(rule sym)
     qed
   qed
 qed
 
 
 subsubsection \<open>True (2)\<close>
 
 lemma eqTrueI: "P \<Longrightarrow> P = True"
   by (iprover intro: iffI TrueI)
 
 
 subsubsection \<open>Universal quantifier (2)\<close>
 
 lemma allI:
   assumes "\<And>x::'a. P x"
   shows "\<forall>x. P x"
   unfolding All_def by (iprover intro: ext eqTrueI assms)
 
 
 subsubsection \<open>Existential quantifier\<close>
 
 lemma exI: "P x \<Longrightarrow> \<exists>x::'a. P x"
   unfolding Ex_def by (iprover intro: allI allE impI mp)
 
 lemma exE:
   assumes major: "\<exists>x::'a. P x"
     and minor: "\<And>x. P x \<Longrightarrow> Q"
   shows "Q"
   by (rule major [unfolded Ex_def, THEN spec, THEN mp]) (iprover intro: impI [THEN allI] minor)
 
 
 subsubsection \<open>Conjunction\<close>
 
 lemma conjI: "\<lbrakk>P; Q\<rbrakk> \<Longrightarrow> P \<and> Q"
   unfolding and_def by (iprover intro: impI [THEN allI] mp)
 
 lemma conjunct1: "\<lbrakk>P \<and> Q\<rbrakk> \<Longrightarrow> P"
   unfolding and_def by (iprover intro: impI dest: spec mp)
 
 lemma conjunct2: "\<lbrakk>P \<and> Q\<rbrakk> \<Longrightarrow> Q"
   unfolding and_def by (iprover intro: impI dest: spec mp)
 
 lemma conjE:
   assumes major: "P \<and> Q"
     and minor: "\<lbrakk>P; Q\<rbrakk> \<Longrightarrow> R"
   shows R
 proof (rule minor)
   show P by (rule major [THEN conjunct1])
   show Q by (rule major [THEN conjunct2])
 qed
 
 lemma context_conjI:
   assumes P "P \<Longrightarrow> Q"
   shows "P \<and> Q"
   by (iprover intro: conjI assms)
 
 
 subsubsection \<open>Disjunction (2)\<close>
 
 lemma disjI1: "P \<Longrightarrow> P \<or> Q"
   unfolding or_def by (iprover intro: allI impI mp)
 
 lemma disjI2: "Q \<Longrightarrow> P \<or> Q"
   unfolding or_def by (iprover intro: allI impI mp)
 
 
 subsubsection \<open>Classical logic\<close>
 
 lemma classical:
   assumes "\<not> P \<Longrightarrow> P"
   shows P
 proof (rule True_or_False [THEN disjE])
   show P if "P = True"
     using that by (iprover intro: eqTrueE)
   show P if "P = False"
   proof (intro notI assms)
     assume P
     with that show False
       by (iprover elim: subst)
   qed
 qed
 
 lemmas ccontr = FalseE [THEN classical]
 
 text \<open>\<open>notE\<close> with premises exchanged; it discharges \<open>\<not> R\<close> so that it can be used to
   make elimination rules.\<close>
 lemma rev_notE:
   assumes premp: P
     and premnot: "\<not> R \<Longrightarrow> \<not> P"
   shows R
   by (iprover intro: ccontr notE [OF premnot premp])
 
 
 text \<open>Double negation law.\<close>
 lemma notnotD: "\<not>\<not> P \<Longrightarrow> P"
   by (iprover intro: ccontr notE )
 
 lemma contrapos_pp:
   assumes p1: Q
     and p2: "\<not> P \<Longrightarrow> \<not> Q"
   shows P
   by (iprover intro: classical p1 p2 notE)
 
 
 subsubsection \<open>Unique existence\<close>
 
 lemma Uniq_I [intro?]:
   assumes "\<And>x y. \<lbrakk>P x; P y\<rbrakk> \<Longrightarrow> y = x"
   shows "Uniq P"
   unfolding Uniq_def by (iprover intro: assms allI impI)
 
 lemma Uniq_D [dest?]: "\<lbrakk>Uniq P; P a; P b\<rbrakk> \<Longrightarrow> a=b"
   unfolding Uniq_def by (iprover dest: spec mp)
 
 lemma ex1I:
   assumes "P a" "\<And>x. P x \<Longrightarrow> x = a"
   shows "\<exists>!x. P x"
   unfolding Ex1_def by (iprover intro: assms exI conjI allI impI)
 
 text \<open>Sometimes easier to use: the premises have no shared variables. Safe!\<close>
 lemma ex_ex1I:
   assumes ex_prem: "\<exists>x. P x"
     and eq: "\<And>x y. \<lbrakk>P x; P y\<rbrakk> \<Longrightarrow> x = y"
   shows "\<exists>!x. P x"
   by (iprover intro: ex_prem [THEN exE] ex1I eq)
 
 lemma ex1E:
   assumes major: "\<exists>!x. P x" and minor: "\<And>x. \<lbrakk>P x; \<forall>y. P y \<longrightarrow> y = x\<rbrakk> \<Longrightarrow> R"
   shows R
 proof (rule major [unfolded Ex1_def, THEN exE])
   show "\<And>x. P x \<and> (\<forall>y. P y \<longrightarrow> y = x) \<Longrightarrow> R"
     by (iprover intro: minor elim: conjE)
 qed
 
 lemma ex1_implies_ex: "\<exists>!x. P x \<Longrightarrow> \<exists>x. P x"
   by (iprover intro: exI elim: ex1E)
 
 subsubsection \<open>Classical intro rules for disjunction and existential quantifiers\<close>
 
 lemma disjCI:
   assumes "\<not> Q \<Longrightarrow> P"
   shows "P \<or> Q"
   by (rule classical) (iprover intro: assms disjI1 disjI2 notI elim: notE)
 
 lemma excluded_middle: "\<not> P \<or> P"
   by (iprover intro: disjCI)
 
 text \<open>
   case distinction as a natural deduction rule.
   Note that \<open>\<not> P\<close> is the second case, not the first.
 \<close>
 lemma case_split [case_names True False]:
   assumes "P \<Longrightarrow> Q" "\<not> P \<Longrightarrow> Q"
   shows Q
   using excluded_middle [of P]
     by (iprover intro: assms elim: disjE)
 
 text \<open>Classical implies (\<open>\<longrightarrow>\<close>) elimination.\<close>
 lemma impCE:
   assumes major: "P \<longrightarrow> Q"
     and minor: "\<not> P \<Longrightarrow> R" "Q \<Longrightarrow> R"
   shows R
   using excluded_middle [of P]
   by (iprover intro: minor major [THEN mp] elim: disjE)+
 
 text \<open>
   This version of \<open>\<longrightarrow>\<close> elimination works on \<open>Q\<close> before \<open>P\<close>.  It works best for
   those cases in which \<open>P\<close> holds "almost everywhere".  Can't install as
   default: would break old proofs.
 \<close>
 lemma impCE':
   assumes major: "P \<longrightarrow> Q"
     and minor: "Q \<Longrightarrow> R" "\<not> P \<Longrightarrow> R"
   shows R
   using assms by (elim impCE)
 
 
 text \<open>Classical \<open>\<longleftrightarrow>\<close> elimination.\<close>
 lemma iffCE:
   assumes major: "P = Q"
     and minor: "\<lbrakk>P; Q\<rbrakk> \<Longrightarrow> R" "\<lbrakk>\<not> P; \<not> Q\<rbrakk> \<Longrightarrow> R"
   shows R
   by (rule major [THEN iffE]) (iprover intro: minor elim: impCE notE)
 
 lemma exCI:
   assumes "\<forall>x. \<not> P x \<Longrightarrow> P a"
   shows "\<exists>x. P x"
   by (rule ccontr) (iprover intro: assms exI allI notI notE [of "\<exists>x. P x"])
 
 
 subsubsection \<open>Intuitionistic Reasoning\<close>
 
 lemma impE':
   assumes 1: "P \<longrightarrow> Q"
     and 2: "Q \<Longrightarrow> R"
     and 3: "P \<longrightarrow> Q \<Longrightarrow> P"
   shows R
 proof -
   from 3 and 1 have P .
   with 1 have Q by (rule impE)
   with 2 show R .
 qed
 
 lemma allE':
   assumes 1: "\<forall>x. P x"
     and 2: "P x \<Longrightarrow> \<forall>x. P x \<Longrightarrow> Q"
   shows Q
 proof -
   from 1 have "P x" by (rule spec)
   from this and 1 show Q by (rule 2)
 qed
 
 lemma notE':
   assumes 1: "\<not> P"
     and 2: "\<not> P \<Longrightarrow> P"
   shows R
 proof -
   from 2 and 1 have P .
   with 1 show R by (rule notE)
 qed
 
 lemma TrueE: "True \<Longrightarrow> P \<Longrightarrow> P" .
 lemma notFalseE: "\<not> False \<Longrightarrow> P \<Longrightarrow> P" .
 
 lemmas [Pure.elim!] = disjE iffE FalseE conjE exE TrueE notFalseE
   and [Pure.intro!] = iffI conjI impI TrueI notI allI refl
   and [Pure.elim 2] = allE notE' impE'
   and [Pure.intro] = exI disjI2 disjI1
 
 lemmas [trans] = trans
   and [sym] = sym not_sym
   and [Pure.elim?] = iffD1 iffD2 impE
 
 
 subsubsection \<open>Atomizing meta-level connectives\<close>
 
 axiomatization where
   eq_reflection: "x = y \<Longrightarrow> x \<equiv> y"  \<comment> \<open>admissible axiom\<close>
 
 lemma atomize_all [atomize]: "(\<And>x. P x) \<equiv> Trueprop (\<forall>x. P x)"
 proof
   assume "\<And>x. P x"
   then show "\<forall>x. P x" ..
 next
   assume "\<forall>x. P x"
   then show "\<And>x. P x" by (rule allE)
 qed
 
 lemma atomize_imp [atomize]: "(A \<Longrightarrow> B) \<equiv> Trueprop (A \<longrightarrow> B)"
 proof
   assume r: "A \<Longrightarrow> B"
   show "A \<longrightarrow> B" by (rule impI) (rule r)
 next
   assume "A \<longrightarrow> B" and A
   then show B by (rule mp)
 qed
 
 lemma atomize_not: "(A \<Longrightarrow> False) \<equiv> Trueprop (\<not> A)"
 proof
   assume r: "A \<Longrightarrow> False"
   show "\<not> A" by (rule notI) (rule r)
 next
   assume "\<not> A" and A
   then show False by (rule notE)
 qed
 
 lemma atomize_eq [atomize, code]: "(x \<equiv> y) \<equiv> Trueprop (x = y)"
 proof
   assume "x \<equiv> y"
   show "x = y" by (unfold \<open>x \<equiv> y\<close>) (rule refl)
 next
   assume "x = y"
   then show "x \<equiv> y" by (rule eq_reflection)
 qed
 
 lemma atomize_conj [atomize]: "(A &&& B) \<equiv> Trueprop (A \<and> B)"
 proof
   assume conj: "A &&& B"
   show "A \<and> B"
   proof (rule conjI)
     from conj show A by (rule conjunctionD1)
     from conj show B by (rule conjunctionD2)
   qed
 next
   assume conj: "A \<and> B"
   show "A &&& B"
   proof -
     from conj show A ..
     from conj show B ..
   qed
 qed
 
 lemmas [symmetric, rulify] = atomize_all atomize_imp
   and [symmetric, defn] = atomize_all atomize_imp atomize_eq
 
 
 subsubsection \<open>Atomizing elimination rules\<close>
 
 lemma atomize_exL[atomize_elim]: "(\<And>x. P x \<Longrightarrow> Q) \<equiv> ((\<exists>x. P x) \<Longrightarrow> Q)"
   by (rule equal_intr_rule) iprover+
 
 lemma atomize_conjL[atomize_elim]: "(A \<Longrightarrow> B \<Longrightarrow> C) \<equiv> (A \<and> B \<Longrightarrow> C)"
   by (rule equal_intr_rule) iprover+
 
 lemma atomize_disjL[atomize_elim]: "((A \<Longrightarrow> C) \<Longrightarrow> (B \<Longrightarrow> C) \<Longrightarrow> C) \<equiv> ((A \<or> B \<Longrightarrow> C) \<Longrightarrow> C)"
   by (rule equal_intr_rule) iprover+
 
 lemma atomize_elimL[atomize_elim]: "(\<And>B. (A \<Longrightarrow> B) \<Longrightarrow> B) \<equiv> Trueprop A" ..
 
 
 subsection \<open>Package setup\<close>
 
 ML_file \<open>Tools/hologic.ML\<close>
 ML_file \<open>Tools/rewrite_hol_proof.ML\<close>
 
 setup \<open>Proofterm.set_preproc (Proof_Rewrite_Rules.standard_preproc Rewrite_HOL_Proof.rews)\<close>
 
 
 subsubsection \<open>Sledgehammer setup\<close>
 
 text \<open>
   Theorems blacklisted to Sledgehammer. These theorems typically produce clauses
   that are prolific (match too many equality or membership literals) and relate to
   seldom-used facts. Some duplicate other rules.
 \<close>
 
 named_theorems no_atp "theorems that should be filtered out by Sledgehammer"
 
 
 subsubsection \<open>Classical Reasoner setup\<close>
 
 lemma imp_elim: "P \<longrightarrow> Q \<Longrightarrow> (\<not> R \<Longrightarrow> P) \<Longrightarrow> (Q \<Longrightarrow> R) \<Longrightarrow> R"
   by (rule classical) iprover
 
 lemma swap: "\<not> P \<Longrightarrow> (\<not> R \<Longrightarrow> P) \<Longrightarrow> R"
   by (rule classical) iprover
 
 lemma thin_refl: "\<lbrakk>x = x; PROP W\<rbrakk> \<Longrightarrow> PROP W" .
 
 ML \<open>
 structure Hypsubst = Hypsubst
 (
   val dest_eq = HOLogic.dest_eq
   val dest_Trueprop = HOLogic.dest_Trueprop
   val dest_imp = HOLogic.dest_imp
   val eq_reflection = @{thm eq_reflection}
   val rev_eq_reflection = @{thm meta_eq_to_obj_eq}
   val imp_intr = @{thm impI}
   val rev_mp = @{thm rev_mp}
   val subst = @{thm subst}
   val sym = @{thm sym}
   val thin_refl = @{thm thin_refl};
 );
 open Hypsubst;
 
 structure Classical = Classical
 (
   val imp_elim = @{thm imp_elim}
   val not_elim = @{thm notE}
   val swap = @{thm swap}
   val classical = @{thm classical}
   val sizef = Drule.size_of_thm
   val hyp_subst_tacs = [Hypsubst.hyp_subst_tac]
 );
 
 structure Basic_Classical: BASIC_CLASSICAL = Classical;
 open Basic_Classical;
 \<close>
 
 setup \<open>
   (*prevent substitution on bool*)
   let
     fun non_bool_eq (\<^const_name>\<open>HOL.eq\<close>, Type (_, [T, _])) = T <> \<^typ>\<open>bool\<close>
       | non_bool_eq _ = false;
     fun hyp_subst_tac' ctxt =
       SUBGOAL (fn (goal, i) =>
         if Term.exists_Const non_bool_eq goal
         then Hypsubst.hyp_subst_tac ctxt i
         else no_tac);
   in
     Context_Rules.addSWrapper (fn ctxt => fn tac => hyp_subst_tac' ctxt ORELSE' tac)
   end
 \<close>
 
 declare iffI [intro!]
   and notI [intro!]
   and impI [intro!]
   and disjCI [intro!]
   and conjI [intro!]
   and TrueI [intro!]
   and refl [intro!]
 
 declare iffCE [elim!]
   and FalseE [elim!]
   and impCE [elim!]
   and disjE [elim!]
   and conjE [elim!]
 
 declare ex_ex1I [intro!]
   and allI [intro!]
   and exI [intro]
 
 declare exE [elim!]
   allE [elim]
 
 ML \<open>val HOL_cs = claset_of \<^context>\<close>
 
 lemma contrapos_np: "\<not> Q \<Longrightarrow> (\<not> P \<Longrightarrow> Q) \<Longrightarrow> P"
   by (erule swap)
 
 declare ex_ex1I [rule del, intro! 2]
   and ex1I [intro]
 
 declare ext [intro]
 
 lemmas [intro?] = ext
   and [elim?] = ex1_implies_ex
 
 text \<open>Better than \<open>ex1E\<close> for classical reasoner: needs no quantifier duplication!\<close>
 lemma alt_ex1E [elim!]:
   assumes major: "\<exists>!x. P x"
     and minor: "\<And>x. \<lbrakk>P x; \<forall>y y'. P y \<and> P y' \<longrightarrow> y = y'\<rbrakk> \<Longrightarrow> R"
   shows R
 proof (rule ex1E [OF major minor])
   show "\<forall>y y'. P y \<and> P y' \<longrightarrow> y = y'" if "P x" and \<section>: "\<forall>y. P y \<longrightarrow> y = x" for x
     using \<open>P x\<close> \<section> \<section> by fast
 qed assumption
 
 text \<open>And again using Uniq\<close>
 lemma alt_ex1E':
   assumes  "\<exists>!x. P x" "\<And>x. \<lbrakk>P x; \<exists>\<^sub>\<le>\<^sub>1x. P x\<rbrakk> \<Longrightarrow> R"
   shows R
   using assms unfolding Uniq_def by fast
 
 lemma ex1_iff_ex_Uniq: "(\<exists>!x. P x) \<longleftrightarrow> (\<exists>x. P x) \<and> (\<exists>\<^sub>\<le>\<^sub>1x. P x)"
   unfolding Uniq_def by fast
 
 
 ML \<open>
   structure Blast = Blast
   (
     structure Classical = Classical
     val Trueprop_const = dest_Const \<^Const>\<open>Trueprop\<close>
     val equality_name = \<^const_name>\<open>HOL.eq\<close>
     val not_name = \<^const_name>\<open>Not\<close>
     val notE = @{thm notE}
     val ccontr = @{thm ccontr}
     val hyp_subst_tac = Hypsubst.blast_hyp_subst_tac
   );
   val blast_tac = Blast.blast_tac;
 \<close>
 
 
 subsubsection \<open>THE: definite description operator\<close>
 
 lemma the_equality [intro]:
   assumes "P a"
     and "\<And>x. P x \<Longrightarrow> x = a"
   shows "(THE x. P x) = a"
   by (blast intro: assms trans [OF arg_cong [where f=The] the_eq_trivial])
 
 lemma theI:
   assumes "P a"
     and "\<And>x. P x \<Longrightarrow> x = a"
   shows "P (THE x. P x)"
   by (iprover intro: assms the_equality [THEN ssubst])
 
 lemma theI': "\<exists>!x. P x \<Longrightarrow> P (THE x. P x)"
   by (blast intro: theI)
 
 text \<open>Easier to apply than \<open>theI\<close>: only one occurrence of \<open>P\<close>.\<close>
 lemma theI2:
   assumes "P a" "\<And>x. P x \<Longrightarrow> x = a" "\<And>x. P x \<Longrightarrow> Q x"
   shows "Q (THE x. P x)"
   by (iprover intro: assms theI)
 
 lemma the1I2:
   assumes "\<exists>!x. P x" "\<And>x. P x \<Longrightarrow> Q x"
   shows "Q (THE x. P x)"
   by (iprover intro: assms(2) theI2[where P=P and Q=Q] ex1E[OF assms(1)] elim: allE impE)
 
 lemma the1_equality [elim?]: "\<lbrakk>\<exists>!x. P x; P a\<rbrakk> \<Longrightarrow> (THE x. P x) = a"
   by blast
 
 lemma the1_equality': "\<lbrakk>\<exists>\<^sub>\<le>\<^sub>1x. P x; P a\<rbrakk> \<Longrightarrow> (THE x. P x) = a"
   unfolding Uniq_def by blast
 
 lemma the_sym_eq_trivial: "(THE y. x = y) = x"
   by blast
 
 
 subsubsection \<open>Simplifier\<close>
 
 lemma eta_contract_eq: "(\<lambda>s. f s) = f" ..
 
 lemma subst_all:
   \<open>(\<And>x. x = a \<Longrightarrow> PROP P x) \<equiv> PROP P a\<close>
   \<open>(\<And>x. a = x \<Longrightarrow> PROP P x) \<equiv> PROP P a\<close>
 proof -
   show \<open>(\<And>x. x = a \<Longrightarrow> PROP P x) \<equiv> PROP P a\<close>
   proof (rule equal_intr_rule)
     assume *: \<open>\<And>x. x = a \<Longrightarrow> PROP P x\<close>
     show \<open>PROP P a\<close>
       by (rule *) (rule refl)
   next
     fix x
     assume \<open>PROP P a\<close> and \<open>x = a\<close>
     from \<open>x = a\<close> have \<open>x \<equiv> a\<close>
       by (rule eq_reflection)
     with \<open>PROP P a\<close> show \<open>PROP P x\<close>
       by simp
   qed
   show \<open>(\<And>x. a = x \<Longrightarrow> PROP P x) \<equiv> PROP P a\<close>
   proof (rule equal_intr_rule)
     assume *: \<open>\<And>x. a = x \<Longrightarrow> PROP P x\<close>
     show \<open>PROP P a\<close>
       by (rule *) (rule refl)
   next
     fix x
     assume \<open>PROP P a\<close> and \<open>a = x\<close>
     from \<open>a = x\<close> have \<open>a \<equiv> x\<close>
       by (rule eq_reflection)
     with \<open>PROP P a\<close> show \<open>PROP P x\<close>
       by simp
   qed
 qed
 
 lemma simp_thms:
   shows not_not: "(\<not> \<not> P) = P"
   and Not_eq_iff: "((\<not> P) = (\<not> Q)) = (P = Q)"
   and
     "(P \<noteq> Q) = (P = (\<not> Q))"
     "(P \<or> \<not>P) = True"    "(\<not> P \<or> P) = True"
     "(x = x) = True"
   and not_True_eq_False [code]: "(\<not> True) = False"
   and not_False_eq_True [code]: "(\<not> False) = True"
   and
     "(\<not> P) \<noteq> P"  "P \<noteq> (\<not> P)"
     "(True = P) = P"
   and eq_True: "(P = True) = P"
   and "(False = P) = (\<not> P)"
   and eq_False: "(P = False) = (\<not> P)"
   and
     "(True \<longrightarrow> P) = P"  "(False \<longrightarrow> P) = True"
     "(P \<longrightarrow> True) = True"  "(P \<longrightarrow> P) = True"
     "(P \<longrightarrow> False) = (\<not> P)"  "(P \<longrightarrow> \<not> P) = (\<not> P)"
     "(P \<and> True) = P"  "(True \<and> P) = P"
     "(P \<and> False) = False"  "(False \<and> P) = False"
     "(P \<and> P) = P"  "(P \<and> (P \<and> Q)) = (P \<and> Q)"
     "(P \<and> \<not> P) = False"    "(\<not> P \<and> P) = False"
     "(P \<or> True) = True"  "(True \<or> P) = True"
     "(P \<or> False) = P"  "(False \<or> P) = P"
     "(P \<or> P) = P"  "(P \<or> (P \<or> Q)) = (P \<or> Q)" and
     "(\<forall>x. P) = P"  "(\<exists>x. P) = P"  "\<exists>x. x = t"  "\<exists>x. t = x"
   and
     "\<And>P. (\<exists>x. x = t \<and> P x) = P t"
     "\<And>P. (\<exists>x. t = x \<and> P x) = P t"
     "\<And>P. (\<forall>x. x = t \<longrightarrow> P x) = P t"
     "\<And>P. (\<forall>x. t = x \<longrightarrow> P x) = P t"
     "(\<forall>x. x \<noteq> t) = False"  "(\<forall>x. t \<noteq> x) = False"
   by (blast, blast, blast, blast, blast, iprover+)
 
 lemma disj_absorb: "A \<or> A \<longleftrightarrow> A"
   by blast
 
 lemma disj_left_absorb: "A \<or> (A \<or> B) \<longleftrightarrow> A \<or> B"
   by blast
 
 lemma conj_absorb: "A \<and> A \<longleftrightarrow> A"
   by blast
 
 lemma conj_left_absorb: "A \<and> (A \<and> B) \<longleftrightarrow> A \<and> B"
   by blast
 
 lemma eq_ac:
   shows eq_commute: "a = b \<longleftrightarrow> b = a"
     and iff_left_commute: "(P \<longleftrightarrow> (Q \<longleftrightarrow> R)) \<longleftrightarrow> (Q \<longleftrightarrow> (P \<longleftrightarrow> R))"
     and iff_assoc: "((P \<longleftrightarrow> Q) \<longleftrightarrow> R) \<longleftrightarrow> (P \<longleftrightarrow> (Q \<longleftrightarrow> R))"
   by (iprover, blast+)
 
 lemma neq_commute: "a \<noteq> b \<longleftrightarrow> b \<noteq> a" by iprover
 
 lemma conj_comms:
   shows conj_commute: "P \<and> Q \<longleftrightarrow> Q \<and> P"
     and conj_left_commute: "P \<and> (Q \<and> R) \<longleftrightarrow> Q \<and> (P \<and> R)" by iprover+
 lemma conj_assoc: "(P \<and> Q) \<and> R \<longleftrightarrow> P \<and> (Q \<and> R)" by iprover
 
 lemmas conj_ac = conj_commute conj_left_commute conj_assoc
 
 lemma disj_comms:
   shows disj_commute: "P \<or> Q \<longleftrightarrow> Q \<or> P"
     and disj_left_commute: "P \<or> (Q \<or> R) \<longleftrightarrow> Q \<or> (P \<or> R)" by iprover+
 lemma disj_assoc: "(P \<or> Q) \<or> R \<longleftrightarrow> P \<or> (Q \<or> R)" by iprover
 
 lemmas disj_ac = disj_commute disj_left_commute disj_assoc
 
 lemma conj_disj_distribL: "P \<and> (Q \<or> R) \<longleftrightarrow> P \<and> Q \<or> P \<and> R" by iprover
 lemma conj_disj_distribR: "(P \<or> Q) \<and> R \<longleftrightarrow> P \<and> R \<or> Q \<and> R" by iprover
 
 lemma disj_conj_distribL: "P \<or> (Q \<and> R) \<longleftrightarrow> (P \<or> Q) \<and> (P \<or> R)" by iprover
 lemma disj_conj_distribR: "(P \<and> Q) \<or> R \<longleftrightarrow> (P \<or> R) \<and> (Q \<or> R)" by iprover
 
 lemma imp_conjR: "(P \<longrightarrow> (Q \<and> R)) = ((P \<longrightarrow> Q) \<and> (P \<longrightarrow> R))" by iprover
 lemma imp_conjL: "((P \<and> Q) \<longrightarrow> R) = (P \<longrightarrow> (Q \<longrightarrow> R))" by iprover
 lemma imp_disjL: "((P \<or> Q) \<longrightarrow> R) = ((P \<longrightarrow> R) \<and> (Q \<longrightarrow> R))" by iprover
 
 text \<open>These two are specialized, but \<open>imp_disj_not1\<close> is useful in \<open>Auth/Yahalom\<close>.\<close>
 lemma imp_disj_not1: "(P \<longrightarrow> Q \<or> R) \<longleftrightarrow> (\<not> Q \<longrightarrow> P \<longrightarrow> R)" by blast
 lemma imp_disj_not2: "(P \<longrightarrow> Q \<or> R) \<longleftrightarrow> (\<not> R \<longrightarrow> P \<longrightarrow> Q)" by blast
 
 lemma imp_disj1: "((P \<longrightarrow> Q) \<or> R) \<longleftrightarrow> (P \<longrightarrow> Q \<or> R)" by blast
 lemma imp_disj2: "(Q \<or> (P \<longrightarrow> R)) \<longleftrightarrow> (P \<longrightarrow> Q \<or> R)" by blast
 
 lemma imp_cong: "(P = P') \<Longrightarrow> (P' \<Longrightarrow> (Q = Q')) \<Longrightarrow> ((P \<longrightarrow> Q) \<longleftrightarrow> (P' \<longrightarrow> Q'))"
   by iprover
 
 lemma de_Morgan_disj: "\<not> (P \<or> Q) \<longleftrightarrow> \<not> P \<and> \<not> Q" by iprover
 lemma de_Morgan_conj: "\<not> (P \<and> Q) \<longleftrightarrow> \<not> P \<or> \<not> Q" by blast
 lemma not_imp: "\<not> (P \<longrightarrow> Q) \<longleftrightarrow> P \<and> \<not> Q" by blast
 lemma not_iff: "P \<noteq> Q \<longleftrightarrow> (P \<longleftrightarrow> \<not> Q)" by blast
 lemma disj_not1: "\<not> P \<or> Q \<longleftrightarrow> (P \<longrightarrow> Q)" by blast
 lemma disj_not2: "P \<or> \<not> Q \<longleftrightarrow> (Q \<longrightarrow> P)" by blast  \<comment> \<open>changes orientation :-(\<close>
 lemma imp_conv_disj: "(P \<longrightarrow> Q) \<longleftrightarrow> (\<not> P) \<or> Q" by blast
 lemma disj_imp: "P \<or> Q \<longleftrightarrow> \<not> P \<longrightarrow> Q" by blast
 
 lemma iff_conv_conj_imp: "(P \<longleftrightarrow> Q) \<longleftrightarrow> (P \<longrightarrow> Q) \<and> (Q \<longrightarrow> P)" by iprover
 
 
 lemma cases_simp: "(P \<longrightarrow> Q) \<and> (\<not> P \<longrightarrow> Q) \<longleftrightarrow> Q"
   \<comment> \<open>Avoids duplication of subgoals after \<open>if_split\<close>, when the true and false\<close>
   \<comment> \<open>cases boil down to the same thing.\<close>
   by blast
 
 lemma not_all: "\<not> (\<forall>x. P x) \<longleftrightarrow> (\<exists>x. \<not> P x)" by blast
 lemma imp_all: "((\<forall>x. P x) \<longrightarrow> Q) \<longleftrightarrow> (\<exists>x. P x \<longrightarrow> Q)" by blast
 lemma not_ex: "\<not> (\<exists>x. P x) \<longleftrightarrow> (\<forall>x. \<not> P x)" by iprover
 lemma imp_ex: "((\<exists>x. P x) \<longrightarrow> Q) \<longleftrightarrow> (\<forall>x. P x \<longrightarrow> Q)" by iprover
 lemma all_not_ex: "(\<forall>x. P x) \<longleftrightarrow> \<not> (\<exists>x. \<not> P x)" by blast
 
 declare All_def [no_atp]
 
 lemma ex_disj_distrib: "(\<exists>x. P x \<or> Q x) \<longleftrightarrow> (\<exists>x. P x) \<or> (\<exists>x. Q x)" by iprover
 lemma all_conj_distrib: "(\<forall>x. P x \<and> Q x) \<longleftrightarrow> (\<forall>x. P x) \<and> (\<forall>x. Q x)" by iprover
 
 text \<open>
   \<^medskip> The \<open>\<and>\<close> congruence rule: not included by default!
   May slow rewrite proofs down by as much as 50\%\<close>
 
 lemma conj_cong: "P = P' \<Longrightarrow> (P' \<Longrightarrow> Q = Q') \<Longrightarrow> (P \<and> Q) = (P' \<and> Q')"
   by iprover
 
 lemma rev_conj_cong: "Q = Q' \<Longrightarrow> (Q' \<Longrightarrow> P = P') \<Longrightarrow> (P \<and> Q) = (P' \<and> Q')"
   by iprover
 
 text \<open>The \<open>|\<close> congruence rule: not included by default!\<close>
 
 lemma disj_cong: "P = P' \<Longrightarrow> (\<not> P' \<Longrightarrow> Q = Q') \<Longrightarrow> (P \<or> Q) = (P' \<or> Q')"
   by blast
 
 
 text \<open>\<^medskip> if-then-else rules\<close>
 
 lemma if_True [code]: "(if True then x else y) = x"
   unfolding If_def by blast
 
 lemma if_False [code]: "(if False then x else y) = y"
   unfolding If_def by blast
 
 lemma if_P: "P \<Longrightarrow> (if P then x else y) = x"
   unfolding If_def by blast
 
 lemma if_not_P: "\<not> P \<Longrightarrow> (if P then x else y) = y"
   unfolding If_def by blast
 
 lemma if_split: "P (if Q then x else y) = ((Q \<longrightarrow> P x) \<and> (\<not> Q \<longrightarrow> P y))"
 proof (rule case_split [of Q])
   show ?thesis if Q
     using that by (simplesubst if_P) blast+
   show ?thesis if "\<not> Q"
     using that by (simplesubst if_not_P) blast+
 qed
 
 lemma if_split_asm: "P (if Q then x else y) = (\<not> ((Q \<and> \<not> P x) \<or> (\<not> Q \<and> \<not> P y)))"
   by (simplesubst if_split) blast
 
 lemmas if_splits [no_atp] = if_split if_split_asm
 
 lemma if_cancel: "(if c then x else x) = x"
   by (simplesubst if_split) blast
 
 lemma if_eq_cancel: "(if x = y then y else x) = x"
   by (simplesubst if_split) blast
 
 lemma if_bool_eq_conj: "(if P then Q else R) = ((P \<longrightarrow> Q) \<and> (\<not> P \<longrightarrow> R))"
   \<comment> \<open>This form is useful for expanding \<open>if\<close>s on the RIGHT of the \<open>\<Longrightarrow>\<close> symbol.\<close>
   by (rule if_split)
 
 lemma if_bool_eq_disj: "(if P then Q else R) = ((P \<and> Q) \<or> (\<not> P \<and> R))"
   \<comment> \<open>And this form is useful for expanding \<open>if\<close>s on the LEFT.\<close>
   by (simplesubst if_split) blast
 
 lemma Eq_TrueI: "P \<Longrightarrow> P \<equiv> True" unfolding atomize_eq by iprover
 lemma Eq_FalseI: "\<not> P \<Longrightarrow> P \<equiv> False" unfolding atomize_eq by iprover
 
 text \<open>\<^medskip> let rules for simproc\<close>
 
 lemma Let_folded: "f x \<equiv> g x \<Longrightarrow> Let x f \<equiv> Let x g"
   by (unfold Let_def)
 
 lemma Let_unfold: "f x \<equiv> g \<Longrightarrow> Let x f \<equiv> g"
   by (unfold Let_def)
 
 text \<open>
   The following copy of the implication operator is useful for
   fine-tuning congruence rules.  It instructs the simplifier to simplify
   its premise.
 \<close>
 
 definition simp_implies :: "prop \<Rightarrow> prop \<Rightarrow> prop"  (infixr "=simp=>" 1)
   where "simp_implies \<equiv> (\<Longrightarrow>)"
 
 lemma simp_impliesI:
   assumes PQ: "(PROP P \<Longrightarrow> PROP Q)"
   shows "PROP P =simp=> PROP Q"
   unfolding simp_implies_def
   by (iprover intro: PQ)
 
 lemma simp_impliesE:
   assumes PQ: "PROP P =simp=> PROP Q"
     and P: "PROP P"
     and QR: "PROP Q \<Longrightarrow> PROP R"
   shows "PROP R"
   by (iprover intro: QR P PQ [unfolded simp_implies_def])
 
 lemma simp_implies_cong:
   assumes PP' :"PROP P \<equiv> PROP P'"
     and P'QQ': "PROP P' \<Longrightarrow> (PROP Q \<equiv> PROP Q')"
   shows "(PROP P =simp=> PROP Q) \<equiv> (PROP P' =simp=> PROP Q')"
   unfolding simp_implies_def
 proof (rule equal_intr_rule)
   assume PQ: "PROP P \<Longrightarrow> PROP Q"
     and P': "PROP P'"
   from PP' [symmetric] and P' have "PROP P"
     by (rule equal_elim_rule1)
   then have "PROP Q" by (rule PQ)
   with P'QQ' [OF P'] show "PROP Q'" by (rule equal_elim_rule1)
 next
   assume P'Q': "PROP P' \<Longrightarrow> PROP Q'"
     and P: "PROP P"
   from PP' and P have P': "PROP P'" by (rule equal_elim_rule1)
   then have "PROP Q'" by (rule P'Q')
   with P'QQ' [OF P', symmetric] show "PROP Q"
     by (rule equal_elim_rule1)
 qed
 
 lemma uncurry:
   assumes "P \<longrightarrow> Q \<longrightarrow> R"
   shows "P \<and> Q \<longrightarrow> R"
   using assms by blast
 
 lemma iff_allI:
   assumes "\<And>x. P x = Q x"
   shows "(\<forall>x. P x) = (\<forall>x. Q x)"
   using assms by blast
 
 lemma iff_exI:
   assumes "\<And>x. P x = Q x"
   shows "(\<exists>x. P x) = (\<exists>x. Q x)"
   using assms by blast
 
 lemma all_comm: "(\<forall>x y. P x y) = (\<forall>y x. P x y)"
   by blast
 
 lemma ex_comm: "(\<exists>x y. P x y) = (\<exists>y x. P x y)"
   by blast
 
 ML_file \<open>Tools/simpdata.ML\<close>
 ML \<open>open Simpdata\<close>
 
 setup \<open>
   map_theory_simpset (put_simpset HOL_basic_ss) #>
   Simplifier.method_setup Splitter.split_modifiers
 \<close>
 
 simproc_setup defined_Ex ("\<exists>x. P x") = \<open>K Quantifier1.rearrange_Ex\<close>
 simproc_setup defined_All ("\<forall>x. P x") = \<open>K Quantifier1.rearrange_All\<close>
 simproc_setup defined_all("\<And>x. PROP P x") = \<open>K Quantifier1.rearrange_all\<close>
 
 text \<open>Simproc for proving \<open>(y = x) \<equiv> False\<close> from premise \<open>\<not> (x = y)\<close>:\<close>
 
-simproc_setup neq ("x = y") = \<open>fn _ =>
+simproc_setup neq ("x = y") = \<open>
   let
     val neq_to_EQ_False = @{thm not_sym} RS @{thm Eq_FalseI};
     fun is_neq eq lhs rhs thm =
       (case Thm.prop_of thm of
         _ $ (Not $ (eq' $ l' $ r')) =>
           Not = HOLogic.Not andalso eq' = eq andalso
           r' aconv lhs andalso l' aconv rhs
       | _ => false);
     fun proc ss ct =
       (case Thm.term_of ct of
         eq $ lhs $ rhs =>
           (case find_first (is_neq eq lhs rhs) (Simplifier.prems_of ss) of
             SOME thm => SOME (thm RS neq_to_EQ_False)
           | NONE => NONE)
        | _ => NONE);
-  in proc end
+  in K proc end
 \<close>
 
 simproc_setup let_simp ("Let x f") = \<open>
   let
     fun count_loose (Bound i) k = if i >= k then 1 else 0
       | count_loose (s $ t) k = count_loose s k + count_loose t k
       | count_loose (Abs (_, _, t)) k = count_loose  t (k + 1)
       | count_loose _ _ = 0;
     fun is_trivial_let (Const (\<^const_name>\<open>Let\<close>, _) $ x $ t) =
       (case t of
         Abs (_, _, t') => count_loose t' 0 <= 1
       | _ => true);
   in
-    fn _ => fn ctxt => fn ct =>
+    K (fn ctxt => fn ct =>
       if is_trivial_let (Thm.term_of ct)
       then SOME @{thm Let_def} (*no or one ocurrence of bound variable*)
       else
         let (*Norbert Schirmer's case*)
           val t = Thm.term_of ct;
           val (t', ctxt') = yield_singleton (Variable.import_terms false) t ctxt;
         in
           Option.map (hd o Variable.export ctxt' ctxt o single)
             (case t' of Const (\<^const_name>\<open>Let\<close>,_) $ x $ f => (* x and f are already in normal form *)
               if is_Free x orelse is_Bound x orelse is_Const x
               then SOME @{thm Let_def}
               else
                 let
                   val n = case f of (Abs (x, _, _)) => x | _ => "x";
                   val cx = Thm.cterm_of ctxt x;
                   val xT = Thm.typ_of_cterm cx;
                   val cf = Thm.cterm_of ctxt f;
                   val fx_g = Simplifier.rewrite ctxt (Thm.apply cf cx);
                   val (_ $ _ $ g) = Thm.prop_of fx_g;
                   val g' = abstract_over (x, g);
                   val abs_g'= Abs (n, xT, g');
                 in
                   if g aconv g' then
                     let
                       val rl =
                         infer_instantiate ctxt [(("f", 0), cf), (("x", 0), cx)] @{thm Let_unfold};
                     in SOME (rl OF [fx_g]) end
                   else if (Envir.beta_eta_contract f) aconv (Envir.beta_eta_contract abs_g')
                   then NONE (*avoid identity conversion*)
                   else
                     let
                       val g'x = abs_g' $ x;
                       val g_g'x = Thm.symmetric (Thm.beta_conversion false (Thm.cterm_of ctxt g'x));
                       val rl =
                         @{thm Let_folded} |> infer_instantiate ctxt
                           [(("f", 0), Thm.cterm_of ctxt f),
                            (("x", 0), cx),
                            (("g", 0), Thm.cterm_of ctxt abs_g')];
                     in SOME (rl OF [Thm.transitive fx_g g_g'x]) end
                 end
             | _ => NONE)
-        end
+        end)
   end
 \<close>
 
 lemma True_implies_equals: "(True \<Longrightarrow> PROP P) \<equiv> PROP P"
 proof
   assume "True \<Longrightarrow> PROP P"
   from this [OF TrueI] show "PROP P" .
 next
   assume "PROP P"
   then show "PROP P" .
 qed
 
 lemma implies_True_equals: "(PROP P \<Longrightarrow> True) \<equiv> Trueprop True"
   by standard (intro TrueI)
 
 lemma False_implies_equals: "(False \<Longrightarrow> P) \<equiv> Trueprop True"
   by standard simp_all
 
 (* It seems that making this a simp rule is slower than using the simproc below *)
 lemma implies_False_swap:
   "(False \<Longrightarrow> PROP P \<Longrightarrow> PROP Q) \<equiv> (PROP P \<Longrightarrow> False \<Longrightarrow> PROP Q)"
   by (rule swap_prems_eq)
 
 ML \<open>
 fun eliminate_false_implies ct =
   let
     val (prems, concl) = Logic.strip_horn (Thm.term_of ct)
     fun go n =
       if n > 1 then
         Conv.rewr_conv @{thm Pure.swap_prems_eq}
         then_conv Conv.arg_conv (go (n - 1))
         then_conv Conv.rewr_conv @{thm HOL.implies_True_equals}
       else
         Conv.rewr_conv @{thm HOL.False_implies_equals}
   in
     case concl of
       Const (@{const_name HOL.Trueprop}, _) $ _ => SOME (go (length prems) ct)
     | _ => NONE
   end
 \<close>
 
 simproc_setup eliminate_false_implies ("False \<Longrightarrow> PROP P") = \<open>K (K eliminate_false_implies)\<close>
 
 
 lemma ex_simps:
   "\<And>P Q. (\<exists>x. P x \<and> Q)   = ((\<exists>x. P x) \<and> Q)"
   "\<And>P Q. (\<exists>x. P \<and> Q x)   = (P \<and> (\<exists>x. Q x))"
   "\<And>P Q. (\<exists>x. P x \<or> Q)   = ((\<exists>x. P x) \<or> Q)"
   "\<And>P Q. (\<exists>x. P \<or> Q x)   = (P \<or> (\<exists>x. Q x))"
   "\<And>P Q. (\<exists>x. P x \<longrightarrow> Q) = ((\<forall>x. P x) \<longrightarrow> Q)"
   "\<And>P Q. (\<exists>x. P \<longrightarrow> Q x) = (P \<longrightarrow> (\<exists>x. Q x))"
   \<comment> \<open>Miniscoping: pushing in existential quantifiers.\<close>
   by (iprover | blast)+
 
 lemma all_simps:
   "\<And>P Q. (\<forall>x. P x \<and> Q)   = ((\<forall>x. P x) \<and> Q)"
   "\<And>P Q. (\<forall>x. P \<and> Q x)   = (P \<and> (\<forall>x. Q x))"
   "\<And>P Q. (\<forall>x. P x \<or> Q)   = ((\<forall>x. P x) \<or> Q)"
   "\<And>P Q. (\<forall>x. P \<or> Q x)   = (P \<or> (\<forall>x. Q x))"
   "\<And>P Q. (\<forall>x. P x \<longrightarrow> Q) = ((\<exists>x. P x) \<longrightarrow> Q)"
   "\<And>P Q. (\<forall>x. P \<longrightarrow> Q x) = (P \<longrightarrow> (\<forall>x. Q x))"
   \<comment> \<open>Miniscoping: pushing in universal quantifiers.\<close>
   by (iprover | blast)+
 
 lemmas [simp] =
   triv_forall_equality  \<comment> \<open>prunes params\<close>
   True_implies_equals implies_True_equals  \<comment> \<open>prune \<open>True\<close> in asms\<close>
   False_implies_equals  \<comment> \<open>prune \<open>False\<close> in asms\<close>
   if_True
   if_False
   if_cancel
   if_eq_cancel
   imp_disjL \<comment> \<open>In general it seems wrong to add distributive laws by default: they
     might cause exponential blow-up.  But \<open>imp_disjL\<close> has been in for a while
     and cannot be removed without affecting existing proofs.  Moreover,
     rewriting by \<open>(P \<or> Q \<longrightarrow> R) = ((P \<longrightarrow> R) \<and> (Q \<longrightarrow> R))\<close> might be justified on the
     grounds that it allows simplification of \<open>R\<close> in the two cases.\<close>
   conj_assoc
   disj_assoc
   de_Morgan_conj
   de_Morgan_disj
   imp_disj1
   imp_disj2
   not_imp
   disj_not1
   not_all
   not_ex
   cases_simp
   the_eq_trivial
   the_sym_eq_trivial
   ex_simps
   all_simps
   simp_thms
   subst_all
 
 lemmas [cong] = imp_cong simp_implies_cong
 lemmas [split] = if_split
 
 ML \<open>val HOL_ss = simpset_of \<^context>\<close>
 
 text \<open>Simplifies \<open>x\<close> assuming \<open>c\<close> and \<open>y\<close> assuming \<open>\<not> c\<close>.\<close>
 lemma if_cong:
   assumes "b = c"
     and "c \<Longrightarrow> x = u"
     and "\<not> c \<Longrightarrow> y = v"
   shows "(if b then x else y) = (if c then u else v)"
   using assms by simp
 
 text \<open>Prevents simplification of \<open>x\<close> and \<open>y\<close>:
   faster and allows the execution of functional programs.\<close>
 lemma if_weak_cong [cong]:
   assumes "b = c"
   shows "(if b then x else y) = (if c then x else y)"
   using assms by (rule arg_cong)
 
 text \<open>Prevents simplification of t: much faster\<close>
 lemma let_weak_cong:
   assumes "a = b"
   shows "(let x = a in t x) = (let x = b in t x)"
   using assms by (rule arg_cong)
 
 text \<open>To tidy up the result of a simproc.  Only the RHS will be simplified.\<close>
 lemma eq_cong2:
   assumes "u = u'"
   shows "(t \<equiv> u) \<equiv> (t \<equiv> u')"
   using assms by simp
 
 lemma if_distrib: "f (if c then x else y) = (if c then f x else f y)"
   by simp
 
 lemma if_distribR: "(if b then f else g) x = (if b then f x else g x)"
   by simp
 
 lemma all_if_distrib: "(\<forall>x. if x = a then P x else Q x) \<longleftrightarrow> P a \<and> (\<forall>x. x\<noteq>a \<longrightarrow> Q x)"
   by auto
 
 lemma ex_if_distrib: "(\<exists>x. if x = a then P x else Q x) \<longleftrightarrow> P a \<or> (\<exists>x. x\<noteq>a \<and> Q x)"
   by auto
 
 lemma if_if_eq_conj: "(if P then if Q then x else y else y) = (if P \<and> Q then x else y)"
   by simp
 
 text \<open>As a simplification rule, it replaces all function equalities by
   first-order equalities.\<close>
 lemma fun_eq_iff: "f = g \<longleftrightarrow> (\<forall>x. f x = g x)"
   by auto
 
 
 subsubsection \<open>Generic cases and induction\<close>
 
 text \<open>Rule projections:\<close>
 ML \<open>
 structure Project_Rule = Project_Rule
 (
   val conjunct1 = @{thm conjunct1}
   val conjunct2 = @{thm conjunct2}
   val mp = @{thm mp}
 );
 \<close>
 
 context
 begin
 
 qualified definition "induct_forall P \<equiv> \<forall>x. P x"
 qualified definition "induct_implies A B \<equiv> A \<longrightarrow> B"
 qualified definition "induct_equal x y \<equiv> x = y"
 qualified definition "induct_conj A B \<equiv> A \<and> B"
 qualified definition "induct_true \<equiv> True"
 qualified definition "induct_false \<equiv> False"
 
 lemma induct_forall_eq: "(\<And>x. P x) \<equiv> Trueprop (induct_forall (\<lambda>x. P x))"
   by (unfold atomize_all induct_forall_def)
 
 lemma induct_implies_eq: "(A \<Longrightarrow> B) \<equiv> Trueprop (induct_implies A B)"
   by (unfold atomize_imp induct_implies_def)
 
 lemma induct_equal_eq: "(x \<equiv> y) \<equiv> Trueprop (induct_equal x y)"
   by (unfold atomize_eq induct_equal_def)
 
 lemma induct_conj_eq: "(A &&& B) \<equiv> Trueprop (induct_conj A B)"
   by (unfold atomize_conj induct_conj_def)
 
 lemmas induct_atomize' = induct_forall_eq induct_implies_eq induct_conj_eq
 lemmas induct_atomize = induct_atomize' induct_equal_eq
 lemmas induct_rulify' [symmetric] = induct_atomize'
 lemmas induct_rulify [symmetric] = induct_atomize
 lemmas induct_rulify_fallback =
   induct_forall_def induct_implies_def induct_equal_def induct_conj_def
   induct_true_def induct_false_def
 
 lemma induct_forall_conj: "induct_forall (\<lambda>x. induct_conj (A x) (B x)) =
     induct_conj (induct_forall A) (induct_forall B)"
   by (unfold induct_forall_def induct_conj_def) iprover
 
 lemma induct_implies_conj: "induct_implies C (induct_conj A B) =
     induct_conj (induct_implies C A) (induct_implies C B)"
   by (unfold induct_implies_def induct_conj_def) iprover
 
 lemma induct_conj_curry: "(induct_conj A B \<Longrightarrow> PROP C) \<equiv> (A \<Longrightarrow> B \<Longrightarrow> PROP C)"
 proof
   assume r: "induct_conj A B \<Longrightarrow> PROP C"
   assume ab: A B
   show "PROP C" by (rule r) (simp add: induct_conj_def ab)
 next
   assume r: "A \<Longrightarrow> B \<Longrightarrow> PROP C"
   assume ab: "induct_conj A B"
   show "PROP C" by (rule r) (simp_all add: ab [unfolded induct_conj_def])
 qed
 
 lemmas induct_conj = induct_forall_conj induct_implies_conj induct_conj_curry
 
 lemma induct_trueI: "induct_true"
   by (simp add: induct_true_def)
 
 text \<open>Method setup.\<close>
 
 ML_file \<open>~~/src/Tools/induct.ML\<close>
 ML \<open>
 structure Induct = Induct
 (
   val cases_default = @{thm case_split}
   val atomize = @{thms induct_atomize}
   val rulify = @{thms induct_rulify'}
   val rulify_fallback = @{thms induct_rulify_fallback}
   val equal_def = @{thm induct_equal_def}
   fun dest_def (Const (\<^const_name>\<open>induct_equal\<close>, _) $ t $ u) = SOME (t, u)
     | dest_def _ = NONE
   fun trivial_tac ctxt = match_tac ctxt @{thms induct_trueI}
 )
 \<close>
 
 ML_file \<open>~~/src/Tools/induction.ML\<close>
 
 declaration \<open>
   fn _ => Induct.map_simpset (fn ss => ss
     addsimprocs
       [Simplifier.make_simproc \<^context> "swap_induct_false"
         {lhss = [\<^term>\<open>induct_false \<Longrightarrow> PROP P \<Longrightarrow> PROP Q\<close>],
          proc = fn _ => fn _ => fn ct =>
           (case Thm.term_of ct of
             _ $ (P as _ $ \<^Const_>\<open>induct_false\<close>) $ (_ $ Q $ _) =>
               if P <> Q then SOME Drule.swap_prems_eq else NONE
           | _ => NONE)},
        Simplifier.make_simproc \<^context> "induct_equal_conj_curry"
         {lhss = [\<^term>\<open>induct_conj P Q \<Longrightarrow> PROP R\<close>],
          proc = fn _ => fn _ => fn ct =>
           (case Thm.term_of ct of
             _ $ (_ $ P) $ _ =>
               let
                 fun is_conj \<^Const_>\<open>induct_conj for P Q\<close> =
                       is_conj P andalso is_conj Q
                   | is_conj \<^Const_>\<open>induct_equal _ for _ _\<close> = true
                   | is_conj \<^Const_>\<open>induct_true\<close> = true
                   | is_conj \<^Const_>\<open>induct_false\<close> = true
                   | is_conj _ = false
               in if is_conj P then SOME @{thm induct_conj_curry} else NONE end
             | _ => NONE)}]
     |> Simplifier.set_mksimps (fn ctxt =>
         Simpdata.mksimps Simpdata.mksimps_pairs ctxt #>
         map (rewrite_rule ctxt (map Thm.symmetric @{thms induct_rulify_fallback}))))
 \<close>
 
 text \<open>Pre-simplification of induction and cases rules\<close>
 
 lemma [induct_simp]: "(\<And>x. induct_equal x t \<Longrightarrow> PROP P x) \<equiv> PROP P t"
   unfolding induct_equal_def
 proof
   assume r: "\<And>x. x = t \<Longrightarrow> PROP P x"
   show "PROP P t" by (rule r [OF refl])
 next
   fix x
   assume "PROP P t" "x = t"
   then show "PROP P x" by simp
 qed
 
 lemma [induct_simp]: "(\<And>x. induct_equal t x \<Longrightarrow> PROP P x) \<equiv> PROP P t"
   unfolding induct_equal_def
 proof
   assume r: "\<And>x. t = x \<Longrightarrow> PROP P x"
   show "PROP P t" by (rule r [OF refl])
 next
   fix x
   assume "PROP P t" "t = x"
   then show "PROP P x" by simp
 qed
 
 lemma [induct_simp]: "(induct_false \<Longrightarrow> P) \<equiv> Trueprop induct_true"
   unfolding induct_false_def induct_true_def
   by (iprover intro: equal_intr_rule)
 
 lemma [induct_simp]: "(induct_true \<Longrightarrow> PROP P) \<equiv> PROP P"
   unfolding induct_true_def
 proof
   assume "True \<Longrightarrow> PROP P"
   then show "PROP P" using TrueI .
 next
   assume "PROP P"
   then show "PROP P" .
 qed
 
 lemma [induct_simp]: "(PROP P \<Longrightarrow> induct_true) \<equiv> Trueprop induct_true"
   unfolding induct_true_def
   by (iprover intro: equal_intr_rule)
 
 lemma [induct_simp]: "(\<And>x::'a::{}. induct_true) \<equiv> Trueprop induct_true"
   unfolding induct_true_def
   by (iprover intro: equal_intr_rule)
 
 lemma [induct_simp]: "induct_implies induct_true P \<equiv> P"
   by (simp add: induct_implies_def induct_true_def)
 
 lemma [induct_simp]: "x = x \<longleftrightarrow> True"
   by (rule simp_thms)
 
 end
 
 ML_file \<open>~~/src/Tools/induct_tacs.ML\<close>
 
 
 subsubsection \<open>Coherent logic\<close>
 
 ML_file \<open>~~/src/Tools/coherent.ML\<close>
 ML \<open>
 structure Coherent = Coherent
 (
   val atomize_elimL = @{thm atomize_elimL};
   val atomize_exL = @{thm atomize_exL};
   val atomize_conjL = @{thm atomize_conjL};
   val atomize_disjL = @{thm atomize_disjL};
   val operator_names = [\<^const_name>\<open>HOL.disj\<close>, \<^const_name>\<open>HOL.conj\<close>, \<^const_name>\<open>Ex\<close>];
 );
 \<close>
 
 
 subsubsection \<open>Reorienting equalities\<close>
 
 ML \<open>
 signature REORIENT_PROC =
 sig
   val add : (term -> bool) -> theory -> theory
-  val proc : morphism -> Proof.context -> cterm -> thm option
+  val proc : Proof.context -> cterm -> thm option
 end;
 
 structure Reorient_Proc : REORIENT_PROC =
 struct
   structure Data = Theory_Data
   (
     type T = ((term -> bool) * stamp) list;
     val empty = [];
     fun merge data : T = Library.merge (eq_snd (op =)) data;
   );
   fun add m = Data.map (cons (m, stamp ()));
   fun matches thy t = exists (fn (m, _) => m t) (Data.get thy);
 
   val meta_reorient = @{thm eq_commute [THEN eq_reflection]};
-  fun proc phi ctxt ct =
+  fun proc ctxt ct =
     let
       val thy = Proof_Context.theory_of ctxt;
     in
       case Thm.term_of ct of
         (_ $ t $ u) => if matches thy u then NONE else SOME meta_reorient
       | _ => NONE
     end;
 end;
 \<close>
 
 
 subsection \<open>Other simple lemmas and lemma duplicates\<close>
 
 lemma eq_iff_swap: "(x = y \<longleftrightarrow> P) \<Longrightarrow> (y = x \<longleftrightarrow> P)"
 by blast
 
 lemma all_cong1: "(\<And>x. P x = P' x) \<Longrightarrow> (\<forall>x. P x) = (\<forall>x. P' x)"
   by auto
 
 lemma ex_cong1: "(\<And>x. P x = P' x) \<Longrightarrow> (\<exists>x. P x) = (\<exists>x. P' x)"
   by auto
 
 lemma all_cong: "(\<And>x. Q x \<Longrightarrow> P x = P' x) \<Longrightarrow> (\<forall>x. Q x \<longrightarrow> P x) = (\<forall>x. Q x \<longrightarrow> P' x)"
   by auto
 
 lemma ex_cong: "(\<And>x. Q x \<Longrightarrow> P x = P' x) \<Longrightarrow> (\<exists>x. Q x \<and> P x) = (\<exists>x. Q x \<and> P' x)"
   by auto
 
 lemma ex1_eq [iff]: "\<exists>!x. x = t" "\<exists>!x. t = x"
   by blast+
 
 lemma choice_eq: "(\<forall>x. \<exists>!y. P x y) = (\<exists>!f. \<forall>x. P x (f x))" (is "?lhs = ?rhs")
 proof (intro iffI allI)
   assume L: ?lhs
   then have \<section>: "\<forall>x. P x (THE y. P x y)"
     by (best intro: theI')
   show ?rhs
     by (rule ex1I) (use L \<section> in \<open>fast+\<close>)
 next
   fix x
   assume R: ?rhs
   then obtain f where f: "\<forall>x. P x (f x)" and f1: "\<And>y. (\<forall>x. P x (y x)) \<Longrightarrow> y = f"
     by (blast elim: ex1E)
   show "\<exists>!y. P x y"
   proof (rule ex1I)
     show "P x (f x)"
       using f by blast
     show "y = f x" if "P x y" for y
     proof -
       have "P z (if z = x then y else f z)" for z
         using f that by (auto split: if_split)
       with f1 [of "\<lambda>z. if z = x then y else f z"] f
       show ?thesis
         by (auto simp add: split: if_split_asm dest: fun_cong)
     qed
   qed
 qed
 
 lemmas eq_sym_conv = eq_commute
 
 lemma nnf_simps:
   "(\<not> (P \<and> Q)) = (\<not> P \<or> \<not> Q)"
   "(\<not> (P \<or> Q)) = (\<not> P \<and> \<not> Q)"
   "(P \<longrightarrow> Q) = (\<not> P \<or> Q)"
   "(P = Q) = ((P \<and> Q) \<or> (\<not> P \<and> \<not> Q))"
   "(\<not> (P = Q)) = ((P \<and> \<not> Q) \<or> (\<not> P \<and> Q))"
   "(\<not> \<not> P) = P"
   by blast+
 
 
 subsection \<open>Basic ML bindings\<close>
 
 ML \<open>
 val FalseE = @{thm FalseE}
 val Let_def = @{thm Let_def}
 val TrueI = @{thm TrueI}
 val allE = @{thm allE}
 val allI = @{thm allI}
 val all_dupE = @{thm all_dupE}
 val arg_cong = @{thm arg_cong}
 val box_equals = @{thm box_equals}
 val ccontr = @{thm ccontr}
 val classical = @{thm classical}
 val conjE = @{thm conjE}
 val conjI = @{thm conjI}
 val conjunct1 = @{thm conjunct1}
 val conjunct2 = @{thm conjunct2}
 val disjCI = @{thm disjCI}
 val disjE = @{thm disjE}
 val disjI1 = @{thm disjI1}
 val disjI2 = @{thm disjI2}
 val eq_reflection = @{thm eq_reflection}
 val ex1E = @{thm ex1E}
 val ex1I = @{thm ex1I}
 val ex1_implies_ex = @{thm ex1_implies_ex}
 val exE = @{thm exE}
 val exI = @{thm exI}
 val excluded_middle = @{thm excluded_middle}
 val ext = @{thm ext}
 val fun_cong = @{thm fun_cong}
 val iffD1 = @{thm iffD1}
 val iffD2 = @{thm iffD2}
 val iffI = @{thm iffI}
 val impE = @{thm impE}
 val impI = @{thm impI}
 val meta_eq_to_obj_eq = @{thm meta_eq_to_obj_eq}
 val mp = @{thm mp}
 val notE = @{thm notE}
 val notI = @{thm notI}
 val not_all = @{thm not_all}
 val not_ex = @{thm not_ex}
 val not_iff = @{thm not_iff}
 val not_not = @{thm not_not}
 val not_sym = @{thm not_sym}
 val refl = @{thm refl}
 val rev_mp = @{thm rev_mp}
 val spec = @{thm spec}
 val ssubst = @{thm ssubst}
 val subst = @{thm subst}
 val sym = @{thm sym}
 val trans = @{thm trans}
 \<close>
 
 locale cnf
 begin
 
 lemma clause2raw_notE: "\<lbrakk>P; \<not>P\<rbrakk> \<Longrightarrow> False" by auto
 lemma clause2raw_not_disj: "\<lbrakk>\<not> P; \<not> Q\<rbrakk> \<Longrightarrow> \<not> (P \<or> Q)" by auto
 lemma clause2raw_not_not: "P \<Longrightarrow> \<not>\<not> P" by auto
 
 lemma iff_refl: "(P::bool) = P" by auto
 lemma iff_trans: "[| (P::bool) = Q; Q = R |] ==> P = R" by auto
 lemma conj_cong: "[| P = P'; Q = Q' |] ==> (P \<and> Q) = (P' \<and> Q')" by auto
 lemma disj_cong: "[| P = P'; Q = Q' |] ==> (P \<or> Q) = (P' \<or> Q')" by auto
 
 lemma make_nnf_imp: "[| (\<not>P) = P'; Q = Q' |] ==> (P \<longrightarrow> Q) = (P' \<or> Q')" by auto
 lemma make_nnf_iff: "[| P = P'; (\<not>P) = NP; Q = Q'; (\<not>Q) = NQ |] ==> (P = Q) = ((P' \<or> NQ) \<and> (NP \<or> Q'))" by auto
 lemma make_nnf_not_false: "(\<not>False) = True" by auto
 lemma make_nnf_not_true: "(\<not>True) = False" by auto
 lemma make_nnf_not_conj: "[| (\<not>P) = P'; (\<not>Q) = Q' |] ==> (\<not>(P \<and> Q)) = (P' \<or> Q')" by auto
 lemma make_nnf_not_disj: "[| (\<not>P) = P'; (\<not>Q) = Q' |] ==> (\<not>(P \<or> Q)) = (P' \<and> Q')" by auto
 lemma make_nnf_not_imp: "[| P = P'; (\<not>Q) = Q' |] ==> (\<not>(P \<longrightarrow> Q)) = (P' \<and> Q')" by auto
 lemma make_nnf_not_iff: "[| P = P'; (\<not>P) = NP; Q = Q'; (\<not>Q) = NQ |] ==> (\<not>(P = Q)) = ((P' \<or> Q') \<and> (NP \<or> NQ))" by auto
 lemma make_nnf_not_not: "P = P' ==> (\<not>\<not>P) = P'" by auto
 
 lemma simp_TF_conj_True_l: "[| P = True; Q = Q' |] ==> (P \<and> Q) = Q'" by auto
 lemma simp_TF_conj_True_r: "[| P = P'; Q = True |] ==> (P \<and> Q) = P'" by auto
 lemma simp_TF_conj_False_l: "P = False ==> (P \<and> Q) = False" by auto
 lemma simp_TF_conj_False_r: "Q = False ==> (P \<and> Q) = False" by auto
 lemma simp_TF_disj_True_l: "P = True ==> (P \<or> Q) = True" by auto
 lemma simp_TF_disj_True_r: "Q = True ==> (P \<or> Q) = True" by auto
 lemma simp_TF_disj_False_l: "[| P = False; Q = Q' |] ==> (P \<or> Q) = Q'" by auto
 lemma simp_TF_disj_False_r: "[| P = P'; Q = False |] ==> (P \<or> Q) = P'" by auto
 
 lemma make_cnf_disj_conj_l: "[| (P \<or> R) = PR; (Q \<or> R) = QR |] ==> ((P \<and> Q) \<or> R) = (PR \<and> QR)" by auto
 lemma make_cnf_disj_conj_r: "[| (P \<or> Q) = PQ; (P \<or> R) = PR |] ==> (P \<or> (Q \<and> R)) = (PQ \<and> PR)" by auto
 
 lemma make_cnfx_disj_ex_l: "((\<exists>(x::bool). P x) \<or> Q) = (\<exists>x. P x \<or> Q)" by auto
 lemma make_cnfx_disj_ex_r: "(P \<or> (\<exists>(x::bool). Q x)) = (\<exists>x. P \<or> Q x)" by auto
 lemma make_cnfx_newlit: "(P \<or> Q) = (\<exists>x. (P \<or> x) \<and> (Q \<or> \<not>x))" by auto
 lemma make_cnfx_ex_cong: "(\<forall>(x::bool). P x = Q x) \<Longrightarrow> (\<exists>x. P x) = (\<exists>x. Q x)" by auto
 
 lemma weakening_thm: "[| P; Q |] ==> Q" by auto
 
 lemma cnftac_eq_imp: "[| P = Q; P |] ==> Q" by auto
 
 end
 
 ML_file \<open>Tools/cnf.ML\<close>
 
 
 section \<open>\<open>NO_MATCH\<close> simproc\<close>
 
 text \<open>
   The simplification procedure can be used to avoid simplification of terms
   of a certain form.
 \<close>
 
 definition NO_MATCH :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
   where "NO_MATCH pat val \<equiv> True"
 
 lemma NO_MATCH_cong[cong]: "NO_MATCH pat val = NO_MATCH pat val"
   by (rule refl)
 
 declare [[coercion_args NO_MATCH - -]]
 
-simproc_setup NO_MATCH ("NO_MATCH pat val") = \<open>fn _ => fn ctxt => fn ct =>
+simproc_setup NO_MATCH ("NO_MATCH pat val") = \<open>K (fn ctxt => fn ct =>
   let
     val thy = Proof_Context.theory_of ctxt
     val dest_binop = Term.dest_comb #> apfst (Term.dest_comb #> snd)
     val m = Pattern.matches thy (dest_binop (Thm.term_of ct))
-  in if m then NONE else SOME @{thm NO_MATCH_def} end
+  in if m then NONE else SOME @{thm NO_MATCH_def} end)
 \<close>
 
 text \<open>
   This setup ensures that a rewrite rule of the form \<^term>\<open>NO_MATCH pat val \<Longrightarrow> t\<close>
   is only applied, if the pattern \<open>pat\<close> does not match the value \<open>val\<close>.
 \<close>
 
 
 text\<open>
   Tagging a premise of a simp rule with ASSUMPTION forces the simplifier
   not to simplify the argument and to solve it by an assumption.
 \<close>
 
 definition ASSUMPTION :: "bool \<Rightarrow> bool"
   where "ASSUMPTION A \<equiv> A"
 
 lemma ASSUMPTION_cong[cong]: "ASSUMPTION A = ASSUMPTION A"
   by (rule refl)
 
 lemma ASSUMPTION_I: "A \<Longrightarrow> ASSUMPTION A"
   by (simp add: ASSUMPTION_def)
 
 lemma ASSUMPTION_D: "ASSUMPTION A \<Longrightarrow> A"
   by (simp add: ASSUMPTION_def)
 
 setup \<open>
 let
   val asm_sol = mk_solver "ASSUMPTION" (fn ctxt =>
     resolve_tac ctxt [@{thm ASSUMPTION_I}] THEN'
     resolve_tac ctxt (Simplifier.prems_of ctxt))
 in
   map_theory_simpset (fn ctxt => Simplifier.addSolver (ctxt,asm_sol))
 end
 \<close>
 
 
 subsection \<open>Code generator setup\<close>
 
 subsubsection \<open>Generic code generator preprocessor setup\<close>
 
 lemma conj_left_cong: "P \<longleftrightarrow> Q \<Longrightarrow> P \<and> R \<longleftrightarrow> Q \<and> R"
   by (fact arg_cong)
 
 lemma disj_left_cong: "P \<longleftrightarrow> Q \<Longrightarrow> P \<or> R \<longleftrightarrow> Q \<or> R"
   by (fact arg_cong)
 
 setup \<open>
   Code_Preproc.map_pre (put_simpset HOL_basic_ss) #>
   Code_Preproc.map_post (put_simpset HOL_basic_ss) #>
   Code_Simp.map_ss (put_simpset HOL_basic_ss #>
   Simplifier.add_cong @{thm conj_left_cong} #>
   Simplifier.add_cong @{thm disj_left_cong})
 \<close>
 
 
 subsubsection \<open>Equality\<close>
 
 class equal =
   fixes equal :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
   assumes equal_eq: "equal x y \<longleftrightarrow> x = y"
 begin
 
 lemma equal: "equal = (=)"
   by (rule ext equal_eq)+
 
 lemma equal_refl: "equal x x \<longleftrightarrow> True"
   unfolding equal by (rule iffI TrueI refl)+
 
 lemma eq_equal: "(=) \<equiv> equal"
   by (rule eq_reflection) (rule ext, rule ext, rule sym, rule equal_eq)
 
 end
 
 declare eq_equal [symmetric, code_post]
 declare eq_equal [code]
 
 setup \<open>
   Code_Preproc.map_pre (fn ctxt =>
     ctxt addsimprocs
       [Simplifier.make_simproc \<^context> "equal"
         {lhss = [\<^term>\<open>HOL.eq\<close>],
          proc = fn _ => fn _ => fn ct =>
           (case Thm.term_of ct of
             Const (_, Type (\<^type_name>\<open>fun\<close>, [Type _, _])) => SOME @{thm eq_equal}
           | _ => NONE)}])
 \<close>
 
 
 subsubsection \<open>Generic code generator foundation\<close>
 
 text \<open>Datatype \<^typ>\<open>bool\<close>\<close>
 
 code_datatype True False
 
 lemma [code]:
   shows "False \<and> P \<longleftrightarrow> False"
     and "True \<and> P \<longleftrightarrow> P"
     and "P \<and> False \<longleftrightarrow> False"
     and "P \<and> True \<longleftrightarrow> P"
   by simp_all
 
 lemma [code]:
   shows "False \<or> P \<longleftrightarrow> P"
     and "True \<or> P \<longleftrightarrow> True"
     and "P \<or> False \<longleftrightarrow> P"
     and "P \<or> True \<longleftrightarrow> True"
   by simp_all
 
 lemma [code]:
   shows "(False \<longrightarrow> P) \<longleftrightarrow> True"
     and "(True \<longrightarrow> P) \<longleftrightarrow> P"
     and "(P \<longrightarrow> False) \<longleftrightarrow> \<not> P"
     and "(P \<longrightarrow> True) \<longleftrightarrow> True"
   by simp_all
 
 text \<open>More about \<^typ>\<open>prop\<close>\<close>
 
 lemma [code nbe]:
   shows "(True \<Longrightarrow> PROP Q) \<equiv> PROP Q"
     and "(PROP Q \<Longrightarrow> True) \<equiv> Trueprop True"
     and "(P \<Longrightarrow> R) \<equiv> Trueprop (P \<longrightarrow> R)"
   by (auto intro!: equal_intr_rule)
 
 lemma Trueprop_code [code]: "Trueprop True \<equiv> Code_Generator.holds"
   by (auto intro!: equal_intr_rule holds)
 
 declare Trueprop_code [symmetric, code_post]
 
 text \<open>Equality\<close>
 
 declare simp_thms(6) [code nbe]
 
 instantiation itself :: (type) equal
 begin
 
 definition equal_itself :: "'a itself \<Rightarrow> 'a itself \<Rightarrow> bool"
   where "equal_itself x y \<longleftrightarrow> x = y"
 
 instance
   by standard (fact equal_itself_def)
 
 end
 
 lemma equal_itself_code [code]: "equal TYPE('a) TYPE('a) \<longleftrightarrow> True"
   by (simp add: equal)
 
 setup \<open>Sign.add_const_constraint (\<^const_name>\<open>equal\<close>, SOME \<^typ>\<open>'a::type \<Rightarrow> 'a \<Rightarrow> bool\<close>)\<close>
 
 lemma equal_alias_cert: "OFCLASS('a, equal_class) \<equiv> (((=) :: 'a \<Rightarrow> 'a \<Rightarrow> bool) \<equiv> equal)"
   (is "?ofclass \<equiv> ?equal")
 proof
   assume "PROP ?ofclass"
   show "PROP ?equal"
     by (tactic \<open>ALLGOALS (resolve_tac \<^context> [Thm.unconstrainT @{thm eq_equal}])\<close>)
       (fact \<open>PROP ?ofclass\<close>)
 next
   assume "PROP ?equal"
   show "PROP ?ofclass" proof
   qed (simp add: \<open>PROP ?equal\<close>)
 qed
 
 setup \<open>Sign.add_const_constraint (\<^const_name>\<open>equal\<close>, SOME \<^typ>\<open>'a::equal \<Rightarrow> 'a \<Rightarrow> bool\<close>)\<close>
 
 setup \<open>Nbe.add_const_alias @{thm equal_alias_cert}\<close>
 
 text \<open>Cases\<close>
 
 lemma Let_case_cert:
   assumes "CASE \<equiv> (\<lambda>x. Let x f)"
   shows "CASE x \<equiv> f x"
   using assms by simp_all
 
 setup \<open>
   Code.declare_case_global @{thm Let_case_cert} #>
   Code.declare_undefined_global \<^const_name>\<open>undefined\<close>
 \<close>
 
 declare [[code abort: undefined]]
 
 
 subsubsection \<open>Generic code generator target languages\<close>
 
 text \<open>type \<^typ>\<open>bool\<close>\<close>
 
 code_printing
   type_constructor bool \<rightharpoonup>
     (SML) "bool" and (OCaml) "bool" and (Haskell) "Bool" and (Scala) "Boolean"
 | constant True \<rightharpoonup>
     (SML) "true" and (OCaml) "true" and (Haskell) "True" and (Scala) "true"
 | constant False \<rightharpoonup>
     (SML) "false" and (OCaml) "false" and (Haskell) "False" and (Scala) "false"
 
 code_reserved SML
   bool true false
 
 code_reserved OCaml
   bool
 
 code_reserved Scala
   Boolean
 
 code_printing
   constant Not \<rightharpoonup>
     (SML) "not" and (OCaml) "not" and (Haskell) "not" and (Scala) "'! _"
 | constant HOL.conj \<rightharpoonup>
     (SML) infixl 1 "andalso" and (OCaml) infixl 3 "&&" and (Haskell) infixr 3 "&&" and (Scala) infixl 3 "&&"
 | constant HOL.disj \<rightharpoonup>
     (SML) infixl 0 "orelse" and (OCaml) infixl 2 "||" and (Haskell) infixl 2 "||" and (Scala) infixl 1 "||"
 | constant HOL.implies \<rightharpoonup>
     (SML) "!(if (_)/ then (_)/ else true)"
     and (OCaml) "!(if (_)/ then (_)/ else true)"
     and (Haskell) "!(if (_)/ then (_)/ else True)"
     and (Scala) "!(if ((_))/ (_)/ else true)"
 | constant If \<rightharpoonup>
     (SML) "!(if (_)/ then (_)/ else (_))"
     and (OCaml) "!(if (_)/ then (_)/ else (_))"
     and (Haskell) "!(if (_)/ then (_)/ else (_))"
     and (Scala) "!(if ((_))/ (_)/ else (_))"
 
 code_reserved SML
   not
 
 code_reserved OCaml
   not
 
 code_identifier
   code_module Pure \<rightharpoonup>
     (SML) HOL and (OCaml) HOL and (Haskell) HOL and (Scala) HOL
 
 text \<open>Using built-in Haskell equality.\<close>
 code_printing
   type_class equal \<rightharpoonup> (Haskell) "Eq"
 | constant HOL.equal \<rightharpoonup> (Haskell) infix 4 "=="
 | constant HOL.eq \<rightharpoonup> (Haskell) infix 4 "=="
 
 text \<open>\<open>undefined\<close>\<close>
 code_printing
   constant undefined \<rightharpoonup>
     (SML) "!(raise/ Fail/ \"undefined\")"
     and (OCaml) "failwith/ \"undefined\""
     and (Haskell) "error/ \"undefined\""
     and (Scala) "!sys.error(\"undefined\")"
 
 
 subsubsection \<open>Evaluation and normalization by evaluation\<close>
 
 method_setup eval = \<open>
   let
     fun eval_tac ctxt =
       let val conv = Code_Runtime.dynamic_holds_conv
       in
         CONVERSION (Conv.params_conv ~1 (Conv.concl_conv ~1 o conv) ctxt) THEN'
         resolve_tac ctxt [TrueI]
       end
   in
     Scan.succeed (SIMPLE_METHOD' o eval_tac)
   end
 \<close> "solve goal by evaluation"
 
 method_setup normalization = \<open>
   Scan.succeed (fn ctxt =>
     SIMPLE_METHOD'
       (CHANGED_PROP o
         (CONVERSION (Nbe.dynamic_conv ctxt)
           THEN_ALL_NEW (TRY o resolve_tac ctxt [TrueI]))))
 \<close> "solve goal by normalization"
 
 
 subsection \<open>Counterexample Search Units\<close>
 
 subsubsection \<open>Quickcheck\<close>
 
 quickcheck_params [size = 5, iterations = 50]
 
 
 subsubsection \<open>Nitpick setup\<close>
 
 named_theorems nitpick_unfold "alternative definitions of constants as needed by Nitpick"
   and nitpick_simp "equational specification of constants as needed by Nitpick"
   and nitpick_psimp "partial equational specification of constants as needed by Nitpick"
   and nitpick_choice_spec "choice specification of constants as needed by Nitpick"
 
 declare if_bool_eq_conj [nitpick_unfold, no_atp]
   and if_bool_eq_disj [no_atp]
 
 
 subsection \<open>Preprocessing for the predicate compiler\<close>
 
 named_theorems code_pred_def "alternative definitions of constants for the Predicate Compiler"
   and code_pred_inline "inlining definitions for the Predicate Compiler"
   and code_pred_simp "simplification rules for the optimisations in the Predicate Compiler"
 
 
 subsection \<open>Legacy tactics and ML bindings\<close>
 
 ML \<open>
   (* combination of (spec RS spec RS ...(j times) ... spec RS mp) *)
   local
     fun wrong_prem (Const (\<^const_name>\<open>All\<close>, _) $ Abs (_, _, t)) = wrong_prem t
       | wrong_prem (Bound _) = true
       | wrong_prem _ = false;
     val filter_right = filter (not o wrong_prem o HOLogic.dest_Trueprop o hd o Thm.prems_of);
     fun smp i = funpow i (fn m => filter_right ([spec] RL m)) [mp];
   in
     fun smp_tac ctxt j = EVERY' [dresolve_tac ctxt (smp j), assume_tac ctxt];
   end;
 
   local
     val nnf_ss =
       simpset_of (put_simpset HOL_basic_ss \<^context> addsimps @{thms simp_thms nnf_simps});
   in
     fun nnf_conv ctxt = Simplifier.rewrite (put_simpset nnf_ss ctxt);
   end
 \<close>
 
 hide_const (open) eq equal
 
 end
diff --git a/src/HOL/HOLCF/Cfun.thy b/src/HOL/HOLCF/Cfun.thy
--- a/src/HOL/HOLCF/Cfun.thy
+++ b/src/HOL/HOLCF/Cfun.thy
@@ -1,523 +1,523 @@
 (*  Title:      HOL/HOLCF/Cfun.thy
     Author:     Franz Regensburger
     Author:     Brian Huffman
 *)
 
 section \<open>The type of continuous functions\<close>
 
 theory Cfun
   imports Cpodef Fun_Cpo Product_Cpo
 begin
 
 default_sort cpo
 
 
 subsection \<open>Definition of continuous function type\<close>
 
 definition "cfun = {f::'a \<Rightarrow> 'b. cont f}"
 
 cpodef ('a, 'b) cfun ("(_ \<rightarrow>/ _)" [1, 0] 0) = "cfun :: ('a \<Rightarrow> 'b) set"
   by (auto simp: cfun_def intro: cont_const adm_cont)
 
 type_notation (ASCII)
   cfun  (infixr "->" 0)
 
 notation (ASCII)
   Rep_cfun  ("(_$/_)" [999,1000] 999)
 
 notation
   Rep_cfun  ("(_\<cdot>/_)" [999,1000] 999)
 
 
 subsection \<open>Syntax for continuous lambda abstraction\<close>
 
 syntax "_cabs" :: "[logic, logic] \<Rightarrow> logic"
 
 parse_translation \<open>
 (* rewrite (_cabs x t) => (Abs_cfun (%x. t)) *)
   [Syntax_Trans.mk_binder_tr (\<^syntax_const>\<open>_cabs\<close>, \<^const_syntax>\<open>Abs_cfun\<close>)]
 \<close>
 
 print_translation \<open>
   [(\<^const_syntax>\<open>Abs_cfun\<close>, fn _ => fn [Abs abs] =>
       let val (x, t) = Syntax_Trans.atomic_abs_tr' abs
       in Syntax.const \<^syntax_const>\<open>_cabs\<close> $ x $ t end)]
 \<close>  \<comment> \<open>To avoid eta-contraction of body\<close>
 
 text \<open>Syntax for nested abstractions\<close>
 
 syntax (ASCII)
   "_Lambda" :: "[cargs, logic] \<Rightarrow> logic"  ("(3LAM _./ _)" [1000, 10] 10)
 
 syntax
   "_Lambda" :: "[cargs, logic] \<Rightarrow> logic" ("(3\<Lambda> _./ _)" [1000, 10] 10)
 
 parse_ast_translation \<open>
 (* rewrite (LAM x y z. t) => (_cabs x (_cabs y (_cabs z t))) *)
 (* cf. Syntax.lambda_ast_tr from src/Pure/Syntax/syn_trans.ML *)
   let
     fun Lambda_ast_tr [pats, body] =
           Ast.fold_ast_p \<^syntax_const>\<open>_cabs\<close>
             (Ast.unfold_ast \<^syntax_const>\<open>_cargs\<close> (Ast.strip_positions pats), body)
       | Lambda_ast_tr asts = raise Ast.AST ("Lambda_ast_tr", asts);
   in [(\<^syntax_const>\<open>_Lambda\<close>, K Lambda_ast_tr)] end
 \<close>
 
 print_ast_translation \<open>
 (* rewrite (_cabs x (_cabs y (_cabs z t))) => (LAM x y z. t) *)
 (* cf. Syntax.abs_ast_tr' from src/Pure/Syntax/syn_trans.ML *)
   let
     fun cabs_ast_tr' asts =
       (case Ast.unfold_ast_p \<^syntax_const>\<open>_cabs\<close>
           (Ast.Appl (Ast.Constant \<^syntax_const>\<open>_cabs\<close> :: asts)) of
         ([], _) => raise Ast.AST ("cabs_ast_tr'", asts)
       | (xs, body) => Ast.Appl
           [Ast.Constant \<^syntax_const>\<open>_Lambda\<close>,
            Ast.fold_ast \<^syntax_const>\<open>_cargs\<close> xs, body]);
   in [(\<^syntax_const>\<open>_cabs\<close>, K cabs_ast_tr')] end
 \<close>
 
 text \<open>Dummy patterns for continuous abstraction\<close>
 translations
   "\<Lambda> _. t" \<rightharpoonup> "CONST Abs_cfun (\<lambda>_. t)"
 
 
 subsection \<open>Continuous function space is pointed\<close>
 
 lemma bottom_cfun: "\<bottom> \<in> cfun"
   by (simp add: cfun_def inst_fun_pcpo)
 
 instance cfun :: (cpo, discrete_cpo) discrete_cpo
   by intro_classes (simp add: below_cfun_def Rep_cfun_inject)
 
 instance cfun :: (cpo, pcpo) pcpo
   by (rule typedef_pcpo [OF type_definition_cfun below_cfun_def bottom_cfun])
 
 lemmas Rep_cfun_strict =
   typedef_Rep_strict [OF type_definition_cfun below_cfun_def bottom_cfun]
 
 lemmas Abs_cfun_strict =
   typedef_Abs_strict [OF type_definition_cfun below_cfun_def bottom_cfun]
 
 text \<open>function application is strict in its first argument\<close>
 
 lemma Rep_cfun_strict1 [simp]: "\<bottom>\<cdot>x = \<bottom>"
   by (simp add: Rep_cfun_strict)
 
 lemma LAM_strict [simp]: "(\<Lambda> x. \<bottom>) = \<bottom>"
   by (simp add: inst_fun_pcpo [symmetric] Abs_cfun_strict)
 
 text \<open>for compatibility with old HOLCF-Version\<close>
 lemma inst_cfun_pcpo: "\<bottom> = (\<Lambda> x. \<bottom>)"
   by simp
 
 
 subsection \<open>Basic properties of continuous functions\<close>
 
 text \<open>Beta-equality for continuous functions\<close>
 
 lemma Abs_cfun_inverse2: "cont f \<Longrightarrow> Rep_cfun (Abs_cfun f) = f"
   by (simp add: Abs_cfun_inverse cfun_def)
 
 lemma beta_cfun: "cont f \<Longrightarrow> (\<Lambda> x. f x)\<cdot>u = f u"
   by (simp add: Abs_cfun_inverse2)
 
 
 subsubsection \<open>Beta-reduction simproc\<close>
 
 text \<open>
   Given the term \<^term>\<open>(\<Lambda> x. f x)\<cdot>y\<close>, the procedure tries to
   construct the theorem \<^term>\<open>(\<Lambda> x. f x)\<cdot>y \<equiv> f y\<close>.  If this
   theorem cannot be completely solved by the cont2cont rules, then
   the procedure returns the ordinary conditional \<open>beta_cfun\<close>
   rule.
 
   The simproc does not solve any more goals that would be solved by
   using \<open>beta_cfun\<close> as a simp rule.  The advantage of the
   simproc is that it can avoid deeply-nested calls to the simplifier
   that would otherwise be caused by large continuity side conditions.
 
   Update: The simproc now uses rule \<open>Abs_cfun_inverse2\<close> instead
   of \<open>beta_cfun\<close>, to avoid problems with eta-contraction.
 \<close>
 
 simproc_setup beta_cfun_proc ("Rep_cfun (Abs_cfun f)") = \<open>
-  fn phi => fn ctxt => fn ct =>
+  K (fn ctxt => fn ct =>
     let
       val f = #2 (Thm.dest_comb (#2 (Thm.dest_comb ct)));
       val [T, U] = Thm.dest_ctyp (Thm.ctyp_of_cterm f);
       val tr = Thm.instantiate' [SOME T, SOME U] [SOME f] (mk_meta_eq @{thm Abs_cfun_inverse2});
       val rules = Named_Theorems.get ctxt \<^named_theorems>\<open>cont2cont\<close>;
       val tac = SOLVED' (REPEAT_ALL_NEW (match_tac ctxt (rev rules)));
-    in SOME (perhaps (SINGLE (tac 1)) tr) end
+    in SOME (perhaps (SINGLE (tac 1)) tr) end)
 \<close>
 
 text \<open>Eta-equality for continuous functions\<close>
 
 lemma eta_cfun: "(\<Lambda> x. f\<cdot>x) = f"
   by (rule Rep_cfun_inverse)
 
 text \<open>Extensionality for continuous functions\<close>
 
 lemma cfun_eq_iff: "f = g \<longleftrightarrow> (\<forall>x. f\<cdot>x = g\<cdot>x)"
   by (simp add: Rep_cfun_inject [symmetric] fun_eq_iff)
 
 lemma cfun_eqI: "(\<And>x. f\<cdot>x = g\<cdot>x) \<Longrightarrow> f = g"
   by (simp add: cfun_eq_iff)
 
 text \<open>Extensionality wrt. ordering for continuous functions\<close>
 
 lemma cfun_below_iff: "f \<sqsubseteq> g \<longleftrightarrow> (\<forall>x. f\<cdot>x \<sqsubseteq> g\<cdot>x)"
   by (simp add: below_cfun_def fun_below_iff)
 
 lemma cfun_belowI: "(\<And>x. f\<cdot>x \<sqsubseteq> g\<cdot>x) \<Longrightarrow> f \<sqsubseteq> g"
   by (simp add: cfun_below_iff)
 
 text \<open>Congruence for continuous function application\<close>
 
 lemma cfun_cong: "f = g \<Longrightarrow> x = y \<Longrightarrow> f\<cdot>x = g\<cdot>y"
   by simp
 
 lemma cfun_fun_cong: "f = g \<Longrightarrow> f\<cdot>x = g\<cdot>x"
   by simp
 
 lemma cfun_arg_cong: "x = y \<Longrightarrow> f\<cdot>x = f\<cdot>y"
   by simp
 
 
 subsection \<open>Continuity of application\<close>
 
 lemma cont_Rep_cfun1: "cont (\<lambda>f. f\<cdot>x)"
   by (rule cont_Rep_cfun [OF cont_id, THEN cont2cont_fun])
 
 lemma cont_Rep_cfun2: "cont (\<lambda>x. f\<cdot>x)"
   using Rep_cfun [where x = f] by (simp add: cfun_def)
 
 lemmas monofun_Rep_cfun = cont_Rep_cfun [THEN cont2mono]
 
 lemmas monofun_Rep_cfun1 = cont_Rep_cfun1 [THEN cont2mono]
 lemmas monofun_Rep_cfun2 = cont_Rep_cfun2 [THEN cont2mono]
 
 text \<open>contlub, cont properties of \<^term>\<open>Rep_cfun\<close> in each argument\<close>
 
 lemma contlub_cfun_arg: "chain Y \<Longrightarrow> f\<cdot>(\<Squnion>i. Y i) = (\<Squnion>i. f\<cdot>(Y i))"
   by (rule cont_Rep_cfun2 [THEN cont2contlubE])
 
 lemma contlub_cfun_fun: "chain F \<Longrightarrow> (\<Squnion>i. F i)\<cdot>x = (\<Squnion>i. F i\<cdot>x)"
   by (rule cont_Rep_cfun1 [THEN cont2contlubE])
 
 text \<open>monotonicity of application\<close>
 
 lemma monofun_cfun_fun: "f \<sqsubseteq> g \<Longrightarrow> f\<cdot>x \<sqsubseteq> g\<cdot>x"
   by (simp add: cfun_below_iff)
 
 lemma monofun_cfun_arg: "x \<sqsubseteq> y \<Longrightarrow> f\<cdot>x \<sqsubseteq> f\<cdot>y"
   by (rule monofun_Rep_cfun2 [THEN monofunE])
 
 lemma monofun_cfun: "f \<sqsubseteq> g \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> f\<cdot>x \<sqsubseteq> g\<cdot>y"
   by (rule below_trans [OF monofun_cfun_fun monofun_cfun_arg])
 
 text \<open>ch2ch - rules for the type \<^typ>\<open>'a \<rightarrow> 'b\<close>\<close>
 
 lemma chain_monofun: "chain Y \<Longrightarrow> chain (\<lambda>i. f\<cdot>(Y i))"
   by (erule monofun_Rep_cfun2 [THEN ch2ch_monofun])
 
 lemma ch2ch_Rep_cfunR: "chain Y \<Longrightarrow> chain (\<lambda>i. f\<cdot>(Y i))"
   by (rule monofun_Rep_cfun2 [THEN ch2ch_monofun])
 
 lemma ch2ch_Rep_cfunL: "chain F \<Longrightarrow> chain (\<lambda>i. (F i)\<cdot>x)"
   by (rule monofun_Rep_cfun1 [THEN ch2ch_monofun])
 
 lemma ch2ch_Rep_cfun [simp]: "chain F \<Longrightarrow> chain Y \<Longrightarrow> chain (\<lambda>i. (F i)\<cdot>(Y i))"
   by (simp add: chain_def monofun_cfun)
 
 lemma ch2ch_LAM [simp]:
   "(\<And>x. chain (\<lambda>i. S i x)) \<Longrightarrow> (\<And>i. cont (\<lambda>x. S i x)) \<Longrightarrow> chain (\<lambda>i. \<Lambda> x. S i x)"
   by (simp add: chain_def cfun_below_iff)
 
 text \<open>contlub, cont properties of \<^term>\<open>Rep_cfun\<close> in both arguments\<close>
 
 lemma lub_APP: "chain F \<Longrightarrow> chain Y \<Longrightarrow> (\<Squnion>i. F i\<cdot>(Y i)) = (\<Squnion>i. F i)\<cdot>(\<Squnion>i. Y i)"
   by (simp add: contlub_cfun_fun contlub_cfun_arg diag_lub)
 
 lemma lub_LAM:
   assumes "\<And>x. chain (\<lambda>i. F i x)"
     and "\<And>i. cont (\<lambda>x. F i x)"
   shows "(\<Squnion>i. \<Lambda> x. F i x) = (\<Lambda> x. \<Squnion>i. F i x)"
   using assms by (simp add: lub_cfun lub_fun ch2ch_lambda)
 
 lemmas lub_distribs = lub_APP lub_LAM
 
 text \<open>strictness\<close>
 
 lemma strictI: "f\<cdot>x = \<bottom> \<Longrightarrow> f\<cdot>\<bottom> = \<bottom>"
   apply (rule bottomI)
   apply (erule subst)
   apply (rule minimal [THEN monofun_cfun_arg])
   done
 
 text \<open>type \<^typ>\<open>'a \<rightarrow> 'b\<close> is chain complete\<close>
 
 lemma lub_cfun: "chain F \<Longrightarrow> (\<Squnion>i. F i) = (\<Lambda> x. \<Squnion>i. F i\<cdot>x)"
   by (simp add: lub_cfun lub_fun ch2ch_lambda)
 
 
 subsection \<open>Continuity simplification procedure\<close>
 
 text \<open>cont2cont lemma for \<^term>\<open>Rep_cfun\<close>\<close>
 
 lemma cont2cont_APP [simp, cont2cont]:
   assumes f: "cont (\<lambda>x. f x)"
   assumes t: "cont (\<lambda>x. t x)"
   shows "cont (\<lambda>x. (f x)\<cdot>(t x))"
 proof -
   from cont_Rep_cfun1 f have "cont (\<lambda>x. (f x)\<cdot>y)" for y
     by (rule cont_compose)
   with t cont_Rep_cfun2 show "cont (\<lambda>x. (f x)\<cdot>(t x))"
     by (rule cont_apply)
 qed
 
 text \<open>
   Two specific lemmas for the combination of LCF and HOL terms.
   These lemmas are needed in theories that use types like \<^typ>\<open>'a \<rightarrow> 'b \<Rightarrow> 'c\<close>.
 \<close>
 
 lemma cont_APP_app [simp]: "cont f \<Longrightarrow> cont g \<Longrightarrow> cont (\<lambda>x. ((f x)\<cdot>(g x)) s)"
   by (rule cont2cont_APP [THEN cont2cont_fun])
 
 lemma cont_APP_app_app [simp]: "cont f \<Longrightarrow> cont g \<Longrightarrow> cont (\<lambda>x. ((f x)\<cdot>(g x)) s t)"
   by (rule cont_APP_app [THEN cont2cont_fun])
 
 
 text \<open>cont2mono Lemma for \<^term>\<open>\<lambda>x. LAM y. c1(x)(y)\<close>\<close>
 
 lemma cont2mono_LAM:
   "\<lbrakk>\<And>x. cont (\<lambda>y. f x y); \<And>y. monofun (\<lambda>x. f x y)\<rbrakk>
     \<Longrightarrow> monofun (\<lambda>x. \<Lambda> y. f x y)"
   by (simp add: monofun_def cfun_below_iff)
 
 text \<open>cont2cont Lemma for \<^term>\<open>\<lambda>x. LAM y. f x y\<close>\<close>
 
 text \<open>
   Not suitable as a cont2cont rule, because on nested lambdas
   it causes exponential blow-up in the number of subgoals.
 \<close>
 
 lemma cont2cont_LAM:
   assumes f1: "\<And>x. cont (\<lambda>y. f x y)"
   assumes f2: "\<And>y. cont (\<lambda>x. f x y)"
   shows "cont (\<lambda>x. \<Lambda> y. f x y)"
 proof (rule cont_Abs_cfun)
   from f1 show "f x \<in> cfun" for x
     by (simp add: cfun_def)
   from f2 show "cont f"
     by (rule cont2cont_lambda)
 qed
 
 text \<open>
   This version does work as a cont2cont rule, since it
   has only a single subgoal.
 \<close>
 
 lemma cont2cont_LAM' [simp, cont2cont]:
   fixes f :: "'a::cpo \<Rightarrow> 'b::cpo \<Rightarrow> 'c::cpo"
   assumes f: "cont (\<lambda>p. f (fst p) (snd p))"
   shows "cont (\<lambda>x. \<Lambda> y. f x y)"
   using assms by (simp add: cont2cont_LAM prod_cont_iff)
 
 lemma cont2cont_LAM_discrete [simp, cont2cont]:
   "(\<And>y::'a::discrete_cpo. cont (\<lambda>x. f x y)) \<Longrightarrow> cont (\<lambda>x. \<Lambda> y. f x y)"
   by (simp add: cont2cont_LAM)
 
 
 subsection \<open>Miscellaneous\<close>
 
 text \<open>Monotonicity of \<^term>\<open>Abs_cfun\<close>\<close>
 
 lemma monofun_LAM: "cont f \<Longrightarrow> cont g \<Longrightarrow> (\<And>x. f x \<sqsubseteq> g x) \<Longrightarrow> (\<Lambda> x. f x) \<sqsubseteq> (\<Lambda> x. g x)"
   by (simp add: cfun_below_iff)
 
 text \<open>some lemmata for functions with flat/chfin domain/range types\<close>
 
 lemma chfin_Rep_cfunR: "chain Y \<Longrightarrow> \<forall>s. \<exists>n. (LUB i. Y i)\<cdot>s = Y n\<cdot>s"
   for Y :: "nat \<Rightarrow> 'a::cpo \<rightarrow> 'b::chfin"
   apply (rule allI)
   apply (subst contlub_cfun_fun)
    apply assumption
   apply (fast intro!: lub_eqI chfin lub_finch2 chfin2finch ch2ch_Rep_cfunL)
   done
 
 lemma adm_chfindom: "adm (\<lambda>(u::'a::cpo \<rightarrow> 'b::chfin). P(u\<cdot>s))"
   by (rule adm_subst, simp, rule adm_chfin)
 
 
 subsection \<open>Continuous injection-retraction pairs\<close>
 
 text \<open>Continuous retractions are strict.\<close>
 
 lemma retraction_strict: "\<forall>x. f\<cdot>(g\<cdot>x) = x \<Longrightarrow> f\<cdot>\<bottom> = \<bottom>"
   apply (rule bottomI)
   apply (drule_tac x="\<bottom>" in spec)
   apply (erule subst)
   apply (rule monofun_cfun_arg)
   apply (rule minimal)
   done
 
 lemma injection_eq: "\<forall>x. f\<cdot>(g\<cdot>x) = x \<Longrightarrow> (g\<cdot>x = g\<cdot>y) = (x = y)"
   apply (rule iffI)
    apply (drule_tac f=f in cfun_arg_cong)
    apply simp
   apply simp
   done
 
 lemma injection_below: "\<forall>x. f\<cdot>(g\<cdot>x) = x \<Longrightarrow> (g\<cdot>x \<sqsubseteq> g\<cdot>y) = (x \<sqsubseteq> y)"
   apply (rule iffI)
    apply (drule_tac f=f in monofun_cfun_arg)
    apply simp
   apply (erule monofun_cfun_arg)
   done
 
 lemma injection_defined_rev: "\<forall>x. f\<cdot>(g\<cdot>x) = x \<Longrightarrow> g\<cdot>z = \<bottom> \<Longrightarrow> z = \<bottom>"
   apply (drule_tac f=f in cfun_arg_cong)
   apply (simp add: retraction_strict)
   done
 
 lemma injection_defined: "\<forall>x. f\<cdot>(g\<cdot>x) = x \<Longrightarrow> z \<noteq> \<bottom> \<Longrightarrow> g\<cdot>z \<noteq> \<bottom>"
   by (erule contrapos_nn, rule injection_defined_rev)
 
 
 text \<open>a result about functions with flat codomain\<close>
 
 lemma flat_eqI: "x \<sqsubseteq> y \<Longrightarrow> x \<noteq> \<bottom> \<Longrightarrow> x = y"
   for x y :: "'a::flat"
   by (drule ax_flat) simp
 
 lemma flat_codom: "f\<cdot>x = c \<Longrightarrow> f\<cdot>\<bottom> = \<bottom> \<or> (\<forall>z. f\<cdot>z = c)"
   for c :: "'b::flat"
   apply (cases "f\<cdot>x = \<bottom>")
    apply (rule disjI1)
    apply (rule bottomI)
    apply (erule_tac t="\<bottom>" in subst)
    apply (rule minimal [THEN monofun_cfun_arg])
   apply clarify
   apply (rule_tac a = "f\<cdot>\<bottom>" in refl [THEN box_equals])
    apply (erule minimal [THEN monofun_cfun_arg, THEN flat_eqI])
   apply (erule minimal [THEN monofun_cfun_arg, THEN flat_eqI])
   done
 
 
 subsection \<open>Identity and composition\<close>
 
 definition ID :: "'a \<rightarrow> 'a"
   where "ID = (\<Lambda> x. x)"
 
 definition cfcomp  :: "('b \<rightarrow> 'c) \<rightarrow> ('a \<rightarrow> 'b) \<rightarrow> 'a \<rightarrow> 'c"
   where oo_def: "cfcomp = (\<Lambda> f g x. f\<cdot>(g\<cdot>x))"
 
 abbreviation cfcomp_syn :: "['b \<rightarrow> 'c, 'a \<rightarrow> 'b] \<Rightarrow> 'a \<rightarrow> 'c"  (infixr "oo" 100)
   where "f oo g == cfcomp\<cdot>f\<cdot>g"
 
 lemma ID1 [simp]: "ID\<cdot>x = x"
   by (simp add: ID_def)
 
 lemma cfcomp1: "(f oo g) = (\<Lambda> x. f\<cdot>(g\<cdot>x))"
   by (simp add: oo_def)
 
 lemma cfcomp2 [simp]: "(f oo g)\<cdot>x = f\<cdot>(g\<cdot>x)"
   by (simp add: cfcomp1)
 
 lemma cfcomp_LAM: "cont g \<Longrightarrow> f oo (\<Lambda> x. g x) = (\<Lambda> x. f\<cdot>(g x))"
   by (simp add: cfcomp1)
 
 lemma cfcomp_strict [simp]: "\<bottom> oo f = \<bottom>"
   by (simp add: cfun_eq_iff)
 
 text \<open>
   Show that interpretation of (pcpo, \<open>_\<rightarrow>_\<close>) is a category.
   \<^item> The class of objects is interpretation of syntactical class pcpo.
   \<^item> The class of arrows  between objects \<^typ>\<open>'a\<close> and \<^typ>\<open>'b\<close> is interpret. of \<^typ>\<open>'a \<rightarrow> 'b\<close>.
   \<^item> The identity arrow is interpretation of \<^term>\<open>ID\<close>.
   \<^item> The composition of f and g is interpretation of \<open>oo\<close>.
 \<close>
 
 lemma ID2 [simp]: "f oo ID = f"
   by (rule cfun_eqI, simp)
 
 lemma ID3 [simp]: "ID oo f = f"
   by (rule cfun_eqI) simp
 
 lemma assoc_oo: "f oo (g oo h) = (f oo g) oo h"
   by (rule cfun_eqI) simp
 
 
 subsection \<open>Strictified functions\<close>
 
 default_sort pcpo
 
 definition seq :: "'a \<rightarrow> 'b \<rightarrow> 'b"
   where "seq = (\<Lambda> x. if x = \<bottom> then \<bottom> else ID)"
 
 lemma cont2cont_if_bottom [cont2cont, simp]:
   assumes f: "cont (\<lambda>x. f x)"
     and g: "cont (\<lambda>x. g x)"
   shows "cont (\<lambda>x. if f x = \<bottom> then \<bottom> else g x)"
 proof (rule cont_apply [OF f])
   show "cont (\<lambda>y. if y = \<bottom> then \<bottom> else g x)" for x
     unfolding cont_def is_lub_def is_ub_def ball_simps
     by (simp add: lub_eq_bottom_iff)
   show "cont (\<lambda>x. if y = \<bottom> then \<bottom> else g x)" for y
     by (simp add: g)
 qed
 
 lemma seq_conv_if: "seq\<cdot>x = (if x = \<bottom> then \<bottom> else ID)"
   by (simp add: seq_def)
 
 lemma seq_simps [simp]:
   "seq\<cdot>\<bottom> = \<bottom>"
   "seq\<cdot>x\<cdot>\<bottom> = \<bottom>"
   "x \<noteq> \<bottom> \<Longrightarrow> seq\<cdot>x = ID"
   by (simp_all add: seq_conv_if)
 
 definition strictify  :: "('a \<rightarrow> 'b) \<rightarrow> 'a \<rightarrow> 'b"
   where "strictify = (\<Lambda> f x. seq\<cdot>x\<cdot>(f\<cdot>x))"
 
 lemma strictify_conv_if: "strictify\<cdot>f\<cdot>x = (if x = \<bottom> then \<bottom> else f\<cdot>x)"
   by (simp add: strictify_def)
 
 lemma strictify1 [simp]: "strictify\<cdot>f\<cdot>\<bottom> = \<bottom>"
   by (simp add: strictify_conv_if)
 
 lemma strictify2 [simp]: "x \<noteq> \<bottom> \<Longrightarrow> strictify\<cdot>f\<cdot>x = f\<cdot>x"
   by (simp add: strictify_conv_if)
 
 
 subsection \<open>Continuity of let-bindings\<close>
 
 lemma cont2cont_Let:
   assumes f: "cont (\<lambda>x. f x)"
   assumes g1: "\<And>y. cont (\<lambda>x. g x y)"
   assumes g2: "\<And>x. cont (\<lambda>y. g x y)"
   shows "cont (\<lambda>x. let y = f x in g x y)"
   unfolding Let_def using f g2 g1 by (rule cont_apply)
 
 lemma cont2cont_Let' [simp, cont2cont]:
   assumes f: "cont (\<lambda>x. f x)"
   assumes g: "cont (\<lambda>p. g (fst p) (snd p))"
   shows "cont (\<lambda>x. let y = f x in g x y)"
   using f
 proof (rule cont2cont_Let)
   from g show "cont (\<lambda>y. g x y)" for x
     by (simp add: prod_cont_iff)
   from g show "cont (\<lambda>x. g x y)" for y
     by (simp add: prod_cont_iff)
 qed
 
 text \<open>The simple version (suggested by Joachim Breitner) is needed if
   the type of the defined term is not a cpo.\<close>
 
 lemma cont2cont_Let_simple [simp, cont2cont]:
   assumes "\<And>y. cont (\<lambda>x. g x y)"
   shows "cont (\<lambda>x. let y = t in g x y)"
   unfolding Let_def using assms .
 
 end
diff --git a/src/HOL/HOLCF/Pcpo.thy b/src/HOL/HOLCF/Pcpo.thy
--- a/src/HOL/HOLCF/Pcpo.thy
+++ b/src/HOL/HOLCF/Pcpo.thy
@@ -1,258 +1,258 @@
 (*  Title:      HOL/HOLCF/Pcpo.thy
     Author:     Franz Regensburger
 *)
 
 section \<open>Classes cpo and pcpo\<close>
 
 theory Pcpo
   imports Porder
 begin
 
 subsection \<open>Complete partial orders\<close>
 
 text \<open>The class cpo of chain complete partial orders\<close>
 
 class cpo = po +
   assumes cpo: "chain S \<Longrightarrow> \<exists>x. range S <<| x"
 begin
 
 text \<open>in cpo's everthing equal to THE lub has lub properties for every chain\<close>
 
 lemma cpo_lubI: "chain S \<Longrightarrow> range S <<| (\<Squnion>i. S i)"
   by (fast dest: cpo elim: is_lub_lub)
 
 lemma thelubE: "\<lbrakk>chain S; (\<Squnion>i. S i) = l\<rbrakk> \<Longrightarrow> range S <<| l"
   by (blast dest: cpo intro: is_lub_lub)
 
 text \<open>Properties of the lub\<close>
 
 lemma is_ub_thelub: "chain S \<Longrightarrow> S x \<sqsubseteq> (\<Squnion>i. S i)"
   by (blast dest: cpo intro: is_lub_lub [THEN is_lub_rangeD1])
 
 lemma is_lub_thelub: "\<lbrakk>chain S; range S <| x\<rbrakk> \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x"
   by (blast dest: cpo intro: is_lub_lub [THEN is_lubD2])
 
 lemma lub_below_iff: "chain S \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x \<longleftrightarrow> (\<forall>i. S i \<sqsubseteq> x)"
   by (simp add: is_lub_below_iff [OF cpo_lubI] is_ub_def)
 
 lemma lub_below: "\<lbrakk>chain S; \<And>i. S i \<sqsubseteq> x\<rbrakk> \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x"
   by (simp add: lub_below_iff)
 
 lemma below_lub: "\<lbrakk>chain S; x \<sqsubseteq> S i\<rbrakk> \<Longrightarrow> x \<sqsubseteq> (\<Squnion>i. S i)"
   by (erule below_trans, erule is_ub_thelub)
 
 lemma lub_range_mono: "\<lbrakk>range X \<subseteq> range Y; chain Y; chain X\<rbrakk> \<Longrightarrow> (\<Squnion>i. X i) \<sqsubseteq> (\<Squnion>i. Y i)"
   apply (erule lub_below)
   apply (subgoal_tac "\<exists>j. X i = Y j")
    apply clarsimp
    apply (erule is_ub_thelub)
   apply auto
   done
 
 lemma lub_range_shift: "chain Y \<Longrightarrow> (\<Squnion>i. Y (i + j)) = (\<Squnion>i. Y i)"
   apply (rule below_antisym)
    apply (rule lub_range_mono)
      apply fast
     apply assumption
    apply (erule chain_shift)
   apply (rule lub_below)
    apply assumption
   apply (rule_tac i="i" in below_lub)
    apply (erule chain_shift)
   apply (erule chain_mono)
   apply (rule le_add1)
   done
 
 lemma maxinch_is_thelub: "chain Y \<Longrightarrow> max_in_chain i Y = ((\<Squnion>i. Y i) = Y i)"
   apply (rule iffI)
    apply (fast intro!: lub_eqI lub_finch1)
   apply (unfold max_in_chain_def)
   apply (safe intro!: below_antisym)
    apply (fast elim!: chain_mono)
   apply (drule sym)
   apply (force elim!: is_ub_thelub)
   done
 
 text \<open>the \<open>\<sqsubseteq>\<close> relation between two chains is preserved by their lubs\<close>
 
 lemma lub_mono: "\<lbrakk>chain X; chain Y; \<And>i. X i \<sqsubseteq> Y i\<rbrakk> \<Longrightarrow> (\<Squnion>i. X i) \<sqsubseteq> (\<Squnion>i. Y i)"
   by (fast elim: lub_below below_lub)
 
 text \<open>the = relation between two chains is preserved by their lubs\<close>
 
 lemma lub_eq: "(\<And>i. X i = Y i) \<Longrightarrow> (\<Squnion>i. X i) = (\<Squnion>i. Y i)"
   by simp
 
 lemma ch2ch_lub:
   assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
   assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
   shows "chain (\<lambda>i. \<Squnion>j. Y i j)"
   apply (rule chainI)
   apply (rule lub_mono [OF 2 2])
   apply (rule chainE [OF 1])
   done
 
 lemma diag_lub:
   assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
   assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
   shows "(\<Squnion>i. \<Squnion>j. Y i j) = (\<Squnion>i. Y i i)"
 proof (rule below_antisym)
   have 3: "chain (\<lambda>i. Y i i)"
     apply (rule chainI)
     apply (rule below_trans)
      apply (rule chainE [OF 1])
     apply (rule chainE [OF 2])
     done
   have 4: "chain (\<lambda>i. \<Squnion>j. Y i j)"
     by (rule ch2ch_lub [OF 1 2])
   show "(\<Squnion>i. \<Squnion>j. Y i j) \<sqsubseteq> (\<Squnion>i. Y i i)"
     apply (rule lub_below [OF 4])
     apply (rule lub_below [OF 2])
     apply (rule below_lub [OF 3])
     apply (rule below_trans)
      apply (rule chain_mono [OF 1 max.cobounded1])
     apply (rule chain_mono [OF 2 max.cobounded2])
     done
   show "(\<Squnion>i. Y i i) \<sqsubseteq> (\<Squnion>i. \<Squnion>j. Y i j)"
     apply (rule lub_mono [OF 3 4])
     apply (rule is_ub_thelub [OF 2])
     done
 qed
 
 lemma ex_lub:
   assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
   assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
   shows "(\<Squnion>i. \<Squnion>j. Y i j) = (\<Squnion>j. \<Squnion>i. Y i j)"
   by (simp add: diag_lub 1 2)
 
 end
 
 
 subsection \<open>Pointed cpos\<close>
 
 text \<open>The class pcpo of pointed cpos\<close>
 
 class pcpo = cpo +
   assumes least: "\<exists>x. \<forall>y. x \<sqsubseteq> y"
 begin
 
 definition bottom :: "'a"  ("\<bottom>")
   where "bottom = (THE x. \<forall>y. x \<sqsubseteq> y)"
 
 lemma minimal [iff]: "\<bottom> \<sqsubseteq> x"
   unfolding bottom_def
   apply (rule the1I2)
    apply (rule ex_ex1I)
     apply (rule least)
    apply (blast intro: below_antisym)
   apply simp
   done
 
 end
 
 text \<open>Old "UU" syntax:\<close>
 
 syntax UU :: logic
 translations "UU" \<rightharpoonup> "CONST bottom"
 
 text \<open>Simproc to rewrite \<^term>\<open>\<bottom> = x\<close> to \<^term>\<open>x = \<bottom>\<close>.\<close>
 setup \<open>Reorient_Proc.add (fn \<^Const_>\<open>bottom _\<close> => true | _ => false)\<close>
-simproc_setup reorient_bottom ("\<bottom> = x") = Reorient_Proc.proc
+simproc_setup reorient_bottom ("\<bottom> = x") = \<open>K Reorient_Proc.proc\<close>
 
 text \<open>useful lemmas about \<^term>\<open>\<bottom>\<close>\<close>
 
 lemma below_bottom_iff [simp]: "x \<sqsubseteq> \<bottom> \<longleftrightarrow> x = \<bottom>"
   by (simp add: po_eq_conv)
 
 lemma eq_bottom_iff: "x = \<bottom> \<longleftrightarrow> x \<sqsubseteq> \<bottom>"
   by simp
 
 lemma bottomI: "x \<sqsubseteq> \<bottom> \<Longrightarrow> x = \<bottom>"
   by (subst eq_bottom_iff)
 
 lemma lub_eq_bottom_iff: "chain Y \<Longrightarrow> (\<Squnion>i. Y i) = \<bottom> \<longleftrightarrow> (\<forall>i. Y i = \<bottom>)"
   by (simp only: eq_bottom_iff lub_below_iff)
 
 
 subsection \<open>Chain-finite and flat cpos\<close>
 
 text \<open>further useful classes for HOLCF domains\<close>
 
 class chfin = po +
   assumes chfin: "chain Y \<Longrightarrow> \<exists>n. max_in_chain n Y"
 begin
 
 subclass cpo
   apply standard
   apply (frule chfin)
   apply (blast intro: lub_finch1)
   done
 
 lemma chfin2finch: "chain Y \<Longrightarrow> finite_chain Y"
   by (simp add: chfin finite_chain_def)
 
 end
 
 class flat = pcpo +
   assumes ax_flat: "x \<sqsubseteq> y \<Longrightarrow> x = \<bottom> \<or> x = y"
 begin
 
 subclass chfin
 proof
   fix Y
   assume *: "chain Y"
   show "\<exists>n. max_in_chain n Y"
     apply (unfold max_in_chain_def)
     apply (cases "\<forall>i. Y i = \<bottom>")
      apply simp
     apply simp
     apply (erule exE)
     apply (rule_tac x="i" in exI)
     apply clarify
     using * apply (blast dest: chain_mono ax_flat)
     done
 qed
 
 lemma flat_below_iff: "x \<sqsubseteq> y \<longleftrightarrow> x = \<bottom> \<or> x = y"
   by (safe dest!: ax_flat)
 
 lemma flat_eq: "a \<noteq> \<bottom> \<Longrightarrow> a \<sqsubseteq> b = (a = b)"
   by (safe dest!: ax_flat)
 
 end
 
 subsection \<open>Discrete cpos\<close>
 
 class discrete_cpo = below +
   assumes discrete_cpo [simp]: "x \<sqsubseteq> y \<longleftrightarrow> x = y"
 begin
 
 subclass po
   by standard simp_all
 
 text \<open>In a discrete cpo, every chain is constant\<close>
 
 lemma discrete_chain_const:
   assumes S: "chain S"
   shows "\<exists>x. S = (\<lambda>i. x)"
 proof (intro exI ext)
   fix i :: nat
   from S le0 have "S 0 \<sqsubseteq> S i" by (rule chain_mono)
   then have "S 0 = S i" by simp
   then show "S i = S 0" by (rule sym)
 qed
 
 subclass chfin
 proof
   fix S :: "nat \<Rightarrow> 'a"
   assume S: "chain S"
   then have "\<exists>x. S = (\<lambda>i. x)"
     by (rule discrete_chain_const)
   then have "max_in_chain 0 S"
     by (auto simp: max_in_chain_def)
   then show "\<exists>i. max_in_chain i S" ..
 qed
 
 end
 
 end
diff --git a/src/HOL/Library/Extended_Nat.thy b/src/HOL/Library/Extended_Nat.thy
--- a/src/HOL/Library/Extended_Nat.thy
+++ b/src/HOL/Library/Extended_Nat.thy
@@ -1,707 +1,707 @@
 (*  Title:      HOL/Library/Extended_Nat.thy
     Author:     David von Oheimb, TU Muenchen;  Florian Haftmann, TU Muenchen
     Contributions: David Trachtenherz, TU Muenchen
 *)
 
 section \<open>Extended natural numbers (i.e. with infinity)\<close>
 
 theory Extended_Nat
 imports Main Countable Order_Continuity
 begin
 
 class infinity =
   fixes infinity :: "'a"  ("\<infinity>")
 
 context
   fixes f :: "nat \<Rightarrow> 'a::{canonically_ordered_monoid_add, linorder_topology, complete_linorder}"
 begin
 
 lemma sums_SUP[simp, intro]: "f sums (SUP n. \<Sum>i<n. f i)"
   unfolding sums_def by (intro LIMSEQ_SUP monoI sum_mono2 zero_le) auto
 
 lemma suminf_eq_SUP: "suminf f = (SUP n. \<Sum>i<n. f i)"
   using sums_SUP by (rule sums_unique[symmetric])
 
 end
 
 subsection \<open>Type definition\<close>
 
 text \<open>
   We extend the standard natural numbers by a special value indicating
   infinity.
 \<close>
 
 typedef enat = "UNIV :: nat option set" ..
 
 text \<open>TODO: introduce enat as coinductive datatype, enat is just \<^const>\<open>of_nat\<close>\<close>
 
 definition enat :: "nat \<Rightarrow> enat" where
   "enat n = Abs_enat (Some n)"
 
 instantiation enat :: infinity
 begin
 
 definition "\<infinity> = Abs_enat None"
 instance ..
 
 end
 
 instance enat :: countable
 proof
   show "\<exists>to_nat::enat \<Rightarrow> nat. inj to_nat"
     by (rule exI[of _ "to_nat \<circ> Rep_enat"]) (simp add: inj_on_def Rep_enat_inject)
 qed
 
 old_rep_datatype enat "\<infinity> :: enat"
 proof -
   fix P i assume "\<And>j. P (enat j)" "P \<infinity>"
   then show "P i"
   proof induct
     case (Abs_enat y) then show ?case
       by (cases y rule: option.exhaust)
          (auto simp: enat_def infinity_enat_def)
   qed
 qed (auto simp add: enat_def infinity_enat_def Abs_enat_inject)
 
 declare [[coercion "enat::nat\<Rightarrow>enat"]]
 
 lemmas enat2_cases = enat.exhaust[case_product enat.exhaust]
 lemmas enat3_cases = enat.exhaust[case_product enat.exhaust enat.exhaust]
 
 lemma not_infinity_eq [iff]: "(x \<noteq> \<infinity>) = (\<exists>i. x = enat i)"
   by (cases x) auto
 
 lemma not_enat_eq [iff]: "(\<forall>y. x \<noteq> enat y) = (x = \<infinity>)"
   by (cases x) auto
 
 lemma enat_ex_split: "(\<exists>c::enat. P c) \<longleftrightarrow> P \<infinity> \<or> (\<exists>c::nat. P c)"
   by (metis enat.exhaust)
 
 primrec the_enat :: "enat \<Rightarrow> nat"
   where "the_enat (enat n) = n"
 
 
 subsection \<open>Constructors and numbers\<close>
 
 instantiation enat :: zero_neq_one
 begin
 
 definition
   "0 = enat 0"
 
 definition
   "1 = enat 1"
 
 instance
   proof qed (simp add: zero_enat_def one_enat_def)
 
 end
 
 definition eSuc :: "enat \<Rightarrow> enat" where
   "eSuc i = (case i of enat n \<Rightarrow> enat (Suc n) | \<infinity> \<Rightarrow> \<infinity>)"
 
 lemma enat_0 [code_post]: "enat 0 = 0"
   by (simp add: zero_enat_def)
 
 lemma enat_1 [code_post]: "enat 1 = 1"
   by (simp add: one_enat_def)
 
 lemma enat_0_iff: "enat x = 0 \<longleftrightarrow> x = 0" "0 = enat x \<longleftrightarrow> x = 0"
   by (auto simp add: zero_enat_def)
 
 lemma enat_1_iff: "enat x = 1 \<longleftrightarrow> x = 1" "1 = enat x \<longleftrightarrow> x = 1"
   by (auto simp add: one_enat_def)
 
 lemma one_eSuc: "1 = eSuc 0"
   by (simp add: zero_enat_def one_enat_def eSuc_def)
 
 lemma infinity_ne_i0 [simp]: "(\<infinity>::enat) \<noteq> 0"
   by (simp add: zero_enat_def)
 
 lemma i0_ne_infinity [simp]: "0 \<noteq> (\<infinity>::enat)"
   by (simp add: zero_enat_def)
 
 lemma zero_one_enat_neq:
   "\<not> 0 = (1::enat)"
   "\<not> 1 = (0::enat)"
   unfolding zero_enat_def one_enat_def by simp_all
 
 lemma infinity_ne_i1 [simp]: "(\<infinity>::enat) \<noteq> 1"
   by (simp add: one_enat_def)
 
 lemma i1_ne_infinity [simp]: "1 \<noteq> (\<infinity>::enat)"
   by (simp add: one_enat_def)
 
 lemma eSuc_enat: "eSuc (enat n) = enat (Suc n)"
   by (simp add: eSuc_def)
 
 lemma eSuc_infinity [simp]: "eSuc \<infinity> = \<infinity>"
   by (simp add: eSuc_def)
 
 lemma eSuc_ne_0 [simp]: "eSuc n \<noteq> 0"
   by (simp add: eSuc_def zero_enat_def split: enat.splits)
 
 lemma zero_ne_eSuc [simp]: "0 \<noteq> eSuc n"
   by (rule eSuc_ne_0 [symmetric])
 
 lemma eSuc_inject [simp]: "eSuc m = eSuc n \<longleftrightarrow> m = n"
   by (simp add: eSuc_def split: enat.splits)
 
 lemma eSuc_enat_iff: "eSuc x = enat y \<longleftrightarrow> (\<exists>n. y = Suc n \<and> x = enat n)"
   by (cases y) (auto simp: enat_0 eSuc_enat[symmetric])
 
 lemma enat_eSuc_iff: "enat y = eSuc x \<longleftrightarrow> (\<exists>n. y = Suc n \<and> enat n = x)"
   by (cases y) (auto simp: enat_0 eSuc_enat[symmetric])
 
 subsection \<open>Addition\<close>
 
 instantiation enat :: comm_monoid_add
 begin
 
 definition [nitpick_simp]:
   "m + n = (case m of \<infinity> \<Rightarrow> \<infinity> | enat m \<Rightarrow> (case n of \<infinity> \<Rightarrow> \<infinity> | enat n \<Rightarrow> enat (m + n)))"
 
 lemma plus_enat_simps [simp, code]:
   fixes q :: enat
   shows "enat m + enat n = enat (m + n)"
     and "\<infinity> + q = \<infinity>"
     and "q + \<infinity> = \<infinity>"
   by (simp_all add: plus_enat_def split: enat.splits)
 
 instance
 proof
   fix n m q :: enat
   show "n + m + q = n + (m + q)"
     by (cases n m q rule: enat3_cases) auto
   show "n + m = m + n"
     by (cases n m rule: enat2_cases) auto
   show "0 + n = n"
     by (cases n) (simp_all add: zero_enat_def)
 qed
 
 end
 
 lemma eSuc_plus_1:
   "eSuc n = n + 1"
   by (cases n) (simp_all add: eSuc_enat one_enat_def)
 
 lemma plus_1_eSuc:
   "1 + q = eSuc q"
   "q + 1 = eSuc q"
   by (simp_all add: eSuc_plus_1 ac_simps)
 
 lemma iadd_Suc: "eSuc m + n = eSuc (m + n)"
   by (simp_all add: eSuc_plus_1 ac_simps)
 
 lemma iadd_Suc_right: "m + eSuc n = eSuc (m + n)"
   by (simp only: add.commute[of m] iadd_Suc)
 
 subsection \<open>Multiplication\<close>
 
 instantiation enat :: "{comm_semiring_1, semiring_no_zero_divisors}"
 begin
 
 definition times_enat_def [nitpick_simp]:
   "m * n = (case m of \<infinity> \<Rightarrow> if n = 0 then 0 else \<infinity> | enat m \<Rightarrow>
     (case n of \<infinity> \<Rightarrow> if m = 0 then 0 else \<infinity> | enat n \<Rightarrow> enat (m * n)))"
 
 lemma times_enat_simps [simp, code]:
   "enat m * enat n = enat (m * n)"
   "\<infinity> * \<infinity> = (\<infinity>::enat)"
   "\<infinity> * enat n = (if n = 0 then 0 else \<infinity>)"
   "enat m * \<infinity> = (if m = 0 then 0 else \<infinity>)"
   unfolding times_enat_def zero_enat_def
   by (simp_all split: enat.split)
 
 instance
 proof
   fix a b c :: enat
   show "(a * b) * c = a * (b * c)"
     unfolding times_enat_def zero_enat_def
     by (simp split: enat.split)
   show comm: "a * b = b * a"
     unfolding times_enat_def zero_enat_def
     by (simp split: enat.split)
   show "1 * a = a"
     unfolding times_enat_def zero_enat_def one_enat_def
     by (simp split: enat.split)
   show distr: "(a + b) * c = a * c + b * c"
     unfolding times_enat_def zero_enat_def
     by (simp split: enat.split add: distrib_right)
   show "0 * a = 0"
     unfolding times_enat_def zero_enat_def
     by (simp split: enat.split)
   show "a * 0 = 0"
     unfolding times_enat_def zero_enat_def
     by (simp split: enat.split)
   show "a * (b + c) = a * b + a * c"
     by (cases a b c rule: enat3_cases) (auto simp: times_enat_def zero_enat_def distrib_left)
   show "a \<noteq> 0 \<Longrightarrow> b \<noteq> 0 \<Longrightarrow> a * b \<noteq> 0"
     by (cases a b rule: enat2_cases) (auto simp: times_enat_def zero_enat_def)
 qed
 
 end
 
 lemma mult_eSuc: "eSuc m * n = n + m * n"
   unfolding eSuc_plus_1 by (simp add: algebra_simps)
 
 lemma mult_eSuc_right: "m * eSuc n = m + m * n"
   unfolding eSuc_plus_1 by (simp add: algebra_simps)
 
 lemma of_nat_eq_enat: "of_nat n = enat n"
   apply (induct n)
   apply (simp add: enat_0)
   apply (simp add: plus_1_eSuc eSuc_enat)
   done
 
 instance enat :: semiring_char_0
 proof
   have "inj enat" by (rule injI) simp
   then show "inj (\<lambda>n. of_nat n :: enat)" by (simp add: of_nat_eq_enat)
 qed
 
 lemma imult_is_infinity: "((a::enat) * b = \<infinity>) = (a = \<infinity> \<and> b \<noteq> 0 \<or> b = \<infinity> \<and> a \<noteq> 0)"
   by (auto simp add: times_enat_def zero_enat_def split: enat.split)
 
 subsection \<open>Numerals\<close>
 
 lemma numeral_eq_enat:
   "numeral k = enat (numeral k)"
   using of_nat_eq_enat [of "numeral k"] by simp
 
 lemma enat_numeral [code_abbrev]:
   "enat (numeral k) = numeral k"
   using numeral_eq_enat ..
 
 lemma infinity_ne_numeral [simp]: "(\<infinity>::enat) \<noteq> numeral k"
   by (simp add: numeral_eq_enat)
 
 lemma numeral_ne_infinity [simp]: "numeral k \<noteq> (\<infinity>::enat)"
   by (simp add: numeral_eq_enat)
 
 lemma eSuc_numeral [simp]: "eSuc (numeral k) = numeral (k + Num.One)"
   by (simp only: eSuc_plus_1 numeral_plus_one)
 
 subsection \<open>Subtraction\<close>
 
 instantiation enat :: minus
 begin
 
 definition diff_enat_def:
 "a - b = (case a of (enat x) \<Rightarrow> (case b of (enat y) \<Rightarrow> enat (x - y) | \<infinity> \<Rightarrow> 0)
           | \<infinity> \<Rightarrow> \<infinity>)"
 
 instance ..
 
 end
 
 lemma idiff_enat_enat [simp, code]: "enat a - enat b = enat (a - b)"
   by (simp add: diff_enat_def)
 
 lemma idiff_infinity [simp, code]: "\<infinity> - n = (\<infinity>::enat)"
   by (simp add: diff_enat_def)
 
 lemma idiff_infinity_right [simp, code]: "enat a - \<infinity> = 0"
   by (simp add: diff_enat_def)
 
 lemma idiff_0 [simp]: "(0::enat) - n = 0"
   by (cases n, simp_all add: zero_enat_def)
 
 lemmas idiff_enat_0 [simp] = idiff_0 [unfolded zero_enat_def]
 
 lemma idiff_0_right [simp]: "(n::enat) - 0 = n"
   by (cases n) (simp_all add: zero_enat_def)
 
 lemmas idiff_enat_0_right [simp] = idiff_0_right [unfolded zero_enat_def]
 
 lemma idiff_self [simp]: "n \<noteq> \<infinity> \<Longrightarrow> (n::enat) - n = 0"
   by (auto simp: zero_enat_def)
 
 lemma eSuc_minus_eSuc [simp]: "eSuc n - eSuc m = n - m"
   by (simp add: eSuc_def split: enat.split)
 
 lemma eSuc_minus_1 [simp]: "eSuc n - 1 = n"
   by (simp add: one_enat_def flip: eSuc_enat zero_enat_def)
 
 (*lemmas idiff_self_eq_0_enat = idiff_self_eq_0[unfolded zero_enat_def]*)
 
 subsection \<open>Ordering\<close>
 
 instantiation enat :: linordered_ab_semigroup_add
 begin
 
 definition [nitpick_simp]:
   "m \<le> n = (case n of enat n1 \<Rightarrow> (case m of enat m1 \<Rightarrow> m1 \<le> n1 | \<infinity> \<Rightarrow> False)
     | \<infinity> \<Rightarrow> True)"
 
 definition [nitpick_simp]:
   "m < n = (case m of enat m1 \<Rightarrow> (case n of enat n1 \<Rightarrow> m1 < n1 | \<infinity> \<Rightarrow> True)
     | \<infinity> \<Rightarrow> False)"
 
 lemma enat_ord_simps [simp]:
   "enat m \<le> enat n \<longleftrightarrow> m \<le> n"
   "enat m < enat n \<longleftrightarrow> m < n"
   "q \<le> (\<infinity>::enat)"
   "q < (\<infinity>::enat) \<longleftrightarrow> q \<noteq> \<infinity>"
   "(\<infinity>::enat) \<le> q \<longleftrightarrow> q = \<infinity>"
   "(\<infinity>::enat) < q \<longleftrightarrow> False"
   by (simp_all add: less_eq_enat_def less_enat_def split: enat.splits)
 
 lemma numeral_le_enat_iff[simp]:
   shows "numeral m \<le> enat n \<longleftrightarrow> numeral m \<le> n"
 by (auto simp: numeral_eq_enat)
 
 lemma numeral_less_enat_iff[simp]:
   shows "numeral m < enat n \<longleftrightarrow> numeral m < n"
 by (auto simp: numeral_eq_enat)
 
 lemma enat_ord_code [code]:
   "enat m \<le> enat n \<longleftrightarrow> m \<le> n"
   "enat m < enat n \<longleftrightarrow> m < n"
   "q \<le> (\<infinity>::enat) \<longleftrightarrow> True"
   "enat m < \<infinity> \<longleftrightarrow> True"
   "\<infinity> \<le> enat n \<longleftrightarrow> False"
   "(\<infinity>::enat) < q \<longleftrightarrow> False"
   by simp_all
 
 instance
   by standard (auto simp add: less_eq_enat_def less_enat_def plus_enat_def split: enat.splits)
 
 end
 
 instance enat :: dioid
 proof
   fix a b :: enat show "(a \<le> b) = (\<exists>c. b = a + c)"
     by (cases a b rule: enat2_cases) (auto simp: le_iff_add enat_ex_split)
 qed
 
 instance enat :: "{linordered_nonzero_semiring, strict_ordered_comm_monoid_add}"
 proof
   fix a b c :: enat
   show "a \<le> b \<Longrightarrow> 0 \<le> c \<Longrightarrow>c * a \<le> c * b"
     unfolding times_enat_def less_eq_enat_def zero_enat_def
     by (simp split: enat.splits)
   show "a < b \<Longrightarrow> c < d \<Longrightarrow> a + c < b + d" for a b c d :: enat
     by (cases a b c d rule: enat2_cases[case_product enat2_cases]) auto
   show "a < b \<Longrightarrow> a + 1 < b + 1"
     by (metis add_right_mono eSuc_minus_1 eSuc_plus_1 less_le)
 qed (simp add: zero_enat_def one_enat_def)
 
 (* BH: These equations are already proven generally for any type in
 class linordered_semidom. However, enat is not in that class because
 it does not have the cancellation property. Would it be worthwhile to
 a generalize linordered_semidom to a new class that includes enat? *)
 
 lemma add_diff_assoc_enat: "z \<le> y \<Longrightarrow> x + (y - z) = x + y - (z::enat)"
 by(cases x)(auto simp add: diff_enat_def split: enat.split)
 
 lemma enat_ord_number [simp]:
   "(numeral m :: enat) \<le> numeral n \<longleftrightarrow> (numeral m :: nat) \<le> numeral n"
   "(numeral m :: enat) < numeral n \<longleftrightarrow> (numeral m :: nat) < numeral n"
   by (simp_all add: numeral_eq_enat)
 
 lemma infinity_ileE [elim!]: "\<infinity> \<le> enat m \<Longrightarrow> R"
   by (simp add: zero_enat_def less_eq_enat_def split: enat.splits)
 
 lemma infinity_ilessE [elim!]: "\<infinity> < enat m \<Longrightarrow> R"
   by simp
 
 lemma eSuc_ile_mono [simp]: "eSuc n \<le> eSuc m \<longleftrightarrow> n \<le> m"
   by (simp add: eSuc_def less_eq_enat_def split: enat.splits)
 
 lemma eSuc_mono [simp]: "eSuc n < eSuc m \<longleftrightarrow> n < m"
   by (simp add: eSuc_def less_enat_def split: enat.splits)
 
 lemma ile_eSuc [simp]: "n \<le> eSuc n"
   by (simp add: eSuc_def less_eq_enat_def split: enat.splits)
 
 lemma not_eSuc_ilei0 [simp]: "\<not> eSuc n \<le> 0"
   by (simp add: zero_enat_def eSuc_def less_eq_enat_def split: enat.splits)
 
 lemma i0_iless_eSuc [simp]: "0 < eSuc n"
   by (simp add: zero_enat_def eSuc_def less_enat_def split: enat.splits)
 
 lemma iless_eSuc0[simp]: "(n < eSuc 0) = (n = 0)"
   by (simp add: zero_enat_def eSuc_def less_enat_def split: enat.split)
 
 lemma ileI1: "m < n \<Longrightarrow> eSuc m \<le> n"
   by (simp add: eSuc_def less_eq_enat_def less_enat_def split: enat.splits)
 
 lemma Suc_ile_eq: "enat (Suc m) \<le> n \<longleftrightarrow> enat m < n"
   by (cases n) auto
 
 lemma iless_Suc_eq [simp]: "enat m < eSuc n \<longleftrightarrow> enat m \<le> n"
   by (auto simp add: eSuc_def less_enat_def split: enat.splits)
 
 lemma imult_infinity: "(0::enat) < n \<Longrightarrow> \<infinity> * n = \<infinity>"
   by (simp add: zero_enat_def less_enat_def split: enat.splits)
 
 lemma imult_infinity_right: "(0::enat) < n \<Longrightarrow> n * \<infinity> = \<infinity>"
   by (simp add: zero_enat_def less_enat_def split: enat.splits)
 
 lemma enat_0_less_mult_iff: "(0 < (m::enat) * n) = (0 < m \<and> 0 < n)"
   by (simp only: zero_less_iff_neq_zero mult_eq_0_iff, simp)
 
 lemma mono_eSuc: "mono eSuc"
   by (simp add: mono_def)
 
 lemma min_enat_simps [simp]:
   "min (enat m) (enat n) = enat (min m n)"
   "min q 0 = 0"
   "min 0 q = 0"
   "min q (\<infinity>::enat) = q"
   "min (\<infinity>::enat) q = q"
   by (auto simp add: min_def)
 
 lemma max_enat_simps [simp]:
   "max (enat m) (enat n) = enat (max m n)"
   "max q 0 = q"
   "max 0 q = q"
   "max q \<infinity> = (\<infinity>::enat)"
   "max \<infinity> q = (\<infinity>::enat)"
   by (simp_all add: max_def)
 
 lemma enat_ile: "n \<le> enat m \<Longrightarrow> \<exists>k. n = enat k"
   by (cases n) simp_all
 
 lemma enat_iless: "n < enat m \<Longrightarrow> \<exists>k. n = enat k"
   by (cases n) simp_all
 
 lemma iadd_le_enat_iff:
   "x + y \<le> enat n \<longleftrightarrow> (\<exists>y' x'. x = enat x' \<and> y = enat y' \<and> x' + y' \<le> n)"
 by(cases x y rule: enat.exhaust[case_product enat.exhaust]) simp_all
 
 lemma chain_incr: "\<forall>i. \<exists>j. Y i < Y j \<Longrightarrow> \<exists>j. enat k < Y j"
 apply (induct_tac k)
  apply (simp (no_asm) only: enat_0)
  apply (fast intro: le_less_trans [OF zero_le])
 apply (erule exE)
 apply (drule spec)
 apply (erule exE)
 apply (drule ileI1)
 apply (rule eSuc_enat [THEN subst])
 apply (rule exI)
 apply (erule (1) le_less_trans)
 done
 
 lemma eSuc_max: "eSuc (max x y) = max (eSuc x) (eSuc y)"
   by (simp add: eSuc_def split: enat.split)
 
 lemma eSuc_Max:
   assumes "finite A" "A \<noteq> {}"
   shows "eSuc (Max A) = Max (eSuc ` A)"
 using assms proof induction
   case (insert x A)
   thus ?case by(cases "A = {}")(simp_all add: eSuc_max)
 qed simp
 
 instantiation enat :: "{order_bot, order_top}"
 begin
 
 definition bot_enat :: enat where "bot_enat = 0"
 definition top_enat :: enat where "top_enat = \<infinity>"
 
 instance
   by standard (simp_all add: bot_enat_def top_enat_def)
 
 end
 
 lemma finite_enat_bounded:
   assumes le_fin: "\<And>y. y \<in> A \<Longrightarrow> y \<le> enat n"
   shows "finite A"
 proof (rule finite_subset)
   show "finite (enat ` {..n})" by blast
   have "A \<subseteq> {..enat n}" using le_fin by fastforce
   also have "\<dots> \<subseteq> enat ` {..n}"
     apply (rule subsetI)
     subgoal for x by (cases x) auto
     done
   finally show "A \<subseteq> enat ` {..n}" .
 qed
 
 
 subsection \<open>Cancellation simprocs\<close>
 
 lemma add_diff_cancel_enat[simp]: "x \<noteq> \<infinity> \<Longrightarrow> x + y - x = (y::enat)"
 by (metis add.commute add.right_neutral add_diff_assoc_enat idiff_self order_refl)
 
 lemma enat_add_left_cancel: "a + b = a + c \<longleftrightarrow> a = (\<infinity>::enat) \<or> b = c"
   unfolding plus_enat_def by (simp split: enat.split)
 
 lemma enat_add_left_cancel_le: "a + b \<le> a + c \<longleftrightarrow> a = (\<infinity>::enat) \<or> b \<le> c"
   unfolding plus_enat_def by (simp split: enat.split)
 
 lemma enat_add_left_cancel_less: "a + b < a + c \<longleftrightarrow> a \<noteq> (\<infinity>::enat) \<and> b < c"
   unfolding plus_enat_def by (simp split: enat.split)
 
 lemma plus_eq_infty_iff_enat: "(m::enat) + n = \<infinity> \<longleftrightarrow> m=\<infinity> \<or> n=\<infinity>"
 using enat_add_left_cancel by fastforce
 
 ML \<open>
 structure Cancel_Enat_Common =
 struct
   (* copied from src/HOL/Tools/nat_numeral_simprocs.ML *)
   fun find_first_t _    _ []         = raise TERM("find_first_t", [])
     | find_first_t past u (t::terms) =
           if u aconv t then (rev past @ terms)
           else find_first_t (t::past) u terms
 
   fun dest_summing (Const (\<^const_name>\<open>Groups.plus\<close>, _) $ t $ u, ts) =
         dest_summing (t, dest_summing (u, ts))
     | dest_summing (t, ts) = t :: ts
 
   val mk_sum = Arith_Data.long_mk_sum
   fun dest_sum t = dest_summing (t, [])
   val find_first = find_first_t []
   val trans_tac = Numeral_Simprocs.trans_tac
   val norm_ss =
     simpset_of (put_simpset HOL_basic_ss \<^context>
       addsimps @{thms ac_simps add_0_left add_0_right})
   fun norm_tac ctxt = ALLGOALS (simp_tac (put_simpset norm_ss ctxt))
   fun simplify_meta_eq ctxt cancel_th th =
     Arith_Data.simplify_meta_eq [] ctxt
       ([th, cancel_th] MRS trans)
   fun mk_eq (a, b) = HOLogic.mk_Trueprop (HOLogic.mk_eq (a, b))
 end
 
 structure Eq_Enat_Cancel = ExtractCommonTermFun
 (open Cancel_Enat_Common
   val mk_bal = HOLogic.mk_eq
   val dest_bal = HOLogic.dest_bin \<^const_name>\<open>HOL.eq\<close> \<^typ>\<open>enat\<close>
   fun simp_conv _ _ = SOME @{thm enat_add_left_cancel}
 )
 
 structure Le_Enat_Cancel = ExtractCommonTermFun
 (open Cancel_Enat_Common
   val mk_bal = HOLogic.mk_binrel \<^const_name>\<open>Orderings.less_eq\<close>
   val dest_bal = HOLogic.dest_bin \<^const_name>\<open>Orderings.less_eq\<close> \<^typ>\<open>enat\<close>
   fun simp_conv _ _ = SOME @{thm enat_add_left_cancel_le}
 )
 
 structure Less_Enat_Cancel = ExtractCommonTermFun
 (open Cancel_Enat_Common
   val mk_bal = HOLogic.mk_binrel \<^const_name>\<open>Orderings.less\<close>
   val dest_bal = HOLogic.dest_bin \<^const_name>\<open>Orderings.less\<close> \<^typ>\<open>enat\<close>
   fun simp_conv _ _ = SOME @{thm enat_add_left_cancel_less}
 )
 \<close>
 
 simproc_setup enat_eq_cancel
   ("(l::enat) + m = n" | "(l::enat) = m + n") =
-  \<open>fn phi => fn ctxt => fn ct => Eq_Enat_Cancel.proc ctxt (Thm.term_of ct)\<close>
+  \<open>K (fn ctxt => fn ct => Eq_Enat_Cancel.proc ctxt (Thm.term_of ct))\<close>
 
 simproc_setup enat_le_cancel
   ("(l::enat) + m \<le> n" | "(l::enat) \<le> m + n") =
-  \<open>fn phi => fn ctxt => fn ct => Le_Enat_Cancel.proc ctxt (Thm.term_of ct)\<close>
+  \<open>K (fn ctxt => fn ct => Le_Enat_Cancel.proc ctxt (Thm.term_of ct))\<close>
 
 simproc_setup enat_less_cancel
   ("(l::enat) + m < n" | "(l::enat) < m + n") =
-  \<open>fn phi => fn ctxt => fn ct => Less_Enat_Cancel.proc ctxt (Thm.term_of ct)\<close>
+  \<open>K (fn ctxt => fn ct => Less_Enat_Cancel.proc ctxt (Thm.term_of ct))\<close>
 
 text \<open>TODO: add regression tests for these simprocs\<close>
 
 text \<open>TODO: add simprocs for combining and cancelling numerals\<close>
 
 subsection \<open>Well-ordering\<close>
 
 lemma less_enatE:
   "[| n < enat m; !!k. n = enat k ==> k < m ==> P |] ==> P"
 by (induct n) auto
 
 lemma less_infinityE:
   "[| n < \<infinity>; !!k. n = enat k ==> P |] ==> P"
 by (induct n) auto
 
 lemma enat_less_induct:
   assumes prem: "\<And>n. \<forall>m::enat. m < n \<longrightarrow> P m \<Longrightarrow> P n" shows "P n"
 proof -
   have P_enat: "\<And>k. P (enat k)"
     apply (rule nat_less_induct)
     apply (rule prem, clarify)
     apply (erule less_enatE, simp)
     done
   show ?thesis
   proof (induct n)
     fix nat
     show "P (enat nat)" by (rule P_enat)
   next
     show "P \<infinity>"
       apply (rule prem, clarify)
       apply (erule less_infinityE)
       apply (simp add: P_enat)
       done
   qed
 qed
 
 instance enat :: wellorder
 proof
   fix P and n
   assume hyp: "(\<And>n::enat. (\<And>m::enat. m < n \<Longrightarrow> P m) \<Longrightarrow> P n)"
   show "P n" by (blast intro: enat_less_induct hyp)
 qed
 
 subsection \<open>Complete Lattice\<close>
 
 instantiation enat :: complete_lattice
 begin
 
 definition inf_enat :: "enat \<Rightarrow> enat \<Rightarrow> enat" where
   "inf_enat = min"
 
 definition sup_enat :: "enat \<Rightarrow> enat \<Rightarrow> enat" where
   "sup_enat = max"
 
 definition Inf_enat :: "enat set \<Rightarrow> enat" where
   "Inf_enat A = (if A = {} then \<infinity> else (LEAST x. x \<in> A))"
 
 definition Sup_enat :: "enat set \<Rightarrow> enat" where
   "Sup_enat A = (if A = {} then 0 else if finite A then Max A else \<infinity>)"
 instance
 proof
   fix x :: "enat" and A :: "enat set"
   { assume "x \<in> A" then show "Inf A \<le> x"
       unfolding Inf_enat_def by (auto intro: Least_le) }
   { assume "\<And>y. y \<in> A \<Longrightarrow> x \<le> y" then show "x \<le> Inf A"
       unfolding Inf_enat_def
       by (cases "A = {}") (auto intro: LeastI2_ex) }
   { assume "x \<in> A" then show "x \<le> Sup A"
       unfolding Sup_enat_def by (cases "finite A") auto }
   { assume "\<And>y. y \<in> A \<Longrightarrow> y \<le> x" then show "Sup A \<le> x"
       unfolding Sup_enat_def using finite_enat_bounded by auto }
 qed (simp_all add:
  inf_enat_def sup_enat_def bot_enat_def top_enat_def Inf_enat_def Sup_enat_def)
 end
 
 instance enat :: complete_linorder ..
 
 lemma eSuc_Sup: "A \<noteq> {} \<Longrightarrow> eSuc (Sup A) = Sup (eSuc ` A)"
   by(auto simp add: Sup_enat_def eSuc_Max inj_on_def dest: finite_imageD)
 
 lemma sup_continuous_eSuc: "sup_continuous f \<Longrightarrow> sup_continuous (\<lambda>x. eSuc (f x))"
   using eSuc_Sup [of "_ ` UNIV"] by (auto simp: sup_continuous_def image_comp)
 
 
 subsection \<open>Traditional theorem names\<close>
 
 lemmas enat_defs = zero_enat_def one_enat_def eSuc_def
   plus_enat_def less_eq_enat_def less_enat_def
 
 lemma iadd_is_0: "(m + n = (0::enat)) = (m = 0 \<and> n = 0)"
   by (rule add_eq_0_iff_both_eq_0)
 
 lemma i0_lb : "(0::enat) \<le> n"
   by (rule zero_le)
 
 lemma ile0_eq: "n \<le> (0::enat) \<longleftrightarrow> n = 0"
   by (rule le_zero_eq)
 
 lemma not_iless0: "\<not> n < (0::enat)"
   by (rule not_less_zero)
 
 lemma i0_less[simp]: "(0::enat) < n \<longleftrightarrow> n \<noteq> 0"
   by (rule zero_less_iff_neq_zero)
 
 lemma imult_is_0: "((m::enat) * n = 0) = (m = 0 \<or> n = 0)"
   by (rule mult_eq_0_iff)
 
 end
diff --git a/src/HOL/Library/Extended_Nonnegative_Real.thy b/src/HOL/Library/Extended_Nonnegative_Real.thy
--- a/src/HOL/Library/Extended_Nonnegative_Real.thy
+++ b/src/HOL/Library/Extended_Nonnegative_Real.thy
@@ -1,2047 +1,2047 @@
 (*  Title:      HOL/Library/Extended_Nonnegative_Real.thy
     Author:     Johannes Hölzl
 *)
 
 section \<open>The type of non-negative extended real numbers\<close>
 
 theory Extended_Nonnegative_Real
   imports Extended_Real Indicator_Function
 begin
 
 lemma ereal_ineq_diff_add:
   assumes "b \<noteq> (-\<infinity>::ereal)" "a \<ge> b"
   shows "a = b + (a-b)"
 by (metis add.commute assms ereal_eq_minus_iff ereal_minus_le_iff ereal_plus_eq_PInfty)
 
 lemma Limsup_const_add:
   fixes c :: "'a::{complete_linorder, linorder_topology, topological_monoid_add, ordered_ab_semigroup_add}"
   shows "F \<noteq> bot \<Longrightarrow> Limsup F (\<lambda>x. c + f x) = c + Limsup F f"
   by (rule Limsup_compose_continuous_mono)
      (auto intro!: monoI add_mono continuous_on_add continuous_on_id continuous_on_const)
 
 lemma Liminf_const_add:
   fixes c :: "'a::{complete_linorder, linorder_topology, topological_monoid_add, ordered_ab_semigroup_add}"
   shows "F \<noteq> bot \<Longrightarrow> Liminf F (\<lambda>x. c + f x) = c + Liminf F f"
   by (rule Liminf_compose_continuous_mono)
      (auto intro!: monoI add_mono continuous_on_add continuous_on_id continuous_on_const)
 
 lemma Liminf_add_const:
   fixes c :: "'a::{complete_linorder, linorder_topology, topological_monoid_add, ordered_ab_semigroup_add}"
   shows "F \<noteq> bot \<Longrightarrow> Liminf F (\<lambda>x. f x + c) = Liminf F f + c"
   by (rule Liminf_compose_continuous_mono)
      (auto intro!: monoI add_mono continuous_on_add continuous_on_id continuous_on_const)
 
 lemma sums_offset:
   fixes f g :: "nat \<Rightarrow> 'a :: {t2_space, topological_comm_monoid_add}"
   assumes "(\<lambda>n. f (n + i)) sums l" shows "f sums (l + (\<Sum>j<i. f j))"
 proof  -
   have "(\<lambda>k. (\<Sum>n<k. f (n + i)) + (\<Sum>j<i. f j)) \<longlonglongrightarrow> l + (\<Sum>j<i. f j)"
     using assms by (auto intro!: tendsto_add simp: sums_def)
   moreover
   { fix k :: nat
     have "(\<Sum>j<k + i. f j) = (\<Sum>j=i..<k + i. f j) + (\<Sum>j=0..<i. f j)"
       by (subst sum.union_disjoint[symmetric]) (auto intro!: sum.cong)
     also have "(\<Sum>j=i..<k + i. f j) = (\<Sum>j\<in>(\<lambda>n. n + i)`{0..<k}. f j)"
       unfolding image_add_atLeastLessThan by simp
     finally have "(\<Sum>j<k + i. f j) = (\<Sum>n<k. f (n + i)) + (\<Sum>j<i. f j)"
       by (auto simp: inj_on_def atLeast0LessThan sum.reindex) }
   ultimately have "(\<lambda>k. (\<Sum>n<k + i. f n)) \<longlonglongrightarrow> l + (\<Sum>j<i. f j)"
     by simp
   then show ?thesis
     unfolding sums_def by (rule LIMSEQ_offset)
 qed
 
 lemma suminf_offset:
   fixes f g :: "nat \<Rightarrow> 'a :: {t2_space, topological_comm_monoid_add}"
   shows "summable (\<lambda>j. f (j + i)) \<Longrightarrow> suminf f = (\<Sum>j. f (j + i)) + (\<Sum>j<i. f j)"
   by (intro sums_unique[symmetric] sums_offset summable_sums)
 
 lemma eventually_at_left_1: "(\<And>z::real. 0 < z \<Longrightarrow> z < 1 \<Longrightarrow> P z) \<Longrightarrow> eventually P (at_left 1)"
   by (subst eventually_at_left[of 0]) (auto intro: exI[of _ 0])
 
 lemma mult_eq_1:
   fixes a b :: "'a :: {ordered_semiring, comm_monoid_mult}"
   shows "0 \<le> a \<Longrightarrow> a \<le> 1 \<Longrightarrow> b \<le> 1 \<Longrightarrow> a * b = 1 \<longleftrightarrow> (a = 1 \<and> b = 1)"
   by (metis mult.left_neutral eq_iff mult.commute mult_right_mono)
 
 lemma ereal_add_diff_cancel:
   fixes a b :: ereal
   shows "\<bar>b\<bar> \<noteq> \<infinity> \<Longrightarrow> (a + b) - b = a"
   by (cases a b rule: ereal2_cases) auto
 
 lemma add_top:
   fixes x :: "'a::{order_top, ordered_comm_monoid_add}"
   shows "0 \<le> x \<Longrightarrow> x + top = top"
   by (intro top_le add_increasing order_refl)
 
 lemma top_add:
   fixes x :: "'a::{order_top, ordered_comm_monoid_add}"
   shows "0 \<le> x \<Longrightarrow> top + x = top"
   by (intro top_le add_increasing2 order_refl)
 
 lemma le_lfp: "mono f \<Longrightarrow> x \<le> lfp f \<Longrightarrow> f x \<le> lfp f"
   by (subst lfp_unfold) (auto dest: monoD)
 
 lemma lfp_transfer:
   assumes \<alpha>: "sup_continuous \<alpha>" and f: "sup_continuous f" and mg: "mono g"
   assumes bot: "\<alpha> bot \<le> lfp g" and eq: "\<And>x. x \<le> lfp f \<Longrightarrow> \<alpha> (f x) = g (\<alpha> x)"
   shows "\<alpha> (lfp f) = lfp g"
 proof (rule antisym)
   note mf = sup_continuous_mono[OF f]
   have f_le_lfp: "(f ^^ i) bot \<le> lfp f" for i
     by (induction i) (auto intro: le_lfp mf)
 
   have "\<alpha> ((f ^^ i) bot) \<le> lfp g" for i
     by (induction i) (auto simp: bot eq f_le_lfp intro!: le_lfp mg)
   then show "\<alpha> (lfp f) \<le> lfp g"
     unfolding sup_continuous_lfp[OF f]
     by (subst \<alpha>[THEN sup_continuousD])
        (auto intro!: mono_funpow sup_continuous_mono[OF f] SUP_least)
 
   show "lfp g \<le> \<alpha> (lfp f)"
     by (rule lfp_lowerbound) (simp add: eq[symmetric] lfp_fixpoint[OF mf])
 qed
 
 lemma sup_continuous_applyD: "sup_continuous f \<Longrightarrow> sup_continuous (\<lambda>x. f x h)"
   using sup_continuous_apply[THEN sup_continuous_compose] .
 
 lemma sup_continuous_SUP[order_continuous_intros]:
   fixes M :: "_ \<Rightarrow> _ \<Rightarrow> 'a::complete_lattice"
   assumes M: "\<And>i. i \<in> I \<Longrightarrow> sup_continuous (M i)"
   shows  "sup_continuous (SUP i\<in>I. M i)"
   unfolding sup_continuous_def by (auto simp add: sup_continuousD [OF M] image_comp intro: SUP_commute)
 
 lemma sup_continuous_apply_SUP[order_continuous_intros]:
   fixes M :: "_ \<Rightarrow> _ \<Rightarrow> 'a::complete_lattice"
   shows "(\<And>i. i \<in> I \<Longrightarrow> sup_continuous (M i)) \<Longrightarrow> sup_continuous (\<lambda>x. SUP i\<in>I. M i x)"
   unfolding SUP_apply[symmetric] by (rule sup_continuous_SUP)
 
 lemma sup_continuous_lfp'[order_continuous_intros]:
   assumes 1: "sup_continuous f"
   assumes 2: "\<And>g. sup_continuous g \<Longrightarrow> sup_continuous (f g)"
   shows "sup_continuous (lfp f)"
 proof -
   have "sup_continuous ((f ^^ i) bot)" for i
   proof (induction i)
     case (Suc i) then show ?case
       by (auto intro!: 2)
   qed (simp add: bot_fun_def sup_continuous_const)
   then show ?thesis
     unfolding sup_continuous_lfp[OF 1] by (intro order_continuous_intros)
 qed
 
 lemma sup_continuous_lfp''[order_continuous_intros]:
   assumes 1: "\<And>s. sup_continuous (f s)"
   assumes 2: "\<And>g. sup_continuous g \<Longrightarrow> sup_continuous (\<lambda>s. f s (g s))"
   shows "sup_continuous (\<lambda>x. lfp (f x))"
 proof -
   have "sup_continuous (\<lambda>x. (f x ^^ i) bot)" for i
   proof (induction i)
     case (Suc i) then show ?case
       by (auto intro!: 2)
   qed (simp add: bot_fun_def sup_continuous_const)
   then show ?thesis
     unfolding sup_continuous_lfp[OF 1] by (intro order_continuous_intros)
 qed
 
 lemma mono_INF_fun:
     "(\<And>x y. mono (F x y)) \<Longrightarrow> mono (\<lambda>z x. INF y \<in> X x. F x y z :: 'a :: complete_lattice)"
   by (auto intro!: INF_mono[OF bexI] simp: le_fun_def mono_def)
 
 lemma continuous_on_cmult_ereal:
   "\<bar>c::ereal\<bar> \<noteq> \<infinity> \<Longrightarrow> continuous_on A f \<Longrightarrow> continuous_on A (\<lambda>x. c * f x)"
   using tendsto_cmult_ereal[of c f "f x" "at x within A" for x]
   by (auto simp: continuous_on_def simp del: tendsto_cmult_ereal)
 
 lemma real_of_nat_Sup:
   assumes "A \<noteq> {}" "bdd_above A"
   shows "of_nat (Sup A) = (SUP a\<in>A. of_nat a :: real)"
 proof (intro antisym)
   show "(SUP a\<in>A. of_nat a::real) \<le> of_nat (Sup A)"
     using assms by (intro cSUP_least of_nat_mono) (auto intro: cSup_upper)
   have "Sup A \<in> A"
     using assms by (auto simp: Sup_nat_def bdd_above_nat)
   then show "of_nat (Sup A) \<le> (SUP a\<in>A. of_nat a::real)"
     by (intro cSUP_upper bdd_above_image_mono assms) (auto simp: mono_def)
 qed
 
 lemma (in complete_lattice) SUP_sup_const1:
   "I \<noteq> {} \<Longrightarrow> (SUP i\<in>I. sup c (f i)) = sup c (SUP i\<in>I. f i)"
   using SUP_sup_distrib[of "\<lambda>_. c" I f] by simp
 
 lemma (in complete_lattice) SUP_sup_const2:
   "I \<noteq> {} \<Longrightarrow> (SUP i\<in>I. sup (f i) c) = sup (SUP i\<in>I. f i) c"
   using SUP_sup_distrib[of f I "\<lambda>_. c"] by simp
 
 lemma one_less_of_natD:
   assumes "(1::'a::linordered_semidom) < of_nat n" shows "1 < n"
   by (cases n) (use assms in auto)
 
 subsection \<open>Defining the extended non-negative reals\<close>
 
 text \<open>Basic definitions and type class setup\<close>
 
 typedef ennreal = "{x :: ereal. 0 \<le> x}"
   morphisms enn2ereal e2ennreal'
   by auto
 
 definition "e2ennreal x = e2ennreal' (max 0 x)"
 
 lemma enn2ereal_range: "e2ennreal ` {0..} = UNIV"
 proof -
   have "\<exists>y\<ge>0. x = e2ennreal y" for x
     by (cases x) (auto simp: e2ennreal_def max_absorb2)
   then show ?thesis
     by (auto simp: image_iff Bex_def)
 qed
 
 lemma type_definition_ennreal': "type_definition enn2ereal e2ennreal {x. 0 \<le> x}"
   using type_definition_ennreal
   by (auto simp: type_definition_def e2ennreal_def max_absorb2)
 
 setup_lifting type_definition_ennreal'
 
 declare [[coercion e2ennreal]]
 
 instantiation ennreal :: complete_linorder
 begin
 
 lift_definition top_ennreal :: ennreal is top by (rule top_greatest)
 lift_definition bot_ennreal :: ennreal is 0 by (rule order_refl)
 lift_definition sup_ennreal :: "ennreal \<Rightarrow> ennreal \<Rightarrow> ennreal" is sup by (rule le_supI1)
 lift_definition inf_ennreal :: "ennreal \<Rightarrow> ennreal \<Rightarrow> ennreal" is inf by (rule le_infI)
 
 lift_definition Inf_ennreal :: "ennreal set \<Rightarrow> ennreal" is "Inf"
   by (rule Inf_greatest)
 
 lift_definition Sup_ennreal :: "ennreal set \<Rightarrow> ennreal" is "sup 0 \<circ> Sup"
   by auto
 
 lift_definition less_eq_ennreal :: "ennreal \<Rightarrow> ennreal \<Rightarrow> bool" is "(\<le>)" .
 lift_definition less_ennreal :: "ennreal \<Rightarrow> ennreal \<Rightarrow> bool" is "(<)" .
 
 instance
   by standard
      (transfer ; auto simp: Inf_lower Inf_greatest Sup_upper Sup_least le_max_iff_disj max.absorb1)+
 
 end
 
 lemma pcr_ennreal_enn2ereal[simp]: "pcr_ennreal (enn2ereal x) x"
   by (simp add: ennreal.pcr_cr_eq cr_ennreal_def)
 
 lemma rel_fun_eq_pcr_ennreal: "rel_fun (=) pcr_ennreal f g \<longleftrightarrow> f = enn2ereal \<circ> g"
   by (auto simp: rel_fun_def ennreal.pcr_cr_eq cr_ennreal_def)
 
 instantiation ennreal :: infinity
 begin
 
 definition infinity_ennreal :: ennreal
 where
   [simp]: "\<infinity> = (top::ennreal)"
 
 instance ..
 
 end
 
 instantiation ennreal :: "{semiring_1_no_zero_divisors, comm_semiring_1}"
 begin
 
 lift_definition one_ennreal :: ennreal is 1 by simp
 lift_definition zero_ennreal :: ennreal is 0 by simp
 lift_definition plus_ennreal :: "ennreal \<Rightarrow> ennreal \<Rightarrow> ennreal" is "(+)" by simp
 lift_definition times_ennreal :: "ennreal \<Rightarrow> ennreal \<Rightarrow> ennreal" is "(*)" by simp
 
 instance
   by standard (transfer; auto simp: field_simps ereal_right_distrib)+
 
 end
 
 instantiation ennreal :: minus
 begin
 
 lift_definition minus_ennreal :: "ennreal \<Rightarrow> ennreal \<Rightarrow> ennreal" is "\<lambda>a b. max 0 (a - b)"
   by simp
 
 instance ..
 
 end
 
 instance ennreal :: numeral ..
 
 instantiation ennreal :: inverse
 begin
 
 lift_definition inverse_ennreal :: "ennreal \<Rightarrow> ennreal" is inverse
   by (rule inverse_ereal_ge0I)
 
 definition divide_ennreal :: "ennreal \<Rightarrow> ennreal \<Rightarrow> ennreal"
   where "x div y = x * inverse (y :: ennreal)"
 
 instance ..
 
 end
 
 lemma ennreal_zero_less_one: "0 < (1::ennreal)" \<comment> \<open>TODO: remove\<close>
   by transfer auto
 
 instance ennreal :: dioid
 proof (standard; transfer)
   fix a b :: ereal assume "0 \<le> a" "0 \<le> b" then show "(a \<le> b) = (\<exists>c\<in>Collect ((\<le>) 0). b = a + c)"
     unfolding ereal_ex_split Bex_def
     by (cases a b rule: ereal2_cases) (auto intro!: exI[of _ "real_of_ereal (b - a)"])
 qed
 
 instance ennreal :: ordered_comm_semiring
   by standard
      (transfer ; auto intro: add_mono mult_mono mult_ac ereal_left_distrib ereal_mult_left_mono)+
 
 instance ennreal :: linordered_nonzero_semiring
 proof
   fix a b::ennreal
   show "a < b \<Longrightarrow> a + 1 < b + 1"
     by transfer (simp add: add_right_mono ereal_add_cancel_right less_le)
 qed (transfer; simp)
 
 instance ennreal :: strict_ordered_ab_semigroup_add
 proof
   fix a b c d :: ennreal show "a < b \<Longrightarrow> c < d \<Longrightarrow> a + c < b + d"
     by transfer (auto intro!: ereal_add_strict_mono)
 qed
 
 declare [[coercion "of_nat :: nat \<Rightarrow> ennreal"]]
 
 lemma e2ennreal_neg: "x \<le> 0 \<Longrightarrow> e2ennreal x = 0"
   unfolding zero_ennreal_def e2ennreal_def by (simp add: max_absorb1)
 
 lemma e2ennreal_mono: "x \<le> y \<Longrightarrow> e2ennreal x \<le> e2ennreal y"
   by (cases "0 \<le> x" "0 \<le> y" rule: bool.exhaust[case_product bool.exhaust])
      (auto simp: e2ennreal_neg less_eq_ennreal.abs_eq eq_onp_def)
 
 lemma enn2ereal_nonneg[simp]: "0 \<le> enn2ereal x"
   using ennreal.enn2ereal[of x] by simp
 
 lemma ereal_ennreal_cases:
   obtains b where "0 \<le> a" "a = enn2ereal b" | "a < 0"
   using e2ennreal'_inverse[of a, symmetric] by (cases "0 \<le> a") (auto intro: enn2ereal_nonneg)
 
 lemma rel_fun_liminf[transfer_rule]: "rel_fun (rel_fun (=) pcr_ennreal) pcr_ennreal liminf liminf"
 proof -
   have "rel_fun (rel_fun (=) pcr_ennreal) pcr_ennreal (\<lambda>x. sup 0 (liminf x)) liminf"
     unfolding liminf_SUP_INF[abs_def] by (transfer_prover_start, transfer_step+; simp)
   then show ?thesis
     apply (subst (asm) (2) rel_fun_def)
     apply (subst (2) rel_fun_def)
     apply (auto simp: comp_def max.absorb2 Liminf_bounded rel_fun_eq_pcr_ennreal)
     done
 qed
 
 lemma rel_fun_limsup[transfer_rule]: "rel_fun (rel_fun (=) pcr_ennreal) pcr_ennreal limsup limsup"
 proof -
   have "rel_fun (rel_fun (=) pcr_ennreal) pcr_ennreal (\<lambda>x. INF n. sup 0 (SUP i\<in>{n..}. x i)) limsup"
     unfolding limsup_INF_SUP[abs_def] by (transfer_prover_start, transfer_step+; simp)
   then show ?thesis
     unfolding limsup_INF_SUP[abs_def]
     apply (subst (asm) (2) rel_fun_def)
     apply (subst (2) rel_fun_def)
     apply (auto simp: comp_def max.absorb2 Sup_upper2 rel_fun_eq_pcr_ennreal)
     apply (subst (asm) max.absorb2)
     apply (auto intro: SUP_upper2)
     done
 qed
 
 lemma sum_enn2ereal[simp]: "(\<And>i. i \<in> I \<Longrightarrow> 0 \<le> f i) \<Longrightarrow> (\<Sum>i\<in>I. enn2ereal (f i)) = enn2ereal (sum f I)"
   by (induction I rule: infinite_finite_induct) (auto simp: sum_nonneg zero_ennreal.rep_eq plus_ennreal.rep_eq)
 
 lemma transfer_e2ennreal_sum [transfer_rule]:
   "rel_fun (rel_fun (=) pcr_ennreal) (rel_fun (=) pcr_ennreal) sum sum"
   by (auto intro!: rel_funI simp: rel_fun_eq_pcr_ennreal comp_def)
 
 lemma enn2ereal_of_nat[simp]: "enn2ereal (of_nat n) = ereal n"
   by (induction n) (auto simp: zero_ennreal.rep_eq one_ennreal.rep_eq plus_ennreal.rep_eq)
 
 lemma enn2ereal_numeral[simp]: "enn2ereal (numeral a) = numeral a"
   by (metis enn2ereal_of_nat numeral_eq_ereal of_nat_numeral)
 
 lemma transfer_numeral[transfer_rule]: "pcr_ennreal (numeral a) (numeral a)"
   unfolding cr_ennreal_def pcr_ennreal_def by auto
 
 subsection \<open>Cancellation simprocs\<close>
 
 lemma ennreal_add_left_cancel: "a + b = a + c \<longleftrightarrow> a = (\<infinity>::ennreal) \<or> b = c"
   unfolding infinity_ennreal_def by transfer (simp add: top_ereal_def ereal_add_cancel_left)
 
 lemma ennreal_add_left_cancel_le: "a + b \<le> a + c \<longleftrightarrow> a = (\<infinity>::ennreal) \<or> b \<le> c"
   unfolding infinity_ennreal_def by transfer (simp add: ereal_add_le_add_iff top_ereal_def disj_commute)
 
 lemma ereal_add_left_cancel_less:
   fixes a b c :: ereal
   shows "0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> a + b < a + c \<longleftrightarrow> a \<noteq> \<infinity> \<and> b < c"
   by (cases a b c rule: ereal3_cases) auto
 
 lemma ennreal_add_left_cancel_less: "a + b < a + c \<longleftrightarrow> a \<noteq> (\<infinity>::ennreal) \<and> b < c"
   unfolding infinity_ennreal_def
   by transfer (simp add: top_ereal_def ereal_add_left_cancel_less)
 
 ML \<open>
 structure Cancel_Ennreal_Common =
 struct
   (* copied from src/HOL/Tools/nat_numeral_simprocs.ML *)
   fun find_first_t _    _ []         = raise TERM("find_first_t", [])
     | find_first_t past u (t::terms) =
           if u aconv t then (rev past @ terms)
           else find_first_t (t::past) u terms
 
   fun dest_summing (Const (\<^const_name>\<open>Groups.plus\<close>, _) $ t $ u, ts) =
         dest_summing (t, dest_summing (u, ts))
     | dest_summing (t, ts) = t :: ts
 
   val mk_sum = Arith_Data.long_mk_sum
   fun dest_sum t = dest_summing (t, [])
   val find_first = find_first_t []
   val trans_tac = Numeral_Simprocs.trans_tac
   val norm_ss =
     simpset_of (put_simpset HOL_basic_ss \<^context>
       addsimps @{thms ac_simps add_0_left add_0_right})
   fun norm_tac ctxt = ALLGOALS (simp_tac (put_simpset norm_ss ctxt))
   fun simplify_meta_eq ctxt cancel_th th =
     Arith_Data.simplify_meta_eq [] ctxt
       ([th, cancel_th] MRS trans)
   fun mk_eq (a, b) = HOLogic.mk_Trueprop (HOLogic.mk_eq (a, b))
 end
 
 structure Eq_Ennreal_Cancel = ExtractCommonTermFun
 (open Cancel_Ennreal_Common
   val mk_bal = HOLogic.mk_eq
   val dest_bal = HOLogic.dest_bin \<^const_name>\<open>HOL.eq\<close> \<^typ>\<open>ennreal\<close>
   fun simp_conv _ _ = SOME @{thm ennreal_add_left_cancel}
 )
 
 structure Le_Ennreal_Cancel = ExtractCommonTermFun
 (open Cancel_Ennreal_Common
   val mk_bal = HOLogic.mk_binrel \<^const_name>\<open>Orderings.less_eq\<close>
   val dest_bal = HOLogic.dest_bin \<^const_name>\<open>Orderings.less_eq\<close> \<^typ>\<open>ennreal\<close>
   fun simp_conv _ _ = SOME @{thm ennreal_add_left_cancel_le}
 )
 
 structure Less_Ennreal_Cancel = ExtractCommonTermFun
 (open Cancel_Ennreal_Common
   val mk_bal = HOLogic.mk_binrel \<^const_name>\<open>Orderings.less\<close>
   val dest_bal = HOLogic.dest_bin \<^const_name>\<open>Orderings.less\<close> \<^typ>\<open>ennreal\<close>
   fun simp_conv _ _ = SOME @{thm ennreal_add_left_cancel_less}
 )
 \<close>
 
 simproc_setup ennreal_eq_cancel
   ("(l::ennreal) + m = n" | "(l::ennreal) = m + n") =
-  \<open>fn phi => fn ctxt => fn ct => Eq_Ennreal_Cancel.proc ctxt (Thm.term_of ct)\<close>
+  \<open>K (fn ctxt => fn ct => Eq_Ennreal_Cancel.proc ctxt (Thm.term_of ct))\<close>
 
 simproc_setup ennreal_le_cancel
   ("(l::ennreal) + m \<le> n" | "(l::ennreal) \<le> m + n") =
-  \<open>fn phi => fn ctxt => fn ct => Le_Ennreal_Cancel.proc ctxt (Thm.term_of ct)\<close>
+  \<open>K (fn ctxt => fn ct => Le_Ennreal_Cancel.proc ctxt (Thm.term_of ct))\<close>
 
 simproc_setup ennreal_less_cancel
   ("(l::ennreal) + m < n" | "(l::ennreal) < m + n") =
-  \<open>fn phi => fn ctxt => fn ct => Less_Ennreal_Cancel.proc ctxt (Thm.term_of ct)\<close>
+  \<open>K (fn ctxt => fn ct => Less_Ennreal_Cancel.proc ctxt (Thm.term_of ct))\<close>
 
 
 subsection \<open>Order with top\<close>
 
 lemma ennreal_zero_less_top[simp]: "0 < (top::ennreal)"
   by transfer (simp add: top_ereal_def)
 
 lemma ennreal_one_less_top[simp]: "1 < (top::ennreal)"
   by transfer (simp add: top_ereal_def)
 
 lemma ennreal_zero_neq_top[simp]: "0 \<noteq> (top::ennreal)"
   by transfer (simp add: top_ereal_def)
 
 lemma ennreal_top_neq_zero[simp]: "(top::ennreal) \<noteq> 0"
   by transfer (simp add: top_ereal_def)
 
 lemma ennreal_top_neq_one[simp]: "top \<noteq> (1::ennreal)"
   by transfer (simp add: top_ereal_def one_ereal_def flip: ereal_max)
 
 lemma ennreal_one_neq_top[simp]: "1 \<noteq> (top::ennreal)"
   by transfer (simp add: top_ereal_def one_ereal_def flip: ereal_max)
 
 lemma ennreal_add_less_top[simp]:
   fixes a b :: ennreal
   shows "a + b < top \<longleftrightarrow> a < top \<and> b < top"
   by transfer (auto simp: top_ereal_def)
 
 lemma ennreal_add_eq_top[simp]:
   fixes a b :: ennreal
   shows "a + b = top \<longleftrightarrow> a = top \<or> b = top"
   by transfer (auto simp: top_ereal_def)
 
 lemma ennreal_sum_less_top[simp]:
   fixes f :: "'a \<Rightarrow> ennreal"
   shows "finite I \<Longrightarrow> (\<Sum>i\<in>I. f i) < top \<longleftrightarrow> (\<forall>i\<in>I. f i < top)"
   by (induction I rule: finite_induct) auto
 
 lemma ennreal_sum_eq_top[simp]:
   fixes f :: "'a \<Rightarrow> ennreal"
   shows "finite I \<Longrightarrow> (\<Sum>i\<in>I. f i) = top \<longleftrightarrow> (\<exists>i\<in>I. f i = top)"
   by (induction I rule: finite_induct) auto
 
 lemma ennreal_mult_eq_top_iff:
   fixes a b :: ennreal
   shows "a * b = top \<longleftrightarrow> (a = top \<and> b \<noteq> 0) \<or> (b = top \<and> a \<noteq> 0)"
   by transfer (auto simp: top_ereal_def)
 
 lemma ennreal_top_eq_mult_iff:
   fixes a b :: ennreal
   shows "top = a * b \<longleftrightarrow> (a = top \<and> b \<noteq> 0) \<or> (b = top \<and> a \<noteq> 0)"
   using ennreal_mult_eq_top_iff[of a b] by auto
 
 lemma ennreal_mult_less_top:
   fixes a b :: ennreal
   shows "a * b < top \<longleftrightarrow> (a = 0 \<or> b = 0 \<or> (a < top \<and> b < top))"
   by transfer (auto simp add: top_ereal_def)
 
 lemma top_power_ennreal: "top ^ n = (if n = 0 then 1 else top :: ennreal)"
   by (induction n) (simp_all add: ennreal_mult_eq_top_iff)
 
 lemma ennreal_prod_eq_0[simp]:
   fixes f :: "'a \<Rightarrow> ennreal"
   shows "(prod f A = 0) = (finite A \<and> (\<exists>i\<in>A. f i = 0))"
   by (induction A rule: infinite_finite_induct) auto
 
 lemma ennreal_prod_eq_top:
   fixes f :: "'a \<Rightarrow> ennreal"
   shows "(\<Prod>i\<in>I. f i) = top \<longleftrightarrow> (finite I \<and> ((\<forall>i\<in>I. f i \<noteq> 0) \<and> (\<exists>i\<in>I. f i = top)))"
   by (induction I rule: infinite_finite_induct) (auto simp: ennreal_mult_eq_top_iff)
 
 lemma ennreal_top_mult: "top * a = (if a = 0 then 0 else top :: ennreal)"
   by (simp add: ennreal_mult_eq_top_iff)
 
 lemma ennreal_mult_top: "a * top = (if a = 0 then 0 else top :: ennreal)"
   by (simp add: ennreal_mult_eq_top_iff)
 
 lemma enn2ereal_eq_top_iff[simp]: "enn2ereal x = \<infinity> \<longleftrightarrow> x = top"
   by transfer (simp add: top_ereal_def)
 
 lemma enn2ereal_top[simp]: "enn2ereal top = \<infinity>"
   by transfer (simp add: top_ereal_def)
 
 lemma e2ennreal_infty[simp]: "e2ennreal \<infinity> = top"
   by (simp add: top_ennreal.abs_eq top_ereal_def)
 
 lemma ennreal_top_minus[simp]: "top - x = (top::ennreal)"
   by transfer (auto simp: top_ereal_def max_def)
 
 lemma minus_top_ennreal: "x - top = (if x = top then top else 0:: ennreal)"
   by transfer (use ereal_eq_minus_iff top_ereal_def in force)
 
 lemma bot_ennreal: "bot = (0::ennreal)"
   by transfer rule
 
 lemma ennreal_of_nat_neq_top[simp]: "of_nat i \<noteq> (top::ennreal)"
   by (induction i) auto
 
 lemma numeral_eq_of_nat: "(numeral a::ennreal) = of_nat (numeral a)"
   by simp
 
 lemma of_nat_less_top: "of_nat i < (top::ennreal)"
   using less_le_trans[of "of_nat i" "of_nat (Suc i)" "top::ennreal"]
   by simp
 
 lemma top_neq_numeral[simp]: "top \<noteq> (numeral i::ennreal)"
   using of_nat_less_top[of "numeral i"] by simp
 
 lemma ennreal_numeral_less_top[simp]: "numeral i < (top::ennreal)"
   using of_nat_less_top[of "numeral i"] by simp
 
 lemma ennreal_add_bot[simp]: "bot + x = (x::ennreal)"
   by transfer simp
 
 lemma add_top_right_ennreal [simp]: "x + top = (top :: ennreal)"
   by (cases x) auto
 
 lemma add_top_left_ennreal [simp]: "top + x = (top :: ennreal)"
   by (cases x) auto
 
 lemma ennreal_top_mult_left [simp]: "x \<noteq> 0 \<Longrightarrow> x * top = (top :: ennreal)"
   by (subst ennreal_mult_eq_top_iff) auto
 
 lemma ennreal_top_mult_right [simp]: "x \<noteq> 0 \<Longrightarrow> top * x = (top :: ennreal)"
   by (subst ennreal_mult_eq_top_iff) auto
 
 
 lemma power_top_ennreal [simp]: "n > 0 \<Longrightarrow> top ^ n = (top :: ennreal)"
   by (induction n) auto
 
 lemma power_eq_top_ennreal_iff: "x ^ n = top \<longleftrightarrow> x = (top :: ennreal) \<and> n > 0"
   by (induction n) (auto simp: ennreal_mult_eq_top_iff)
 
 lemma ennreal_mult_le_mult_iff: "c \<noteq> 0 \<Longrightarrow> c \<noteq> top \<Longrightarrow> c * a \<le> c * b \<longleftrightarrow> a \<le> (b :: ennreal)"
   including ennreal.lifting
   by (transfer, subst ereal_mult_le_mult_iff) (auto simp: top_ereal_def)
 
 lemma power_mono_ennreal: "x \<le> y \<Longrightarrow> x ^ n \<le> (y ^ n :: ennreal)"
   by (induction n) (auto intro!: mult_mono)
 
 instance ennreal :: semiring_char_0
 proof (standard, safe intro!: linorder_injI)
   have *: "1 + of_nat k \<noteq> (0::ennreal)" for k
     using add_pos_nonneg[OF zero_less_one, of "of_nat k :: ennreal"] by auto
   fix x y :: nat assume "x < y" "of_nat x = (of_nat y::ennreal)" then show False
     by (auto simp add: less_iff_Suc_add *)
 qed
 
 subsection \<open>Arithmetic\<close>
 
 lemma ennreal_minus_zero[simp]: "a - (0::ennreal) = a"
   by transfer (auto simp: max_def)
 
 lemma ennreal_add_diff_cancel_right[simp]:
   fixes x y z :: ennreal shows "y \<noteq> top \<Longrightarrow> (x + y) - y = x"
   by transfer (metis ereal_eq_minus_iff max_absorb2 not_MInfty_nonneg top_ereal_def)
 
 lemma ennreal_add_diff_cancel_left[simp]:
   fixes x y z :: ennreal shows "y \<noteq> top \<Longrightarrow> (y + x) - y = x"
   by (simp add: add.commute)
 
 lemma
   fixes a b :: ennreal
   shows "a - b = 0 \<Longrightarrow> a \<le> b"
   by transfer (metis ereal_diff_gr0 le_cases max.absorb2 not_less)
 
 lemma ennreal_minus_cancel:
   fixes a b c :: ennreal
   shows "c \<noteq> top \<Longrightarrow> a \<le> c \<Longrightarrow> b \<le> c \<Longrightarrow> c - a = c - b \<Longrightarrow> a = b"
   by (metis ennreal_add_diff_cancel_left ennreal_add_diff_cancel_right ennreal_add_eq_top less_eqE)
 
 lemma sup_const_add_ennreal:
   fixes a b c :: "ennreal"
   shows "sup (c + a) (c + b) = c + sup a b"
   by transfer (metis add_left_mono le_cases sup.absorb2 sup.orderE)
 
 lemma ennreal_diff_add_assoc:
   fixes a b c :: ennreal
   shows "a \<le> b \<Longrightarrow> c + b - a = c + (b - a)"
   by (metis add.left_commute ennreal_add_diff_cancel_left ennreal_add_eq_top ennreal_top_minus less_eqE)
 
 lemma mult_divide_eq_ennreal:
   fixes a b :: ennreal
   shows "b \<noteq> 0 \<Longrightarrow> b \<noteq> top \<Longrightarrow> (a * b) / b = a"
   unfolding divide_ennreal_def
   apply transfer
   by (metis abs_ereal_ge0 divide_ereal_def ereal_divide_eq ereal_times_divide_eq top_ereal_def)
 
 lemma divide_mult_eq: "a \<noteq> 0 \<Longrightarrow> a \<noteq> \<infinity> \<Longrightarrow> x * a / (b * a) = x / (b::ennreal)"
   unfolding divide_ennreal_def infinity_ennreal_def
   apply transfer
   subgoal for a b c
     apply (cases a b c rule: ereal3_cases)
     apply (auto simp: top_ereal_def)
     done
   done
 
 lemma ennreal_mult_divide_eq:
   fixes a b :: ennreal
   shows "b \<noteq> 0 \<Longrightarrow> b \<noteq> top \<Longrightarrow> (a * b) / b = a"
   by (fact mult_divide_eq_ennreal)
 
 lemma ennreal_add_diff_cancel:
   fixes a b :: ennreal
   shows "b \<noteq> \<infinity> \<Longrightarrow> (a + b) - b = a"
   by simp
 
 lemma ennreal_minus_eq_0:
   "a - b = 0 \<Longrightarrow> a \<le> (b::ennreal)"
   by transfer (metis ereal_diff_gr0 le_cases max.absorb2 not_less)
 
 lemma ennreal_mono_minus_cancel:
   fixes a b c :: ennreal
   shows "a - b \<le> a - c \<Longrightarrow> a < top \<Longrightarrow> b \<le> a \<Longrightarrow> c \<le> a \<Longrightarrow> c \<le> b"
   by transfer
      (auto simp add: max.absorb2 ereal_diff_positive top_ereal_def dest: ereal_mono_minus_cancel)
 
 lemma ennreal_mono_minus:
   fixes a b c :: ennreal
   shows "c \<le> b \<Longrightarrow> a - b \<le> a - c"
   by transfer (meson ereal_minus_mono max.mono order_refl)
 
 lemma ennreal_minus_pos_iff:
   fixes a b :: ennreal
   shows "a < top \<or> b < top \<Longrightarrow> 0 < a - b \<Longrightarrow> b < a"
   by transfer (use add.left_neutral ereal_minus_le_iff less_irrefl not_less in fastforce)
 
 lemma ennreal_inverse_top[simp]: "inverse top = (0::ennreal)"
   by transfer (simp add: top_ereal_def ereal_inverse_eq_0)
 
 lemma ennreal_inverse_zero[simp]: "inverse 0 = (top::ennreal)"
   by transfer (simp add: top_ereal_def ereal_inverse_eq_0)
 
 lemma ennreal_top_divide: "top / (x::ennreal) = (if x = top then 0 else top)"
   unfolding divide_ennreal_def
   by transfer (simp add: top_ereal_def ereal_inverse_eq_0 ereal_0_gt_inverse)
 
 lemma ennreal_zero_divide[simp]: "0 / (x::ennreal) = 0"
   by (simp add: divide_ennreal_def)
 
 lemma ennreal_divide_zero[simp]: "x / (0::ennreal) = (if x = 0 then 0 else top)"
   by (simp add: divide_ennreal_def ennreal_mult_top)
 
 lemma ennreal_divide_top[simp]: "x / (top::ennreal) = 0"
   by (simp add: divide_ennreal_def ennreal_top_mult)
 
 lemma ennreal_times_divide: "a * (b / c) = a * b / (c::ennreal)"
   unfolding divide_ennreal_def
   by transfer (simp add: divide_ereal_def[symmetric] ereal_times_divide_eq)
 
 lemma ennreal_zero_less_divide: "0 < a / b \<longleftrightarrow> (0 < a \<and> b < (top::ennreal))"
   unfolding divide_ennreal_def
   by transfer (auto simp: ereal_zero_less_0_iff top_ereal_def ereal_0_gt_inverse)
 
 lemma add_divide_distrib_ennreal: "(a + b) / c = a / c + b / (c :: ennreal)"
   by (simp add: divide_ennreal_def ring_distribs)
 
 lemma divide_right_mono_ennreal:
   fixes a b c :: ennreal
   shows "a \<le> b \<Longrightarrow> a / c \<le> b / c"
   unfolding divide_ennreal_def by (intro mult_mono) auto
 
 lemma ennreal_mult_strict_right_mono: "(a::ennreal) < c \<Longrightarrow> 0 < b \<Longrightarrow> b < top \<Longrightarrow> a * b < c * b"
   by transfer (auto intro!: ereal_mult_strict_right_mono)
 
 lemma ennreal_indicator_less[simp]:
   "indicator A x \<le> (indicator B x::ennreal) \<longleftrightarrow> (x \<in> A \<longrightarrow> x \<in> B)"
   by (simp add: indicator_def not_le)
 
 lemma ennreal_inverse_positive: "0 < inverse x \<longleftrightarrow> (x::ennreal) \<noteq> top"
   by transfer (simp add: ereal_0_gt_inverse top_ereal_def)
 
 lemma ennreal_inverse_mult': "((0 < b \<or> a < top) \<and> (0 < a \<or> b < top)) \<Longrightarrow> inverse (a * b::ennreal) = inverse a * inverse b"
   apply transfer
   subgoal for a b
     by (cases a b rule: ereal2_cases) (auto simp: top_ereal_def)
   done
 
 lemma ennreal_inverse_mult: "a < top \<Longrightarrow> b < top \<Longrightarrow> inverse (a * b::ennreal) = inverse a * inverse b"
   apply transfer
   subgoal for a b
     by (cases a b rule: ereal2_cases) (auto simp: top_ereal_def)
   done
 
 lemma ennreal_inverse_1[simp]: "inverse (1::ennreal) = 1"
   by transfer simp
 
 lemma ennreal_inverse_eq_0_iff[simp]: "inverse (a::ennreal) = 0 \<longleftrightarrow> a = top"
   by transfer (simp add: ereal_inverse_eq_0 top_ereal_def)
 
 lemma ennreal_inverse_eq_top_iff[simp]: "inverse (a::ennreal) = top \<longleftrightarrow> a = 0"
   by transfer (simp add: top_ereal_def)
 
 lemma ennreal_divide_eq_0_iff[simp]: "(a::ennreal) / b = 0 \<longleftrightarrow> (a = 0 \<or> b = top)"
   by (simp add: divide_ennreal_def)
 
 lemma ennreal_divide_eq_top_iff: "(a::ennreal) / b = top \<longleftrightarrow> ((a \<noteq> 0 \<and> b = 0) \<or> (a = top \<and> b \<noteq> top))"
   by (auto simp add: divide_ennreal_def ennreal_mult_eq_top_iff)
 
 lemma one_divide_one_divide_ennreal[simp]: "1 / (1 / c) = (c::ennreal)"
   including ennreal.lifting
   unfolding divide_ennreal_def
   by transfer auto
 
 lemma ennreal_mult_left_cong:
   "((a::ennreal) \<noteq> 0 \<Longrightarrow> b = c) \<Longrightarrow> a * b = a * c"
   by (cases "a = 0") simp_all
 
 lemma ennreal_mult_right_cong:
   "((a::ennreal) \<noteq> 0 \<Longrightarrow> b = c) \<Longrightarrow> b * a = c * a"
   by (cases "a = 0") simp_all
 
 lemma ennreal_zero_less_mult_iff: "0 < a * b \<longleftrightarrow> 0 < a \<and> 0 < (b::ennreal)"
   by transfer (auto simp add: ereal_zero_less_0_iff le_less)
 
 lemma less_diff_eq_ennreal:
   fixes a b c :: ennreal
   shows "b < top \<or> c < top \<Longrightarrow> a < b - c \<longleftrightarrow> a + c < b"
   apply transfer
   subgoal for a b c
     by (cases a b c rule: ereal3_cases) (auto split: split_max)
   done
 
 lemma diff_add_cancel_ennreal:
   fixes a b :: ennreal shows "a \<le> b \<Longrightarrow> b - a + a = b"
   unfolding infinity_ennreal_def
   by transfer (metis (no_types) add.commute ereal_diff_positive ereal_ineq_diff_add max_def not_MInfty_nonneg)
 
 lemma ennreal_diff_self[simp]: "a \<noteq> top \<Longrightarrow> a - a = (0::ennreal)"
   by transfer (simp add: top_ereal_def)
 
 lemma ennreal_minus_mono:
   fixes a b c :: ennreal
   shows "a \<le> c \<Longrightarrow> d \<le> b \<Longrightarrow> a - b \<le> c - d"
   by transfer (meson ereal_minus_mono max.mono order_refl)
 
 lemma ennreal_minus_eq_top[simp]: "a - (b::ennreal) = top \<longleftrightarrow> a = top"
   by (metis add_top diff_add_cancel_ennreal ennreal_mono_minus ennreal_top_minus zero_le)
 
 lemma ennreal_divide_self[simp]: "a \<noteq> 0 \<Longrightarrow> a < top \<Longrightarrow> a / a = (1::ennreal)"
   by (metis mult_1 mult_divide_eq_ennreal top.not_eq_extremum)
 
 subsection \<open>Coercion from \<^typ>\<open>real\<close> to \<^typ>\<open>ennreal\<close>\<close>
 
 lift_definition ennreal :: "real \<Rightarrow> ennreal" is "sup 0 \<circ> ereal"
   by simp
 
 declare [[coercion ennreal]]
 
 lemma ennreal_cong: "x = y \<Longrightarrow> ennreal x = ennreal y" 
   by simp
 
 lemma ennreal_cases[cases type: ennreal]:
   fixes x :: ennreal
   obtains (real) r :: real where "0 \<le> r" "x = ennreal r" | (top) "x = top"
   apply transfer
   subgoal for x thesis
     by (cases x) (auto simp: max.absorb2 top_ereal_def)
   done
 
 lemmas ennreal2_cases = ennreal_cases[case_product ennreal_cases]
 lemmas ennreal3_cases = ennreal_cases[case_product ennreal2_cases]
 
 lemma ennreal_neq_top[simp]: "ennreal r \<noteq> top"
   by transfer (simp add: top_ereal_def zero_ereal_def flip: ereal_max)
 
 lemma top_neq_ennreal[simp]: "top \<noteq> ennreal r"
   using ennreal_neq_top[of r] by (auto simp del: ennreal_neq_top)
 
 lemma ennreal_less_top[simp]: "ennreal x < top"
   by transfer (simp add: top_ereal_def max_def)
 
 lemma ennreal_neg: "x \<le> 0 \<Longrightarrow> ennreal x = 0"
   by transfer (simp add: max.absorb1)
 
 lemma ennreal_inj[simp]:
   "0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> ennreal a = ennreal b \<longleftrightarrow> a = b"
   by (transfer fixing: a b) (auto simp: max_absorb2)
 
 lemma ennreal_le_iff[simp]: "0 \<le> y \<Longrightarrow> ennreal x \<le> ennreal y \<longleftrightarrow> x \<le> y"
   by (auto simp: ennreal_def zero_ereal_def less_eq_ennreal.abs_eq eq_onp_def split: split_max)
 
 lemma le_ennreal_iff: "0 \<le> r \<Longrightarrow> x \<le> ennreal r \<longleftrightarrow> (\<exists>q\<ge>0. x = ennreal q \<and> q \<le> r)"
   by (cases x) (auto simp: top_unique)
 
 lemma ennreal_less_iff: "0 \<le> r \<Longrightarrow> ennreal r < ennreal q \<longleftrightarrow> r < q"
   unfolding not_le[symmetric] by auto
 
 lemma ennreal_eq_zero_iff[simp]: "0 \<le> x \<Longrightarrow> ennreal x = 0 \<longleftrightarrow> x = 0"
   by transfer (auto simp: max_absorb2)
 
 lemma ennreal_less_zero_iff[simp]: "0 < ennreal x \<longleftrightarrow> 0 < x"
   by transfer (auto simp: max_def)
 
 lemma ennreal_lessI: "0 < q \<Longrightarrow> r < q \<Longrightarrow> ennreal r < ennreal q"
   by (cases "0 \<le> r") (auto simp: ennreal_less_iff ennreal_neg)
 
 lemma ennreal_leI: "x \<le> y \<Longrightarrow> ennreal x \<le> ennreal y"
   by (cases "0 \<le> y") (auto simp: ennreal_neg)
 
 lemma enn2ereal_ennreal[simp]: "0 \<le> x \<Longrightarrow> enn2ereal (ennreal x) = x"
   by transfer (simp add: max_absorb2)
 
 lemma e2ennreal_enn2ereal[simp]: "e2ennreal (enn2ereal x) = x"
   by (simp add: e2ennreal_def max_absorb2 ennreal.enn2ereal_inverse)
 
 lemma enn2ereal_e2ennreal: "x \<ge> 0 \<Longrightarrow> enn2ereal (e2ennreal x) = x"
 by (metis e2ennreal_enn2ereal ereal_ennreal_cases not_le)
 
 lemma e2ennreal_ereal [simp]: "e2ennreal (ereal x) = ennreal x"
 by (metis e2ennreal_def enn2ereal_inverse ennreal.rep_eq sup_ereal_def)
 
 lemma ennreal_0[simp]: "ennreal 0 = 0"
   by (simp add: ennreal_def max.absorb1 zero_ennreal.abs_eq)
 
 lemma ennreal_1[simp]: "ennreal 1 = 1"
   by transfer (simp add: max_absorb2)
 
 lemma ennreal_eq_0_iff: "ennreal x = 0 \<longleftrightarrow> x \<le> 0"
   by (cases "0 \<le> x") (auto simp: ennreal_neg)
 
 lemma ennreal_le_iff2: "ennreal x \<le> ennreal y \<longleftrightarrow> ((0 \<le> y \<and> x \<le> y) \<or> (x \<le> 0 \<and> y \<le> 0))"
   by (cases "0 \<le> y") (auto simp: ennreal_eq_0_iff ennreal_neg)
 
 lemma ennreal_eq_1[simp]: "ennreal x = 1 \<longleftrightarrow> x = 1"
   by (cases "0 \<le> x") (auto simp: ennreal_neg simp flip: ennreal_1)
 
 lemma ennreal_le_1[simp]: "ennreal x \<le> 1 \<longleftrightarrow> x \<le> 1"
   by (cases "0 \<le> x") (auto simp: ennreal_neg simp flip: ennreal_1)
 
 lemma ennreal_ge_1[simp]: "ennreal x \<ge> 1 \<longleftrightarrow> x \<ge> 1"
   by (cases "0 \<le> x") (auto simp: ennreal_neg simp flip: ennreal_1)
 
 lemma one_less_ennreal[simp]: "1 < ennreal x \<longleftrightarrow> 1 < x"
   by (meson ennreal_le_1 linorder_not_le)
 
 lemma ennreal_plus[simp]:
   "0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> ennreal (a + b) = ennreal a + ennreal b"
   by (transfer fixing: a b) (auto simp: max_absorb2)
 
 lemma add_mono_ennreal: "x < ennreal y \<Longrightarrow> x' < ennreal y' \<Longrightarrow> x + x' < ennreal (y + y')"
   by (metis (full_types) add_strict_mono ennreal_less_zero_iff ennreal_plus less_le not_less zero_le)
 
 lemma sum_ennreal[simp]: "(\<And>i. i \<in> I \<Longrightarrow> 0 \<le> f i) \<Longrightarrow> (\<Sum>i\<in>I. ennreal (f i)) = ennreal (sum f I)"
   by (induction I rule: infinite_finite_induct) (auto simp: sum_nonneg)
 
 lemma sum_list_ennreal[simp]:
   assumes "\<And>x. x \<in> set xs \<Longrightarrow> f x \<ge> 0"
   shows   "sum_list (map (\<lambda>x. ennreal (f x)) xs) = ennreal (sum_list (map f xs))"
 using assms
 proof (induction xs)
   case (Cons x xs)
   from Cons have "(\<Sum>x\<leftarrow>x # xs. ennreal (f x)) = ennreal (f x) + ennreal (sum_list (map f xs))"
     by simp
   also from Cons.prems have "\<dots> = ennreal (f x + sum_list (map f xs))"
     by (intro ennreal_plus [symmetric] sum_list_nonneg) auto
   finally show ?case by simp
 qed simp_all
 
 lemma ennreal_of_nat_eq_real_of_nat: "of_nat i = ennreal (of_nat i)"
   by (induction i) simp_all
 
 lemma of_nat_le_ennreal_iff[simp]: "0 \<le> r \<Longrightarrow> of_nat i \<le> ennreal r \<longleftrightarrow> of_nat i \<le> r"
   by (simp add: ennreal_of_nat_eq_real_of_nat)
 
 lemma ennreal_le_of_nat_iff[simp]: "ennreal r \<le> of_nat i \<longleftrightarrow> r \<le> of_nat i"
   by (simp add: ennreal_of_nat_eq_real_of_nat)
 
 lemma ennreal_indicator: "ennreal (indicator A x) = indicator A x"
   by (auto split: split_indicator)
 
 lemma ennreal_numeral[simp]: "ennreal (numeral n) = numeral n"
   using ennreal_of_nat_eq_real_of_nat[of "numeral n"] by simp
 
 lemma ennreal_less_numeral_iff [simp]: "ennreal n < numeral w \<longleftrightarrow> n < numeral w"
   by (metis ennreal_less_iff ennreal_numeral less_le not_less zero_less_numeral)
 
 lemma numeral_less_ennreal_iff [simp]: "numeral w < ennreal n \<longleftrightarrow> numeral w < n"
   using ennreal_less_iff zero_le_numeral by fastforce
 
 lemma numeral_le_ennreal_iff [simp]: "numeral n \<le> ennreal m \<longleftrightarrow> numeral n \<le> m"
   by (metis not_le ennreal_less_numeral_iff)
 
 lemma min_ennreal: "0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> min (ennreal x) (ennreal y) = ennreal (min x y)"
   by (auto split: split_min)
 
 lemma ennreal_half[simp]: "ennreal (1/2) = inverse 2"
   by transfer (simp add: max.absorb2)
 
 lemma ennreal_minus: "0 \<le> q \<Longrightarrow> ennreal r - ennreal q = ennreal (r - q)"
   by transfer
      (simp add: max.absorb2 zero_ereal_def flip: ereal_max)
 
 lemma ennreal_minus_top[simp]: "ennreal a - top = 0"
   by (simp add: minus_top_ennreal)
 
 lemma e2eenreal_enn2ereal_diff [simp]:
   "e2ennreal(enn2ereal x - enn2ereal y) = x - y" for x y
 by (cases x, cases y, auto simp add: ennreal_minus e2ennreal_neg)
 
 lemma ennreal_mult: "0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> ennreal (a * b) = ennreal a * ennreal b"
   by transfer (simp add: max_absorb2)
 
 lemma ennreal_mult': "0 \<le> a \<Longrightarrow> ennreal (a * b) = ennreal a * ennreal b"
   by (cases "0 \<le> b") (auto simp: ennreal_mult ennreal_neg mult_nonneg_nonpos)
 
 lemma indicator_mult_ennreal: "indicator A x * ennreal r = ennreal (indicator A x * r)"
   by (simp split: split_indicator)
 
 lemma ennreal_mult'': "0 \<le> b \<Longrightarrow> ennreal (a * b) = ennreal a * ennreal b"
   by (cases "0 \<le> a") (auto simp: ennreal_mult ennreal_neg mult_nonpos_nonneg)
 
 lemma numeral_mult_ennreal: "0 \<le> x \<Longrightarrow> numeral b * ennreal x = ennreal (numeral b * x)"
   by (simp add: ennreal_mult)
 
 lemma ennreal_power: "0 \<le> r \<Longrightarrow> ennreal r ^ n = ennreal (r ^ n)"
   by (induction n) (auto simp: ennreal_mult)
 
 lemma power_eq_top_ennreal: "x ^ n = top \<longleftrightarrow> (n \<noteq> 0 \<and> (x::ennreal) = top)"
   by (cases x rule: ennreal_cases)
      (auto simp: ennreal_power top_power_ennreal)
 
 lemma inverse_ennreal: "0 < r \<Longrightarrow> inverse (ennreal r) = ennreal (inverse r)"
   by transfer (simp add: max.absorb2)
 
 lemma divide_ennreal: "0 \<le> r \<Longrightarrow> 0 < q \<Longrightarrow> ennreal r / ennreal q = ennreal (r / q)"
   by (simp add: divide_ennreal_def inverse_ennreal ennreal_mult[symmetric] inverse_eq_divide)
 
 lemma ennreal_inverse_power: "inverse (x ^ n :: ennreal) = inverse x ^ n"
 proof (cases x rule: ennreal_cases)
   case top with power_eq_top_ennreal[of x n] show ?thesis
     by (cases "n = 0") auto
 next
   case (real r) then show ?thesis
   proof (cases "x = 0")
     case False then show ?thesis
       by (smt (verit, best) ennreal_0 ennreal_power inverse_ennreal 
                inverse_nonnegative_iff_nonnegative power_inverse real zero_less_power)
   qed (simp add: top_power_ennreal)
 qed
 
 lemma power_divide_distrib_ennreal [algebra_simps]:
   "(x / y) ^ n = x ^ n / (y ^ n :: ennreal)"
   by (simp add: divide_ennreal_def algebra_simps ennreal_inverse_power)
 
 lemma ennreal_divide_numeral: "0 \<le> x \<Longrightarrow> ennreal x / numeral b = ennreal (x / numeral b)"
   by (subst divide_ennreal[symmetric]) auto
 
 lemma prod_ennreal: "(\<And>i. i \<in> A \<Longrightarrow> 0 \<le> f i) \<Longrightarrow> (\<Prod>i\<in>A. ennreal (f i)) = ennreal (prod f A)"
   by (induction A rule: infinite_finite_induct)
      (auto simp: ennreal_mult prod_nonneg)
 
 lemma prod_mono_ennreal:
   assumes "\<And>x. x \<in> A \<Longrightarrow> f x \<le> (g x :: ennreal)"
   shows   "prod f A \<le> prod g A"
   using assms by (induction A rule: infinite_finite_induct) (auto intro!: mult_mono)
 
 lemma mult_right_ennreal_cancel: "a * ennreal c = b * ennreal c \<longleftrightarrow> (a = b \<or> c \<le> 0)"
 proof (cases "0 \<le> c")
   case True
   then show ?thesis
     by (metis ennreal_eq_0_iff ennreal_mult_right_cong ennreal_neq_top mult_divide_eq_ennreal)
 qed (use ennreal_neg in auto)
 
 lemma ennreal_le_epsilon:
   "(\<And>e::real. y < top \<Longrightarrow> 0 < e \<Longrightarrow> x \<le> y + ennreal e) \<Longrightarrow> x \<le> y"
   apply (cases y rule: ennreal_cases)
   apply (cases x rule: ennreal_cases)
   apply (auto simp flip: ennreal_plus simp add: top_unique intro: zero_less_one field_le_epsilon)
   done
 
 lemma ennreal_rat_dense:
   fixes x y :: ennreal
   shows "x < y \<Longrightarrow> \<exists>r::rat. x < real_of_rat r \<and> real_of_rat r < y"
 proof transfer
   fix x y :: ereal assume xy: "0 \<le> x" "0 \<le> y" "x < y"
   moreover
   from ereal_dense3[OF \<open>x < y\<close>]
   obtain r where r: "x < ereal (real_of_rat r)" "ereal (real_of_rat r) < y"
     by auto
   then have "0 \<le> r"
     using le_less_trans[OF \<open>0 \<le> x\<close> \<open>x < ereal (real_of_rat r)\<close>] by auto
   with r show "\<exists>r. x < (sup 0 \<circ> ereal) (real_of_rat r) \<and> (sup 0 \<circ> ereal) (real_of_rat r) < y"
     by (intro exI[of _ r]) (auto simp: max_absorb2)
 qed
 
 lemma ennreal_Ex_less_of_nat: "(x::ennreal) < top \<Longrightarrow> \<exists>n. x < of_nat n"
   by (cases x rule: ennreal_cases)
      (auto simp: ennreal_of_nat_eq_real_of_nat ennreal_less_iff reals_Archimedean2)
 
 subsection \<open>Coercion from \<^typ>\<open>ennreal\<close> to \<^typ>\<open>real\<close>\<close>
 
 definition "enn2real x = real_of_ereal (enn2ereal x)"
 
 lemma enn2real_nonneg[simp]: "0 \<le> enn2real x"
   by (auto simp: enn2real_def intro!: real_of_ereal_pos enn2ereal_nonneg)
 
 lemma enn2real_mono: "a \<le> b \<Longrightarrow> b < top \<Longrightarrow> enn2real a \<le> enn2real b"
   by (auto simp add: enn2real_def less_eq_ennreal.rep_eq intro!: real_of_ereal_positive_mono enn2ereal_nonneg)
 
 lemma enn2real_of_nat[simp]: "enn2real (of_nat n) = n"
   by (auto simp: enn2real_def)
 
 lemma enn2real_ennreal[simp]: "0 \<le> r \<Longrightarrow> enn2real (ennreal r) = r"
   by (simp add: enn2real_def)
 
 lemma ennreal_enn2real[simp]: "r < top \<Longrightarrow> ennreal (enn2real r) = r"
   by (cases r rule: ennreal_cases) auto
 
 lemma real_of_ereal_enn2ereal[simp]: "real_of_ereal (enn2ereal x) = enn2real x"
   by (simp add: enn2real_def)
 
 lemma enn2real_top[simp]: "enn2real top = 0"
   unfolding enn2real_def top_ennreal.rep_eq top_ereal_def by simp
 
 lemma enn2real_0[simp]: "enn2real 0 = 0"
   unfolding enn2real_def zero_ennreal.rep_eq by simp
 
 lemma enn2real_1[simp]: "enn2real 1 = 1"
   unfolding enn2real_def one_ennreal.rep_eq by simp
 
 lemma enn2real_numeral[simp]: "enn2real (numeral n) = (numeral n)"
   unfolding enn2real_def by simp
 
 lemma enn2real_mult: "enn2real (a * b) = enn2real a * enn2real b"
   unfolding enn2real_def
   by (simp del: real_of_ereal_enn2ereal add: times_ennreal.rep_eq)
 
 lemma enn2real_leI: "0 \<le> B \<Longrightarrow> x \<le> ennreal B \<Longrightarrow> enn2real x \<le> B"
   by (cases x rule: ennreal_cases) (auto simp: top_unique)
 
 lemma enn2real_positive_iff: "0 < enn2real x \<longleftrightarrow> (0 < x \<and> x < top)"
   by (cases x rule: ennreal_cases) auto
 
 lemma enn2real_eq_posreal_iff[simp]: "c > 0 \<Longrightarrow> enn2real x = c \<longleftrightarrow> x = c"
   by (cases x) auto
 
 lemma ennreal_enn2real_if: "ennreal (enn2real r) = (if r = top then 0 else r)"
   by(auto intro!: ennreal_enn2real simp add: less_top)
 
 subsection \<open>Coercion from \<^typ>\<open>enat\<close> to \<^typ>\<open>ennreal\<close>\<close>
 
 
 definition ennreal_of_enat :: "enat \<Rightarrow> ennreal"
 where
   "ennreal_of_enat n = (case n of \<infinity> \<Rightarrow> top | enat n \<Rightarrow> of_nat n)"
 
 declare [[coercion ennreal_of_enat]]
 declare [[coercion "of_nat :: nat \<Rightarrow> ennreal"]]
 
 lemma ennreal_of_enat_infty[simp]: "ennreal_of_enat \<infinity> = \<infinity>"
   by (simp add: ennreal_of_enat_def)
 
 lemma ennreal_of_enat_enat[simp]: "ennreal_of_enat (enat n) = of_nat n"
   by (simp add: ennreal_of_enat_def)
 
 lemma ennreal_of_enat_0[simp]: "ennreal_of_enat 0 = 0"
   using ennreal_of_enat_enat[of 0] unfolding enat_0 by simp
 
 lemma ennreal_of_enat_1[simp]: "ennreal_of_enat 1 = 1"
   using ennreal_of_enat_enat[of 1] unfolding enat_1 by simp
 
 lemma ennreal_top_neq_of_nat[simp]: "(top::ennreal) \<noteq> of_nat i"
   using ennreal_of_nat_neq_top[of i] by metis
 
 lemma ennreal_of_enat_inj[simp]: "ennreal_of_enat i = ennreal_of_enat j \<longleftrightarrow> i = j"
   by (cases i j rule: enat.exhaust[case_product enat.exhaust]) auto
 
 lemma ennreal_of_enat_le_iff[simp]: "ennreal_of_enat m \<le> ennreal_of_enat n \<longleftrightarrow> m \<le> n"
   by (auto simp: ennreal_of_enat_def top_unique split: enat.split)
 
 lemma of_nat_less_ennreal_of_nat[simp]: "of_nat n \<le> ennreal_of_enat x \<longleftrightarrow> of_nat n \<le> x"
   by (cases x) (auto simp: of_nat_eq_enat)
 
 lemma ennreal_of_enat_Sup: "ennreal_of_enat (Sup X) = (SUP x\<in>X. ennreal_of_enat x)"
 proof -
   have "ennreal_of_enat (Sup X) \<le> (SUP x \<in> X. ennreal_of_enat x)"
     unfolding Sup_enat_def
   proof (clarsimp, intro conjI impI)
     fix x assume "finite X" "X \<noteq> {}"
     then show "ennreal_of_enat (Max X) \<le> (SUP x \<in> X. ennreal_of_enat x)"
       by (intro SUP_upper Max_in)
   next
     assume "infinite X" "X \<noteq> {}"
     have "\<exists>y\<in>X. r < ennreal_of_enat y" if r: "r < top" for r
     proof -
       obtain n where n: "r < of_nat n"
         using ennreal_Ex_less_of_nat[OF r] ..
       have "\<not> (X \<subseteq> enat ` {.. n})"
         using \<open>infinite X\<close> by (auto dest: finite_subset)
       then obtain x where x: "x \<in> X" "x \<notin> enat ` {..n}"
         by blast
       then have "of_nat n \<le> x"
         by (cases x) (auto simp: of_nat_eq_enat)
       with x show ?thesis
         by (auto intro!: bexI[of _ x] less_le_trans[OF n])
     qed
     then have "(SUP x \<in> X. ennreal_of_enat x) = top"
       by simp
     then show "top \<le> (SUP x \<in> X. ennreal_of_enat x)"
       unfolding top_unique by simp
   qed
   then show ?thesis
     by (auto intro!: antisym Sup_least intro: Sup_upper)
 qed
 
 lemma ennreal_of_enat_eSuc[simp]: "ennreal_of_enat (eSuc x) = 1 + ennreal_of_enat x"
   by (cases x) (auto simp: eSuc_enat)
 
 (* Contributed by Dominique Unruh *)
 lemma ennreal_of_enat_plus[simp]: \<open>ennreal_of_enat (a+b) = ennreal_of_enat a + ennreal_of_enat b\<close>
   apply (induct a)
    apply (metis enat.exhaust ennreal_add_eq_top ennreal_of_enat_enat ennreal_of_enat_infty infinity_ennreal_def of_nat_add plus_enat_simps(1) plus_eq_infty_iff_enat)
   apply simp
   done
 
 (* Contributed by Dominique Unruh *)
 lemma sum_ennreal_of_enat[simp]: "(\<Sum>i\<in>I. ennreal_of_enat (f i)) = ennreal_of_enat (sum f I)"
   by (induct I rule: infinite_finite_induct) (auto simp: sum_nonneg)
 
 
 subsection \<open>Topology on \<^typ>\<open>ennreal\<close>\<close>
 
 lemma enn2ereal_Iio: "enn2ereal -` {..<a} = (if 0 \<le> a then {..< e2ennreal a} else {})"
   using enn2ereal_nonneg
   by (cases a rule: ereal_ennreal_cases)
      (auto simp add: vimage_def set_eq_iff ennreal.enn2ereal_inverse less_ennreal.rep_eq e2ennreal_def max_absorb2
            simp del: enn2ereal_nonneg
            intro: le_less_trans less_imp_le)
 
 lemma enn2ereal_Ioi: "enn2ereal -` {a <..} = (if 0 \<le> a then {e2ennreal a <..} else UNIV)"
   by (cases a rule: ereal_ennreal_cases)
      (auto simp add: vimage_def set_eq_iff ennreal.enn2ereal_inverse less_ennreal.rep_eq e2ennreal_def max_absorb2
            intro: less_le_trans)
 
 instantiation ennreal :: linear_continuum_topology
 begin
 
 definition open_ennreal :: "ennreal set \<Rightarrow> bool"
   where "(open :: ennreal set \<Rightarrow> bool) = generate_topology (range lessThan \<union> range greaterThan)"
 
 instance
 proof
   show "\<exists>a b::ennreal. a \<noteq> b"
     using zero_neq_one by (intro exI)
   show "\<And>x y::ennreal. x < y \<Longrightarrow> \<exists>z>x. z < y"
   proof transfer
     fix x y :: ereal
     assume *: "0 \<le> x"
     assume "x < y"
     from dense[OF this] obtain z where "x < z \<and> z < y" ..
     with * show "\<exists>z\<in>Collect ((\<le>) 0). x < z \<and> z < y"
       by (intro bexI[of _ z]) auto
   qed
 qed (rule open_ennreal_def)
 
 end
 
 lemma continuous_on_e2ennreal: "continuous_on A e2ennreal"
 proof (rule continuous_on_subset)
   show "continuous_on ({0..} \<union> {..0}) e2ennreal"
   proof (rule continuous_on_closed_Un)
     show "continuous_on {0 ..} e2ennreal"
       by (rule continuous_onI_mono)
          (auto simp add: less_eq_ennreal.abs_eq eq_onp_def enn2ereal_range)
     show "continuous_on {.. 0} e2ennreal"
       by (subst continuous_on_cong[OF refl, of _ _ "\<lambda>_. 0"])
          (auto simp add: e2ennreal_neg continuous_on_const)
   qed auto
   show "A \<subseteq> {0..} \<union> {..0::ereal}"
     by auto
 qed
 
 lemma continuous_at_e2ennreal: "continuous (at x within A) e2ennreal"
   by (rule continuous_on_imp_continuous_within[OF continuous_on_e2ennreal, of _ UNIV]) auto
 
 lemma continuous_on_enn2ereal: "continuous_on UNIV enn2ereal"
   by (rule continuous_on_generate_topology[OF open_generated_order])
      (auto simp add: enn2ereal_Iio enn2ereal_Ioi)
 
 lemma continuous_at_enn2ereal: "continuous (at x within A) enn2ereal"
   by (rule continuous_on_imp_continuous_within[OF continuous_on_enn2ereal]) auto
 
 lemma sup_continuous_e2ennreal[order_continuous_intros]:
   assumes f: "sup_continuous f" shows "sup_continuous (\<lambda>x. e2ennreal (f x))"
 proof (rule sup_continuous_compose[OF _ f])
   show "sup_continuous e2ennreal"
     by (simp add: continuous_at_e2ennreal continuous_at_left_imp_sup_continuous e2ennreal_mono mono_def)
 qed
 
 lemma sup_continuous_enn2ereal[order_continuous_intros]:
   assumes f: "sup_continuous f" shows "sup_continuous (\<lambda>x. enn2ereal (f x))"
 proof (rule sup_continuous_compose[OF _ f])
   show "sup_continuous enn2ereal"
   by (simp add: continuous_at_enn2ereal continuous_at_left_imp_sup_continuous less_eq_ennreal.rep_eq mono_def)
 qed
 
 lemma sup_continuous_mult_left_ennreal':
   fixes c :: "ennreal"
   shows "sup_continuous (\<lambda>x. c * x)"
   unfolding sup_continuous_def
   by transfer (auto simp: SUP_ereal_mult_left max.absorb2 SUP_upper2)
 
 lemma sup_continuous_mult_left_ennreal[order_continuous_intros]:
   "sup_continuous f \<Longrightarrow> sup_continuous (\<lambda>x. c * f x :: ennreal)"
   by (rule sup_continuous_compose[OF sup_continuous_mult_left_ennreal'])
 
 lemma sup_continuous_mult_right_ennreal[order_continuous_intros]:
   "sup_continuous f \<Longrightarrow> sup_continuous (\<lambda>x. f x * c :: ennreal)"
   using sup_continuous_mult_left_ennreal[of f c] by (simp add: mult.commute)
 
 lemma sup_continuous_divide_ennreal[order_continuous_intros]:
   fixes f g :: "'a::complete_lattice \<Rightarrow> ennreal"
   shows "sup_continuous f \<Longrightarrow> sup_continuous (\<lambda>x. f x / c)"
   unfolding divide_ennreal_def by (rule sup_continuous_mult_right_ennreal)
 
 lemma transfer_enn2ereal_continuous_on [transfer_rule]:
   "rel_fun (=) (rel_fun (rel_fun (=) pcr_ennreal) (=)) continuous_on continuous_on"
 proof -
   have "continuous_on A f" if "continuous_on A (\<lambda>x. enn2ereal (f x))" for A and f :: "'a \<Rightarrow> ennreal"
     using continuous_on_compose2[OF continuous_on_e2ennreal[of "{0..}"] that]
     by (auto simp: ennreal.enn2ereal_inverse subset_eq e2ennreal_def max_absorb2)
   moreover
   have "continuous_on A (\<lambda>x. enn2ereal (f x))" if "continuous_on A f" for A and f :: "'a \<Rightarrow> ennreal"
     using continuous_on_compose2[OF continuous_on_enn2ereal that] by auto
   ultimately
   show ?thesis
     by (auto simp add: rel_fun_def ennreal.pcr_cr_eq cr_ennreal_def)
 qed
 
 lemma transfer_sup_continuous[transfer_rule]:
   "(rel_fun (rel_fun (=) pcr_ennreal) (=)) sup_continuous sup_continuous"
 proof (safe intro!: rel_funI dest!: rel_fun_eq_pcr_ennreal[THEN iffD1])
   show "sup_continuous (enn2ereal \<circ> f) \<Longrightarrow> sup_continuous f" for f :: "'a \<Rightarrow> _"
     using sup_continuous_e2ennreal[of "enn2ereal \<circ> f"] by simp
   show "sup_continuous f \<Longrightarrow> sup_continuous (enn2ereal \<circ> f)" for f :: "'a \<Rightarrow> _"
     using sup_continuous_enn2ereal[of f] by (simp add: comp_def)
 qed
 
 lemma continuous_on_ennreal[tendsto_intros]:
   "continuous_on A f \<Longrightarrow> continuous_on A (\<lambda>x. ennreal (f x))"
   by transfer (auto intro!: continuous_on_max continuous_on_const continuous_on_ereal)
 
 lemma tendsto_ennrealD:
   assumes lim: "((\<lambda>x. ennreal (f x)) \<longlongrightarrow> ennreal x) F"
   assumes *: "\<forall>\<^sub>F x in F. 0 \<le> f x" and x: "0 \<le> x"
   shows "(f \<longlongrightarrow> x) F"
 proof -
   have "((\<lambda>x. enn2ereal (ennreal (f x))) \<longlongrightarrow> enn2ereal (ennreal x)) F 
     \<longleftrightarrow> (f \<longlongrightarrow> enn2ereal (ennreal x)) F"
     using "*" eventually_mono
     by (intro tendsto_cong) fastforce
   then show ?thesis
     using assms(1) continuous_at_enn2ereal isCont_tendsto_compose x by fastforce
 qed
 
 lemma tendsto_ennreal_iff [simp]:
   \<open>((\<lambda>x. ennreal (f x)) \<longlongrightarrow> ennreal x) F \<longleftrightarrow> (f \<longlongrightarrow> x) F\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
   if \<open>\<forall>\<^sub>F x in F. 0 \<le> f x\<close> \<open>0 \<le> x\<close>
 proof
   assume \<open>?P\<close>
   then show \<open>?Q\<close>
     using that by (rule tendsto_ennrealD)
 next
   assume \<open>?Q\<close>
   have \<open>continuous_on UNIV ereal\<close>
     using continuous_on_ereal [of _ id] by simp
   then have \<open>continuous_on UNIV (e2ennreal \<circ> ereal)\<close>
     by (rule continuous_on_compose) (simp_all add: continuous_on_e2ennreal)
   then have \<open>((\<lambda>x. (e2ennreal \<circ> ereal) (f x)) \<longlongrightarrow> (e2ennreal \<circ> ereal) x) F\<close>
     using \<open>?Q\<close> by (rule continuous_on_tendsto_compose) simp_all
   then show \<open>?P\<close>
     by (simp flip: e2ennreal_ereal)
 qed
 
 lemma tendsto_enn2ereal_iff[simp]: "((\<lambda>i. enn2ereal (f i)) \<longlongrightarrow> enn2ereal x) F \<longleftrightarrow> (f \<longlongrightarrow> x) F"
   using continuous_on_enn2ereal[THEN continuous_on_tendsto_compose, of f x F]
     continuous_on_e2ennreal[THEN continuous_on_tendsto_compose, of "\<lambda>x. enn2ereal (f x)" "enn2ereal x" F UNIV]
   by auto
 
 lemma ennreal_tendsto_0_iff: "(\<And>n. f n \<ge> 0) \<Longrightarrow> ((\<lambda>n. ennreal (f n)) \<longlonglongrightarrow> 0) \<longleftrightarrow> (f \<longlonglongrightarrow> 0)"
   by (metis (mono_tags) ennreal_0 eventuallyI order_refl tendsto_ennreal_iff)
     
 lemma continuous_on_add_ennreal:
   fixes f g :: "'a::topological_space \<Rightarrow> ennreal"
   shows "continuous_on A f \<Longrightarrow> continuous_on A g \<Longrightarrow> continuous_on A (\<lambda>x. f x + g x)"
   by (transfer fixing: A) (auto intro!: tendsto_add_ereal_nonneg simp: continuous_on_def)
 
 lemma continuous_on_inverse_ennreal[continuous_intros]:
   fixes f :: "'a::topological_space \<Rightarrow> ennreal"
   shows "continuous_on A f \<Longrightarrow> continuous_on A (\<lambda>x. inverse (f x))"
 proof (transfer fixing: A)
   show "pred_fun top  ((\<le>) 0) f \<Longrightarrow> continuous_on A (\<lambda>x. inverse (f x))" if "continuous_on A f"
     for f :: "'a \<Rightarrow> ereal"
     using continuous_on_compose2[OF continuous_on_inverse_ereal that] by (auto simp: subset_eq)
 qed
 
 instance ennreal :: topological_comm_monoid_add
 proof
   show "((\<lambda>x. fst x + snd x) \<longlongrightarrow> a + b) (nhds a \<times>\<^sub>F nhds b)" for a b :: ennreal
     using continuous_on_add_ennreal[of UNIV fst snd]
     using tendsto_at_iff_tendsto_nhds[symmetric, of "\<lambda>x::(ennreal \<times> ennreal). fst x + snd x"]
     by (auto simp: continuous_on_eq_continuous_at)
        (simp add: isCont_def nhds_prod[symmetric])
 qed
 
 lemma sup_continuous_add_ennreal[order_continuous_intros]:
   fixes f g :: "'a::complete_lattice \<Rightarrow> ennreal"
   shows "sup_continuous f \<Longrightarrow> sup_continuous g \<Longrightarrow> sup_continuous (\<lambda>x. f x + g x)"
   by transfer (auto intro!: sup_continuous_add)
 
 lemma ennreal_suminf_lessD: "(\<Sum>i. f i :: ennreal) < x \<Longrightarrow> f i < x"
   using le_less_trans[OF sum_le_suminf[OF summableI, of "{i}" f]] by simp
 
 lemma sums_ennreal[simp]: "(\<And>i. 0 \<le> f i) \<Longrightarrow> 0 \<le> x \<Longrightarrow> (\<lambda>i. ennreal (f i)) sums ennreal x \<longleftrightarrow> f sums x"
   unfolding sums_def by (simp add: always_eventually sum_nonneg)
 
 lemma summable_suminf_not_top: "(\<And>i. 0 \<le> f i) \<Longrightarrow> (\<Sum>i. ennreal (f i)) \<noteq> top \<Longrightarrow> summable f"
   using summable_sums[OF summableI, of "\<lambda>i. ennreal (f i)"]
   by (cases "\<Sum>i. ennreal (f i)" rule: ennreal_cases)
      (auto simp: summable_def)
 
 lemma suminf_ennreal[simp]:
   "(\<And>i. 0 \<le> f i) \<Longrightarrow> (\<Sum>i. ennreal (f i)) \<noteq> top \<Longrightarrow> (\<Sum>i. ennreal (f i)) = ennreal (\<Sum>i. f i)"
   by (rule sums_unique[symmetric]) (simp add: summable_suminf_not_top suminf_nonneg summable_sums)
 
 lemma sums_enn2ereal[simp]: "(\<lambda>i. enn2ereal (f i)) sums enn2ereal x \<longleftrightarrow> f sums x"
   unfolding sums_def by (simp add: always_eventually sum_nonneg)
 
 lemma suminf_enn2ereal[simp]: "(\<Sum>i. enn2ereal (f i)) = enn2ereal (suminf f)"
   by (rule sums_unique[symmetric]) (simp add: summable_sums)
 
 lemma transfer_e2ennreal_suminf [transfer_rule]: "rel_fun (rel_fun (=) pcr_ennreal) pcr_ennreal suminf suminf"
   by (auto simp: rel_funI rel_fun_eq_pcr_ennreal comp_def)
 
 lemma ennreal_suminf_cmult[simp]: "(\<Sum>i. r * f i) = r * (\<Sum>i. f i::ennreal)"
   by transfer (auto intro!: suminf_cmult_ereal)
 
 lemma ennreal_suminf_multc[simp]: "(\<Sum>i. f i * r) = (\<Sum>i. f i::ennreal) * r"
   using ennreal_suminf_cmult[of r f] by (simp add: ac_simps)
 
 lemma ennreal_suminf_divide[simp]: "(\<Sum>i. f i / r) = (\<Sum>i. f i::ennreal) / r"
   by (simp add: divide_ennreal_def)
 
 lemma ennreal_suminf_neq_top: "summable f \<Longrightarrow> (\<And>i. 0 \<le> f i) \<Longrightarrow> (\<Sum>i. ennreal (f i)) \<noteq> top"
   using sums_ennreal[of f "suminf f"]
   by (simp add: suminf_nonneg flip: sums_unique summable_sums_iff del: sums_ennreal)
 
 lemma suminf_ennreal_eq:
   "(\<And>i. 0 \<le> f i) \<Longrightarrow> f sums x \<Longrightarrow> (\<Sum>i. ennreal (f i)) = ennreal x"
   using suminf_nonneg[of f] sums_unique[of f x]
   by (intro sums_unique[symmetric]) (auto simp: summable_sums_iff)
 
 lemma ennreal_suminf_bound_add:
   fixes f :: "nat \<Rightarrow> ennreal"
   shows "(\<And>N. (\<Sum>n<N. f n) + y \<le> x) \<Longrightarrow> suminf f + y \<le> x"
   by transfer (auto intro!: suminf_bound_add)
 
 lemma ennreal_suminf_SUP_eq_directed:
   fixes f :: "'a \<Rightarrow> nat \<Rightarrow> ennreal"
   assumes *: "\<And>N i j. i \<in> I \<Longrightarrow> j \<in> I \<Longrightarrow> finite N \<Longrightarrow> \<exists>k\<in>I. \<forall>n\<in>N. f i n \<le> f k n \<and> f j n \<le> f k n"
   shows "(\<Sum>n. SUP i\<in>I. f i n) = (SUP i\<in>I. \<Sum>n. f i n)"
 proof cases
   assume "I \<noteq> {}"
   then obtain i where "i \<in> I" by auto
   from * show ?thesis
     by (transfer fixing: I)
        (auto simp: max_absorb2 SUP_upper2[OF \<open>i \<in> I\<close>] suminf_nonneg summable_ereal_pos \<open>I \<noteq> {}\<close>
              intro!: suminf_SUP_eq_directed)
 qed (simp add: bot_ennreal)
 
 lemma INF_ennreal_add_const:
   fixes f g :: "nat \<Rightarrow> ennreal"
   shows "(INF i. f i + c) = (INF i. f i) + c"
   using continuous_at_Inf_mono[of "\<lambda>x. x + c" "f`UNIV"]
   using continuous_add[of "at_right (Inf (range f))", of "\<lambda>x. x" "\<lambda>x. c"]
   by (auto simp: mono_def image_comp)
 
 lemma INF_ennreal_const_add:
   fixes f g :: "nat \<Rightarrow> ennreal"
   shows "(INF i. c + f i) = c + (INF i. f i)"
   using INF_ennreal_add_const[of f c] by (simp add: ac_simps)
 
 lemma SUP_mult_left_ennreal: "c * (SUP i\<in>I. f i) = (SUP i\<in>I. c * f i ::ennreal)"
 proof cases
   assume "I \<noteq> {}" then show ?thesis
     by transfer (auto simp add: SUP_ereal_mult_left max_absorb2 SUP_upper2)
 qed (simp add: bot_ennreal)
 
 lemma SUP_mult_right_ennreal: "(SUP i\<in>I. f i) * c = (SUP i\<in>I. f i * c ::ennreal)"
   using SUP_mult_left_ennreal by (simp add: mult.commute)
 
 lemma SUP_divide_ennreal: "(SUP i\<in>I. f i) / c = (SUP i\<in>I. f i / c ::ennreal)"
   using SUP_mult_right_ennreal by (simp add: divide_ennreal_def)
 
 lemma ennreal_SUP_of_nat_eq_top: "(SUP x. of_nat x :: ennreal) = top"
 proof (intro antisym top_greatest le_SUP_iff[THEN iffD2] allI impI)
   fix y :: ennreal assume "y < top"
   then obtain r where "y = ennreal r"
     by (cases y rule: ennreal_cases) auto
   then show "\<exists>i\<in>UNIV. y < of_nat i"
     using reals_Archimedean2[of "max 1 r"] zero_less_one
     by (simp add: ennreal_Ex_less_of_nat)
 qed
 
 lemma ennreal_SUP_eq_top:
   fixes f :: "'a \<Rightarrow> ennreal"
   assumes "\<And>n. \<exists>i\<in>I. of_nat n \<le> f i"
   shows "(SUP i \<in> I. f i) = top"
 proof -
   have "(SUP x. of_nat x :: ennreal) \<le> (SUP i \<in> I. f i)"
     using assms by (auto intro!: SUP_least intro: SUP_upper2)
   then show ?thesis
     by (auto simp: ennreal_SUP_of_nat_eq_top top_unique)
 qed
 
 lemma ennreal_INF_const_minus:
   fixes f :: "'a \<Rightarrow> ennreal"
   shows "I \<noteq> {} \<Longrightarrow> (SUP x\<in>I. c - f x) = c - (INF x\<in>I. f x)"
   by (transfer fixing: I)
      (simp add: sup_max[symmetric] SUP_sup_const1 SUP_ereal_minus_right del: sup_ereal_def)
 
 lemma of_nat_Sup_ennreal:
   assumes "A \<noteq> {}" "bdd_above A"
   shows "of_nat (Sup A) = (SUP a\<in>A. of_nat a :: ennreal)"
 proof (intro antisym)
   show "(SUP a\<in>A. of_nat a::ennreal) \<le> of_nat (Sup A)"
     by (intro SUP_least of_nat_mono) (auto intro: cSup_upper assms)
   have "Sup A \<in> A"
     using assms by (auto simp: Sup_nat_def bdd_above_nat)
   then show "of_nat (Sup A) \<le> (SUP a\<in>A. of_nat a::ennreal)"
     by (intro SUP_upper)
 qed
 
 lemma ennreal_tendsto_const_minus:
   fixes g :: "'a \<Rightarrow> ennreal"
   assumes ae: "\<forall>\<^sub>F x in F. g x \<le> c"
   assumes g: "((\<lambda>x. c - g x) \<longlongrightarrow> 0) F"
   shows "(g \<longlongrightarrow> c) F"
 proof (cases c rule: ennreal_cases)
   case top with tendsto_unique[OF _ g, of "top"] show ?thesis
     by (cases "F = bot") auto
 next
   case (real r)
   then have "\<forall>x. \<exists>q\<ge>0. g x \<le> c \<longrightarrow> (g x = ennreal q \<and> q \<le> r)"
     by (auto simp: le_ennreal_iff)
   then obtain f where *: "0 \<le> f x" "g x = ennreal (f x)" "f x \<le> r" if "g x \<le> c" for x
     by metis
   from ae have ae2: "\<forall>\<^sub>F x in F. c - g x = ennreal (r - f x) \<and> f x \<le> r \<and> g x = ennreal (f x) \<and> 0 \<le> f x"
   proof eventually_elim
     fix x assume "g x \<le> c" with *[of x] \<open>0 \<le> r\<close> show "c - g x = ennreal (r - f x) \<and> f x \<le> r \<and> g x = ennreal (f x) \<and> 0 \<le> f x"
       by (auto simp: real ennreal_minus)
   qed
   with g have "((\<lambda>x. ennreal (r - f x)) \<longlongrightarrow> ennreal 0) F"
     by (auto simp add: tendsto_cong eventually_conj_iff)
   with ae2 have "((\<lambda>x. r - f x) \<longlongrightarrow> 0) F"
     by (subst (asm) tendsto_ennreal_iff) (auto elim: eventually_mono)
   then have "(f \<longlongrightarrow> r) F"
     by (rule Lim_transform2[OF tendsto_const])
   with ae2 have "((\<lambda>x. ennreal (f x)) \<longlongrightarrow> ennreal r) F"
     by (subst tendsto_ennreal_iff) (auto elim: eventually_mono simp: real)
   with ae2 show ?thesis
     by (auto simp: real tendsto_cong eventually_conj_iff)
 qed
 
 lemma ennreal_SUP_add:
   fixes f g :: "nat \<Rightarrow> ennreal"
   shows "incseq f \<Longrightarrow> incseq g \<Longrightarrow> (SUP i. f i + g i) = Sup (f ` UNIV) + Sup (g ` UNIV)"
   unfolding incseq_def le_fun_def
   by transfer
      (simp add: SUP_ereal_add incseq_def le_fun_def max_absorb2 SUP_upper2)
 
 lemma ennreal_SUP_sum:
   fixes f :: "'a \<Rightarrow> nat \<Rightarrow> ennreal"
   shows "(\<And>i. i \<in> I \<Longrightarrow> incseq (f i)) \<Longrightarrow> (SUP n. \<Sum>i\<in>I. f i n) = (\<Sum>i\<in>I. SUP n. f i n)"
   unfolding incseq_def
   by transfer
      (simp add: SUP_ereal_sum incseq_def SUP_upper2 max_absorb2 sum_nonneg)
 
 lemma ennreal_liminf_minus:
   fixes f :: "nat \<Rightarrow> ennreal"
   shows "(\<And>n. f n \<le> c) \<Longrightarrow> liminf (\<lambda>n. c - f n) = c - limsup f"
   apply transfer
   apply (simp add: ereal_diff_positive liminf_ereal_cminus)
   by (metis max.absorb2 ereal_diff_positive Limsup_bounded eventually_sequentiallyI)
 
 lemma ennreal_continuous_on_cmult:
   "(c::ennreal) < top \<Longrightarrow> continuous_on A f \<Longrightarrow> continuous_on A (\<lambda>x. c * f x)"
   by (transfer fixing: A) (auto intro: continuous_on_cmult_ereal)
 
 lemma ennreal_tendsto_cmult:
   "(c::ennreal) < top \<Longrightarrow> (f \<longlongrightarrow> x) F \<Longrightarrow> ((\<lambda>x. c * f x) \<longlongrightarrow> c * x) F"
   by (rule continuous_on_tendsto_compose[where g=f, OF ennreal_continuous_on_cmult, where s=UNIV])
      (auto simp: continuous_on_id)
 
 lemma tendsto_ennrealI[intro, simp, tendsto_intros]:
   "(f \<longlongrightarrow> x) F \<Longrightarrow> ((\<lambda>x. ennreal (f x)) \<longlongrightarrow> ennreal x) F"
   by (auto simp: ennreal_def
            intro!: continuous_on_tendsto_compose[OF continuous_on_e2ennreal[of UNIV]] tendsto_max)
 
 lemma tendsto_enn2erealI [tendsto_intros]:
   assumes "(f \<longlongrightarrow> l) F"
   shows "((\<lambda>i. enn2ereal(f i)) \<longlongrightarrow> enn2ereal l) F"
 using tendsto_enn2ereal_iff assms by auto
 
 lemma tendsto_e2ennrealI [tendsto_intros]:
   assumes "(f \<longlongrightarrow> l) F"
   shows "((\<lambda>i. e2ennreal(f i)) \<longlongrightarrow> e2ennreal l) F"
 proof -
   have *: "e2ennreal (max x 0) = e2ennreal x" for x
     by (simp add: e2ennreal_def max.commute)
   have "((\<lambda>i. max (f i) 0) \<longlongrightarrow> max l 0) F"
     apply (intro tendsto_intros) using assms by auto
   then have "((\<lambda>i. enn2ereal(e2ennreal (max (f i) 0))) \<longlongrightarrow> enn2ereal (e2ennreal (max l 0))) F"
     by (subst enn2ereal_e2ennreal, auto)+
   then have "((\<lambda>i. e2ennreal (max (f i) 0)) \<longlongrightarrow> e2ennreal (max l 0)) F"
     using tendsto_enn2ereal_iff by auto
   then show ?thesis
     unfolding * by auto
 qed
 
 lemma ennreal_suminf_minus:
   fixes f g :: "nat \<Rightarrow> ennreal"
   shows "(\<And>i. g i \<le> f i) \<Longrightarrow> suminf f \<noteq> top \<Longrightarrow> suminf g \<noteq> top \<Longrightarrow> (\<Sum>i. f i - g i) = suminf f - suminf g"
   by transfer
      (auto simp add: max.absorb2 ereal_diff_positive suminf_le_pos top_ereal_def intro!: suminf_ereal_minus)
 
 lemma ennreal_Sup_countable_SUP:
   "A \<noteq> {} \<Longrightarrow> \<exists>f::nat \<Rightarrow> ennreal. incseq f \<and> range f \<subseteq> A \<and> Sup A = (SUP i. f i)"
   unfolding incseq_def
   apply transfer
   subgoal for A
     using Sup_countable_SUP[of A]
     by (force simp add: incseq_def[symmetric] SUP_upper2 max.absorb2 image_subset_iff Sup_upper2 cong: conj_cong)
   done
 
 lemma ennreal_Inf_countable_INF:
   "A \<noteq> {} \<Longrightarrow> \<exists>f::nat \<Rightarrow> ennreal. decseq f \<and> range f \<subseteq> A \<and> Inf A = (INF i. f i)"
   unfolding decseq_def
   apply transfer
   subgoal for A
     using Inf_countable_INF[of A]
     apply (clarsimp simp flip: decseq_def)
     subgoal for f
       by (intro exI[of _ f]) auto
     done
   done
 
 lemma ennreal_SUP_countable_SUP:
   "A \<noteq> {} \<Longrightarrow> \<exists>f::nat \<Rightarrow> ennreal. range f \<subseteq> g`A \<and> Sup (g ` A) = Sup (f ` UNIV)"
   using ennreal_Sup_countable_SUP [of "g`A"] by auto
 
 lemma of_nat_tendsto_top_ennreal: "(\<lambda>n::nat. of_nat n :: ennreal) \<longlonglongrightarrow> top"
   using LIMSEQ_SUP[of "of_nat :: nat \<Rightarrow> ennreal"]
   by (simp add: ennreal_SUP_of_nat_eq_top incseq_def)
 
 lemma SUP_sup_continuous_ennreal:
   fixes f :: "ennreal \<Rightarrow> 'a::complete_lattice"
   assumes f: "sup_continuous f" and "I \<noteq> {}"
   shows "(SUP i\<in>I. f (g i)) = f (SUP i\<in>I. g i)"
 proof (rule antisym)
   show "(SUP i\<in>I. f (g i)) \<le> f (SUP i\<in>I. g i)"
     by (rule mono_SUP[OF sup_continuous_mono[OF f]])
   from ennreal_Sup_countable_SUP[of "g`I"] \<open>I \<noteq> {}\<close>
   obtain M :: "nat \<Rightarrow> ennreal" where "incseq M" and M: "range M \<subseteq> g ` I" and eq: "(SUP i \<in> I. g i) = (SUP i. M i)"
     by auto
   have "f (SUP i \<in> I. g i) = (SUP i \<in> range M. f i)"
     unfolding eq sup_continuousD[OF f \<open>mono M\<close>] by (simp add: image_comp)
   also have "\<dots> \<le> (SUP i \<in> I. f (g i))"
     by (insert M, drule SUP_subset_mono) (auto simp add: image_comp)
   finally show "f (SUP i \<in> I. g i) \<le> (SUP i \<in> I. f (g i))" .
 qed
 
 lemma ennreal_suminf_SUP_eq:
   fixes f :: "nat \<Rightarrow> nat \<Rightarrow> ennreal"
   shows "(\<And>i. incseq (\<lambda>n. f n i)) \<Longrightarrow> (\<Sum>i. SUP n. f n i) = (SUP n. \<Sum>i. f n i)"
   apply (rule ennreal_suminf_SUP_eq_directed)
   subgoal for N n j
     by (auto simp: incseq_def intro!:exI[of _ "max n j"])
   done
 
 lemma ennreal_SUP_add_left:
   fixes c :: ennreal
   shows "I \<noteq> {} \<Longrightarrow> (SUP i\<in>I. f i + c) = (SUP i\<in>I. f i) + c"
   apply transfer
   apply (simp add: SUP_ereal_add_left)
   by (metis SUP_upper all_not_in_conv ereal_le_add_mono1 max.absorb2 max.bounded_iff)
 
 lemma ennreal_SUP_const_minus:
   fixes f :: "'a \<Rightarrow> ennreal"
   shows "I \<noteq> {} \<Longrightarrow> c < top \<Longrightarrow> (INF x\<in>I. c - f x) = c - (SUP x\<in>I. f x)"
   apply (transfer fixing: I)
   unfolding ex_in_conv[symmetric]
   apply (auto simp add: SUP_upper2 sup_absorb2 simp flip: sup_ereal_def)
   apply (subst INF_ereal_minus_right[symmetric])
   apply (auto simp del: sup_ereal_def simp add: sup_INF)
   done
 
 (* Contributed by Dominique Unruh *)
 lemma isCont_ennreal[simp]: \<open>isCont ennreal x\<close>
   apply (auto intro!: sequentially_imp_eventually_within simp: continuous_within tendsto_def)
   by (metis tendsto_def tendsto_ennrealI)
 
 (* Contributed by Dominique Unruh *)
 lemma isCont_ennreal_of_enat[simp]: \<open>isCont ennreal_of_enat x\<close>
 proof -
   have continuous_at_open:
     \<comment> \<open>Copied lemma from \<^session>\<open>HOL-Analysis\<close> to avoid dependency.\<close>
       "continuous (at x) f \<longleftrightarrow> (\<forall>t. open t \<and> f x \<in> t --> (\<exists>s. open s \<and> x \<in> s \<and> (\<forall>x' \<in> s. (f x') \<in> t)))" for f :: \<open>enat \<Rightarrow> 'z::topological_space\<close>
     unfolding continuous_within_topological [of x UNIV f]
     unfolding imp_conjL
     by (intro all_cong imp_cong ex_cong conj_cong refl) auto
   show ?thesis
   proof (subst continuous_at_open, intro allI impI, cases \<open>x = \<infinity>\<close>)
     case True
 
     fix t assume \<open>open t \<and> ennreal_of_enat x \<in> t\<close>
     then have \<open>\<exists>y<\<infinity>. {y <.. \<infinity>} \<subseteq> t\<close>
       by (rule_tac open_left[where y=0]) (auto simp: True)
     then obtain y where \<open>{y<..} \<subseteq> t\<close> and \<open>y \<noteq> \<infinity>\<close>
       by fastforce
     from \<open>y \<noteq> \<infinity>\<close>
     obtain x' where x'y: \<open>ennreal_of_enat x' > y\<close> and \<open>x' \<noteq> \<infinity>\<close>
       by (metis enat.simps(3) ennreal_Ex_less_of_nat ennreal_of_enat_enat infinity_ennreal_def top.not_eq_extremum)
     define s where \<open>s = {x'<..}\<close>
     have \<open>open s\<close>
       by (simp add: s_def)
     moreover have \<open>x \<in> s\<close>
       by (simp add: \<open>x' \<noteq> \<infinity>\<close> s_def True)
     moreover have \<open>ennreal_of_enat z \<in> t\<close> if \<open>z \<in> s\<close> for z
       by (metis x'y \<open>{y<..} \<subseteq> t\<close> ennreal_of_enat_le_iff greaterThan_iff le_less_trans less_imp_le not_less s_def subsetD that)
     ultimately show \<open>\<exists>s. open s \<and> x \<in> s \<and> (\<forall>z\<in>s. ennreal_of_enat z \<in> t)\<close>
       by auto
   next
     case False
     fix t assume asm: \<open>open t \<and> ennreal_of_enat x \<in> t\<close>
     define s where \<open>s = {x}\<close>
     have \<open>open s\<close>
       using False open_enat_iff s_def by blast
     moreover have \<open>x \<in> s\<close>
       using s_def by auto
     moreover have \<open>ennreal_of_enat z \<in> t\<close> if \<open>z \<in> s\<close> for z
       using asm s_def that by blast
     ultimately show \<open>\<exists>s. open s \<and> x \<in> s \<and> (\<forall>z\<in>s. ennreal_of_enat z \<in> t)\<close>
       by auto
   qed
 qed
 
 subsection \<open>Approximation lemmas\<close>
 
 lemma INF_approx_ennreal:
   fixes x::ennreal and e::real
   assumes "e > 0"
   assumes INF: "x = (INF i \<in> A. f i)"
   assumes "x \<noteq> \<infinity>"
   shows "\<exists>i \<in> A. f i < x + e"
 proof -
   have "(INF i \<in> A. f i) < x + e"
     unfolding INF[symmetric] using \<open>0<e\<close> \<open>x \<noteq> \<infinity>\<close> by (cases x) auto
   then show ?thesis
     unfolding INF_less_iff .
 qed
 
 lemma SUP_approx_ennreal:
   fixes x::ennreal and e::real
   assumes "e > 0" "A \<noteq> {}"
   assumes SUP: "x = (SUP i \<in> A. f i)"
   assumes "x \<noteq> \<infinity>"
   shows "\<exists>i \<in> A. x < f i + e"
 proof -
   have "x < x + e"
     using \<open>0<e\<close> \<open>x \<noteq> \<infinity>\<close> by (cases x) auto
   also have "x + e = (SUP i \<in> A. f i + e)"
     unfolding SUP ennreal_SUP_add_left[OF \<open>A \<noteq> {}\<close>] ..
   finally show ?thesis
     unfolding less_SUP_iff .
 qed
 
 lemma ennreal_approx_SUP:
   fixes x::ennreal
   assumes f_bound: "\<And>i. i \<in> A \<Longrightarrow> f i \<le> x"
   assumes approx: "\<And>e. (e::real) > 0 \<Longrightarrow> \<exists>i \<in> A. x \<le> f i + e"
   shows "x = (SUP i \<in> A. f i)"
 proof (rule antisym)
   show "x \<le> (SUP i\<in>A. f i)"
   proof (rule ennreal_le_epsilon)
     fix e :: real assume "0 < e"
     from approx[OF this] obtain i where "i \<in> A" and *: "x \<le> f i + ennreal e"
       by blast
     from * have "x \<le> f i + e"
       by simp
     also have "\<dots> \<le> (SUP i\<in>A. f i) + e"
       by (intro add_mono \<open>i \<in> A\<close> SUP_upper order_refl)
     finally show "x \<le> (SUP i\<in>A. f i) + e" .
   qed
 qed (intro SUP_least f_bound)
 
 lemma ennreal_approx_INF:
   fixes x::ennreal
   assumes f_bound: "\<And>i. i \<in> A \<Longrightarrow> x \<le> f i"
   assumes approx: "\<And>e. (e::real) > 0 \<Longrightarrow> \<exists>i \<in> A. f i \<le> x + e"
   shows "x = (INF i \<in> A. f i)"
 proof (rule antisym)
   show "(INF i\<in>A. f i) \<le> x"
   proof (rule ennreal_le_epsilon)
     fix e :: real assume "0 < e"
     from approx[OF this] obtain i where "i\<in>A" "f i \<le> x + ennreal e"
       by blast
     then have "(INF i\<in>A. f i) \<le> f i"
       by (intro INF_lower)
     also have "\<dots> \<le> x + e"
       by fact
     finally show "(INF i\<in>A. f i) \<le> x + e" .
   qed
 qed (intro INF_greatest f_bound)
 
 lemma ennreal_approx_unit:
   "(\<And>a::ennreal. 0 < a \<Longrightarrow> a < 1 \<Longrightarrow> a * z \<le> y) \<Longrightarrow> z \<le> y"
   apply (subst SUP_mult_right_ennreal[of "\<lambda>x. x" "{0 <..< 1}" z, simplified])
   apply (auto intro: SUP_least)
   done
 
 lemma suminf_ennreal2:
   "(\<And>i. 0 \<le> f i) \<Longrightarrow> summable f \<Longrightarrow> (\<Sum>i. ennreal (f i)) = ennreal (\<Sum>i. f i)"
   using suminf_ennreal_eq by blast
 
 lemma less_top_ennreal: "x < top \<longleftrightarrow> (\<exists>r\<ge>0. x = ennreal r)"
   by (cases x) auto
 
 lemma enn2real_less_iff[simp]: "x < top \<Longrightarrow> enn2real x < c \<longleftrightarrow> x < c"
   using ennreal_less_iff less_top_ennreal by auto
 
 lemma enn2real_le_iff[simp]: "\<lbrakk>x < top; c > 0\<rbrakk> \<Longrightarrow> enn2real x \<le> c \<longleftrightarrow> x \<le> c"
   by (cases x) auto
 
 lemma enn2real_less:
   assumes "enn2real e < r" "e \<noteq> top" shows "e < ennreal r"
   using enn2real_less_iff assms top.not_eq_extremum by blast
 
 lemma enn2real_le:
   assumes "enn2real e \<le> r" "e \<noteq> top" shows "e \<le> ennreal r"
   by (metis assms enn2real_less ennreal_enn2real_if eq_iff less_le)
 
 lemma tendsto_top_iff_ennreal:
   fixes f :: "'a \<Rightarrow> ennreal"
   shows "(f \<longlongrightarrow> top) F \<longleftrightarrow> (\<forall>l\<ge>0. eventually (\<lambda>x. ennreal l < f x) F)"
   by (auto simp: less_top_ennreal order_tendsto_iff )
 
 lemma ennreal_tendsto_top_eq_at_top:
   "((\<lambda>z. ennreal (f z)) \<longlongrightarrow> top) F \<longleftrightarrow> (LIM z F. f z :> at_top)"
   unfolding filterlim_at_top_dense tendsto_top_iff_ennreal
   apply (auto simp: ennreal_less_iff)
   subgoal for y
     by (auto elim!: eventually_mono allE[of _ "max 0 y"])
   done
 
 lemma tendsto_0_if_Limsup_eq_0_ennreal:
   fixes f :: "_ \<Rightarrow> ennreal"
   shows "Limsup F f = 0 \<Longrightarrow> (f \<longlongrightarrow> 0) F"
   using Liminf_le_Limsup[of F f] tendsto_iff_Liminf_eq_Limsup[of F f 0]
   by (cases "F = bot") auto
 
 lemma diff_le_self_ennreal[simp]: "a - b \<le> (a::ennreal)"
   by (cases a b rule: ennreal2_cases) (auto simp: ennreal_minus)
 
 lemma ennreal_ineq_diff_add: "b \<le> a \<Longrightarrow> a = b + (a - b::ennreal)"
   by transfer (auto simp: ereal_diff_positive max.absorb2 ereal_ineq_diff_add)
 
 lemma ennreal_mult_strict_left_mono: "(a::ennreal) < c \<Longrightarrow> 0 < b \<Longrightarrow> b < top \<Longrightarrow> b * a < b * c"
   by transfer (auto intro!: ereal_mult_strict_left_mono)
 
 lemma ennreal_between: "0 < e \<Longrightarrow> 0 < x \<Longrightarrow> x < top \<Longrightarrow> x - e < (x::ennreal)"
   by transfer (auto intro!: ereal_between)
 
 lemma minus_less_iff_ennreal: "b < top \<Longrightarrow> b \<le> a \<Longrightarrow> a - b < c \<longleftrightarrow> a < c + (b::ennreal)"
   by transfer
      (auto simp: top_ereal_def ereal_minus_less le_less)
 
 lemma tendsto_zero_ennreal:
   assumes ev: "\<And>r. 0 < r \<Longrightarrow> \<forall>\<^sub>F x in F. f x < ennreal r"
   shows "(f \<longlongrightarrow> 0) F"
 proof (rule order_tendstoI)
   fix e::ennreal assume "e > 0"
   obtain e'::real where "e' > 0" "ennreal e' < e"
     using \<open>0 < e\<close> dense[of 0 "if e = top then 1 else (enn2real e)"]
     by (cases e) (auto simp: ennreal_less_iff)
   from ev[OF \<open>e' > 0\<close>] show "\<forall>\<^sub>F x in F. f x < e"
     by eventually_elim (insert \<open>ennreal e' < e\<close>, auto)
 qed simp
 
 lifting_update ennreal.lifting
 lifting_forget ennreal.lifting
 
 
 subsection \<open>\<^typ>\<open>ennreal\<close> theorems\<close>
 
 lemma neq_top_trans: fixes x y :: ennreal shows "\<lbrakk> y \<noteq> top; x \<le> y \<rbrakk> \<Longrightarrow> x \<noteq> top"
   by (auto simp: top_unique)
 
 lemma diff_diff_ennreal: fixes a b :: ennreal shows "a \<le> b \<Longrightarrow> b \<noteq> \<infinity> \<Longrightarrow> b - (b - a) = a"
   by (cases a b rule: ennreal2_cases) (auto simp: ennreal_minus top_unique)
 
 lemma ennreal_less_one_iff[simp]: "ennreal x < 1 \<longleftrightarrow> x < 1"
   by (cases "0 \<le> x") (auto simp: ennreal_neg ennreal_less_iff simp flip: ennreal_1)
 
 lemma SUP_const_minus_ennreal:
   fixes f :: "'a \<Rightarrow> ennreal" shows "I \<noteq> {} \<Longrightarrow> (SUP x\<in>I. c - f x) = c - (INF x\<in>I. f x)"
   including ennreal.lifting
   by (transfer fixing: I)
      (simp add: SUP_sup_distrib[symmetric] SUP_ereal_minus_right
            flip: sup_ereal_def)
 
 lemma zero_minus_ennreal[simp]: "0 - (a::ennreal) = 0"
   including ennreal.lifting
   by transfer (simp split: split_max)
 
 lemma diff_diff_commute_ennreal:
   fixes a b c :: ennreal shows "a - b - c = a - c - b"
   by (cases a b c rule: ennreal3_cases) (simp_all add: ennreal_minus field_simps)
 
 lemma diff_gr0_ennreal: "b < (a::ennreal) \<Longrightarrow> 0 < a - b"
   including ennreal.lifting by transfer (auto simp: ereal_diff_gr0 ereal_diff_positive split: split_max)
 
 lemma divide_le_posI_ennreal:
   fixes x y z :: ennreal
   shows "x > 0 \<Longrightarrow> z \<le> x * y \<Longrightarrow> z / x \<le> y"
   by (cases x y z rule: ennreal3_cases)
      (auto simp: divide_ennreal ennreal_mult[symmetric] field_simps top_unique)
 
 lemma add_diff_eq_ennreal:
   fixes x y z :: ennreal
   shows "z \<le> y \<Longrightarrow> x + (y - z) = x + y - z"
   using ennreal_diff_add_assoc by auto
 
 lemma add_diff_inverse_ennreal:
   fixes x y :: ennreal shows "x \<le> y \<Longrightarrow> x + (y - x) = y"
   by (cases x) (simp_all add: top_unique add_diff_eq_ennreal)
 
 lemma add_diff_eq_iff_ennreal[simp]:
   fixes x y :: ennreal shows "x + (y - x) = y \<longleftrightarrow> x \<le> y"
 proof
   assume *: "x + (y - x) = y" show "x \<le> y"
     by (subst *[symmetric]) simp
 qed (simp add: add_diff_inverse_ennreal)
 
 lemma add_diff_le_ennreal: "a + b - c \<le> a + (b - c::ennreal)"
   apply (cases a b c rule: ennreal3_cases)
   subgoal for a' b' c'
     by (cases "0 \<le> b' - c'") (simp_all add: ennreal_minus top_add ennreal_neg flip: ennreal_plus)
   apply (simp_all add: top_add flip: ennreal_plus)
   done
 
 lemma diff_eq_0_ennreal: "a < top \<Longrightarrow> a \<le> b \<Longrightarrow> a - b = (0::ennreal)"
   using ennreal_minus_pos_iff gr_zeroI not_less by blast
 
 lemma diff_diff_ennreal': fixes x y z :: ennreal shows "z \<le> y \<Longrightarrow> y - z \<le> x \<Longrightarrow> x - (y - z) = x + z - y"
   by (cases x; cases y; cases z)
      (auto simp add: top_add add_top minus_top_ennreal ennreal_minus top_unique
            simp flip: ennreal_plus)
 
 lemma diff_diff_ennreal'': fixes x y z :: ennreal
   shows "z \<le> y \<Longrightarrow> x - (y - z) = (if y - z \<le> x then x + z - y else 0)"
   by (cases x; cases y; cases z)
      (auto simp add: top_add add_top minus_top_ennreal ennreal_minus top_unique ennreal_neg
            simp flip: ennreal_plus)
 
 lemma power_less_top_ennreal: fixes x :: ennreal shows "x ^ n < top \<longleftrightarrow> x < top \<or> n = 0"
   using power_eq_top_ennreal[of x n] by (auto simp: less_top)
 
 lemma ennreal_divide_times: "(a / b) * c = a * (c / b :: ennreal)"
   by (simp add: mult.commute ennreal_times_divide)
 
 lemma diff_less_top_ennreal: "a - b < top \<longleftrightarrow>  a < (top :: ennreal)"
   by (cases a; cases b) (auto simp: ennreal_minus)
 
 lemma divide_less_ennreal: "b \<noteq> 0 \<Longrightarrow> b < top \<Longrightarrow> a / b < c \<longleftrightarrow> a < (c * b :: ennreal)"
   by (cases a; cases b; cases c)
      (auto simp: divide_ennreal ennreal_mult[symmetric] ennreal_less_iff field_simps ennreal_top_mult ennreal_top_divide)
 
 lemma one_less_numeral[simp]: "1 < (numeral n::ennreal) \<longleftrightarrow> (num.One < n)"
   by (simp flip: ennreal_1 ennreal_numeral add: ennreal_less_iff)
 
 lemma divide_eq_1_ennreal: "a / b = (1::ennreal) \<longleftrightarrow> (b \<noteq> top \<and> b \<noteq> 0 \<and> b = a)"
   by (cases a ; cases b; cases "b = 0") (auto simp: ennreal_top_divide divide_ennreal split: if_split_asm)
 
 lemma ennreal_mult_cancel_left: "(a * b = a * c) = (a = top \<and> b \<noteq> 0 \<and> c \<noteq> 0 \<or> a = 0 \<or> b = (c::ennreal))"
   by (cases a; cases b; cases c) (auto simp: ennreal_mult[symmetric] ennreal_mult_top ennreal_top_mult)
 
 lemma ennreal_minus_if: "ennreal a - ennreal b = ennreal (if 0 \<le> b then (if b \<le> a then a - b else 0) else a)"
   by (auto simp: ennreal_minus ennreal_neg)
 
 lemma ennreal_plus_if: "ennreal a + ennreal b = ennreal (if 0 \<le> a then (if 0 \<le> b then a + b else a) else b)"
   by (auto simp: ennreal_neg)
 
 lemma power_le_one_iff: "0 \<le> (a::real) \<Longrightarrow> a ^ n \<le> 1 \<longleftrightarrow> (n = 0 \<or> a \<le> 1)"
   by (metis (mono_tags, opaque_lifting) le_less neq0_conv not_le one_le_power power_0 power_eq_imp_eq_base power_le_one zero_le_one)
 
 lemma ennreal_diff_le_mono_left: "a \<le> b \<Longrightarrow> a - c \<le> (b::ennreal)"
   using ennreal_mono_minus[of 0 c a, THEN order_trans, of b] by simp
 
 lemma ennreal_minus_le_iff: "a - b \<le> c \<longleftrightarrow> (a \<le> b + (c::ennreal) \<and> (a = top \<and> b = top \<longrightarrow> c = top))"
   by (cases a; cases b; cases c)
      (auto simp: top_unique top_add add_top ennreal_minus simp flip: ennreal_plus)
 
 lemma ennreal_le_minus_iff: "a \<le> b - c \<longleftrightarrow> (a + c \<le> (b::ennreal) \<or> (a = 0 \<and> b \<le> c))"
   by (cases a; cases b; cases c)
      (auto simp: top_unique top_add add_top ennreal_minus ennreal_le_iff2
            simp flip: ennreal_plus)
 
 lemma diff_add_eq_diff_diff_swap_ennreal: "x - (y + z :: ennreal) = x - y - z"
   by (cases x; cases y; cases z)
      (auto simp: ennreal_minus_if add_top top_add simp flip: ennreal_plus)
 
 lemma diff_add_assoc2_ennreal: "b \<le> a \<Longrightarrow> (a - b + c::ennreal) = a + c - b"
   by (cases a; cases b; cases c)
      (auto simp add: ennreal_minus_if ennreal_plus_if add_top top_add top_unique simp del: ennreal_plus)
 
 lemma diff_gt_0_iff_gt_ennreal: "0 < a - b \<longleftrightarrow> (a = top \<and> b = top \<or> b < (a::ennreal))"
   by (cases a; cases b) (auto simp: ennreal_minus_if ennreal_less_iff)
 
 lemma diff_eq_0_iff_ennreal: "(a - b::ennreal) = 0 \<longleftrightarrow> (a < top \<and> a \<le> b)"
   by (cases a) (auto simp: ennreal_minus_eq_0 diff_eq_0_ennreal)
 
 lemma add_diff_self_ennreal: "a + (b - a::ennreal) = (if a \<le> b then b else a)"
   by (auto simp: diff_eq_0_iff_ennreal less_top)
 
 lemma diff_add_self_ennreal: "(b - a + a::ennreal) = (if a \<le> b then b else a)"
   by (auto simp: diff_add_cancel_ennreal diff_eq_0_iff_ennreal less_top)
 
 lemma ennreal_minus_cancel_iff:
   fixes a b c :: ennreal
   shows "a - b = a - c \<longleftrightarrow> (b = c \<or> (a \<le> b \<and> a \<le> c) \<or> a = top)"
   by (cases a; cases b; cases c) (auto simp: ennreal_minus_if)
 
 text \<open>The next lemma is wrong for $a = top$, for $b = c = 1$ for instance.\<close>
 
 lemma ennreal_right_diff_distrib:
   fixes a b c :: ennreal
   assumes "a \<noteq> top"
   shows "a * (b - c) = a * b - a * c"
   apply (cases a; cases b; cases c)
          apply (use assms in \<open>auto simp add: ennreal_mult_top ennreal_minus ennreal_mult' [symmetric]\<close>)
   apply (simp add: algebra_simps)
   done
 
 lemma SUP_diff_ennreal:
   "c < top \<Longrightarrow> (SUP i\<in>I. f i - c :: ennreal) = (SUP i\<in>I. f i) - c"
   by (auto intro!: SUP_eqI ennreal_minus_mono SUP_least intro: SUP_upper
            simp: ennreal_minus_cancel_iff ennreal_minus_le_iff less_top[symmetric])
 
 lemma ennreal_SUP_add_right:
   fixes c :: ennreal shows "I \<noteq> {} \<Longrightarrow> c + (SUP i\<in>I. f i) = (SUP i\<in>I. c + f i)"
   using ennreal_SUP_add_left[of I f c] by (simp add: add.commute)
 
 lemma SUP_add_directed_ennreal:
   fixes f g :: "_ \<Rightarrow> ennreal"
   assumes directed: "\<And>i j. i \<in> I \<Longrightarrow> j \<in> I \<Longrightarrow> \<exists>k\<in>I. f i + g j \<le> f k + g k"
   shows "(SUP i\<in>I. f i + g i) = (SUP i\<in>I. f i) + (SUP i\<in>I. g i)"
 proof (cases "I = {}")
   case False
   show ?thesis
   proof (rule antisym)
     show "(SUP i\<in>I. f i + g i) \<le> (SUP i\<in>I. f i) + (SUP i\<in>I. g i)"
       by (rule SUP_least; intro add_mono SUP_upper)
   next
     have "(SUP i\<in>I. f i) + (SUP i\<in>I. g i) = (SUP i\<in>I. f i + (SUP i\<in>I. g i))"
       by (intro ennreal_SUP_add_left[symmetric] \<open>I \<noteq> {}\<close>)
     also have "\<dots> = (SUP i\<in>I. (SUP j\<in>I. f i + g j))"
       using \<open>I \<noteq> {}\<close> by (simp add: ennreal_SUP_add_right)
     also have "\<dots> \<le> (SUP i\<in>I. f i + g i)"
       using directed by (intro SUP_least) (blast intro: SUP_upper2)
     finally show "(SUP i\<in>I. f i) + (SUP i\<in>I. g i) \<le> (SUP i\<in>I. f i + g i)" .
   qed
 qed (simp add: bot_ereal_def)
 
 
 lemma enn2real_eq_0_iff: "enn2real x = 0 \<longleftrightarrow> x = 0 \<or> x = top"
   by (cases x) auto
 
 lemma continuous_on_diff_ennreal:
   "continuous_on A f \<Longrightarrow> continuous_on A g \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> f x \<noteq> top) \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> g x \<noteq> top) \<Longrightarrow> continuous_on A (\<lambda>z. f z - g z::ennreal)"
   including ennreal.lifting
 proof (transfer fixing: A, simp add: top_ereal_def)
   fix f g :: "'a \<Rightarrow> ereal" assume "\<forall>x. 0 \<le> f x" "\<forall>x. 0 \<le> g x" "continuous_on A f" "continuous_on A g"
   moreover assume "f x \<noteq> \<infinity>" "g x \<noteq> \<infinity>" if "x \<in> A" for x
   ultimately show "continuous_on A (\<lambda>z. max 0 (f z - g z))"
     by (intro continuous_on_max continuous_on_const continuous_on_diff_ereal) auto
 qed
 
 lemma tendsto_diff_ennreal:
   "(f \<longlongrightarrow> x) F \<Longrightarrow> (g \<longlongrightarrow> y) F \<Longrightarrow> x \<noteq> top \<Longrightarrow> y \<noteq> top \<Longrightarrow> ((\<lambda>z. f z - g z::ennreal) \<longlongrightarrow> x - y) F"
   using continuous_on_tendsto_compose[where f="\<lambda>x. fst x - snd x::ennreal" and s="{(x, y). x \<noteq> top \<and> y \<noteq> top}" and g="\<lambda>x. (f x, g x)" and l="(x, y)" and F="F",
     OF continuous_on_diff_ennreal]
   by (auto simp: tendsto_Pair eventually_conj_iff less_top order_tendstoD continuous_on_fst continuous_on_snd continuous_on_id)
 
 declare lim_real_of_ereal [tendsto_intros]
 
 lemma tendsto_enn2real [tendsto_intros]:
   assumes "(u \<longlongrightarrow> ennreal l) F" "l \<ge> 0"
   shows "((\<lambda>n. enn2real (u n)) \<longlongrightarrow> l) F"
   unfolding enn2real_def
   by (metis assms enn2ereal_ennreal lim_real_of_ereal tendsto_enn2erealI)
 
 end
diff --git a/src/HOL/Library/Multiset.thy b/src/HOL/Library/Multiset.thy
--- a/src/HOL/Library/Multiset.thy
+++ b/src/HOL/Library/Multiset.thy
@@ -1,4526 +1,4526 @@
 (*  Title:      HOL/Library/Multiset.thy
     Author:     Tobias Nipkow, Markus Wenzel, Lawrence C Paulson, Norbert Voelker
     Author:     Andrei Popescu, TU Muenchen
     Author:     Jasmin Blanchette, Inria, LORIA, MPII
     Author:     Dmitriy Traytel, TU Muenchen
     Author:     Mathias Fleury, MPII
     Author:     Martin Desharnais, MPI-INF Saarbruecken
 *)
 
 section \<open>(Finite) Multisets\<close>
 
 theory Multiset
   imports Cancellation
 begin
 
 subsection \<open>The type of multisets\<close>
 
 typedef 'a multiset = \<open>{f :: 'a \<Rightarrow> nat. finite {x. f x > 0}}\<close>
   morphisms count Abs_multiset
 proof
   show \<open>(\<lambda>x. 0::nat) \<in> {f. finite {x. f x > 0}}\<close>
     by simp
 qed
 
 setup_lifting type_definition_multiset
 
 lemma count_Abs_multiset:
   \<open>count (Abs_multiset f) = f\<close> if \<open>finite {x. f x > 0}\<close>
   by (rule Abs_multiset_inverse) (simp add: that)
 
 lemma multiset_eq_iff: "M = N \<longleftrightarrow> (\<forall>a. count M a = count N a)"
   by (simp only: count_inject [symmetric] fun_eq_iff)
 
 lemma multiset_eqI: "(\<And>x. count A x = count B x) \<Longrightarrow> A = B"
   using multiset_eq_iff by auto
 
 text \<open>Preservation of the representing set \<^term>\<open>multiset\<close>.\<close>
 
 lemma diff_preserves_multiset:
   \<open>finite {x. 0 < M x - N x}\<close> if \<open>finite {x. 0 < M x}\<close> for M N :: \<open>'a \<Rightarrow> nat\<close>
   using that by (rule rev_finite_subset) auto
 
 lemma filter_preserves_multiset:
   \<open>finite {x. 0 < (if P x then M x else 0)}\<close> if \<open>finite {x. 0 < M x}\<close> for M N :: \<open>'a \<Rightarrow> nat\<close>
   using that by (rule rev_finite_subset) auto
 
 lemmas in_multiset = diff_preserves_multiset filter_preserves_multiset
 
 
 subsection \<open>Representing multisets\<close>
 
 text \<open>Multiset enumeration\<close>
 
 instantiation multiset :: (type) cancel_comm_monoid_add
 begin
 
 lift_definition zero_multiset :: \<open>'a multiset\<close>
   is \<open>\<lambda>a. 0\<close>
   by simp
 
 abbreviation empty_mset :: \<open>'a multiset\<close> (\<open>{#}\<close>)
   where \<open>empty_mset \<equiv> 0\<close>
 
 lift_definition plus_multiset :: \<open>'a multiset \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset\<close>
   is \<open>\<lambda>M N a. M a + N a\<close>
   by simp
 
 lift_definition minus_multiset :: \<open>'a multiset \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset\<close>
   is \<open>\<lambda>M N a. M a - N a\<close>
   by (rule diff_preserves_multiset)
 
 instance
   by (standard; transfer) (simp_all add: fun_eq_iff)
 
 end
 
 context
 begin
 
 qualified definition is_empty :: "'a multiset \<Rightarrow> bool" where
   [code_abbrev]: "is_empty A \<longleftrightarrow> A = {#}"
 
 end
 
 lemma add_mset_in_multiset:
   \<open>finite {x. 0 < (if x = a then Suc (M x) else M x)}\<close>
   if \<open>finite {x. 0 < M x}\<close>
   using that by (simp add: flip: insert_Collect)
 
 lift_definition add_mset :: "'a \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset" is
   "\<lambda>a M b. if b = a then Suc (M b) else M b"
 by (rule add_mset_in_multiset)
 
 syntax
   "_multiset" :: "args \<Rightarrow> 'a multiset"    ("{#(_)#}")
 translations
   "{#x, xs#}" == "CONST add_mset x {#xs#}"
   "{#x#}" == "CONST add_mset x {#}"
 
 lemma count_empty [simp]: "count {#} a = 0"
   by (simp add: zero_multiset.rep_eq)
 
 lemma count_add_mset [simp]:
   "count (add_mset b A) a = (if b = a then Suc (count A a) else count A a)"
   by (simp add: add_mset.rep_eq)
 
 lemma count_single: "count {#b#} a = (if b = a then 1 else 0)"
   by simp
 
 lemma
   add_mset_not_empty [simp]: \<open>add_mset a A \<noteq> {#}\<close> and
   empty_not_add_mset [simp]: "{#} \<noteq> add_mset a A"
   by (auto simp: multiset_eq_iff)
 
 lemma add_mset_add_mset_same_iff [simp]:
   "add_mset a A = add_mset a B \<longleftrightarrow> A = B"
   by (auto simp: multiset_eq_iff)
 
 lemma add_mset_commute:
   "add_mset x (add_mset y M) = add_mset y (add_mset x M)"
   by (auto simp: multiset_eq_iff)
 
 
 subsection \<open>Basic operations\<close>
 
 subsubsection \<open>Conversion to set and membership\<close>
 
 definition set_mset :: \<open>'a multiset \<Rightarrow> 'a set\<close>
   where \<open>set_mset M = {x. count M x > 0}\<close>
 
 abbreviation member_mset :: \<open>'a \<Rightarrow> 'a multiset \<Rightarrow> bool\<close>
   where \<open>member_mset a M \<equiv> a \<in> set_mset M\<close>
 
 notation
   member_mset  (\<open>'(\<in>#')\<close>) and
   member_mset  (\<open>(_/ \<in># _)\<close> [50, 51] 50)
 
 notation  (ASCII)
   member_mset  (\<open>'(:#')\<close>) and
   member_mset  (\<open>(_/ :# _)\<close> [50, 51] 50)
 
 abbreviation not_member_mset :: \<open>'a \<Rightarrow> 'a multiset \<Rightarrow> bool\<close>
   where \<open>not_member_mset a M \<equiv> a \<notin> set_mset M\<close>
 
 notation
   not_member_mset  (\<open>'(\<notin>#')\<close>) and
   not_member_mset  (\<open>(_/ \<notin># _)\<close> [50, 51] 50)
 
 notation  (ASCII)
   not_member_mset  (\<open>'(~:#')\<close>) and
   not_member_mset  (\<open>(_/ ~:# _)\<close> [50, 51] 50)
 
 context
 begin
 
 qualified abbreviation Ball :: "'a multiset \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
   where "Ball M \<equiv> Set.Ball (set_mset M)"
 
 qualified abbreviation Bex :: "'a multiset \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
   where "Bex M \<equiv> Set.Bex (set_mset M)"
 
 end
 
 syntax
   "_MBall"       :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool"      ("(3\<forall>_\<in>#_./ _)" [0, 0, 10] 10)
   "_MBex"        :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool"      ("(3\<exists>_\<in>#_./ _)" [0, 0, 10] 10)
 
 syntax  (ASCII)
   "_MBall"       :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool"      ("(3\<forall>_:#_./ _)" [0, 0, 10] 10)
   "_MBex"        :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool"      ("(3\<exists>_:#_./ _)" [0, 0, 10] 10)
 
 translations
   "\<forall>x\<in>#A. P" \<rightleftharpoons> "CONST Multiset.Ball A (\<lambda>x. P)"
   "\<exists>x\<in>#A. P" \<rightleftharpoons> "CONST Multiset.Bex A (\<lambda>x. P)"
 
 print_translation \<open>
  [Syntax_Trans.preserve_binder_abs2_tr' \<^const_syntax>\<open>Multiset.Ball\<close> \<^syntax_const>\<open>_MBall\<close>,
   Syntax_Trans.preserve_binder_abs2_tr' \<^const_syntax>\<open>Multiset.Bex\<close> \<^syntax_const>\<open>_MBex\<close>]
 \<close> \<comment> \<open>to avoid eta-contraction of body\<close>
 
 lemma count_eq_zero_iff:
   "count M x = 0 \<longleftrightarrow> x \<notin># M"
   by (auto simp add: set_mset_def)
 
 lemma not_in_iff:
   "x \<notin># M \<longleftrightarrow> count M x = 0"
   by (auto simp add: count_eq_zero_iff)
 
 lemma count_greater_zero_iff [simp]:
   "count M x > 0 \<longleftrightarrow> x \<in># M"
   by (auto simp add: set_mset_def)
 
 lemma count_inI:
   assumes "count M x = 0 \<Longrightarrow> False"
   shows "x \<in># M"
 proof (rule ccontr)
   assume "x \<notin># M"
   with assms show False by (simp add: not_in_iff)
 qed
 
 lemma in_countE:
   assumes "x \<in># M"
   obtains n where "count M x = Suc n"
 proof -
   from assms have "count M x > 0" by simp
   then obtain n where "count M x = Suc n"
     using gr0_conv_Suc by blast
   with that show thesis .
 qed
 
 lemma count_greater_eq_Suc_zero_iff [simp]:
   "count M x \<ge> Suc 0 \<longleftrightarrow> x \<in># M"
   by (simp add: Suc_le_eq)
 
 lemma count_greater_eq_one_iff [simp]:
   "count M x \<ge> 1 \<longleftrightarrow> x \<in># M"
   by simp
 
 lemma set_mset_empty [simp]:
   "set_mset {#} = {}"
   by (simp add: set_mset_def)
 
 lemma set_mset_single:
   "set_mset {#b#} = {b}"
   by (simp add: set_mset_def)
 
 lemma set_mset_eq_empty_iff [simp]:
   "set_mset M = {} \<longleftrightarrow> M = {#}"
   by (auto simp add: multiset_eq_iff count_eq_zero_iff)
 
 lemma finite_set_mset [iff]:
   "finite (set_mset M)"
   using count [of M] by simp
 
 lemma set_mset_add_mset_insert [simp]: \<open>set_mset (add_mset a A) = insert a (set_mset A)\<close>
   by (auto simp flip: count_greater_eq_Suc_zero_iff split: if_splits)
 
 lemma multiset_nonemptyE [elim]:
   assumes "A \<noteq> {#}"
   obtains x where "x \<in># A"
 proof -
   have "\<exists>x. x \<in># A" by (rule ccontr) (insert assms, auto)
   with that show ?thesis by blast
 qed
 
 
 subsubsection \<open>Union\<close>
 
 lemma count_union [simp]:
   "count (M + N) a = count M a + count N a"
   by (simp add: plus_multiset.rep_eq)
 
 lemma set_mset_union [simp]:
   "set_mset (M + N) = set_mset M \<union> set_mset N"
   by (simp only: set_eq_iff count_greater_zero_iff [symmetric] count_union) simp
 
 lemma union_mset_add_mset_left [simp]:
   "add_mset a A + B = add_mset a (A + B)"
   by (auto simp: multiset_eq_iff)
 
 lemma union_mset_add_mset_right [simp]:
   "A + add_mset a B = add_mset a (A + B)"
   by (auto simp: multiset_eq_iff)
 
 lemma add_mset_add_single: \<open>add_mset a A = A + {#a#}\<close>
   by (subst union_mset_add_mset_right, subst add.comm_neutral) standard
 
 
 subsubsection \<open>Difference\<close>
 
 instance multiset :: (type) comm_monoid_diff
   by standard (transfer; simp add: fun_eq_iff)
 
 lemma count_diff [simp]:
   "count (M - N) a = count M a - count N a"
   by (simp add: minus_multiset.rep_eq)
 
 lemma add_mset_diff_bothsides:
   \<open>add_mset a M - add_mset a A = M - A\<close>
   by (auto simp: multiset_eq_iff)
 
 lemma in_diff_count:
   "a \<in># M - N \<longleftrightarrow> count N a < count M a"
   by (simp add: set_mset_def)
 
 lemma count_in_diffI:
   assumes "\<And>n. count N x = n + count M x \<Longrightarrow> False"
   shows "x \<in># M - N"
 proof (rule ccontr)
   assume "x \<notin># M - N"
   then have "count N x = (count N x - count M x) + count M x"
     by (simp add: in_diff_count not_less)
   with assms show False by auto
 qed
 
 lemma in_diff_countE:
   assumes "x \<in># M - N"
   obtains n where "count M x = Suc n + count N x"
 proof -
   from assms have "count M x - count N x > 0" by (simp add: in_diff_count)
   then have "count M x > count N x" by simp
   then obtain n where "count M x = Suc n + count N x"
     using less_iff_Suc_add by auto
   with that show thesis .
 qed
 
 lemma in_diffD:
   assumes "a \<in># M - N"
   shows "a \<in># M"
 proof -
   have "0 \<le> count N a" by simp
   also from assms have "count N a < count M a"
     by (simp add: in_diff_count)
   finally show ?thesis by simp
 qed
 
 lemma set_mset_diff:
   "set_mset (M - N) = {a. count N a < count M a}"
   by (simp add: set_mset_def)
 
 lemma diff_empty [simp]: "M - {#} = M \<and> {#} - M = {#}"
   by rule (fact Groups.diff_zero, fact Groups.zero_diff)
 
 lemma diff_cancel: "A - A = {#}"
   by (fact Groups.diff_cancel)
 
 lemma diff_union_cancelR: "M + N - N = (M::'a multiset)"
   by (fact add_diff_cancel_right')
 
 lemma diff_union_cancelL: "N + M - N = (M::'a multiset)"
   by (fact add_diff_cancel_left')
 
 lemma diff_right_commute:
   fixes M N Q :: "'a multiset"
   shows "M - N - Q = M - Q - N"
   by (fact diff_right_commute)
 
 lemma diff_add:
   fixes M N Q :: "'a multiset"
   shows "M - (N + Q) = M - N - Q"
   by (rule sym) (fact diff_diff_add)
 
 lemma insert_DiffM [simp]: "x \<in># M \<Longrightarrow> add_mset x (M - {#x#}) = M"
   by (clarsimp simp: multiset_eq_iff)
 
 lemma insert_DiffM2: "x \<in># M \<Longrightarrow> (M - {#x#}) + {#x#} = M"
   by simp
 
 lemma diff_union_swap: "a \<noteq> b \<Longrightarrow> add_mset b (M - {#a#}) = add_mset b M - {#a#}"
   by (auto simp add: multiset_eq_iff)
 
 lemma diff_add_mset_swap [simp]: "b \<notin># A \<Longrightarrow> add_mset b M - A = add_mset b (M - A)"
   by (auto simp add: multiset_eq_iff simp: not_in_iff)
 
 lemma diff_union_swap2 [simp]: "y \<in># M \<Longrightarrow> add_mset x M - {#y#} = add_mset x (M - {#y#})"
   by (metis add_mset_diff_bothsides diff_union_swap diff_zero insert_DiffM)
 
 lemma diff_diff_add_mset [simp]: "(M::'a multiset) - N - P = M - (N + P)"
   by (rule diff_diff_add)
 
 lemma diff_union_single_conv:
   "a \<in># J \<Longrightarrow> I + J - {#a#} = I + (J - {#a#})"
   by (simp add: multiset_eq_iff Suc_le_eq)
 
 lemma mset_add [elim?]:
   assumes "a \<in># A"
   obtains B where "A = add_mset a B"
 proof -
   from assms have "A = add_mset a (A - {#a#})"
     by simp
   with that show thesis .
 qed
 
 lemma union_iff:
   "a \<in># A + B \<longleftrightarrow> a \<in># A \<or> a \<in># B"
   by auto
 
 lemma count_minus_inter_lt_count_minus_inter_iff:
   "count (M2 - M1) y < count (M1 - M2) y \<longleftrightarrow> y \<in># M1 - M2"
   by (meson count_greater_zero_iff gr_implies_not_zero in_diff_count leI order.strict_trans2
       order_less_asym)
 
 lemma minus_inter_eq_minus_inter_iff:
   "(M1 - M2) = (M2 - M1) \<longleftrightarrow> set_mset (M1 - M2) = set_mset (M2 - M1)"
   by (metis add.commute count_diff count_eq_zero_iff diff_add_zero in_diff_countE multiset_eq_iff)
 
 
 subsubsection \<open>Min and Max\<close>
 
 abbreviation Min_mset :: "'a::linorder multiset \<Rightarrow> 'a" where
 "Min_mset m \<equiv> Min (set_mset m)"
 
 abbreviation Max_mset :: "'a::linorder multiset \<Rightarrow> 'a" where
 "Max_mset m \<equiv> Max (set_mset m)"
 
 
 subsubsection \<open>Equality of multisets\<close>
 
 lemma single_eq_single [simp]: "{#a#} = {#b#} \<longleftrightarrow> a = b"
   by (auto simp add: multiset_eq_iff)
 
 lemma union_eq_empty [iff]: "M + N = {#} \<longleftrightarrow> M = {#} \<and> N = {#}"
   by (auto simp add: multiset_eq_iff)
 
 lemma empty_eq_union [iff]: "{#} = M + N \<longleftrightarrow> M = {#} \<and> N = {#}"
   by (auto simp add: multiset_eq_iff)
 
 lemma multi_self_add_other_not_self [simp]: "M = add_mset x M \<longleftrightarrow> False"
   by (auto simp add: multiset_eq_iff)
 
 lemma add_mset_remove_trivial [simp]: \<open>add_mset x M - {#x#} = M\<close>
   by (auto simp: multiset_eq_iff)
 
 lemma diff_single_trivial: "\<not> x \<in># M \<Longrightarrow> M - {#x#} = M"
   by (auto simp add: multiset_eq_iff not_in_iff)
 
 lemma diff_single_eq_union: "x \<in># M \<Longrightarrow> M - {#x#} = N \<longleftrightarrow> M = add_mset x N"
   by auto
 
 lemma union_single_eq_diff: "add_mset x M = N \<Longrightarrow> M = N - {#x#}"
   unfolding add_mset_add_single[of _ M] by (fact add_implies_diff)
 
 lemma union_single_eq_member: "add_mset x M = N \<Longrightarrow> x \<in># N"
   by auto
 
 lemma add_mset_remove_trivial_If:
   "add_mset a (N - {#a#}) = (if a \<in># N then N else add_mset a N)"
   by (simp add: diff_single_trivial)
 
 lemma add_mset_remove_trivial_eq: \<open>N = add_mset a (N - {#a#}) \<longleftrightarrow> a \<in># N\<close>
   by (auto simp: add_mset_remove_trivial_If)
 
 lemma union_is_single:
   "M + N = {#a#} \<longleftrightarrow> M = {#a#} \<and> N = {#} \<or> M = {#} \<and> N = {#a#}"
   (is "?lhs = ?rhs")
 proof
   show ?lhs if ?rhs using that by auto
   show ?rhs if ?lhs
     by (metis Multiset.diff_cancel add.commute add_diff_cancel_left' diff_add_zero diff_single_trivial insert_DiffM that)
 qed
 
 lemma single_is_union: "{#a#} = M + N \<longleftrightarrow> {#a#} = M \<and> N = {#} \<or> M = {#} \<and> {#a#} = N"
   by (auto simp add: eq_commute [of "{#a#}" "M + N"] union_is_single)
 
 lemma add_eq_conv_diff:
   "add_mset a M = add_mset b N \<longleftrightarrow> M = N \<and> a = b \<or> M = add_mset b (N - {#a#}) \<and> N = add_mset a (M - {#b#})"
   (is "?lhs \<longleftrightarrow> ?rhs")
 (* shorter: by (simp add: multiset_eq_iff) fastforce *)
 proof
   show ?lhs if ?rhs
     using that
     by (auto simp add: add_mset_commute[of a b])
   show ?rhs if ?lhs
   proof (cases "a = b")
     case True with \<open>?lhs\<close> show ?thesis by simp
   next
     case False
     from \<open>?lhs\<close> have "a \<in># add_mset b N" by (rule union_single_eq_member)
     with False have "a \<in># N" by auto
     moreover from \<open>?lhs\<close> have "M = add_mset b N - {#a#}" by (rule union_single_eq_diff)
     moreover note False
     ultimately show ?thesis by (auto simp add: diff_right_commute [of _ "{#a#}"])
   qed
 qed
 
 lemma add_mset_eq_single [iff]: "add_mset b M = {#a#} \<longleftrightarrow> b = a \<and> M = {#}"
   by (auto simp: add_eq_conv_diff)
 
 lemma single_eq_add_mset [iff]: "{#a#} = add_mset b M \<longleftrightarrow> b = a \<and> M = {#}"
   by (auto simp: add_eq_conv_diff)
 
 lemma insert_noteq_member:
   assumes BC: "add_mset b B = add_mset c C"
    and bnotc: "b \<noteq> c"
   shows "c \<in># B"
 proof -
   have "c \<in># add_mset c C" by simp
   have nc: "\<not> c \<in># {#b#}" using bnotc by simp
   then have "c \<in># add_mset b B" using BC by simp
   then show "c \<in># B" using nc by simp
 qed
 
 lemma add_eq_conv_ex:
   "(add_mset a M = add_mset b N) =
     (M = N \<and> a = b \<or> (\<exists>K. M = add_mset b K \<and> N = add_mset a K))"
   by (auto simp add: add_eq_conv_diff)
 
 lemma multi_member_split: "x \<in># M \<Longrightarrow> \<exists>A. M = add_mset x A"
   by (rule exI [where x = "M - {#x#}"]) simp
 
 lemma multiset_add_sub_el_shuffle:
   assumes "c \<in># B"
     and "b \<noteq> c"
   shows "add_mset b (B - {#c#}) = add_mset b B - {#c#}"
 proof -
   from \<open>c \<in># B\<close> obtain A where B: "B = add_mset c A"
     by (blast dest: multi_member_split)
   have "add_mset b A = add_mset c (add_mset b A) - {#c#}" by simp
   then have "add_mset b A = add_mset b (add_mset c A) - {#c#}"
     by (simp add: \<open>b \<noteq> c\<close>)
   then show ?thesis using B by simp
 qed
 
 lemma add_mset_eq_singleton_iff[iff]:
   "add_mset x M = {#y#} \<longleftrightarrow> M = {#} \<and> x = y"
   by auto
 
 
 subsubsection \<open>Pointwise ordering induced by count\<close>
 
 definition subseteq_mset :: "'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool"  (infix "\<subseteq>#" 50)
   where "A \<subseteq># B \<longleftrightarrow> (\<forall>a. count A a \<le> count B a)"
 
 definition subset_mset :: "'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool" (infix "\<subset>#" 50)
   where "A \<subset># B \<longleftrightarrow> A \<subseteq># B \<and> A \<noteq> B"
 
 abbreviation (input) supseteq_mset :: "'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool"  (infix "\<supseteq>#" 50)
   where "supseteq_mset A B \<equiv> B \<subseteq># A"
 
 abbreviation (input) supset_mset :: "'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool"  (infix "\<supset>#" 50)
   where "supset_mset A B \<equiv> B \<subset># A"
 
 notation (input)
   subseteq_mset  (infix "\<le>#" 50) and
   supseteq_mset  (infix "\<ge>#" 50)
 
 notation (ASCII)
   subseteq_mset  (infix "<=#" 50) and
   subset_mset  (infix "<#" 50) and
   supseteq_mset  (infix ">=#" 50) and
   supset_mset  (infix ">#" 50)
 
 global_interpretation subset_mset: ordering \<open>(\<subseteq>#)\<close> \<open>(\<subset>#)\<close>
   by standard (auto simp add: subset_mset_def subseteq_mset_def multiset_eq_iff intro: order.trans order.antisym)
 
 interpretation subset_mset: ordered_ab_semigroup_add_imp_le \<open>(+)\<close> \<open>(-)\<close> \<open>(\<subseteq>#)\<close> \<open>(\<subset>#)\<close>
   by standard (auto simp add: subset_mset_def subseteq_mset_def multiset_eq_iff intro: order_trans antisym)
     \<comment> \<open>FIXME: avoid junk stemming from type class interpretation\<close>
 
 interpretation subset_mset: ordered_ab_semigroup_monoid_add_imp_le "(+)" 0 "(-)" "(\<subseteq>#)" "(\<subset>#)"
   by standard
     \<comment> \<open>FIXME: avoid junk stemming from type class interpretation\<close>
 
 lemma mset_subset_eqI:
   "(\<And>a. count A a \<le> count B a) \<Longrightarrow> A \<subseteq># B"
   by (simp add: subseteq_mset_def)
 
 lemma mset_subset_eq_count:
   "A \<subseteq># B \<Longrightarrow> count A a \<le> count B a"
   by (simp add: subseteq_mset_def)
 
 lemma mset_subset_eq_exists_conv: "(A::'a multiset) \<subseteq># B \<longleftrightarrow> (\<exists>C. B = A + C)"
   unfolding subseteq_mset_def
   apply (rule iffI)
    apply (rule exI [where x = "B - A"])
    apply (auto intro: multiset_eq_iff [THEN iffD2])
   done
 
 interpretation subset_mset: ordered_cancel_comm_monoid_diff "(+)" 0 "(\<subseteq>#)" "(\<subset>#)" "(-)"
   by standard (simp, fact mset_subset_eq_exists_conv)
     \<comment> \<open>FIXME: avoid junk stemming from type class interpretation\<close>
 
 declare subset_mset.add_diff_assoc[simp] subset_mset.add_diff_assoc2[simp]
 
 lemma mset_subset_eq_mono_add_right_cancel: "(A::'a multiset) + C \<subseteq># B + C \<longleftrightarrow> A \<subseteq># B"
    by (fact subset_mset.add_le_cancel_right)
 
 lemma mset_subset_eq_mono_add_left_cancel: "C + (A::'a multiset) \<subseteq># C + B \<longleftrightarrow> A \<subseteq># B"
    by (fact subset_mset.add_le_cancel_left)
 
 lemma mset_subset_eq_mono_add: "(A::'a multiset) \<subseteq># B \<Longrightarrow> C \<subseteq># D \<Longrightarrow> A + C \<subseteq># B + D"
    by (fact subset_mset.add_mono)
 
 lemma mset_subset_eq_add_left: "(A::'a multiset) \<subseteq># A + B"
    by simp
 
 lemma mset_subset_eq_add_right: "B \<subseteq># (A::'a multiset) + B"
    by simp
 
 lemma single_subset_iff [simp]:
   "{#a#} \<subseteq># M \<longleftrightarrow> a \<in># M"
   by (auto simp add: subseteq_mset_def Suc_le_eq)
 
 lemma mset_subset_eq_single: "a \<in># B \<Longrightarrow> {#a#} \<subseteq># B"
   by simp
 
 lemma mset_subset_eq_add_mset_cancel: \<open>add_mset a A \<subseteq># add_mset a B \<longleftrightarrow> A \<subseteq># B\<close>
   unfolding add_mset_add_single[of _ A] add_mset_add_single[of _ B]
   by (rule mset_subset_eq_mono_add_right_cancel)
 
 lemma multiset_diff_union_assoc:
   fixes A B C D :: "'a multiset"
   shows "C \<subseteq># B \<Longrightarrow> A + B - C = A + (B - C)"
   by (fact subset_mset.diff_add_assoc)
 
 lemma mset_subset_eq_multiset_union_diff_commute:
   fixes A B C D :: "'a multiset"
   shows "B \<subseteq># A \<Longrightarrow> A - B + C = A + C - B"
   by (fact subset_mset.add_diff_assoc2)
 
 lemma diff_subset_eq_self[simp]:
   "(M::'a multiset) - N \<subseteq># M"
   by (simp add: subseteq_mset_def)
 
 lemma mset_subset_eqD:
   assumes "A \<subseteq># B" and "x \<in># A"
   shows "x \<in># B"
 proof -
   from \<open>x \<in># A\<close> have "count A x > 0" by simp
   also from \<open>A \<subseteq># B\<close> have "count A x \<le> count B x"
     by (simp add: subseteq_mset_def)
   finally show ?thesis by simp
 qed
 
 lemma mset_subsetD:
   "A \<subset># B \<Longrightarrow> x \<in># A \<Longrightarrow> x \<in># B"
   by (auto intro: mset_subset_eqD [of A])
 
 lemma set_mset_mono:
   "A \<subseteq># B \<Longrightarrow> set_mset A \<subseteq> set_mset B"
   by (metis mset_subset_eqD subsetI)
 
 lemma mset_subset_eq_insertD:
   "add_mset x A \<subseteq># B \<Longrightarrow> x \<in># B \<and> A \<subset># B"
 apply (rule conjI)
  apply (simp add: mset_subset_eqD)
  apply (clarsimp simp: subset_mset_def subseteq_mset_def)
  apply safe
   apply (erule_tac x = a in allE)
   apply (auto split: if_split_asm)
 done
 
 lemma mset_subset_insertD:
   "add_mset x A \<subset># B \<Longrightarrow> x \<in># B \<and> A \<subset># B"
   by (rule mset_subset_eq_insertD) simp
 
 lemma mset_subset_of_empty[simp]: "A \<subset># {#} \<longleftrightarrow> False"
   by (simp only: subset_mset.not_less_zero)
 
 lemma empty_subset_add_mset[simp]: "{#} \<subset># add_mset x M"
   by (auto intro: subset_mset.gr_zeroI)
 
 lemma empty_le: "{#} \<subseteq># A"
   by (fact subset_mset.zero_le)
 
 lemma insert_subset_eq_iff:
   "add_mset a A \<subseteq># B \<longleftrightarrow> a \<in># B \<and> A \<subseteq># B - {#a#}"
   using le_diff_conv2 [of "Suc 0" "count B a" "count A a"]
   apply (auto simp add: subseteq_mset_def not_in_iff Suc_le_eq)
   apply (rule ccontr)
   apply (auto simp add: not_in_iff)
   done
 
 lemma insert_union_subset_iff:
   "add_mset a A \<subset># B \<longleftrightarrow> a \<in># B \<and> A \<subset># B - {#a#}"
   by (auto simp add: insert_subset_eq_iff subset_mset_def)
 
 lemma subset_eq_diff_conv:
   "A - C \<subseteq># B \<longleftrightarrow> A \<subseteq># B + C"
   by (simp add: subseteq_mset_def le_diff_conv)
 
 lemma multi_psub_of_add_self [simp]: "A \<subset># add_mset x A"
   by (auto simp: subset_mset_def subseteq_mset_def)
 
 lemma multi_psub_self: "A \<subset># A = False"
   by simp
 
 lemma mset_subset_add_mset [simp]: "add_mset x N \<subset># add_mset x M \<longleftrightarrow> N \<subset># M"
   unfolding add_mset_add_single[of _ N] add_mset_add_single[of _ M]
   by (fact subset_mset.add_less_cancel_right)
 
 lemma mset_subset_diff_self: "c \<in># B \<Longrightarrow> B - {#c#} \<subset># B"
   by (auto simp: subset_mset_def elim: mset_add)
 
 lemma Diff_eq_empty_iff_mset: "A - B = {#} \<longleftrightarrow> A \<subseteq># B"
   by (auto simp: multiset_eq_iff subseteq_mset_def)
 
 lemma add_mset_subseteq_single_iff[iff]: "add_mset a M \<subseteq># {#b#} \<longleftrightarrow> M = {#} \<and> a = b"
 proof
   assume A: "add_mset a M \<subseteq># {#b#}"
   then have \<open>a = b\<close>
     by (auto dest: mset_subset_eq_insertD)
   then show "M={#} \<and> a=b"
     using A by (simp add: mset_subset_eq_add_mset_cancel)
 qed simp
 
 
 subsubsection \<open>Intersection and bounded union\<close>
 
 definition inter_mset :: \<open>'a multiset \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset\<close>  (infixl \<open>\<inter>#\<close> 70)
   where \<open>A \<inter># B = A - (A - B)\<close>
 
 lemma count_inter_mset [simp]:
   \<open>count (A \<inter># B) x = min (count A x) (count B x)\<close>
   by (simp add: inter_mset_def)
 
 (*global_interpretation subset_mset: semilattice_order \<open>(\<inter>#)\<close> \<open>(\<subseteq>#)\<close> \<open>(\<subset>#)\<close>
   by standard (simp_all add: multiset_eq_iff subseteq_mset_def subset_mset_def min_def)*)
 
 interpretation subset_mset: semilattice_inf \<open>(\<inter>#)\<close> \<open>(\<subseteq>#)\<close> \<open>(\<subset>#)\<close>
   by standard (simp_all add: multiset_eq_iff subseteq_mset_def)
   \<comment> \<open>FIXME: avoid junk stemming from type class interpretation\<close>
 
 definition union_mset :: \<open>'a multiset \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset\<close>  (infixl \<open>\<union>#\<close> 70)
   where \<open>A \<union># B = A + (B - A)\<close>
 
 lemma count_union_mset [simp]:
   \<open>count (A \<union># B) x = max (count A x) (count B x)\<close>
   by (simp add: union_mset_def)
 
 global_interpretation subset_mset: semilattice_neutr_order \<open>(\<union>#)\<close> \<open>{#}\<close> \<open>(\<supseteq>#)\<close> \<open>(\<supset>#)\<close>
   apply standard
       apply (simp_all add: multiset_eq_iff subseteq_mset_def subset_mset_def max_def)
    apply (auto simp add: le_antisym dest: sym)
    apply (metis nat_le_linear)+
   done
 
 interpretation subset_mset: semilattice_sup \<open>(\<union>#)\<close> \<open>(\<subseteq>#)\<close> \<open>(\<subset>#)\<close>
 proof -
   have [simp]: "m \<le> n \<Longrightarrow> q \<le> n \<Longrightarrow> m + (q - m) \<le> n" for m n q :: nat
     by arith
   show "class.semilattice_sup (\<union>#) (\<subseteq>#) (\<subset>#)"
     by standard (auto simp add: union_mset_def subseteq_mset_def)
 qed \<comment> \<open>FIXME: avoid junk stemming from type class interpretation\<close>
 
 interpretation subset_mset: bounded_lattice_bot "(\<inter>#)" "(\<subseteq>#)" "(\<subset>#)"
   "(\<union>#)" "{#}"
   by standard auto
     \<comment> \<open>FIXME: avoid junk stemming from type class interpretation\<close>
 
 
 subsubsection \<open>Additional intersection facts\<close>
 
 lemma set_mset_inter [simp]:
   "set_mset (A \<inter># B) = set_mset A \<inter> set_mset B"
   by (simp only: set_mset_def) auto
 
 lemma diff_intersect_left_idem [simp]:
   "M - M \<inter># N = M - N"
   by (simp add: multiset_eq_iff min_def)
 
 lemma diff_intersect_right_idem [simp]:
   "M - N \<inter># M = M - N"
   by (simp add: multiset_eq_iff min_def)
 
 lemma multiset_inter_single[simp]: "a \<noteq> b \<Longrightarrow> {#a#} \<inter># {#b#} = {#}"
   by (rule multiset_eqI) auto
 
 lemma multiset_union_diff_commute:
   assumes "B \<inter># C = {#}"
   shows "A + B - C = A - C + B"
 proof (rule multiset_eqI)
   fix x
   from assms have "min (count B x) (count C x) = 0"
     by (auto simp add: multiset_eq_iff)
   then have "count B x = 0 \<or> count C x = 0"
     unfolding min_def by (auto split: if_splits)
   then show "count (A + B - C) x = count (A - C + B) x"
     by auto
 qed
 
 lemma disjunct_not_in:
   "A \<inter># B = {#} \<longleftrightarrow> (\<forall>a. a \<notin># A \<or> a \<notin># B)" (is "?P \<longleftrightarrow> ?Q")
 proof
   assume ?P
   show ?Q
   proof
     fix a
     from \<open>?P\<close> have "min (count A a) (count B a) = 0"
       by (simp add: multiset_eq_iff)
     then have "count A a = 0 \<or> count B a = 0"
       by (cases "count A a \<le> count B a") (simp_all add: min_def)
     then show "a \<notin># A \<or> a \<notin># B"
       by (simp add: not_in_iff)
   qed
 next
   assume ?Q
   show ?P
   proof (rule multiset_eqI)
     fix a
     from \<open>?Q\<close> have "count A a = 0 \<or> count B a = 0"
       by (auto simp add: not_in_iff)
     then show "count (A \<inter># B) a = count {#} a"
       by auto
   qed
 qed
 
 lemma inter_mset_empty_distrib_right: "A \<inter># (B + C) = {#} \<longleftrightarrow> A \<inter># B = {#} \<and> A \<inter># C = {#}"
   by (meson disjunct_not_in union_iff)
 
 lemma inter_mset_empty_distrib_left: "(A + B) \<inter># C = {#} \<longleftrightarrow> A \<inter># C = {#} \<and> B \<inter># C = {#}"
   by (meson disjunct_not_in union_iff)
 
 lemma add_mset_inter_add_mset [simp]:
   "add_mset a A \<inter># add_mset a B = add_mset a (A \<inter># B)"
   by (rule multiset_eqI) simp
 
 lemma add_mset_disjoint [simp]:
   "add_mset a A \<inter># B = {#} \<longleftrightarrow> a \<notin># B \<and> A \<inter># B = {#}"
   "{#} = add_mset a A \<inter># B \<longleftrightarrow> a \<notin># B \<and> {#} = A \<inter># B"
   by (auto simp: disjunct_not_in)
 
 lemma disjoint_add_mset [simp]:
   "B \<inter># add_mset a A = {#} \<longleftrightarrow> a \<notin># B \<and> B \<inter># A = {#}"
   "{#} = A \<inter># add_mset b B \<longleftrightarrow> b \<notin># A \<and> {#} = A \<inter># B"
   by (auto simp: disjunct_not_in)
 
 lemma inter_add_left1: "\<not> x \<in># N \<Longrightarrow> (add_mset x M) \<inter># N = M \<inter># N"
   by (simp add: multiset_eq_iff not_in_iff)
 
 lemma inter_add_left2: "x \<in># N \<Longrightarrow> (add_mset x M) \<inter># N = add_mset x (M \<inter># (N - {#x#}))"
   by (auto simp add: multiset_eq_iff elim: mset_add)
 
 lemma inter_add_right1: "\<not> x \<in># N \<Longrightarrow> N \<inter># (add_mset x M) = N \<inter># M"
   by (simp add: multiset_eq_iff not_in_iff)
 
 lemma inter_add_right2: "x \<in># N \<Longrightarrow> N \<inter># (add_mset x M) = add_mset x ((N - {#x#}) \<inter># M)"
   by (auto simp add: multiset_eq_iff elim: mset_add)
 
 lemma disjunct_set_mset_diff:
   assumes "M \<inter># N = {#}"
   shows "set_mset (M - N) = set_mset M"
 proof (rule set_eqI)
   fix a
   from assms have "a \<notin># M \<or> a \<notin># N"
     by (simp add: disjunct_not_in)
   then show "a \<in># M - N \<longleftrightarrow> a \<in># M"
     by (auto dest: in_diffD) (simp add: in_diff_count not_in_iff)
 qed
 
 lemma at_most_one_mset_mset_diff:
   assumes "a \<notin># M - {#a#}"
   shows "set_mset (M - {#a#}) = set_mset M - {a}"
   using assms by (auto simp add: not_in_iff in_diff_count set_eq_iff)
 
 lemma more_than_one_mset_mset_diff:
   assumes "a \<in># M - {#a#}"
   shows "set_mset (M - {#a#}) = set_mset M"
 proof (rule set_eqI)
   fix b
   have "Suc 0 < count M b \<Longrightarrow> count M b > 0" by arith
   then show "b \<in># M - {#a#} \<longleftrightarrow> b \<in># M"
     using assms by (auto simp add: in_diff_count)
 qed
 
 lemma inter_iff:
   "a \<in># A \<inter># B \<longleftrightarrow> a \<in># A \<and> a \<in># B"
   by simp
 
 lemma inter_union_distrib_left:
   "A \<inter># B + C = (A + C) \<inter># (B + C)"
   by (simp add: multiset_eq_iff min_add_distrib_left)
 
 lemma inter_union_distrib_right:
   "C + A \<inter># B = (C + A) \<inter># (C + B)"
   using inter_union_distrib_left [of A B C] by (simp add: ac_simps)
 
 lemma inter_subset_eq_union:
   "A \<inter># B \<subseteq># A + B"
   by (auto simp add: subseteq_mset_def)
 
 
 subsubsection \<open>Additional bounded union facts\<close>
 
 lemma set_mset_sup [simp]:
   \<open>set_mset (A \<union># B) = set_mset A \<union> set_mset B\<close>
   by (simp only: set_mset_def) (auto simp add: less_max_iff_disj)
 
 lemma sup_union_left1 [simp]: "\<not> x \<in># N \<Longrightarrow> (add_mset x M) \<union># N = add_mset x (M \<union># N)"
   by (simp add: multiset_eq_iff not_in_iff)
 
 lemma sup_union_left2: "x \<in># N \<Longrightarrow> (add_mset x M) \<union># N = add_mset x (M \<union># (N - {#x#}))"
   by (simp add: multiset_eq_iff)
 
 lemma sup_union_right1 [simp]: "\<not> x \<in># N \<Longrightarrow> N \<union># (add_mset x M) = add_mset x (N \<union># M)"
   by (simp add: multiset_eq_iff not_in_iff)
 
 lemma sup_union_right2: "x \<in># N \<Longrightarrow> N \<union># (add_mset x M) = add_mset x ((N - {#x#}) \<union># M)"
   by (simp add: multiset_eq_iff)
 
 lemma sup_union_distrib_left:
   "A \<union># B + C = (A + C) \<union># (B + C)"
   by (simp add: multiset_eq_iff max_add_distrib_left)
 
 lemma union_sup_distrib_right:
   "C + A \<union># B = (C + A) \<union># (C + B)"
   using sup_union_distrib_left [of A B C] by (simp add: ac_simps)
 
 lemma union_diff_inter_eq_sup:
   "A + B - A \<inter># B = A \<union># B"
   by (auto simp add: multiset_eq_iff)
 
 lemma union_diff_sup_eq_inter:
   "A + B - A \<union># B = A \<inter># B"
   by (auto simp add: multiset_eq_iff)
 
 lemma add_mset_union:
   \<open>add_mset a A \<union># add_mset a B = add_mset a (A \<union># B)\<close>
   by (auto simp: multiset_eq_iff max_def)
 
 
 subsection \<open>Replicate and repeat operations\<close>
 
 definition replicate_mset :: "nat \<Rightarrow> 'a \<Rightarrow> 'a multiset" where
   "replicate_mset n x = (add_mset x ^^ n) {#}"
 
 lemma replicate_mset_0[simp]: "replicate_mset 0 x = {#}"
   unfolding replicate_mset_def by simp
 
 lemma replicate_mset_Suc [simp]: "replicate_mset (Suc n) x = add_mset x (replicate_mset n x)"
   unfolding replicate_mset_def by (induct n) (auto intro: add.commute)
 
 lemma count_replicate_mset[simp]: "count (replicate_mset n x) y = (if y = x then n else 0)"
   unfolding replicate_mset_def by (induct n) auto
 
 lift_definition repeat_mset :: \<open>nat \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset\<close>
   is \<open>\<lambda>n M a. n * M a\<close> by simp
 
 lemma count_repeat_mset [simp]: "count (repeat_mset i A) a = i * count A a"
   by transfer rule
 
 lemma repeat_mset_0 [simp]:
   \<open>repeat_mset 0 M = {#}\<close>
   by transfer simp
 
 lemma repeat_mset_Suc [simp]:
   \<open>repeat_mset (Suc n) M = M + repeat_mset n M\<close>
   by transfer simp
 
 lemma repeat_mset_right [simp]: "repeat_mset a (repeat_mset b A) = repeat_mset (a * b) A"
   by (auto simp: multiset_eq_iff left_diff_distrib')
 
 lemma left_diff_repeat_mset_distrib': \<open>repeat_mset (i - j) u = repeat_mset i u - repeat_mset j u\<close>
   by (auto simp: multiset_eq_iff left_diff_distrib')
 
 lemma left_add_mult_distrib_mset:
   "repeat_mset i u + (repeat_mset j u + k) = repeat_mset (i+j) u + k"
   by (auto simp: multiset_eq_iff add_mult_distrib)
 
 lemma repeat_mset_distrib:
   "repeat_mset (m + n) A = repeat_mset m A + repeat_mset n A"
   by (auto simp: multiset_eq_iff Nat.add_mult_distrib)
 
 lemma repeat_mset_distrib2[simp]:
   "repeat_mset n (A + B) = repeat_mset n A + repeat_mset n B"
   by (auto simp: multiset_eq_iff add_mult_distrib2)
 
 lemma repeat_mset_replicate_mset[simp]:
   "repeat_mset n {#a#} = replicate_mset n a"
   by (auto simp: multiset_eq_iff)
 
 lemma repeat_mset_distrib_add_mset[simp]:
   "repeat_mset n (add_mset a A) = replicate_mset n a + repeat_mset n A"
   by (auto simp: multiset_eq_iff)
 
 lemma repeat_mset_empty[simp]: "repeat_mset n {#} = {#}"
   by transfer simp
 
 
 subsubsection \<open>Simprocs\<close>
 
 lemma repeat_mset_iterate_add: \<open>repeat_mset n M = iterate_add n M\<close>
   unfolding iterate_add_def by (induction n) auto
 
 lemma mset_subseteq_add_iff1:
   "j \<le> (i::nat) \<Longrightarrow> (repeat_mset i u + m \<subseteq># repeat_mset j u + n) = (repeat_mset (i-j) u + m \<subseteq># n)"
   by (auto simp add: subseteq_mset_def nat_le_add_iff1)
 
 lemma mset_subseteq_add_iff2:
   "i \<le> (j::nat) \<Longrightarrow> (repeat_mset i u + m \<subseteq># repeat_mset j u + n) = (m \<subseteq># repeat_mset (j-i) u + n)"
   by (auto simp add: subseteq_mset_def nat_le_add_iff2)
 
 lemma mset_subset_add_iff1:
   "j \<le> (i::nat) \<Longrightarrow> (repeat_mset i u + m \<subset># repeat_mset j u + n) = (repeat_mset (i-j) u + m \<subset># n)"
   unfolding subset_mset_def repeat_mset_iterate_add
   by (simp add: iterate_add_eq_add_iff1 mset_subseteq_add_iff1[unfolded repeat_mset_iterate_add])
 
 lemma mset_subset_add_iff2:
   "i \<le> (j::nat) \<Longrightarrow> (repeat_mset i u + m \<subset># repeat_mset j u + n) = (m \<subset># repeat_mset (j-i) u + n)"
   unfolding subset_mset_def repeat_mset_iterate_add
   by (simp add: iterate_add_eq_add_iff2 mset_subseteq_add_iff2[unfolded repeat_mset_iterate_add])
 
 ML_file \<open>multiset_simprocs.ML\<close>
 
 lemma add_mset_replicate_mset_safe[cancelation_simproc_pre]: \<open>NO_MATCH {#} M \<Longrightarrow> add_mset a M = {#a#} + M\<close>
   by simp
 
 declare repeat_mset_iterate_add[cancelation_simproc_pre]
 
 declare iterate_add_distrib[cancelation_simproc_pre]
 declare repeat_mset_iterate_add[symmetric, cancelation_simproc_post]
 
 declare add_mset_not_empty[cancelation_simproc_eq_elim]
     empty_not_add_mset[cancelation_simproc_eq_elim]
     subset_mset.le_zero_eq[cancelation_simproc_eq_elim]
     empty_not_add_mset[cancelation_simproc_eq_elim]
     add_mset_not_empty[cancelation_simproc_eq_elim]
     subset_mset.le_zero_eq[cancelation_simproc_eq_elim]
     le_zero_eq[cancelation_simproc_eq_elim]
 
 simproc_setup mseteq_cancel
   ("(l::'a multiset) + m = n" | "(l::'a multiset) = m + n" |
    "add_mset a m = n" | "m = add_mset a n" |
    "replicate_mset p a = n" | "m = replicate_mset p a" |
    "repeat_mset p m = n" | "m = repeat_mset p m") =
-  \<open>fn phi => Cancel_Simprocs.eq_cancel\<close>
+  \<open>K Cancel_Simprocs.eq_cancel\<close>
 
 simproc_setup msetsubset_cancel
   ("(l::'a multiset) + m \<subset># n" | "(l::'a multiset) \<subset># m + n" |
    "add_mset a m \<subset># n" | "m \<subset># add_mset a n" |
    "replicate_mset p r \<subset># n" | "m \<subset># replicate_mset p r" |
    "repeat_mset p m \<subset># n" | "m \<subset># repeat_mset p m") =
-  \<open>fn phi => Multiset_Simprocs.subset_cancel_msets\<close>
+  \<open>K Multiset_Simprocs.subset_cancel_msets\<close>
 
 simproc_setup msetsubset_eq_cancel
   ("(l::'a multiset) + m \<subseteq># n" | "(l::'a multiset) \<subseteq># m + n" |
    "add_mset a m \<subseteq># n" | "m \<subseteq># add_mset a n" |
    "replicate_mset p r \<subseteq># n" | "m \<subseteq># replicate_mset p r" |
    "repeat_mset p m \<subseteq># n" | "m \<subseteq># repeat_mset p m") =
-  \<open>fn phi => Multiset_Simprocs.subseteq_cancel_msets\<close>
+  \<open>K Multiset_Simprocs.subseteq_cancel_msets\<close>
 
 simproc_setup msetdiff_cancel
   ("((l::'a multiset) + m) - n" | "(l::'a multiset) - (m + n)" |
    "add_mset a m - n" | "m - add_mset a n" |
    "replicate_mset p r - n" | "m - replicate_mset p r" |
    "repeat_mset p m - n" | "m - repeat_mset p m") =
-  \<open>fn phi => Cancel_Simprocs.diff_cancel\<close>
+  \<open>K Cancel_Simprocs.diff_cancel\<close>
 
 
 subsubsection \<open>Conditionally complete lattice\<close>
 
 instantiation multiset :: (type) Inf
 begin
 
 lift_definition Inf_multiset :: "'a multiset set \<Rightarrow> 'a multiset" is
   "\<lambda>A i. if A = {} then 0 else Inf ((\<lambda>f. f i) ` A)"
 proof -
   fix A :: "('a \<Rightarrow> nat) set"
   assume *: "\<And>f. f \<in> A \<Longrightarrow> finite {x. 0 < f x}"
   show \<open>finite {i. 0 < (if A = {} then 0 else INF f\<in>A. f i)}\<close>
   proof (cases "A = {}")
     case False
     then obtain f where "f \<in> A" by blast
     hence "{i. Inf ((\<lambda>f. f i) ` A) > 0} \<subseteq> {i. f i > 0}"
       by (auto intro: less_le_trans[OF _ cInf_lower])
     moreover from \<open>f \<in> A\<close> * have "finite \<dots>" by simp
     ultimately have "finite {i. Inf ((\<lambda>f. f i) ` A) > 0}" by (rule finite_subset)
     with False show ?thesis by simp
   qed simp_all
 qed
 
 instance ..
 
 end
 
 lemma Inf_multiset_empty: "Inf {} = {#}"
   by transfer simp_all
 
 lemma count_Inf_multiset_nonempty: "A \<noteq> {} \<Longrightarrow> count (Inf A) x = Inf ((\<lambda>X. count X x) ` A)"
   by transfer simp_all
 
 
 instantiation multiset :: (type) Sup
 begin
 
 definition Sup_multiset :: "'a multiset set \<Rightarrow> 'a multiset" where
   "Sup_multiset A = (if A \<noteq> {} \<and> subset_mset.bdd_above A then
            Abs_multiset (\<lambda>i. Sup ((\<lambda>X. count X i) ` A)) else {#})"
 
 lemma Sup_multiset_empty: "Sup {} = {#}"
   by (simp add: Sup_multiset_def)
 
 lemma Sup_multiset_unbounded: "\<not> subset_mset.bdd_above A \<Longrightarrow> Sup A = {#}"
   by (simp add: Sup_multiset_def)
 
 instance ..
 
 end
 
 lemma bdd_above_multiset_imp_bdd_above_count:
   assumes "subset_mset.bdd_above (A :: 'a multiset set)"
   shows   "bdd_above ((\<lambda>X. count X x) ` A)"
 proof -
   from assms obtain Y where Y: "\<forall>X\<in>A. X \<subseteq># Y"
     by (meson subset_mset.bdd_above.E)
   hence "count X x \<le> count Y x" if "X \<in> A" for X
     using that by (auto intro: mset_subset_eq_count)
   thus ?thesis by (intro bdd_aboveI[of _ "count Y x"]) auto
 qed
 
 lemma bdd_above_multiset_imp_finite_support:
   assumes "A \<noteq> {}" "subset_mset.bdd_above (A :: 'a multiset set)"
   shows   "finite (\<Union>X\<in>A. {x. count X x > 0})"
 proof -
   from assms obtain Y where Y: "\<forall>X\<in>A. X \<subseteq># Y"
     by (meson subset_mset.bdd_above.E)
   hence "count X x \<le> count Y x" if "X \<in> A" for X x
     using that by (auto intro: mset_subset_eq_count)
   hence "(\<Union>X\<in>A. {x. count X x > 0}) \<subseteq> {x. count Y x > 0}"
     by safe (erule less_le_trans)
   moreover have "finite \<dots>" by simp
   ultimately show ?thesis by (rule finite_subset)
 qed
 
 lemma Sup_multiset_in_multiset:
   \<open>finite {i. 0 < (SUP M\<in>A. count M i)}\<close>
   if \<open>A \<noteq> {}\<close> \<open>subset_mset.bdd_above A\<close>
 proof -
   have "{i. Sup ((\<lambda>X. count X i) ` A) > 0} \<subseteq> (\<Union>X\<in>A. {i. 0 < count X i})"
   proof safe
     fix i assume pos: "(SUP X\<in>A. count X i) > 0"
     show "i \<in> (\<Union>X\<in>A. {i. 0 < count X i})"
     proof (rule ccontr)
       assume "i \<notin> (\<Union>X\<in>A. {i. 0 < count X i})"
       hence "\<forall>X\<in>A. count X i \<le> 0" by (auto simp: count_eq_zero_iff)
       with that have "(SUP X\<in>A. count X i) \<le> 0"
         by (intro cSup_least bdd_above_multiset_imp_bdd_above_count) auto
       with pos show False by simp
     qed
   qed
   moreover from that have "finite \<dots>"
     by (rule bdd_above_multiset_imp_finite_support)
   ultimately show "finite {i. Sup ((\<lambda>X. count X i) ` A) > 0}"
     by (rule finite_subset)
 qed
 
 lemma count_Sup_multiset_nonempty:
   \<open>count (Sup A) x = (SUP X\<in>A. count X x)\<close>
   if \<open>A \<noteq> {}\<close> \<open>subset_mset.bdd_above A\<close>
   using that by (simp add: Sup_multiset_def Sup_multiset_in_multiset count_Abs_multiset)
 
 interpretation subset_mset: conditionally_complete_lattice Inf Sup "(\<inter>#)" "(\<subseteq>#)" "(\<subset>#)" "(\<union>#)"
 proof
   fix X :: "'a multiset" and A
   assume "X \<in> A"
   show "Inf A \<subseteq># X"
   proof (rule mset_subset_eqI)
     fix x
     from \<open>X \<in> A\<close> have "A \<noteq> {}" by auto
     hence "count (Inf A) x = (INF X\<in>A. count X x)"
       by (simp add: count_Inf_multiset_nonempty)
     also from \<open>X \<in> A\<close> have "\<dots> \<le> count X x"
       by (intro cInf_lower) simp_all
     finally show "count (Inf A) x \<le> count X x" .
   qed
 next
   fix X :: "'a multiset" and A
   assume nonempty: "A \<noteq> {}" and le: "\<And>Y. Y \<in> A \<Longrightarrow> X \<subseteq># Y"
   show "X \<subseteq># Inf A"
   proof (rule mset_subset_eqI)
     fix x
     from nonempty have "count X x \<le> (INF X\<in>A. count X x)"
       by (intro cInf_greatest) (auto intro: mset_subset_eq_count le)
     also from nonempty have "\<dots> = count (Inf A) x" by (simp add: count_Inf_multiset_nonempty)
     finally show "count X x \<le> count (Inf A) x" .
   qed
 next
   fix X :: "'a multiset" and A
   assume X: "X \<in> A" and bdd: "subset_mset.bdd_above A"
   show "X \<subseteq># Sup A"
   proof (rule mset_subset_eqI)
     fix x
     from X have "A \<noteq> {}" by auto
     have "count X x \<le> (SUP X\<in>A. count X x)"
       by (intro cSUP_upper X bdd_above_multiset_imp_bdd_above_count bdd)
     also from count_Sup_multiset_nonempty[OF \<open>A \<noteq> {}\<close> bdd]
       have "(SUP X\<in>A. count X x) = count (Sup A) x" by simp
     finally show "count X x \<le> count (Sup A) x" .
   qed
 next
   fix X :: "'a multiset" and A
   assume nonempty: "A \<noteq> {}" and ge: "\<And>Y. Y \<in> A \<Longrightarrow> Y \<subseteq># X"
   from ge have bdd: "subset_mset.bdd_above A"
     by blast
   show "Sup A \<subseteq># X"
   proof (rule mset_subset_eqI)
     fix x
     from count_Sup_multiset_nonempty[OF \<open>A \<noteq> {}\<close> bdd]
       have "count (Sup A) x = (SUP X\<in>A. count X x)" .
     also from nonempty have "\<dots> \<le> count X x"
       by (intro cSup_least) (auto intro: mset_subset_eq_count ge)
     finally show "count (Sup A) x \<le> count X x" .
   qed
 qed \<comment> \<open>FIXME: avoid junk stemming from type class interpretation\<close>
 
 lemma set_mset_Inf:
   assumes "A \<noteq> {}"
   shows   "set_mset (Inf A) = (\<Inter>X\<in>A. set_mset X)"
 proof safe
   fix x X assume "x \<in># Inf A" "X \<in> A"
   hence nonempty: "A \<noteq> {}" by (auto simp: Inf_multiset_empty)
   from \<open>x \<in># Inf A\<close> have "{#x#} \<subseteq># Inf A" by auto
   also from \<open>X \<in> A\<close> have "\<dots> \<subseteq># X" by (rule subset_mset.cInf_lower) simp_all
   finally show "x \<in># X" by simp
 next
   fix x assume x: "x \<in> (\<Inter>X\<in>A. set_mset X)"
   hence "{#x#} \<subseteq># X" if "X \<in> A" for X using that by auto
   from assms and this have "{#x#} \<subseteq># Inf A" by (rule subset_mset.cInf_greatest)
   thus "x \<in># Inf A" by simp
 qed
 
 lemma in_Inf_multiset_iff:
   assumes "A \<noteq> {}"
   shows   "x \<in># Inf A \<longleftrightarrow> (\<forall>X\<in>A. x \<in># X)"
 proof -
   from assms have "set_mset (Inf A) = (\<Inter>X\<in>A. set_mset X)" by (rule set_mset_Inf)
   also have "x \<in> \<dots> \<longleftrightarrow> (\<forall>X\<in>A. x \<in># X)" by simp
   finally show ?thesis .
 qed
 
 lemma in_Inf_multisetD: "x \<in># Inf A \<Longrightarrow> X \<in> A \<Longrightarrow> x \<in># X"
   by (subst (asm) in_Inf_multiset_iff) auto
 
 lemma set_mset_Sup:
   assumes "subset_mset.bdd_above A"
   shows   "set_mset (Sup A) = (\<Union>X\<in>A. set_mset X)"
 proof safe
   fix x assume "x \<in># Sup A"
   hence nonempty: "A \<noteq> {}" by (auto simp: Sup_multiset_empty)
   show "x \<in> (\<Union>X\<in>A. set_mset X)"
   proof (rule ccontr)
     assume x: "x \<notin> (\<Union>X\<in>A. set_mset X)"
     have "count X x \<le> count (Sup A) x" if "X \<in> A" for X x
       using that by (intro mset_subset_eq_count subset_mset.cSup_upper assms)
     with x have "X \<subseteq># Sup A - {#x#}" if "X \<in> A" for X
       using that by (auto simp: subseteq_mset_def algebra_simps not_in_iff)
     hence "Sup A \<subseteq># Sup A - {#x#}" by (intro subset_mset.cSup_least nonempty)
     with \<open>x \<in># Sup A\<close> show False
       by (auto simp: subseteq_mset_def simp flip: count_greater_zero_iff
                dest!: spec[of _ x])
   qed
 next
   fix x X assume "x \<in> set_mset X" "X \<in> A"
   hence "{#x#} \<subseteq># X" by auto
   also have "X \<subseteq># Sup A" by (intro subset_mset.cSup_upper \<open>X \<in> A\<close> assms)
   finally show "x \<in> set_mset (Sup A)" by simp
 qed
 
 lemma in_Sup_multiset_iff:
   assumes "subset_mset.bdd_above A"
   shows   "x \<in># Sup A \<longleftrightarrow> (\<exists>X\<in>A. x \<in># X)"
 proof -
   from assms have "set_mset (Sup A) = (\<Union>X\<in>A. set_mset X)" by (rule set_mset_Sup)
   also have "x \<in> \<dots> \<longleftrightarrow> (\<exists>X\<in>A. x \<in># X)" by simp
   finally show ?thesis .
 qed
 
 lemma in_Sup_multisetD:
   assumes "x \<in># Sup A"
   shows   "\<exists>X\<in>A. x \<in># X"
 proof -
   have "subset_mset.bdd_above A"
     by (rule ccontr) (insert assms, simp_all add: Sup_multiset_unbounded)
   with assms show ?thesis by (simp add: in_Sup_multiset_iff)
 qed
 
 interpretation subset_mset: distrib_lattice "(\<inter>#)" "(\<subseteq>#)" "(\<subset>#)" "(\<union>#)"
 proof
   fix A B C :: "'a multiset"
   show "A \<union># (B \<inter># C) = A \<union># B \<inter># (A \<union># C)"
     by (intro multiset_eqI) simp_all
 qed \<comment> \<open>FIXME: avoid junk stemming from type class interpretation\<close>
 
 
 subsubsection \<open>Filter (with comprehension syntax)\<close>
 
 text \<open>Multiset comprehension\<close>
 
 lift_definition filter_mset :: "('a \<Rightarrow> bool) \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset"
 is "\<lambda>P M. \<lambda>x. if P x then M x else 0"
 by (rule filter_preserves_multiset)
 
 syntax (ASCII)
   "_MCollect" :: "pttrn \<Rightarrow> 'a multiset \<Rightarrow> bool \<Rightarrow> 'a multiset"    ("(1{#_ :# _./ _#})")
 syntax
   "_MCollect" :: "pttrn \<Rightarrow> 'a multiset \<Rightarrow> bool \<Rightarrow> 'a multiset"    ("(1{#_ \<in># _./ _#})")
 translations
   "{#x \<in># M. P#}" == "CONST filter_mset (\<lambda>x. P) M"
 
 lemma count_filter_mset [simp]:
   "count (filter_mset P M) a = (if P a then count M a else 0)"
   by (simp add: filter_mset.rep_eq)
 
 lemma set_mset_filter [simp]:
   "set_mset (filter_mset P M) = {a \<in> set_mset M. P a}"
   by (simp only: set_eq_iff count_greater_zero_iff [symmetric] count_filter_mset) simp
 
 lemma filter_empty_mset [simp]: "filter_mset P {#} = {#}"
   by (rule multiset_eqI) simp
 
 lemma filter_single_mset: "filter_mset P {#x#} = (if P x then {#x#} else {#})"
   by (rule multiset_eqI) simp
 
 lemma filter_union_mset [simp]: "filter_mset P (M + N) = filter_mset P M + filter_mset P N"
   by (rule multiset_eqI) simp
 
 lemma filter_diff_mset [simp]: "filter_mset P (M - N) = filter_mset P M - filter_mset P N"
   by (rule multiset_eqI) simp
 
 lemma filter_inter_mset [simp]: "filter_mset P (M \<inter># N) = filter_mset P M \<inter># filter_mset P N"
   by (rule multiset_eqI) simp
 
 lemma filter_sup_mset[simp]: "filter_mset P (A \<union># B) = filter_mset P A \<union># filter_mset P B"
   by (rule multiset_eqI) simp
 
 lemma filter_mset_add_mset [simp]:
    "filter_mset P (add_mset x A) =
      (if P x then add_mset x (filter_mset P A) else filter_mset P A)"
    by (auto simp: multiset_eq_iff)
 
 lemma multiset_filter_subset[simp]: "filter_mset f M \<subseteq># M"
   by (simp add: mset_subset_eqI)
 
 lemma multiset_filter_mono:
   assumes "A \<subseteq># B"
   shows "filter_mset f A \<subseteq># filter_mset f B"
 proof -
   from assms[unfolded mset_subset_eq_exists_conv]
   obtain C where B: "B = A + C" by auto
   show ?thesis unfolding B by auto
 qed
 
 lemma filter_mset_eq_conv:
   "filter_mset P M = N \<longleftrightarrow> N \<subseteq># M \<and> (\<forall>b\<in>#N. P b) \<and> (\<forall>a\<in>#M - N. \<not> P a)" (is "?P \<longleftrightarrow> ?Q")
 proof
   assume ?P then show ?Q by auto (simp add: multiset_eq_iff in_diff_count)
 next
   assume ?Q
   then obtain Q where M: "M = N + Q"
     by (auto simp add: mset_subset_eq_exists_conv)
   then have MN: "M - N = Q" by simp
   show ?P
   proof (rule multiset_eqI)
     fix a
     from \<open>?Q\<close> MN have *: "\<not> P a \<Longrightarrow> a \<notin># N" "P a \<Longrightarrow> a \<notin># Q"
       by auto
     show "count (filter_mset P M) a = count N a"
     proof (cases "a \<in># M")
       case True
       with * show ?thesis
         by (simp add: not_in_iff M)
     next
       case False then have "count M a = 0"
         by (simp add: not_in_iff)
       with M show ?thesis by simp
     qed
   qed
 qed
 
 lemma filter_filter_mset: "filter_mset P (filter_mset Q M) = {#x \<in># M. Q x \<and> P x#}"
   by (auto simp: multiset_eq_iff)
 
 lemma
   filter_mset_True[simp]: "{#y \<in># M. True#} = M" and
   filter_mset_False[simp]: "{#y \<in># M. False#} = {#}"
   by (auto simp: multiset_eq_iff)
 
 lemma filter_mset_cong0:
   assumes "\<And>x. x \<in># M \<Longrightarrow> f x \<longleftrightarrow> g x"
   shows "filter_mset f M = filter_mset g M"
 proof (rule subset_mset.antisym; unfold subseteq_mset_def; rule allI)
   fix x
   show "count (filter_mset f M) x \<le> count (filter_mset g M) x"
     using assms by (cases "x \<in># M") (simp_all add: not_in_iff)
 next
   fix x
   show "count (filter_mset g M) x \<le> count (filter_mset f M) x"
     using assms by (cases "x \<in># M") (simp_all add: not_in_iff)
 qed
 
 lemma filter_mset_cong:
   assumes "M = M'" and "\<And>x. x \<in># M' \<Longrightarrow> f x \<longleftrightarrow> g x"
   shows "filter_mset f M = filter_mset g M'"
   unfolding \<open>M = M'\<close>
   using assms by (auto intro: filter_mset_cong0)
 
 
 subsubsection \<open>Size\<close>
 
 definition wcount where "wcount f M = (\<lambda>x. count M x * Suc (f x))"
 
 lemma wcount_union: "wcount f (M + N) a = wcount f M a + wcount f N a"
   by (auto simp: wcount_def add_mult_distrib)
 
 lemma wcount_add_mset:
   "wcount f (add_mset x M) a = (if x = a then Suc (f a) else 0) + wcount f M a"
   unfolding add_mset_add_single[of _ M] wcount_union by (auto simp: wcount_def)
 
 definition size_multiset :: "('a \<Rightarrow> nat) \<Rightarrow> 'a multiset \<Rightarrow> nat" where
   "size_multiset f M = sum (wcount f M) (set_mset M)"
 
 lemmas size_multiset_eq = size_multiset_def[unfolded wcount_def]
 
 instantiation multiset :: (type) size
 begin
 
 definition size_multiset where
   size_multiset_overloaded_def: "size_multiset = Multiset.size_multiset (\<lambda>_. 0)"
 instance ..
 
 end
 
 lemmas size_multiset_overloaded_eq =
   size_multiset_overloaded_def[THEN fun_cong, unfolded size_multiset_eq, simplified]
 
 lemma size_multiset_empty [simp]: "size_multiset f {#} = 0"
 by (simp add: size_multiset_def)
 
 lemma size_empty [simp]: "size {#} = 0"
 by (simp add: size_multiset_overloaded_def)
 
 lemma size_multiset_single : "size_multiset f {#b#} = Suc (f b)"
 by (simp add: size_multiset_eq)
 
 lemma size_single: "size {#b#} = 1"
 by (simp add: size_multiset_overloaded_def size_multiset_single)
 
 lemma sum_wcount_Int:
   "finite A \<Longrightarrow> sum (wcount f N) (A \<inter> set_mset N) = sum (wcount f N) A"
   by (induct rule: finite_induct)
     (simp_all add: Int_insert_left wcount_def count_eq_zero_iff)
 
 lemma size_multiset_union [simp]:
   "size_multiset f (M + N::'a multiset) = size_multiset f M + size_multiset f N"
 apply (simp add: size_multiset_def sum_Un_nat sum.distrib sum_wcount_Int wcount_union)
 apply (subst Int_commute)
 apply (simp add: sum_wcount_Int)
 done
 
 lemma size_multiset_add_mset [simp]:
   "size_multiset f (add_mset a M) = Suc (f a) + size_multiset f M"
   unfolding add_mset_add_single[of _ M] size_multiset_union by (auto simp: size_multiset_single)
 
 lemma size_add_mset [simp]: "size (add_mset a A) = Suc (size A)"
 by (simp add: size_multiset_overloaded_def wcount_add_mset)
 
 lemma size_union [simp]: "size (M + N::'a multiset) = size M + size N"
 by (auto simp add: size_multiset_overloaded_def)
 
 lemma size_multiset_eq_0_iff_empty [iff]:
   "size_multiset f M = 0 \<longleftrightarrow> M = {#}"
   by (auto simp add: size_multiset_eq count_eq_zero_iff)
 
 lemma size_eq_0_iff_empty [iff]: "(size M = 0) = (M = {#})"
 by (auto simp add: size_multiset_overloaded_def)
 
 lemma nonempty_has_size: "(S \<noteq> {#}) = (0 < size S)"
 by (metis gr0I gr_implies_not0 size_empty size_eq_0_iff_empty)
 
 lemma size_eq_Suc_imp_elem: "size M = Suc n \<Longrightarrow> \<exists>a. a \<in># M"
 apply (unfold size_multiset_overloaded_eq)
 apply (drule sum_SucD)
 apply auto
 done
 
 lemma size_eq_Suc_imp_eq_union:
   assumes "size M = Suc n"
   shows "\<exists>a N. M = add_mset a N"
 proof -
   from assms obtain a where "a \<in># M"
     by (erule size_eq_Suc_imp_elem [THEN exE])
   then have "M = add_mset a (M - {#a#})" by simp
   then show ?thesis by blast
 qed
 
 lemma size_mset_mono:
   fixes A B :: "'a multiset"
   assumes "A \<subseteq># B"
   shows "size A \<le> size B"
 proof -
   from assms[unfolded mset_subset_eq_exists_conv]
   obtain C where B: "B = A + C" by auto
   show ?thesis unfolding B by (induct C) auto
 qed
 
 lemma size_filter_mset_lesseq[simp]: "size (filter_mset f M) \<le> size M"
 by (rule size_mset_mono[OF multiset_filter_subset])
 
 lemma size_Diff_submset:
   "M \<subseteq># M' \<Longrightarrow> size (M' - M) = size M' - size(M::'a multiset)"
 by (metis add_diff_cancel_left' size_union mset_subset_eq_exists_conv)
 
 
 subsection \<open>Induction and case splits\<close>
 
 theorem multiset_induct [case_names empty add, induct type: multiset]:
   assumes empty: "P {#}"
   assumes add: "\<And>x M. P M \<Longrightarrow> P (add_mset x M)"
   shows "P M"
 proof (induct "size M" arbitrary: M)
   case 0 thus "P M" by (simp add: empty)
 next
   case (Suc k)
   obtain N x where "M = add_mset x N"
     using \<open>Suc k = size M\<close> [symmetric]
     using size_eq_Suc_imp_eq_union by fast
   with Suc add show "P M" by simp
 qed
 
 lemma multiset_induct_min[case_names empty add]:
   fixes M :: "'a::linorder multiset"
   assumes
     empty: "P {#}" and
     add: "\<And>x M. P M \<Longrightarrow> (\<forall>y \<in># M. y \<ge> x) \<Longrightarrow> P (add_mset x M)"
   shows "P M"
 proof (induct "size M" arbitrary: M)
   case (Suc k)
   note ih = this(1) and Sk_eq_sz_M = this(2)
 
   let ?y = "Min_mset M"
   let ?N = "M - {#?y#}"
 
   have M: "M = add_mset ?y ?N"
     by (metis Min_in Sk_eq_sz_M finite_set_mset insert_DiffM lessI not_less_zero
       set_mset_eq_empty_iff size_empty)
   show ?case
     by (subst M, rule add, rule ih, metis M Sk_eq_sz_M nat.inject size_add_mset,
       meson Min_le finite_set_mset in_diffD)
 qed (simp add: empty)
 
 lemma multiset_induct_max[case_names empty add]:
   fixes M :: "'a::linorder multiset"
   assumes
     empty: "P {#}" and
     add: "\<And>x M. P M \<Longrightarrow> (\<forall>y \<in># M. y \<le> x) \<Longrightarrow> P (add_mset x M)"
   shows "P M"
 proof (induct "size M" arbitrary: M)
   case (Suc k)
   note ih = this(1) and Sk_eq_sz_M = this(2)
 
   let ?y = "Max_mset M"
   let ?N = "M - {#?y#}"
 
   have M: "M = add_mset ?y ?N"
     by (metis Max_in Sk_eq_sz_M finite_set_mset insert_DiffM lessI not_less_zero
       set_mset_eq_empty_iff size_empty)
   show ?case
     by (subst M, rule add, rule ih, metis M Sk_eq_sz_M nat.inject size_add_mset,
       meson Max_ge finite_set_mset in_diffD)
 qed (simp add: empty)
 
 lemma multi_nonempty_split: "M \<noteq> {#} \<Longrightarrow> \<exists>A a. M = add_mset a A"
 by (induct M) auto
 
 lemma multiset_cases [cases type]:
   obtains (empty) "M = {#}"
     | (add) x N where "M = add_mset x N"
   by (induct M) simp_all
 
 lemma multi_drop_mem_not_eq: "c \<in># B \<Longrightarrow> B - {#c#} \<noteq> B"
 by (cases "B = {#}") (auto dest: multi_member_split)
 
 lemma union_filter_mset_complement[simp]:
   "\<forall>x. P x = (\<not> Q x) \<Longrightarrow> filter_mset P M + filter_mset Q M = M"
 by (subst multiset_eq_iff) auto
 
 lemma multiset_partition: "M = {#x \<in># M. P x#} + {#x \<in># M. \<not> P x#}"
 by simp
 
 lemma mset_subset_size: "A \<subset># B \<Longrightarrow> size A < size B"
 proof (induct A arbitrary: B)
   case empty
   then show ?case
     using nonempty_has_size by auto
 next
   case (add x A)
   have "add_mset x A \<subseteq># B"
     by (meson add.prems subset_mset_def)
   then show ?case
     by (metis (no_types) add.prems add.right_neutral add_diff_cancel_left' leD nat_neq_iff
       size_Diff_submset size_eq_0_iff_empty size_mset_mono subset_mset.le_iff_add subset_mset_def)
 qed
 
 lemma size_1_singleton_mset: "size M = 1 \<Longrightarrow> \<exists>a. M = {#a#}"
   by (cases M) auto
 
 
 subsubsection \<open>Strong induction and subset induction for multisets\<close>
 
 text \<open>Well-foundedness of strict subset relation\<close>
 
 lemma wf_subset_mset_rel: "wf {(M, N :: 'a multiset). M \<subset># N}"
 apply (rule wf_measure [THEN wf_subset, where f1=size])
 apply (clarsimp simp: measure_def inv_image_def mset_subset_size)
 done
 
 lemma wfP_subset_mset[simp]: "wfP (\<subset>#)"
   by (rule wf_subset_mset_rel[to_pred])
 
 lemma full_multiset_induct [case_names less]:
 assumes ih: "\<And>B. \<forall>(A::'a multiset). A \<subset># B \<longrightarrow> P A \<Longrightarrow> P B"
 shows "P B"
 apply (rule wf_subset_mset_rel [THEN wf_induct])
 apply (rule ih, auto)
 done
 
 lemma multi_subset_induct [consumes 2, case_names empty add]:
   assumes "F \<subseteq># A"
     and empty: "P {#}"
     and insert: "\<And>a F. a \<in># A \<Longrightarrow> P F \<Longrightarrow> P (add_mset a F)"
   shows "P F"
 proof -
   from \<open>F \<subseteq># A\<close>
   show ?thesis
   proof (induct F)
     show "P {#}" by fact
   next
     fix x F
     assume P: "F \<subseteq># A \<Longrightarrow> P F" and i: "add_mset x F \<subseteq># A"
     show "P (add_mset x F)"
     proof (rule insert)
       from i show "x \<in># A" by (auto dest: mset_subset_eq_insertD)
       from i have "F \<subseteq># A" by (auto dest: mset_subset_eq_insertD)
       with P show "P F" .
     qed
   qed
 qed
 
 
 subsection \<open>Least and greatest elements\<close>
 
 context begin
 
 qualified lemma
   assumes
     "M \<noteq> {#}" and
     "transp_on (set_mset M) R" and
     "totalp_on (set_mset M) R"
   shows
     bex_least_element: "(\<exists>l \<in># M. \<forall>x \<in># M. x \<noteq> l \<longrightarrow> R l x)" and
     bex_greatest_element: "(\<exists>g \<in># M. \<forall>x \<in># M. x \<noteq> g \<longrightarrow> R x g)"
   using assms
   by (auto intro: Finite_Set.bex_least_element Finite_Set.bex_greatest_element)
 
 end
 
 
 subsection \<open>The fold combinator\<close>
 
 definition fold_mset :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a multiset \<Rightarrow> 'b"
 where
   "fold_mset f s M = Finite_Set.fold (\<lambda>x. f x ^^ count M x) s (set_mset M)"
 
 lemma fold_mset_empty [simp]: "fold_mset f s {#} = s"
   by (simp add: fold_mset_def)
 
 context comp_fun_commute
 begin
 
 lemma fold_mset_add_mset [simp]: "fold_mset f s (add_mset x M) = f x (fold_mset f s M)"
 proof -
   interpret mset: comp_fun_commute "\<lambda>y. f y ^^ count M y"
     by (fact comp_fun_commute_funpow)
   interpret mset_union: comp_fun_commute "\<lambda>y. f y ^^ count (add_mset x M) y"
     by (fact comp_fun_commute_funpow)
   show ?thesis
   proof (cases "x \<in> set_mset M")
     case False
     then have *: "count (add_mset x M) x = 1"
       by (simp add: not_in_iff)
     from False have "Finite_Set.fold (\<lambda>y. f y ^^ count (add_mset x M) y) s (set_mset M) =
       Finite_Set.fold (\<lambda>y. f y ^^ count M y) s (set_mset M)"
       by (auto intro!: Finite_Set.fold_cong comp_fun_commute_on_funpow)
     with False * show ?thesis
       by (simp add: fold_mset_def del: count_add_mset)
   next
     case True
     define N where "N = set_mset M - {x}"
     from N_def True have *: "set_mset M = insert x N" "x \<notin> N" "finite N" by auto
     then have "Finite_Set.fold (\<lambda>y. f y ^^ count (add_mset x M) y) s N =
       Finite_Set.fold (\<lambda>y. f y ^^ count M y) s N"
       by (auto intro!: Finite_Set.fold_cong comp_fun_commute_on_funpow)
     with * show ?thesis by (simp add: fold_mset_def del: count_add_mset) simp
   qed
 qed
 
 corollary fold_mset_single: "fold_mset f s {#x#} = f x s"
   by simp
 
 lemma fold_mset_fun_left_comm: "f x (fold_mset f s M) = fold_mset f (f x s) M"
   by (induct M) (simp_all add: fun_left_comm)
 
 lemma fold_mset_union [simp]: "fold_mset f s (M + N) = fold_mset f (fold_mset f s M) N"
   by (induct M) (simp_all add: fold_mset_fun_left_comm)
 
 lemma fold_mset_fusion:
   assumes "comp_fun_commute g"
     and *: "\<And>x y. h (g x y) = f x (h y)"
   shows "h (fold_mset g w A) = fold_mset f (h w) A"
 proof -
   interpret comp_fun_commute g by (fact assms)
   from * show ?thesis by (induct A) auto
 qed
 
 end
 
 lemma union_fold_mset_add_mset: "A + B = fold_mset add_mset A B"
 proof -
   interpret comp_fun_commute add_mset
     by standard auto
   show ?thesis
     by (induction B) auto
 qed
 
 text \<open>
   A note on code generation: When defining some function containing a
   subterm \<^term>\<open>fold_mset F\<close>, code generation is not automatic. When
   interpreting locale \<open>left_commutative\<close> with \<open>F\<close>, the
   would be code thms for \<^const>\<open>fold_mset\<close> become thms like
   \<^term>\<open>fold_mset F z {#} = z\<close> where \<open>F\<close> is not a pattern but
   contains defined symbols, i.e.\ is not a code thm. Hence a separate
   constant with its own code thms needs to be introduced for \<open>F\<close>. See the image operator below.
 \<close>
 
 
 subsection \<open>Image\<close>
 
 definition image_mset :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a multiset \<Rightarrow> 'b multiset" where
   "image_mset f = fold_mset (add_mset \<circ> f) {#}"
 
 lemma comp_fun_commute_mset_image: "comp_fun_commute (add_mset \<circ> f)"
   by unfold_locales (simp add: fun_eq_iff)
 
 lemma image_mset_empty [simp]: "image_mset f {#} = {#}"
   by (simp add: image_mset_def)
 
 lemma image_mset_single: "image_mset f {#x#} = {#f x#}"
   by (simp add: comp_fun_commute.fold_mset_add_mset comp_fun_commute_mset_image image_mset_def)
 
 lemma image_mset_union [simp]: "image_mset f (M + N) = image_mset f M + image_mset f N"
 proof -
   interpret comp_fun_commute "add_mset \<circ> f"
     by (fact comp_fun_commute_mset_image)
   show ?thesis by (induct N) (simp_all add: image_mset_def)
 qed
 
 corollary image_mset_add_mset [simp]:
   "image_mset f (add_mset a M) = add_mset (f a) (image_mset f M)"
   unfolding image_mset_union add_mset_add_single[of a M] by (simp add: image_mset_single)
 
 lemma set_image_mset [simp]: "set_mset (image_mset f M) = image f (set_mset M)"
   by (induct M) simp_all
 
 lemma size_image_mset [simp]: "size (image_mset f M) = size M"
   by (induct M) simp_all
 
 lemma image_mset_is_empty_iff [simp]: "image_mset f M = {#} \<longleftrightarrow> M = {#}"
   by (cases M) auto
 
 lemma image_mset_If:
   "image_mset (\<lambda>x. if P x then f x else g x) A =
      image_mset f (filter_mset P A) + image_mset g (filter_mset (\<lambda>x. \<not>P x) A)"
   by (induction A) auto
 
 lemma image_mset_Diff:
   assumes "B \<subseteq># A"
   shows   "image_mset f (A - B) = image_mset f A - image_mset f B"
 proof -
   have "image_mset f (A - B + B) = image_mset f (A - B) + image_mset f B"
     by simp
   also from assms have "A - B + B = A"
     by (simp add: subset_mset.diff_add)
   finally show ?thesis by simp
 qed
 
 lemma count_image_mset:
   \<open>count (image_mset f A) x = (\<Sum>y\<in>f -` {x} \<inter> set_mset A. count A y)\<close>
 proof (induction A)
   case empty
   then show ?case by simp
 next
   case (add x A)
   moreover have *: "(if x = y then Suc n else n) = n + (if x = y then 1 else 0)" for n y
     by simp
   ultimately show ?case
     by (auto simp: sum.distrib intro!: sum.mono_neutral_left)
 qed
 
 lemma count_image_mset':
   \<open>count (image_mset f X) y = (\<Sum>x | x \<in># X \<and> y = f x. count X x)\<close>
   by (auto simp add: count_image_mset simp flip: singleton_conv2 simp add: Collect_conj_eq ac_simps)
 
 lemma image_mset_subseteq_mono: "A \<subseteq># B \<Longrightarrow> image_mset f A \<subseteq># image_mset f B"
   by (metis image_mset_union subset_mset.le_iff_add)
 
 lemma image_mset_subset_mono: "M \<subset># N \<Longrightarrow> image_mset f M \<subset># image_mset f N"
   by (metis (no_types) Diff_eq_empty_iff_mset image_mset_Diff image_mset_is_empty_iff
     image_mset_subseteq_mono subset_mset.less_le_not_le)
 
 syntax (ASCII)
   "_comprehension_mset" :: "'a \<Rightarrow> 'b \<Rightarrow> 'b multiset \<Rightarrow> 'a multiset"  ("({#_/. _ :# _#})")
 syntax
   "_comprehension_mset" :: "'a \<Rightarrow> 'b \<Rightarrow> 'b multiset \<Rightarrow> 'a multiset"  ("({#_/. _ \<in># _#})")
 translations
   "{#e. x \<in># M#}" \<rightleftharpoons> "CONST image_mset (\<lambda>x. e) M"
 
 syntax (ASCII)
   "_comprehension_mset'" :: "'a \<Rightarrow> 'b \<Rightarrow> 'b multiset \<Rightarrow> bool \<Rightarrow> 'a multiset"  ("({#_/ | _ :# _./ _#})")
 syntax
   "_comprehension_mset'" :: "'a \<Rightarrow> 'b \<Rightarrow> 'b multiset \<Rightarrow> bool \<Rightarrow> 'a multiset"  ("({#_/ | _ \<in># _./ _#})")
 translations
   "{#e | x\<in>#M. P#}" \<rightharpoonup> "{#e. x \<in># {# x\<in>#M. P#}#}"
 
 text \<open>
   This allows to write not just filters like \<^term>\<open>{#x\<in>#M. x<c#}\<close>
   but also images like \<^term>\<open>{#x+x. x\<in>#M #}\<close> and @{term [source]
   "{#x+x|x\<in>#M. x<c#}"}, where the latter is currently displayed as
   \<^term>\<open>{#x+x|x\<in>#M. x<c#}\<close>.
 \<close>
 
 lemma in_image_mset: "y \<in># {#f x. x \<in># M#} \<longleftrightarrow> y \<in> f ` set_mset M"
   by simp
 
 functor image_mset: image_mset
 proof -
   fix f g show "image_mset f \<circ> image_mset g = image_mset (f \<circ> g)"
   proof
     fix A
     show "(image_mset f \<circ> image_mset g) A = image_mset (f \<circ> g) A"
       by (induct A) simp_all
   qed
   show "image_mset id = id"
   proof
     fix A
     show "image_mset id A = id A"
       by (induct A) simp_all
   qed
 qed
 
 declare
   image_mset.id [simp]
   image_mset.identity [simp]
 
 lemma image_mset_id[simp]: "image_mset id x = x"
   unfolding id_def by auto
 
 lemma image_mset_cong: "(\<And>x. x \<in># M \<Longrightarrow> f x = g x) \<Longrightarrow> {#f x. x \<in># M#} = {#g x. x \<in># M#}"
   by (induct M) auto
 
 lemma image_mset_cong_pair:
   "(\<forall>x y. (x, y) \<in># M \<longrightarrow> f x y = g x y) \<Longrightarrow> {#f x y. (x, y) \<in># M#} = {#g x y. (x, y) \<in># M#}"
   by (metis image_mset_cong split_cong)
 
 lemma image_mset_const_eq:
   "{#c. a \<in># M#} = replicate_mset (size M) c"
   by (induct M) simp_all
 
 lemma image_mset_filter_mset_swap:
   "image_mset f (filter_mset (\<lambda>x. P (f x)) M) = filter_mset P (image_mset f M)"
   by (induction M rule: multiset_induct) simp_all
 
 
 lemma image_mset_eq_plusD:
   "image_mset f A = B + C \<Longrightarrow> \<exists>B' C'. A = B' + C' \<and> B = image_mset f B' \<and> C = image_mset f C'"
 proof (induction A arbitrary: B C)
   case empty
   thus ?case by simp
 next
   case (add x A)
   show ?case
   proof (cases "f x \<in># B")
     case True
     with add.prems have "image_mset f A = (B - {#f x#}) + C"
       by (metis add_mset_remove_trivial image_mset_add_mset mset_subset_eq_single
           subset_mset.add_diff_assoc2)
     thus ?thesis
       using add.IH add.prems by force
   next
     case False
     with add.prems have "image_mset f A = B + (C - {#f x#})"
       by (metis diff_single_eq_union diff_union_single_conv image_mset_add_mset union_iff
           union_single_eq_member)
     then show ?thesis
       using add.IH add.prems by force
   qed
 qed
 
 lemma image_mset_eq_image_mset_plusD:
   assumes "image_mset f A = image_mset f B + C" and inj_f: "inj_on f (set_mset A \<union> set_mset B)"
   shows "\<exists>C'. A = B + C' \<and> C = image_mset f C'"
   using assms
 proof (induction A arbitrary: B C)
   case empty
   thus ?case by simp
 next
   case (add x A)
   show ?case
   proof (cases "x \<in># B")
     case True
     with add.prems have "image_mset f A = image_mset f (B - {#x#}) + C"
       by (smt (verit, del_insts) add.left_commute add_cancel_right_left diff_union_cancelL
           diff_union_single_conv image_mset_union union_mset_add_mset_left
           union_mset_add_mset_right)
     with add.IH have "\<exists>M3'. A = B - {#x#} + M3' \<and> image_mset f M3' = C"
       by (smt (verit, del_insts) True Un_insert_left Un_insert_right add.prems(2) inj_on_insert
           insert_DiffM set_mset_add_mset_insert)
     with True show ?thesis
       by auto
   next
     case False
     with add.prems(2) have "f x \<notin># image_mset f B"
       by auto
     with add.prems(1) have "image_mset f A = image_mset f B + (C - {#f x#})"
       by (metis (no_types, lifting) diff_union_single_conv image_eqI image_mset_Diff
           image_mset_single mset_subset_eq_single set_image_mset union_iff union_single_eq_diff
           union_single_eq_member)
     with add.prems(2) add.IH have "\<exists>M3'. A = B + M3' \<and> C - {#f x#} = image_mset f M3'"
       by auto
     then show ?thesis
       by (metis add.prems(1) add_diff_cancel_left' image_mset_Diff mset_subset_eq_add_left
           union_mset_add_mset_right)
   qed
 qed
 
 lemma image_mset_eq_plus_image_msetD:
   "image_mset f A = B + image_mset f C \<Longrightarrow> inj_on f (set_mset A \<union> set_mset C) \<Longrightarrow>
   \<exists>B'. A = B' + C \<and> B = image_mset f B'"
   unfolding add.commute[of B] add.commute[of _ C]
   by (rule image_mset_eq_image_mset_plusD; assumption)
 
 
 subsection \<open>Further conversions\<close>
 
 primrec mset :: "'a list \<Rightarrow> 'a multiset" where
   "mset [] = {#}" |
   "mset (a # x) = add_mset a (mset x)"
 
 lemma in_multiset_in_set:
   "x \<in># mset xs \<longleftrightarrow> x \<in> set xs"
   by (induct xs) simp_all
 
 lemma count_mset:
   "count (mset xs) x = length (filter (\<lambda>y. x = y) xs)"
   by (induct xs) simp_all
 
 lemma mset_zero_iff[simp]: "(mset x = {#}) = (x = [])"
   by (induct x) auto
 
 lemma mset_zero_iff_right[simp]: "({#} = mset x) = (x = [])"
 by (induct x) auto
 
 lemma count_mset_gt_0: "x \<in> set xs \<Longrightarrow> count (mset xs) x > 0"
   by (induction xs) auto
 
 lemma count_mset_0_iff [simp]: "count (mset xs) x = 0 \<longleftrightarrow> x \<notin> set xs"
   by (induction xs) auto
 
 lemma mset_single_iff[iff]: "mset xs = {#x#} \<longleftrightarrow> xs = [x]"
   by (cases xs) auto
 
 lemma mset_single_iff_right[iff]: "{#x#} = mset xs \<longleftrightarrow> xs = [x]"
   by (cases xs) auto
 
 lemma set_mset_mset[simp]: "set_mset (mset xs) = set xs"
   by (induct xs) auto
 
 lemma set_mset_comp_mset [simp]: "set_mset \<circ> mset = set"
   by (simp add: fun_eq_iff)
 
 lemma size_mset [simp]: "size (mset xs) = length xs"
   by (induct xs) simp_all
 
 lemma mset_append [simp]: "mset (xs @ ys) = mset xs + mset ys"
   by (induct xs arbitrary: ys) auto
 
 lemma mset_filter[simp]: "mset (filter P xs) = {#x \<in># mset xs. P x #}"
   by (induct xs) simp_all
 
 lemma mset_rev [simp]:
   "mset (rev xs) = mset xs"
   by (induct xs) simp_all
 
 lemma surj_mset: "surj mset"
   unfolding surj_def
 proof (rule allI)
   fix M
   show "\<exists>xs. M = mset xs"
     by (induction M) (auto intro: exI[of _ "_ # _"])
 qed
 
 lemma distinct_count_atmost_1:
   "distinct x = (\<forall>a. count (mset x) a = (if a \<in> set x then 1 else 0))"
 proof (induct x)
   case Nil then show ?case by simp
 next
   case (Cons x xs) show ?case (is "?lhs \<longleftrightarrow> ?rhs")
   proof
     assume ?lhs then show ?rhs using Cons by simp
   next
     assume ?rhs then have "x \<notin> set xs"
       by (simp split: if_splits)
     moreover from \<open>?rhs\<close> have "(\<forall>a. count (mset xs) a =
        (if a \<in> set xs then 1 else 0))"
       by (auto split: if_splits simp add: count_eq_zero_iff)
     ultimately show ?lhs using Cons by simp
   qed
 qed
 
 lemma mset_eq_setD:
   assumes "mset xs = mset ys"
   shows "set xs = set ys"
 proof -
   from assms have "set_mset (mset xs) = set_mset (mset ys)"
     by simp
   then show ?thesis by simp
 qed
 
 lemma set_eq_iff_mset_eq_distinct:
   \<open>distinct x \<Longrightarrow> distinct y \<Longrightarrow> set x = set y \<longleftrightarrow> mset x = mset y\<close>
   by (auto simp: multiset_eq_iff distinct_count_atmost_1)
 
 lemma set_eq_iff_mset_remdups_eq:
   \<open>set x = set y \<longleftrightarrow> mset (remdups x) = mset (remdups y)\<close>
 apply (rule iffI)
 apply (simp add: set_eq_iff_mset_eq_distinct[THEN iffD1])
 apply (drule distinct_remdups [THEN distinct_remdups
       [THEN set_eq_iff_mset_eq_distinct [THEN iffD2]]])
 apply simp
 done
 
 lemma mset_eq_imp_distinct_iff:
   \<open>distinct xs \<longleftrightarrow> distinct ys\<close> if \<open>mset xs = mset ys\<close>
   using that by (auto simp add: distinct_count_atmost_1 dest: mset_eq_setD)
 
 lemma nth_mem_mset: "i < length ls \<Longrightarrow> (ls ! i) \<in># mset ls"
 proof (induct ls arbitrary: i)
   case Nil
   then show ?case by simp
 next
   case Cons
   then show ?case by (cases i) auto
 qed
 
 lemma mset_remove1[simp]: "mset (remove1 a xs) = mset xs - {#a#}"
   by (induct xs) (auto simp add: multiset_eq_iff)
 
 lemma mset_eq_length:
   assumes "mset xs = mset ys"
   shows "length xs = length ys"
   using assms by (metis size_mset)
 
 lemma mset_eq_length_filter:
   assumes "mset xs = mset ys"
   shows "length (filter (\<lambda>x. z = x) xs) = length (filter (\<lambda>y. z = y) ys)"
   using assms by (metis count_mset)
 
 lemma fold_multiset_equiv:
   \<open>List.fold f xs = List.fold f ys\<close>
     if f: \<open>\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> f x \<circ> f y = f y \<circ> f x\<close>
     and \<open>mset xs = mset ys\<close>
 using f \<open>mset xs = mset ys\<close> [symmetric] proof (induction xs arbitrary: ys)
   case Nil
   then show ?case by simp
 next
   case (Cons x xs)
   then have *: \<open>set ys = set (x # xs)\<close>
     by (blast dest: mset_eq_setD)
   have \<open>\<And>x y. x \<in> set ys \<Longrightarrow> y \<in> set ys \<Longrightarrow> f x \<circ> f y = f y \<circ> f x\<close>
     by (rule Cons.prems(1)) (simp_all add: *)
   moreover from * have \<open>x \<in> set ys\<close>
     by simp
   ultimately have \<open>List.fold f ys = List.fold f (remove1 x ys) \<circ> f x\<close>
     by (fact fold_remove1_split)
   moreover from Cons.prems have \<open>List.fold f xs = List.fold f (remove1 x ys)\<close>
     by (auto intro: Cons.IH)
   ultimately show ?case
     by simp
 qed
 
 lemma fold_permuted_eq:
   \<open>List.fold (\<odot>) xs z = List.fold (\<odot>) ys z\<close>
     if \<open>mset xs = mset ys\<close>
     and \<open>P z\<close> and P: \<open>\<And>x z. x \<in> set xs \<Longrightarrow> P z \<Longrightarrow> P (x \<odot> z)\<close>
     and f: \<open>\<And>x y z. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> P z \<Longrightarrow> x \<odot> (y \<odot> z) = y \<odot> (x \<odot> z)\<close>
   for f (infixl \<open>\<odot>\<close> 70)
 using \<open>P z\<close> P f \<open>mset xs = mset ys\<close> [symmetric] proof (induction xs arbitrary: ys z)
   case Nil
   then show ?case by simp
 next
   case (Cons x xs)
   then have *: \<open>set ys = set (x # xs)\<close>
     by (blast dest: mset_eq_setD)
   have \<open>P z\<close>
     by (fact Cons.prems(1))
   moreover have \<open>\<And>x z. x \<in> set ys \<Longrightarrow> P z \<Longrightarrow> P (x \<odot> z)\<close>
     by (rule Cons.prems(2)) (simp_all add: *)
   moreover have \<open>\<And>x y z. x \<in> set ys \<Longrightarrow> y \<in> set ys \<Longrightarrow> P z \<Longrightarrow> x \<odot> (y \<odot> z) = y \<odot> (x \<odot> z)\<close>
     by (rule Cons.prems(3)) (simp_all add: *)
   moreover from * have \<open>x \<in> set ys\<close>
     by simp
   ultimately have \<open>fold (\<odot>) ys z = fold (\<odot>) (remove1 x ys) (x \<odot> z)\<close>
     by (induction ys arbitrary: z) auto
   moreover from Cons.prems have \<open>fold (\<odot>) xs (x \<odot> z) = fold (\<odot>) (remove1 x ys) (x \<odot> z)\<close>
     by (auto intro: Cons.IH)
   ultimately show ?case
     by simp
 qed
 
 lemma mset_shuffles: "zs \<in> shuffles xs ys \<Longrightarrow> mset zs = mset xs + mset ys"
   by (induction xs ys arbitrary: zs rule: shuffles.induct) auto
 
 lemma mset_insort [simp]: "mset (insort x xs) = add_mset x (mset xs)"
   by (induct xs) simp_all
 
 lemma mset_map[simp]: "mset (map f xs) = image_mset f (mset xs)"
   by (induct xs) simp_all
 
 global_interpretation mset_set: folding add_mset "{#}"
   defines mset_set = "folding_on.F add_mset {#}"
   by standard (simp add: fun_eq_iff)
 
 lemma sum_multiset_singleton [simp]: "sum (\<lambda>n. {#n#}) A = mset_set A"
   by (induction A rule: infinite_finite_induct) auto
 
 lemma count_mset_set [simp]:
   "finite A \<Longrightarrow> x \<in> A \<Longrightarrow> count (mset_set A) x = 1" (is "PROP ?P")
   "\<not> finite A \<Longrightarrow> count (mset_set A) x = 0" (is "PROP ?Q")
   "x \<notin> A \<Longrightarrow> count (mset_set A) x = 0" (is "PROP ?R")
 proof -
   have *: "count (mset_set A) x = 0" if "x \<notin> A" for A
   proof (cases "finite A")
     case False then show ?thesis by simp
   next
     case True from True \<open>x \<notin> A\<close> show ?thesis by (induct A) auto
   qed
   then show "PROP ?P" "PROP ?Q" "PROP ?R"
   by (auto elim!: Set.set_insert)
 qed \<comment> \<open>TODO: maybe define \<^const>\<open>mset_set\<close> also in terms of \<^const>\<open>Abs_multiset\<close>\<close>
 
 lemma elem_mset_set[simp, intro]: "finite A \<Longrightarrow> x \<in># mset_set A \<longleftrightarrow> x \<in> A"
   by (induct A rule: finite_induct) simp_all
 
 lemma mset_set_Union:
   "finite A \<Longrightarrow> finite B \<Longrightarrow> A \<inter> B = {} \<Longrightarrow> mset_set (A \<union> B) = mset_set A + mset_set B"
   by (induction A rule: finite_induct) auto
 
 lemma filter_mset_mset_set [simp]:
   "finite A \<Longrightarrow> filter_mset P (mset_set A) = mset_set {x\<in>A. P x}"
 proof (induction A rule: finite_induct)
   case (insert x A)
   from insert.hyps have "filter_mset P (mset_set (insert x A)) =
       filter_mset P (mset_set A) + mset_set (if P x then {x} else {})"
     by simp
   also have "filter_mset P (mset_set A) = mset_set {x\<in>A. P x}"
     by (rule insert.IH)
   also from insert.hyps
     have "\<dots> + mset_set (if P x then {x} else {}) =
             mset_set ({x \<in> A. P x} \<union> (if P x then {x} else {}))" (is "_ = mset_set ?A")
      by (intro mset_set_Union [symmetric]) simp_all
   also from insert.hyps have "?A = {y\<in>insert x A. P y}" by auto
   finally show ?case .
 qed simp_all
 
 lemma mset_set_Diff:
   assumes "finite A" "B \<subseteq> A"
   shows  "mset_set (A - B) = mset_set A - mset_set B"
 proof -
   from assms have "mset_set ((A - B) \<union> B) = mset_set (A - B) + mset_set B"
     by (intro mset_set_Union) (auto dest: finite_subset)
   also from assms have "A - B \<union> B = A" by blast
   finally show ?thesis by simp
 qed
 
 lemma mset_set_set: "distinct xs \<Longrightarrow> mset_set (set xs) = mset xs"
   by (induction xs) simp_all
 
 lemma count_mset_set': "count (mset_set A) x = (if finite A \<and> x \<in> A then 1 else 0)"
   by auto
 
 lemma subset_imp_msubset_mset_set: 
   assumes "A \<subseteq> B" "finite B"
   shows   "mset_set A \<subseteq># mset_set B"
 proof (rule mset_subset_eqI)
   fix x :: 'a
   from assms have "finite A" by (rule finite_subset)
   with assms show "count (mset_set A) x \<le> count (mset_set B) x"
     by (cases "x \<in> A"; cases "x \<in> B") auto
 qed
 
 lemma mset_set_set_mset_msubset: "mset_set (set_mset A) \<subseteq># A"
 proof (rule mset_subset_eqI)
   fix x show "count (mset_set (set_mset A)) x \<le> count A x"
     by (cases "x \<in># A") simp_all
 qed
 
 lemma mset_set_upto_eq_mset_upto:
   \<open>mset_set {..<n} = mset [0..<n]\<close>
   by (induction n) (auto simp: ac_simps lessThan_Suc)
 
 context linorder
 begin
 
 definition sorted_list_of_multiset :: "'a multiset \<Rightarrow> 'a list"
 where
   "sorted_list_of_multiset M = fold_mset insort [] M"
 
 lemma sorted_list_of_multiset_empty [simp]:
   "sorted_list_of_multiset {#} = []"
   by (simp add: sorted_list_of_multiset_def)
 
 lemma sorted_list_of_multiset_singleton [simp]:
   "sorted_list_of_multiset {#x#} = [x]"
 proof -
   interpret comp_fun_commute insort by (fact comp_fun_commute_insort)
   show ?thesis by (simp add: sorted_list_of_multiset_def)
 qed
 
 lemma sorted_list_of_multiset_insert [simp]:
   "sorted_list_of_multiset (add_mset x M) = List.insort x (sorted_list_of_multiset M)"
 proof -
   interpret comp_fun_commute insort by (fact comp_fun_commute_insort)
   show ?thesis by (simp add: sorted_list_of_multiset_def)
 qed
 
 end
 
 lemma mset_sorted_list_of_multiset[simp]: "mset (sorted_list_of_multiset M) = M"
   by (induct M) simp_all
 
 lemma sorted_list_of_multiset_mset[simp]: "sorted_list_of_multiset (mset xs) = sort xs"
   by (induct xs) simp_all
 
 lemma finite_set_mset_mset_set[simp]: "finite A \<Longrightarrow> set_mset (mset_set A) = A"
   by auto
 
 lemma mset_set_empty_iff: "mset_set A = {#} \<longleftrightarrow> A = {} \<or> infinite A"
   using finite_set_mset_mset_set by fastforce
 
 lemma infinite_set_mset_mset_set: "\<not> finite A \<Longrightarrow> set_mset (mset_set A) = {}"
   by simp
 
 lemma set_sorted_list_of_multiset [simp]:
   "set (sorted_list_of_multiset M) = set_mset M"
 by (induct M) (simp_all add: set_insort_key)
 
 lemma sorted_list_of_mset_set [simp]:
   "sorted_list_of_multiset (mset_set A) = sorted_list_of_set A"
 by (cases "finite A") (induct A rule: finite_induct, simp_all)
 
 lemma mset_upt [simp]: "mset [m..<n] = mset_set {m..<n}"
   by (induction n) (simp_all add: atLeastLessThanSuc)
 
 lemma image_mset_map_of:
   "distinct (map fst xs) \<Longrightarrow> {#the (map_of xs i). i \<in># mset (map fst xs)#} = mset (map snd xs)"
 proof (induction xs)
   case (Cons x xs)
   have "{#the (map_of (x # xs) i). i \<in># mset (map fst (x # xs))#} =
           add_mset (snd x) {#the (if i = fst x then Some (snd x) else map_of xs i).
              i \<in># mset (map fst xs)#}" (is "_ = add_mset _ ?A") by simp
   also from Cons.prems have "?A = {#the (map_of xs i). i :# mset (map fst xs)#}"
     by (cases x, intro image_mset_cong) (auto simp: in_multiset_in_set)
   also from Cons.prems have "\<dots> = mset (map snd xs)" by (intro Cons.IH) simp_all
   finally show ?case by simp
 qed simp_all
 
 lemma msubset_mset_set_iff[simp]:
   assumes "finite A" "finite B"
   shows "mset_set A \<subseteq># mset_set B \<longleftrightarrow> A \<subseteq> B"
   using assms set_mset_mono subset_imp_msubset_mset_set by fastforce
 
 lemma mset_set_eq_iff[simp]:
   assumes "finite A" "finite B"
   shows "mset_set A = mset_set B \<longleftrightarrow> A = B"
   using assms by (fastforce dest: finite_set_mset_mset_set)
 
 lemma image_mset_mset_set: \<^marker>\<open>contributor \<open>Lukas Bulwahn\<close>\<close>
   assumes "inj_on f A"
   shows "image_mset f (mset_set A) = mset_set (f ` A)"
 proof cases
   assume "finite A"
   from this \<open>inj_on f A\<close> show ?thesis
     by (induct A) auto
 next
   assume "infinite A"
   from this \<open>inj_on f A\<close> have "infinite (f ` A)"
     using finite_imageD by blast
   from \<open>infinite A\<close> \<open>infinite (f ` A)\<close> show ?thesis by simp
 qed
 
 
 subsection \<open>More properties of the replicate and repeat operations\<close>
 
 lemma in_replicate_mset[simp]: "x \<in># replicate_mset n y \<longleftrightarrow> n > 0 \<and> x = y"
   unfolding replicate_mset_def by (induct n) auto
 
 lemma set_mset_replicate_mset_subset[simp]: "set_mset (replicate_mset n x) = (if n = 0 then {} else {x})"
   by (auto split: if_splits)
 
 lemma size_replicate_mset[simp]: "size (replicate_mset n M) = n"
   by (induct n, simp_all)
 
 lemma count_le_replicate_mset_subset_eq: "n \<le> count M x \<longleftrightarrow> replicate_mset n x \<subseteq># M"
   by (auto simp add: mset_subset_eqI) (metis count_replicate_mset subseteq_mset_def)
 
 lemma filter_eq_replicate_mset: "{#y \<in># D. y = x#} = replicate_mset (count D x) x"
   by (induct D) simp_all
 
 lemma replicate_count_mset_eq_filter_eq: "replicate (count (mset xs) k) k = filter (HOL.eq k) xs"
   by (induct xs) auto
 
 lemma replicate_mset_eq_empty_iff [simp]: "replicate_mset n a = {#} \<longleftrightarrow> n = 0"
   by (induct n) simp_all
 
 lemma replicate_mset_eq_iff:
   "replicate_mset m a = replicate_mset n b \<longleftrightarrow> m = 0 \<and> n = 0 \<or> m = n \<and> a = b"
   by (auto simp add: multiset_eq_iff)
 
 lemma repeat_mset_cancel1: "repeat_mset a A = repeat_mset a B \<longleftrightarrow> A = B \<or> a = 0"
   by (auto simp: multiset_eq_iff)
 
 lemma repeat_mset_cancel2: "repeat_mset a A = repeat_mset b A \<longleftrightarrow> a = b \<or> A = {#}"
   by (auto simp: multiset_eq_iff)
 
 lemma repeat_mset_eq_empty_iff: "repeat_mset n A = {#} \<longleftrightarrow> n = 0 \<or> A = {#}"
   by (cases n) auto
 
 lemma image_replicate_mset [simp]:
   "image_mset f (replicate_mset n a) = replicate_mset n (f a)"
   by (induct n) simp_all
 
 lemma replicate_mset_msubseteq_iff:
   "replicate_mset m a \<subseteq># replicate_mset n b \<longleftrightarrow> m = 0 \<or> a = b \<and> m \<le> n"
   by (cases m)
     (auto simp: insert_subset_eq_iff simp flip: count_le_replicate_mset_subset_eq)
 
 lemma msubseteq_replicate_msetE:
   assumes "A \<subseteq># replicate_mset n a"
   obtains m where "m \<le> n" and "A = replicate_mset m a"
 proof (cases "n = 0")
   case True
   with assms that show thesis
     by simp
 next
   case False
   from assms have "set_mset A \<subseteq> set_mset (replicate_mset n a)"
     by (rule set_mset_mono)
   with False have "set_mset A \<subseteq> {a}"
     by simp
   then have "\<exists>m. A = replicate_mset m a"
   proof (induction A)
     case empty
     then show ?case
       by simp
   next
     case (add b A)
     then obtain m where "A = replicate_mset m a"
       by auto
     with add.prems show ?case
       by (auto intro: exI [of _ "Suc m"])
   qed
   then obtain m where A: "A = replicate_mset m a" ..
   with assms have "m \<le> n"
     by (auto simp add: replicate_mset_msubseteq_iff)
   then show thesis using A ..
 qed
 
 
 subsection \<open>Big operators\<close>
 
 locale comm_monoid_mset = comm_monoid
 begin
 
 interpretation comp_fun_commute f
   by standard (simp add: fun_eq_iff left_commute)
 
 interpretation comp?: comp_fun_commute "f \<circ> g"
   by (fact comp_comp_fun_commute)
 
 context
 begin
 
 definition F :: "'a multiset \<Rightarrow> 'a"
   where eq_fold: "F M = fold_mset f \<^bold>1 M"
 
 lemma empty [simp]: "F {#} = \<^bold>1"
   by (simp add: eq_fold)
 
 lemma singleton [simp]: "F {#x#} = x"
 proof -
   interpret comp_fun_commute
     by standard (simp add: fun_eq_iff left_commute)
   show ?thesis by (simp add: eq_fold)
 qed
 
 lemma union [simp]: "F (M + N) = F M \<^bold>* F N"
 proof -
   interpret comp_fun_commute f
     by standard (simp add: fun_eq_iff left_commute)
   show ?thesis
     by (induct N) (simp_all add: left_commute eq_fold)
 qed
 
 lemma add_mset [simp]: "F (add_mset x N) = x \<^bold>* F N"
   unfolding add_mset_add_single[of x N] union by (simp add: ac_simps)
 
 lemma insert [simp]:
   shows "F (image_mset g (add_mset x A)) = g x \<^bold>* F (image_mset g A)"
   by (simp add: eq_fold)
 
 lemma remove:
   assumes "x \<in># A"
   shows "F A = x \<^bold>* F (A - {#x#})"
   using multi_member_split[OF assms] by auto
 
 lemma neutral:
   "\<forall>x\<in>#A. x = \<^bold>1 \<Longrightarrow> F A = \<^bold>1"
   by (induct A) simp_all
 
 lemma neutral_const [simp]:
   "F (image_mset (\<lambda>_. \<^bold>1) A) = \<^bold>1"
   by (simp add: neutral)
 
 private lemma F_image_mset_product:
   "F {#g x j \<^bold>* F {#g i j. i \<in># A#}. j \<in># B#} =
     F (image_mset (g x) B) \<^bold>* F {#F {#g i j. i \<in># A#}. j \<in># B#}"
   by (induction B) (simp_all add: left_commute semigroup.assoc semigroup_axioms)
 
 lemma swap:
   "F (image_mset (\<lambda>i. F (image_mset (g i) B)) A) =
     F (image_mset (\<lambda>j. F (image_mset (\<lambda>i. g i j) A)) B)"
   apply (induction A, simp)
   apply (induction B, auto simp add: F_image_mset_product ac_simps)
   done
 
 lemma distrib: "F (image_mset (\<lambda>x. g x \<^bold>* h x) A) = F (image_mset g A) \<^bold>* F (image_mset h A)"
   by (induction A) (auto simp: ac_simps)
 
 lemma union_disjoint:
   "A \<inter># B = {#} \<Longrightarrow> F (image_mset g (A \<union># B)) = F (image_mset g A) \<^bold>* F (image_mset g B)"
   by (induction A) (auto simp: ac_simps)
 
 end
 end
 
 lemma comp_fun_commute_plus_mset[simp]: "comp_fun_commute ((+) :: 'a multiset \<Rightarrow> _ \<Rightarrow> _)"
   by standard (simp add: add_ac comp_def)
 
 declare comp_fun_commute.fold_mset_add_mset[OF comp_fun_commute_plus_mset, simp]
 
 lemma in_mset_fold_plus_iff[iff]: "x \<in># fold_mset (+) M NN \<longleftrightarrow> x \<in># M \<or> (\<exists>N. N \<in># NN \<and> x \<in># N)"
   by (induct NN) auto
 
 context comm_monoid_add
 begin
 
 sublocale sum_mset: comm_monoid_mset plus 0
   defines sum_mset = sum_mset.F ..
 
 lemma sum_unfold_sum_mset:
   "sum f A = sum_mset (image_mset f (mset_set A))"
   by (cases "finite A") (induct A rule: finite_induct, simp_all)
 
 end
 
 notation sum_mset ("\<Sum>\<^sub>#")
 
 syntax (ASCII)
   "_sum_mset_image" :: "pttrn \<Rightarrow> 'b set \<Rightarrow> 'a \<Rightarrow> 'a::comm_monoid_add"  ("(3SUM _:#_. _)" [0, 51, 10] 10)
 syntax
   "_sum_mset_image" :: "pttrn \<Rightarrow> 'b set \<Rightarrow> 'a \<Rightarrow> 'a::comm_monoid_add"  ("(3\<Sum>_\<in>#_. _)" [0, 51, 10] 10)
 translations
   "\<Sum>i \<in># A. b" \<rightleftharpoons> "CONST sum_mset (CONST image_mset (\<lambda>i. b) A)"
 
 context comm_monoid_add
 begin
 
 lemma sum_mset_sum_list:
   "sum_mset (mset xs) = sum_list xs"
   by (induction xs) auto
 
 end
 
 context canonically_ordered_monoid_add
 begin
 
 lemma sum_mset_0_iff [simp]:
   "sum_mset M = 0  \<longleftrightarrow> (\<forall>x \<in> set_mset M. x = 0)"
   by (induction M) auto
 
 end
 
 context ordered_comm_monoid_add
 begin
 
 lemma sum_mset_mono:
   "sum_mset (image_mset f K) \<le> sum_mset (image_mset g K)"
   if "\<And>i. i \<in># K \<Longrightarrow> f i \<le> g i"
   using that by (induction K) (simp_all add: add_mono)
 
 end
 
 context cancel_comm_monoid_add
 begin
 
 lemma sum_mset_diff:
   "sum_mset (M - N) = sum_mset M - sum_mset N" if "N \<subseteq># M" for M N :: "'a multiset"
   using that by (auto simp add: subset_mset.le_iff_add)
 
 end
 
 context semiring_0
 begin
 
 lemma sum_mset_distrib_left:
   "c * (\<Sum>x \<in># M. f x) = (\<Sum>x \<in># M. c * f(x))"
   by (induction M) (simp_all add: algebra_simps)
 
 lemma sum_mset_distrib_right:
   "(\<Sum>x \<in># M. f x) * c = (\<Sum>x \<in># M. f x * c)"
   by (induction M) (simp_all add: algebra_simps)
 
 end
 
 lemma sum_mset_product:
   fixes f :: "'a::{comm_monoid_add,times} \<Rightarrow> 'b::semiring_0"
   shows "(\<Sum>i \<in># A. f i) * (\<Sum>i \<in># B. g i) = (\<Sum>i\<in>#A. \<Sum>j\<in>#B. f i * g j)"
   by (subst sum_mset.swap) (simp add: sum_mset_distrib_left sum_mset_distrib_right)
 
 context semiring_1
 begin
 
 lemma sum_mset_replicate_mset [simp]:
   "sum_mset (replicate_mset n a) = of_nat n * a"
   by (induction n) (simp_all add: algebra_simps)
 
 lemma sum_mset_delta:
   "sum_mset (image_mset (\<lambda>x. if x = y then c else 0) A) = c * of_nat (count A y)"
   by (induction A) (simp_all add: algebra_simps)
 
 lemma sum_mset_delta':
   "sum_mset (image_mset (\<lambda>x. if y = x then c else 0) A) = c * of_nat (count A y)"
   by (induction A) (simp_all add: algebra_simps)
 
 end
 
 lemma of_nat_sum_mset [simp]:
   "of_nat (sum_mset A) = sum_mset (image_mset of_nat A)"
   by (induction A) auto
 
 lemma size_eq_sum_mset:
   "size M = (\<Sum>a\<in>#M. 1)"
   using image_mset_const_eq [of "1::nat" M] by simp
 
 lemma size_mset_set [simp]:
   "size (mset_set A) = card A"
   by (simp only: size_eq_sum_mset card_eq_sum sum_unfold_sum_mset)
 
 lemma sum_mset_constant [simp]:
   fixes y :: "'b::semiring_1"
   shows \<open>(\<Sum>x\<in>#A. y) = of_nat (size A) * y\<close>
   by (induction A) (auto simp: algebra_simps)
 
 lemma set_mset_Union_mset[simp]: "set_mset (\<Sum>\<^sub># MM) = (\<Union>M \<in> set_mset MM. set_mset M)"
   by (induct MM) auto
 
 lemma in_Union_mset_iff[iff]: "x \<in># \<Sum>\<^sub># MM \<longleftrightarrow> (\<exists>M. M \<in># MM \<and> x \<in># M)"
   by (induct MM) auto
 
 lemma count_sum:
   "count (sum f A) x = sum (\<lambda>a. count (f a) x) A"
   by (induct A rule: infinite_finite_induct) simp_all
 
 lemma sum_eq_empty_iff:
   assumes "finite A"
   shows "sum f A = {#} \<longleftrightarrow> (\<forall>a\<in>A. f a = {#})"
   using assms by induct simp_all
 
 lemma Union_mset_empty_conv[simp]: "\<Sum>\<^sub># M = {#} \<longleftrightarrow> (\<forall>i\<in>#M. i = {#})"
   by (induction M) auto
 
 lemma Union_image_single_mset[simp]: "\<Sum>\<^sub># (image_mset (\<lambda>x. {#x#}) m) = m"
 by(induction m) auto
 
 
 context comm_monoid_mult
 begin
 
 sublocale prod_mset: comm_monoid_mset times 1
   defines prod_mset = prod_mset.F ..
 
 lemma prod_mset_empty:
   "prod_mset {#} = 1"
   by (fact prod_mset.empty)
 
 lemma prod_mset_singleton:
   "prod_mset {#x#} = x"
   by (fact prod_mset.singleton)
 
 lemma prod_mset_Un:
   "prod_mset (A + B) = prod_mset A * prod_mset B"
   by (fact prod_mset.union)
 
 lemma prod_mset_prod_list:
   "prod_mset (mset xs) = prod_list xs"
   by (induct xs) auto
 
 lemma prod_mset_replicate_mset [simp]:
   "prod_mset (replicate_mset n a) = a ^ n"
   by (induct n) simp_all
 
 lemma prod_unfold_prod_mset:
   "prod f A = prod_mset (image_mset f (mset_set A))"
   by (cases "finite A") (induct A rule: finite_induct, simp_all)
 
 lemma prod_mset_multiplicity:
   "prod_mset M = prod (\<lambda>x. x ^ count M x) (set_mset M)"
   by (simp add: fold_mset_def prod.eq_fold prod_mset.eq_fold funpow_times_power comp_def)
 
 lemma prod_mset_delta: "prod_mset (image_mset (\<lambda>x. if x = y then c else 1) A) = c ^ count A y"
   by (induction A) simp_all
 
 lemma prod_mset_delta': "prod_mset (image_mset (\<lambda>x. if y = x then c else 1) A) = c ^ count A y"
   by (induction A) simp_all
 
 lemma prod_mset_subset_imp_dvd:
   assumes "A \<subseteq># B"
   shows   "prod_mset A dvd prod_mset B"
 proof -
   from assms have "B = (B - A) + A" by (simp add: subset_mset.diff_add)
   also have "prod_mset \<dots> = prod_mset (B - A) * prod_mset A" by simp
   also have "prod_mset A dvd \<dots>" by simp
   finally show ?thesis .
 qed
 
 lemma dvd_prod_mset:
   assumes "x \<in># A"
   shows "x dvd prod_mset A"
   using assms prod_mset_subset_imp_dvd [of "{#x#}" A] by simp
 
 end
 
 notation prod_mset ("\<Prod>\<^sub>#")
 
 syntax (ASCII)
   "_prod_mset_image" :: "pttrn \<Rightarrow> 'b set \<Rightarrow> 'a \<Rightarrow> 'a::comm_monoid_mult"  ("(3PROD _:#_. _)" [0, 51, 10] 10)
 syntax
   "_prod_mset_image" :: "pttrn \<Rightarrow> 'b set \<Rightarrow> 'a \<Rightarrow> 'a::comm_monoid_mult"  ("(3\<Prod>_\<in>#_. _)" [0, 51, 10] 10)
 translations
   "\<Prod>i \<in># A. b" \<rightleftharpoons> "CONST prod_mset (CONST image_mset (\<lambda>i. b) A)"
 
 lemma prod_mset_constant [simp]: "(\<Prod>_\<in>#A. c) = c ^ size A"
   by (simp add: image_mset_const_eq)
 
 lemma (in semidom) prod_mset_zero_iff [iff]:
   "prod_mset A = 0 \<longleftrightarrow> 0 \<in># A"
   by (induct A) auto
 
 lemma (in semidom_divide) prod_mset_diff:
   assumes "B \<subseteq># A" and "0 \<notin># B"
   shows "prod_mset (A - B) = prod_mset A div prod_mset B"
 proof -
   from assms obtain C where "A = B + C"
     by (metis subset_mset.add_diff_inverse)
   with assms show ?thesis by simp
 qed
 
 lemma (in semidom_divide) prod_mset_minus:
   assumes "a \<in># A" and "a \<noteq> 0"
   shows "prod_mset (A - {#a#}) = prod_mset A div a"
   using assms prod_mset_diff [of "{#a#}" A] by auto
 
 lemma (in normalization_semidom) normalize_prod_mset_normalize:
   "normalize (prod_mset (image_mset normalize A)) = normalize (prod_mset A)"
 proof (induction A)
   case (add x A)
   have "normalize (prod_mset (image_mset normalize (add_mset x A))) =
           normalize (x * normalize (prod_mset (image_mset normalize A)))"
     by simp
   also note add.IH
   finally show ?case by simp
 qed auto
 
 lemma (in algebraic_semidom) is_unit_prod_mset_iff:
   "is_unit (prod_mset A) \<longleftrightarrow> (\<forall>x \<in># A. is_unit x)"
   by (induct A) (auto simp: is_unit_mult_iff)
 
 lemma (in normalization_semidom_multiplicative) normalize_prod_mset:
   "normalize (prod_mset A) = prod_mset (image_mset normalize A)"
   by (induct A) (simp_all add: normalize_mult)
 
 lemma (in normalization_semidom_multiplicative) normalized_prod_msetI:
   assumes "\<And>a. a \<in># A \<Longrightarrow> normalize a = a"
   shows "normalize (prod_mset A) = prod_mset A"
 proof -
   from assms have "image_mset normalize A = A"
     by (induct A) simp_all
   then show ?thesis by (simp add: normalize_prod_mset)
 qed
 
 
 subsection \<open>Multiset as order-ignorant lists\<close>
 
 context linorder
 begin
 
 lemma mset_insort [simp]:
   "mset (insort_key k x xs) = add_mset x (mset xs)"
   by (induct xs) simp_all
 
 lemma mset_sort [simp]:
   "mset (sort_key k xs) = mset xs"
   by (induct xs) simp_all
 
 text \<open>
   This lemma shows which properties suffice to show that a function
   \<open>f\<close> with \<open>f xs = ys\<close> behaves like sort.
 \<close>
 
 lemma properties_for_sort_key:
   assumes "mset ys = mset xs"
     and "\<And>k. k \<in> set ys \<Longrightarrow> filter (\<lambda>x. f k = f x) ys = filter (\<lambda>x. f k = f x) xs"
     and "sorted (map f ys)"
   shows "sort_key f xs = ys"
   using assms
 proof (induct xs arbitrary: ys)
   case Nil then show ?case by simp
 next
   case (Cons x xs)
   from Cons.prems(2) have
     "\<forall>k \<in> set ys. filter (\<lambda>x. f k = f x) (remove1 x ys) = filter (\<lambda>x. f k = f x) xs"
     by (simp add: filter_remove1)
   with Cons.prems have "sort_key f xs = remove1 x ys"
     by (auto intro!: Cons.hyps simp add: sorted_map_remove1)
   moreover from Cons.prems have "x \<in># mset ys"
     by auto
   then have "x \<in> set ys"
     by simp
   ultimately show ?case using Cons.prems by (simp add: insort_key_remove1)
 qed
 
 lemma properties_for_sort:
   assumes multiset: "mset ys = mset xs"
     and "sorted ys"
   shows "sort xs = ys"
 proof (rule properties_for_sort_key)
   from multiset show "mset ys = mset xs" .
   from \<open>sorted ys\<close> show "sorted (map (\<lambda>x. x) ys)" by simp
   from multiset have "length (filter (\<lambda>y. k = y) ys) = length (filter (\<lambda>x. k = x) xs)" for k
     by (rule mset_eq_length_filter)
   then have "replicate (length (filter (\<lambda>y. k = y) ys)) k =
     replicate (length (filter (\<lambda>x. k = x) xs)) k" for k
     by simp
   then show "k \<in> set ys \<Longrightarrow> filter (\<lambda>y. k = y) ys = filter (\<lambda>x. k = x) xs" for k
     by (simp add: replicate_length_filter)
 qed
 
 lemma sort_key_inj_key_eq:
   assumes mset_equal: "mset xs = mset ys"
     and "inj_on f (set xs)"
     and "sorted (map f ys)"
   shows "sort_key f xs = ys"
 proof (rule properties_for_sort_key)
   from mset_equal
   show "mset ys = mset xs" by simp
   from \<open>sorted (map f ys)\<close>
   show "sorted (map f ys)" .
   show "[x\<leftarrow>ys . f k = f x] = [x\<leftarrow>xs . f k = f x]" if "k \<in> set ys" for k
   proof -
     from mset_equal
     have set_equal: "set xs = set ys" by (rule mset_eq_setD)
     with that have "insert k (set ys) = set ys" by auto
     with \<open>inj_on f (set xs)\<close> have inj: "inj_on f (insert k (set ys))"
       by (simp add: set_equal)
     from inj have "[x\<leftarrow>ys . f k = f x] = filter (HOL.eq k) ys"
       by (auto intro!: inj_on_filter_key_eq)
     also have "\<dots> = replicate (count (mset ys) k) k"
       by (simp add: replicate_count_mset_eq_filter_eq)
     also have "\<dots> = replicate (count (mset xs) k) k"
       using mset_equal by simp
     also have "\<dots> = filter (HOL.eq k) xs"
       by (simp add: replicate_count_mset_eq_filter_eq)
     also have "\<dots> = [x\<leftarrow>xs . f k = f x]"
       using inj by (auto intro!: inj_on_filter_key_eq [symmetric] simp add: set_equal)
     finally show ?thesis .
   qed
 qed
 
 lemma sort_key_eq_sort_key:
   assumes "mset xs = mset ys"
     and "inj_on f (set xs)"
   shows "sort_key f xs = sort_key f ys"
   by (rule sort_key_inj_key_eq) (simp_all add: assms)
 
 lemma sort_key_by_quicksort:
   "sort_key f xs = sort_key f [x\<leftarrow>xs. f x < f (xs ! (length xs div 2))]
     @ [x\<leftarrow>xs. f x = f (xs ! (length xs div 2))]
     @ sort_key f [x\<leftarrow>xs. f x > f (xs ! (length xs div 2))]" (is "sort_key f ?lhs = ?rhs")
 proof (rule properties_for_sort_key)
   show "mset ?rhs = mset ?lhs"
     by (rule multiset_eqI) auto
   show "sorted (map f ?rhs)"
     by (auto simp add: sorted_append intro: sorted_map_same)
 next
   fix l
   assume "l \<in> set ?rhs"
   let ?pivot = "f (xs ! (length xs div 2))"
   have *: "\<And>x. f l = f x \<longleftrightarrow> f x = f l" by auto
   have "[x \<leftarrow> sort_key f xs . f x = f l] = [x \<leftarrow> xs. f x = f l]"
     unfolding filter_sort by (rule properties_for_sort_key) (auto intro: sorted_map_same)
   with * have **: "[x \<leftarrow> sort_key f xs . f l = f x] = [x \<leftarrow> xs. f l = f x]" by simp
   have "\<And>x P. P (f x) ?pivot \<and> f l = f x \<longleftrightarrow> P (f l) ?pivot \<and> f l = f x" by auto
   then have "\<And>P. [x \<leftarrow> sort_key f xs . P (f x) ?pivot \<and> f l = f x] =
     [x \<leftarrow> sort_key f xs. P (f l) ?pivot \<and> f l = f x]" by simp
   note *** = this [of "(<)"] this [of "(>)"] this [of "(=)"]
   show "[x \<leftarrow> ?rhs. f l = f x] = [x \<leftarrow> ?lhs. f l = f x]"
   proof (cases "f l" ?pivot rule: linorder_cases)
     case less
     then have "f l \<noteq> ?pivot" and "\<not> f l > ?pivot" by auto
     with less show ?thesis
       by (simp add: filter_sort [symmetric] ** ***)
   next
     case equal then show ?thesis
       by (simp add: * less_le)
   next
     case greater
     then have "f l \<noteq> ?pivot" and "\<not> f l < ?pivot" by auto
     with greater show ?thesis
       by (simp add: filter_sort [symmetric] ** ***)
   qed
 qed
 
 lemma sort_by_quicksort:
   "sort xs = sort [x\<leftarrow>xs. x < xs ! (length xs div 2)]
     @ [x\<leftarrow>xs. x = xs ! (length xs div 2)]
     @ sort [x\<leftarrow>xs. x > xs ! (length xs div 2)]" (is "sort ?lhs = ?rhs")
   using sort_key_by_quicksort [of "\<lambda>x. x", symmetric] by simp
 
 text \<open>A stable parameterized quicksort\<close>
 
 definition part :: "('b \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'b list \<Rightarrow> 'b list \<times> 'b list \<times> 'b list" where
   "part f pivot xs = ([x \<leftarrow> xs. f x < pivot], [x \<leftarrow> xs. f x = pivot], [x \<leftarrow> xs. pivot < f x])"
 
 lemma part_code [code]:
   "part f pivot [] = ([], [], [])"
   "part f pivot (x # xs) = (let (lts, eqs, gts) = part f pivot xs; x' = f x in
      if x' < pivot then (x # lts, eqs, gts)
      else if x' > pivot then (lts, eqs, x # gts)
      else (lts, x # eqs, gts))"
   by (auto simp add: part_def Let_def split_def)
 
 lemma sort_key_by_quicksort_code [code]:
   "sort_key f xs =
     (case xs of
       [] \<Rightarrow> []
     | [x] \<Rightarrow> xs
     | [x, y] \<Rightarrow> (if f x \<le> f y then xs else [y, x])
     | _ \<Rightarrow>
         let (lts, eqs, gts) = part f (f (xs ! (length xs div 2))) xs
         in sort_key f lts @ eqs @ sort_key f gts)"
 proof (cases xs)
   case Nil then show ?thesis by simp
 next
   case (Cons _ ys) note hyps = Cons show ?thesis
   proof (cases ys)
     case Nil with hyps show ?thesis by simp
   next
     case (Cons _ zs) note hyps = hyps Cons show ?thesis
     proof (cases zs)
       case Nil with hyps show ?thesis by auto
     next
       case Cons
       from sort_key_by_quicksort [of f xs]
       have "sort_key f xs = (let (lts, eqs, gts) = part f (f (xs ! (length xs div 2))) xs
         in sort_key f lts @ eqs @ sort_key f gts)"
       by (simp only: split_def Let_def part_def fst_conv snd_conv)
       with hyps Cons show ?thesis by (simp only: list.cases)
     qed
   qed
 qed
 
 end
 
 hide_const (open) part
 
 lemma mset_remdups_subset_eq: "mset (remdups xs) \<subseteq># mset xs"
   by (induct xs) (auto intro: subset_mset.order_trans)
 
 lemma mset_update:
   "i < length ls \<Longrightarrow> mset (ls[i := v]) = add_mset v (mset ls - {#ls ! i#})"
 proof (induct ls arbitrary: i)
   case Nil then show ?case by simp
 next
   case (Cons x xs)
   show ?case
   proof (cases i)
     case 0 then show ?thesis by simp
   next
     case (Suc i')
     with Cons show ?thesis
       by (cases \<open>x = xs ! i'\<close>) auto
   qed
 qed
 
 lemma mset_swap:
   "i < length ls \<Longrightarrow> j < length ls \<Longrightarrow>
     mset (ls[j := ls ! i, i := ls ! j]) = mset ls"
   by (cases "i = j") (simp_all add: mset_update nth_mem_mset)
 
 lemma mset_eq_finite:
   \<open>finite {ys. mset ys = mset xs}\<close>
 proof -
   have \<open>{ys. mset ys = mset xs} \<subseteq> {ys. set ys \<subseteq> set xs \<and> length ys \<le> length xs}\<close>
     by (auto simp add: dest: mset_eq_setD mset_eq_length)
   moreover have \<open>finite {ys. set ys \<subseteq> set xs \<and> length ys \<le> length xs}\<close>
     using finite_lists_length_le by blast
   ultimately show ?thesis
     by (rule finite_subset)
 qed
 
 
 subsection \<open>The multiset order\<close>
 
 definition mult1 :: "('a \<times> 'a) set \<Rightarrow> ('a multiset \<times> 'a multiset) set" where
   "mult1 r = {(N, M). \<exists>a M0 K. M = add_mset a M0 \<and> N = M0 + K \<and>
       (\<forall>b. b \<in># K \<longrightarrow> (b, a) \<in> r)}"
 
 definition mult :: "('a \<times> 'a) set \<Rightarrow> ('a multiset \<times> 'a multiset) set" where
   "mult r = (mult1 r)\<^sup>+"
 
 definition multp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool" where
   "multp r M N \<longleftrightarrow> (M, N) \<in> mult {(x, y). r x y}"
 
 declare multp_def[pred_set_conv]
 
 lemma mult1I:
   assumes "M = add_mset a M0" and "N = M0 + K" and "\<And>b. b \<in># K \<Longrightarrow> (b, a) \<in> r"
   shows "(N, M) \<in> mult1 r"
   using assms unfolding mult1_def by blast
 
 lemma mult1E:
   assumes "(N, M) \<in> mult1 r"
   obtains a M0 K where "M = add_mset a M0" "N = M0 + K" "\<And>b. b \<in># K \<Longrightarrow> (b, a) \<in> r"
   using assms unfolding mult1_def by blast
 
 lemma mono_mult1:
   assumes "r \<subseteq> r'" shows "mult1 r \<subseteq> mult1 r'"
   unfolding mult1_def using assms by blast
 
 lemma mono_mult:
   assumes "r \<subseteq> r'" shows "mult r \<subseteq> mult r'"
   unfolding mult_def using mono_mult1[OF assms] trancl_mono by blast
 
 lemma mono_multp[mono]: "r \<le> r' \<Longrightarrow> multp r \<le> multp r'"
   unfolding le_fun_def le_bool_def
 proof (intro allI impI)
   fix M N :: "'a multiset"
   assume "\<forall>x xa. r x xa \<longrightarrow> r' x xa"
   hence "{(x, y). r x y} \<subseteq> {(x, y). r' x y}"
     by blast
   thus "multp r M N \<Longrightarrow> multp r' M N"
     unfolding multp_def
     by (fact mono_mult[THEN subsetD, rotated])
 qed
 
 lemma not_less_empty [iff]: "(M, {#}) \<notin> mult1 r"
   by (simp add: mult1_def)
 
 
 subsubsection \<open>Well-foundedness\<close>
 
 lemma less_add:
   assumes mult1: "(N, add_mset a M0) \<in> mult1 r"
   shows
     "(\<exists>M. (M, M0) \<in> mult1 r \<and> N = add_mset a M) \<or>
      (\<exists>K. (\<forall>b. b \<in># K \<longrightarrow> (b, a) \<in> r) \<and> N = M0 + K)"
 proof -
   let ?r = "\<lambda>K a. \<forall>b. b \<in># K \<longrightarrow> (b, a) \<in> r"
   let ?R = "\<lambda>N M. \<exists>a M0 K. M = add_mset a M0 \<and> N = M0 + K \<and> ?r K a"
   obtain a' M0' K where M0: "add_mset a M0 = add_mset a' M0'"
     and N: "N = M0' + K"
     and r: "?r K a'"
     using mult1 unfolding mult1_def by auto
   show ?thesis (is "?case1 \<or> ?case2")
   proof -
     from M0 consider "M0 = M0'" "a = a'"
       | K' where "M0 = add_mset a' K'" "M0' = add_mset a K'"
       by atomize_elim (simp only: add_eq_conv_ex)
     then show ?thesis
     proof cases
       case 1
       with N r have "?r K a \<and> N = M0 + K" by simp
       then have ?case2 ..
       then show ?thesis ..
     next
       case 2
       from N 2(2) have n: "N = add_mset a (K' + K)" by simp
       with r 2(1) have "?R (K' + K) M0" by blast
       with n have ?case1 by (simp add: mult1_def)
       then show ?thesis ..
     qed
   qed
 qed
 
 lemma all_accessible:
   assumes "wf r"
   shows "\<forall>M. M \<in> Wellfounded.acc (mult1 r)"
 proof
   let ?R = "mult1 r"
   let ?W = "Wellfounded.acc ?R"
   {
     fix M M0 a
     assume M0: "M0 \<in> ?W"
       and wf_hyp: "\<And>b. (b, a) \<in> r \<Longrightarrow> (\<forall>M \<in> ?W. add_mset b M \<in> ?W)"
       and acc_hyp: "\<forall>M. (M, M0) \<in> ?R \<longrightarrow> add_mset a M \<in> ?W"
     have "add_mset a M0 \<in> ?W"
     proof (rule accI [of "add_mset a M0"])
       fix N
       assume "(N, add_mset a M0) \<in> ?R"
       then consider M where "(M, M0) \<in> ?R" "N = add_mset a M"
         | K where "\<forall>b. b \<in># K \<longrightarrow> (b, a) \<in> r" "N = M0 + K"
         by atomize_elim (rule less_add)
       then show "N \<in> ?W"
       proof cases
         case 1
         from acc_hyp have "(M, M0) \<in> ?R \<longrightarrow> add_mset a M \<in> ?W" ..
         from this and \<open>(M, M0) \<in> ?R\<close> have "add_mset a M \<in> ?W" ..
         then show "N \<in> ?W" by (simp only: \<open>N = add_mset a M\<close>)
       next
         case 2
         from this(1) have "M0 + K \<in> ?W"
         proof (induct K)
           case empty
           from M0 show "M0 + {#} \<in> ?W" by simp
         next
           case (add x K)
           from add.prems have "(x, a) \<in> r" by simp
           with wf_hyp have "\<forall>M \<in> ?W. add_mset x M \<in> ?W" by blast
           moreover from add have "M0 + K \<in> ?W" by simp
           ultimately have "add_mset x (M0 + K) \<in> ?W" ..
           then show "M0 + (add_mset x K) \<in> ?W" by simp
         qed
         then show "N \<in> ?W" by (simp only: 2(2))
       qed
     qed
   } note tedious_reasoning = this
 
   show "M \<in> ?W" for M
   proof (induct M)
     show "{#} \<in> ?W"
     proof (rule accI)
       fix b assume "(b, {#}) \<in> ?R"
       with not_less_empty show "b \<in> ?W" by contradiction
     qed
 
     fix M a assume "M \<in> ?W"
     from \<open>wf r\<close> have "\<forall>M \<in> ?W. add_mset a M \<in> ?W"
     proof induct
       fix a
       assume r: "\<And>b. (b, a) \<in> r \<Longrightarrow> (\<forall>M \<in> ?W. add_mset b M \<in> ?W)"
       show "\<forall>M \<in> ?W. add_mset a M \<in> ?W"
       proof
         fix M assume "M \<in> ?W"
         then show "add_mset a M \<in> ?W"
           by (rule acc_induct) (rule tedious_reasoning [OF _ r])
       qed
     qed
     from this and \<open>M \<in> ?W\<close> show "add_mset a M \<in> ?W" ..
   qed
 qed
 
 lemma wf_mult1: "wf r \<Longrightarrow> wf (mult1 r)"
   by (rule acc_wfI) (rule all_accessible)
 
 lemma wf_mult: "wf r \<Longrightarrow> wf (mult r)"
   unfolding mult_def by (rule wf_trancl) (rule wf_mult1)
 
 lemma wfP_multp: "wfP r \<Longrightarrow> wfP (multp r)"
   unfolding multp_def wfP_def
   by (simp add: wf_mult)
 
 
 subsubsection \<open>Closure-free presentation\<close>
 
 text \<open>One direction.\<close>
 lemma mult_implies_one_step:
   assumes
     trans: "trans r" and
     MN: "(M, N) \<in> mult r"
   shows "\<exists>I J K. N = I + J \<and> M = I + K \<and> J \<noteq> {#} \<and> (\<forall>k \<in> set_mset K. \<exists>j \<in> set_mset J. (k, j) \<in> r)"
   using MN unfolding mult_def mult1_def
 proof (induction rule: converse_trancl_induct)
   case (base y)
   then show ?case by force
 next
   case (step y z) note yz = this(1) and zN = this(2) and N_decomp = this(3)
   obtain I J K where
     N: "N = I + J" "z = I + K" "J \<noteq> {#}" "\<forall>k\<in>#K. \<exists>j\<in>#J. (k, j) \<in> r"
     using N_decomp by blast
   obtain a M0 K' where
     z: "z = add_mset a M0" and y: "y = M0 + K'" and K: "\<forall>b. b \<in># K' \<longrightarrow> (b, a) \<in> r"
     using yz by blast
   show ?case
   proof (cases "a \<in># K")
     case True
     moreover have "\<exists>j\<in>#J. (k, j) \<in> r" if "k \<in># K'" for k
       using K N trans True by (meson that transE)
     ultimately show ?thesis
       by (rule_tac x = I in exI, rule_tac x = J in exI, rule_tac x = "(K - {#a#}) + K'" in exI)
         (use z y N in \<open>auto simp del: subset_mset.add_diff_assoc2 dest: in_diffD\<close>)
   next
     case False
     then have "a \<in># I" by (metis N(2) union_iff union_single_eq_member z)
     moreover have "M0 = I + K - {#a#}"
       using N(2) z by force
     ultimately show ?thesis
       by (rule_tac x = "I - {#a#}" in exI, rule_tac x = "add_mset a J" in exI,
           rule_tac x = "K + K'" in exI)
         (use z y N False K in \<open>auto simp: add.assoc\<close>)
   qed
 qed
 
 lemma multp_implies_one_step:
   "transp R \<Longrightarrow> multp R M N \<Longrightarrow> \<exists>I J K. N = I + J \<and> M = I + K \<and> J \<noteq> {#} \<and> (\<forall>k\<in>#K. \<exists>x\<in>#J. R k x)"
   by (rule mult_implies_one_step[to_pred])
 
 lemma one_step_implies_mult:
   assumes
     "J \<noteq> {#}" and
     "\<forall>k \<in> set_mset K. \<exists>j \<in> set_mset J. (k, j) \<in> r"
   shows "(I + K, I + J) \<in> mult r"
   using assms
 proof (induction "size J" arbitrary: I J K)
   case 0
   then show ?case by auto
 next
   case (Suc n) note IH = this(1) and size_J = this(2)[THEN sym]
   obtain J' a where J: "J = add_mset a J'"
     using size_J by (blast dest: size_eq_Suc_imp_eq_union)
   show ?case
   proof (cases "J' = {#}")
     case True
     then show ?thesis
       using J Suc by (fastforce simp add: mult_def mult1_def)
   next
     case [simp]: False
     have K: "K = {#x \<in># K. (x, a) \<in> r#} + {#x \<in># K. (x, a) \<notin> r#}"
       by simp
     have "(I + K, (I + {# x \<in># K. (x, a) \<in> r #}) + J') \<in> mult r"
       using IH[of J' "{# x \<in># K. (x, a) \<notin> r#}" "I + {# x \<in># K. (x, a) \<in> r#}"]
         J Suc.prems K size_J by (auto simp: ac_simps)
     moreover have "(I + {#x \<in># K. (x, a) \<in> r#} + J', I + J) \<in> mult r"
       by (fastforce simp: J mult1_def mult_def)
     ultimately show ?thesis
       unfolding mult_def by simp
   qed
 qed
 
 lemma one_step_implies_multp:
   "J \<noteq> {#} \<Longrightarrow> \<forall>k\<in>#K. \<exists>j\<in>#J. R k j \<Longrightarrow> multp R (I + K) (I + J)"
   by (rule one_step_implies_mult[of _ _ "{(x, y). r x y}" for r, folded multp_def, simplified])
 
 lemma subset_implies_mult:
   assumes sub: "A \<subset># B"
   shows "(A, B) \<in> mult r"
 proof -
   have ApBmA: "A + (B - A) = B"
     using sub by simp
   have BmA: "B - A \<noteq> {#}"
     using sub by (simp add: Diff_eq_empty_iff_mset subset_mset.less_le_not_le)
   thus ?thesis
     by (rule one_step_implies_mult[of "B - A" "{#}" _ A, unfolded ApBmA, simplified])
 qed
 
 lemma subset_implies_multp: "A \<subset># B \<Longrightarrow> multp r A B"
   by (rule subset_implies_mult[of _ _ "{(x, y). r x y}" for r, folded multp_def])
 
 lemma multp_repeat_mset_repeat_msetI:
   assumes "transp R" and "multp R A B" and "n \<noteq> 0"
   shows "multp R (repeat_mset n A) (repeat_mset n  B)"
 proof -
   from \<open>transp R\<close> \<open>multp R A B\<close> obtain I J K where
     "B = I + J" and "A = I + K" and "J \<noteq> {#}" and "\<forall>k \<in># K. \<exists>x \<in># J. R k x"
     by (auto dest: multp_implies_one_step)
 
   have repeat_n_A_eq: "repeat_mset n A = repeat_mset n I + repeat_mset n K"
     using \<open>A = I + K\<close> by simp
 
   have repeat_n_B_eq: "repeat_mset n B = repeat_mset n I + repeat_mset n J"
     using \<open>B = I + J\<close> by simp
 
   show ?thesis
     unfolding repeat_n_A_eq repeat_n_B_eq
   proof (rule one_step_implies_multp)
     from \<open>n \<noteq> 0\<close> show "repeat_mset n J \<noteq> {#}"
       using \<open>J \<noteq> {#}\<close>
       by (simp add: repeat_mset_eq_empty_iff)
   next
     show "\<forall>k \<in># repeat_mset n K. \<exists>j \<in># repeat_mset n J. R k j"
       using \<open>\<forall>k \<in># K. \<exists>x \<in># J. R k x\<close>
       by (metis count_greater_zero_iff nat_0_less_mult_iff repeat_mset.rep_eq)
   qed
 qed
 
 
 subsubsection \<open>Monotonicity\<close>
 
 lemma multp_mono_strong:
   assumes "multp R M1 M2" and "transp R" and
     S_if_R: "\<And>x y. x \<in> set_mset M1 \<Longrightarrow> y \<in> set_mset M2 \<Longrightarrow> R x y \<Longrightarrow> S x y"
   shows "multp S M1 M2"
 proof -
   obtain I J K where "M2 = I + J" and "M1 = I + K" and "J \<noteq> {#}" and "\<forall>k\<in>#K. \<exists>x\<in>#J. R k x"
     using multp_implies_one_step[OF \<open>transp R\<close> \<open>multp R M1 M2\<close>] by auto
   show ?thesis
     unfolding \<open>M2 = I + J\<close> \<open>M1 = I + K\<close>
   proof (rule one_step_implies_multp[OF \<open>J \<noteq> {#}\<close>])
     show "\<forall>k\<in>#K. \<exists>j\<in>#J. S k j"
       using S_if_R
       by (metis \<open>M1 = I + K\<close> \<open>M2 = I + J\<close> \<open>\<forall>k\<in>#K. \<exists>x\<in>#J. R k x\<close> union_iff)
   qed
 qed
 
 lemma mult_mono_strong:
   assumes "(M1, M2) \<in> mult r" and "trans r" and
     S_if_R: "\<And>x y. x \<in> set_mset M1 \<Longrightarrow> y \<in> set_mset M2 \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> (x, y) \<in> s"
   shows "(M1, M2) \<in> mult s"
   using assms multp_mono_strong[of "\<lambda>x y. (x, y) \<in> r" M1 M2 "\<lambda>x y. (x, y) \<in> s",
       unfolded multp_def transp_trans_eq, simplified]
   by blast
 
 lemma monotone_on_multp_multp_image_mset:
   assumes "monotone_on A orda ordb f" and "transp orda"
   shows "monotone_on {M. set_mset M \<subseteq> A} (multp orda) (multp ordb) (image_mset f)"
 proof (rule monotone_onI)
   fix M1 M2
   assume
     M1_in: "M1 \<in> {M. set_mset M \<subseteq> A}" and
     M2_in: "M2 \<in> {M. set_mset M \<subseteq> A}" and
     M1_lt_M2: "multp orda M1 M2"
 
   from multp_implies_one_step[OF \<open>transp orda\<close> M1_lt_M2] obtain I J K where
     M2_eq: "M2 = I + J" and
     M1_eq: "M1 = I + K" and
     J_neq_mempty: "J \<noteq> {#}" and
     ball_K_less: "\<forall>k\<in>#K. \<exists>x\<in>#J. orda k x"
     by metis
 
   have "multp ordb (image_mset f I + image_mset f K) (image_mset f I + image_mset f J)"
   proof (intro one_step_implies_multp ballI)
     show "image_mset f J \<noteq> {#}"
       using J_neq_mempty by simp
   next
     fix k' assume "k'\<in>#image_mset f K"
     then obtain k where "k' = f k" and k_in: "k \<in># K"
       by auto
     then obtain j where j_in: "j\<in>#J" and "orda k j"
       using ball_K_less by auto
 
     have "ordb (f k) (f j)"
     proof (rule \<open>monotone_on A orda ordb f\<close>[THEN monotone_onD, OF _ _ \<open>orda k j\<close>])
       show "k \<in> A"
         using M1_eq M1_in k_in by auto
     next
       show "j \<in> A"
         using M2_eq M2_in j_in by auto
     qed
     thus "\<exists>j\<in>#image_mset f J. ordb k' j"
       using \<open>j \<in># J\<close> \<open>k' = f k\<close> by auto
   qed
   thus "multp ordb (image_mset f M1) (image_mset f M2)"
     by (simp add: M1_eq M2_eq)
 qed
 
 lemma monotone_multp_multp_image_mset:
   assumes "monotone orda ordb f" and "transp orda"
   shows "monotone (multp orda) (multp ordb) (image_mset f)"
   by (rule monotone_on_multp_multp_image_mset[OF assms, simplified])
 
 lemma multp_image_mset_image_msetI:
   assumes "multp (\<lambda>x y. R (f x) (f y)) M1 M2" and "transp R"
   shows "multp R (image_mset f M1) (image_mset f M2)"
 proof -
   from \<open>transp R\<close> have "transp (\<lambda>x y. R (f x) (f y))"
     by (auto intro: transpI dest: transpD)
   with \<open>multp (\<lambda>x y. R (f x) (f y)) M1 M2\<close> obtain I J K where
     "M2 = I + J" and "M1 = I + K" and "J \<noteq> {#}" and "\<forall>k\<in>#K. \<exists>x\<in>#J. R (f k) (f x)"
     using multp_implies_one_step by blast
 
   have "multp R (image_mset f I + image_mset f K) (image_mset f I + image_mset f J)"
   proof (rule one_step_implies_multp)
     show "image_mset f J \<noteq> {#}"
       by (simp add: \<open>J \<noteq> {#}\<close>)
   next
     show "\<forall>k\<in>#image_mset f K. \<exists>j\<in>#image_mset f J. R k j"
       by (simp add: \<open>\<forall>k\<in>#K. \<exists>x\<in>#J. R (f k) (f x)\<close>)
   qed
   thus ?thesis
     by (simp add: \<open>M1 = I + K\<close> \<open>M2 = I + J\<close>)
 qed
 
 lemma multp_image_mset_image_msetD:
   assumes
     "multp R (image_mset f A) (image_mset f B)" and
     "transp R" and
     inj_on_f: "inj_on f (set_mset A \<union> set_mset B)"
   shows "multp (\<lambda>x y. R (f x) (f y)) A B"
 proof -
   from assms(1,2) obtain I J K where
     f_B_eq: "image_mset f B = I + J" and
     f_A_eq: "image_mset f A = I + K" and
     J_neq_mempty: "J \<noteq> {#}" and
     ball_K_less: "\<forall>k\<in>#K. \<exists>x\<in>#J. R k x"
     by (auto dest: multp_implies_one_step)
 
   from f_B_eq obtain I' J' where
     B_def: "B = I' + J'" and I_def: "I = image_mset f I'" and J_def: "J = image_mset f J'"
     using image_mset_eq_plusD by blast
 
   from inj_on_f have inj_on_f': "inj_on f (set_mset A \<union> set_mset I')"
     by (rule inj_on_subset) (auto simp add: B_def)
 
   from f_A_eq obtain K' where
     A_def: "A = I' + K'" and K_def: "K = image_mset f K'"
     by (auto simp: I_def dest: image_mset_eq_image_mset_plusD[OF _ inj_on_f'])
 
   show ?thesis
     unfolding A_def B_def
   proof (intro one_step_implies_multp ballI)
     from J_neq_mempty show "J' \<noteq> {#}"
       by (simp add: J_def)
   next
     fix k assume "k \<in># K'"
     with ball_K_less obtain j' where "j' \<in># J" and "R (f k) j'"
       using K_def by auto
     moreover then obtain j where "j \<in># J'" and "f j = j'"
       using J_def by auto
     ultimately show "\<exists>j\<in>#J'. R (f k) (f j)"
       by blast
   qed
 qed
 
 
 subsubsection \<open>The multiset extension is cancellative for multiset union\<close>
 
 lemma mult_cancel:
   assumes "trans s" and "irrefl_on (set_mset Z) s"
   shows "(X + Z, Y + Z) \<in> mult s \<longleftrightarrow> (X, Y) \<in> mult s" (is "?L \<longleftrightarrow> ?R")
 proof
   assume ?L thus ?R
     using \<open>irrefl_on (set_mset Z) s\<close>
   proof (induct Z)
     case (add z Z)
     obtain X' Y' Z' where *: "add_mset z X + Z = Z' + X'" "add_mset z Y + Z = Z' + Y'" "Y' \<noteq> {#}"
       "\<forall>x \<in> set_mset X'. \<exists>y \<in> set_mset Y'. (x, y) \<in> s"
       using mult_implies_one_step[OF \<open>trans s\<close> add(2)] by auto
     consider Z2 where "Z' = add_mset z Z2" | X2 Y2 where "X' = add_mset z X2" "Y' = add_mset z Y2"
       using *(1,2) by (metis add_mset_remove_trivial_If insert_iff set_mset_add_mset_insert union_iff)
     thus ?case
     proof (cases)
       case 1 thus ?thesis
         using * one_step_implies_mult[of Y' X' s Z2] add(3)
         by (auto simp: add.commute[of _ "{#_#}"] add.assoc intro: add(1) elim: irrefl_on_subset)
     next
       case 2 then obtain y where "y \<in> set_mset Y2" "(z, y) \<in> s"
         using *(4) \<open>irrefl_on (set_mset (add_mset z Z)) s\<close>
         by (auto simp: irrefl_on_def)
       moreover from this transD[OF \<open>trans s\<close> _ this(2)]
       have "x' \<in> set_mset X2 \<Longrightarrow> \<exists>y \<in> set_mset Y2. (x', y) \<in> s" for x'
         using 2 *(4)[rule_format, of x'] by auto
       ultimately show ?thesis
         using * one_step_implies_mult[of Y2 X2 s Z'] 2 add(3)
         by (force simp: add.commute[of "{#_#}"] add.assoc[symmetric] intro: add(1)
             elim: irrefl_on_subset)
     qed
   qed auto
 next
   assume ?R then obtain I J K
     where "Y = I + J" "X = I + K" "J \<noteq> {#}" "\<forall>k \<in> set_mset K. \<exists>j \<in> set_mset J. (k, j) \<in> s"
     using mult_implies_one_step[OF \<open>trans s\<close>] by blast
   thus ?L using one_step_implies_mult[of J K s "I + Z"] by (auto simp: ac_simps)
 qed
 
 lemma multp_cancel:
   "transp R \<Longrightarrow> irreflp_on (set_mset Z) R \<Longrightarrow> multp R (X + Z) (Y + Z) \<longleftrightarrow> multp R X Y"
   by (rule mult_cancel[to_pred])
 
 lemma mult_cancel_add_mset:
   "trans r \<Longrightarrow> irrefl_on {z} r \<Longrightarrow>
     ((add_mset z X, add_mset z Y) \<in> mult r) = ((X, Y) \<in> mult r)"
   by (rule mult_cancel[of _ "{#_#}", simplified])
 
 lemma multp_cancel_add_mset:
   "transp R \<Longrightarrow> irreflp_on {z} R \<Longrightarrow> multp R (add_mset z X) (add_mset z Y) = multp R X Y"
   by (rule mult_cancel_add_mset[to_pred, folded bot_set_def])
 
 lemma mult_cancel_max0:
   assumes "trans s" and "irrefl_on (set_mset X \<inter> set_mset Y) s"
   shows "(X, Y) \<in> mult s \<longleftrightarrow> (X - X \<inter># Y, Y - X \<inter># Y) \<in> mult s" (is "?L \<longleftrightarrow> ?R")
 proof -
   have "(X - X \<inter># Y + X \<inter># Y, Y - X \<inter># Y + X \<inter># Y) \<in> mult s \<longleftrightarrow> (X - X \<inter># Y, Y - X \<inter># Y) \<in> mult s"
   proof (rule mult_cancel)
     from assms show "trans s"
       by simp
   next
     from assms show "irrefl_on (set_mset (X \<inter># Y)) s"
       by simp
   qed
   moreover have "X - X \<inter># Y + X \<inter># Y = X" "Y - X \<inter># Y + X \<inter># Y = Y"
     by (auto simp flip: count_inject)
   ultimately show ?thesis
     by simp
 qed
 
 lemma mult_cancel_max:
   "trans r \<Longrightarrow> irrefl_on (set_mset X \<inter> set_mset Y) r \<Longrightarrow>
     (X, Y) \<in> mult r \<longleftrightarrow> (X - Y, Y - X) \<in> mult r"
   by (rule mult_cancel_max0[simplified])
 
 lemma multp_cancel_max:
   "transp R \<Longrightarrow> irreflp_on (set_mset X \<inter> set_mset Y) R \<Longrightarrow> multp R X Y \<longleftrightarrow> multp R (X - Y) (Y - X)"
   by (rule mult_cancel_max[to_pred])
 
 
 subsubsection \<open>Strict partial-order properties\<close>
 
 lemma mult1_lessE:
   assumes "(N, M) \<in> mult1 {(a, b). r a b}" and "asymp r"
   obtains a M0 K where "M = add_mset a M0" "N = M0 + K"
     "a \<notin># K" "\<And>b. b \<in># K \<Longrightarrow> r b a"
 proof -
   from assms obtain a M0 K where "M = add_mset a M0" "N = M0 + K" and
     *: "b \<in># K \<Longrightarrow> r b a" for b by (blast elim: mult1E)
   moreover from * [of a] have "a \<notin># K"
     using \<open>asymp r\<close> by (meson asympD)
   ultimately show thesis by (auto intro: that)
 qed
 
 lemma trans_mult: "trans r \<Longrightarrow> trans (mult r)"
   by (simp add: mult_def)
 
 lemma transp_multp: "transp r \<Longrightarrow> transp (multp r)"
   unfolding multp_def transp_trans_eq
   by (fact trans_mult[of "{(x, y). r x y}" for r, folded transp_trans])
 
 lemma irrefl_mult:
   assumes "trans r" "irrefl r"
   shows "irrefl (mult r)"
 proof (intro irreflI notI)
   fix M
   assume "(M, M) \<in> mult r"
   then obtain I J K where "M = I + J" and "M = I + K"
     and "J \<noteq> {#}" and "(\<forall>k\<in>set_mset K. \<exists>j\<in>set_mset J. (k, j) \<in> r)"
     using mult_implies_one_step[OF \<open>trans r\<close>] by blast
   then have *: "K \<noteq> {#}" and **: "\<forall>k\<in>set_mset K. \<exists>j\<in>set_mset K. (k, j) \<in> r" by auto
   have "finite (set_mset K)" by simp
   hence "set_mset K = {}"
     using **
   proof (induction rule: finite_induct)
     case empty
     thus ?case by simp
   next
     case (insert x F)
     have False
       using \<open>irrefl r\<close>[unfolded irrefl_def, rule_format]
       using \<open>trans r\<close>[THEN transD]
       by (metis equals0D insert.IH insert.prems insertE insertI1 insertI2)
     thus ?case ..
   qed
   with * show False by simp
 qed
 
 lemma irreflp_multp: "transp R \<Longrightarrow> irreflp R \<Longrightarrow> irreflp (multp R)"
   by (rule irrefl_mult[of "{(x, y). r x y}" for r,
     folded transp_trans_eq irreflp_irrefl_eq, simplified, folded multp_def])
 
 instantiation multiset :: (preorder) order begin
 
 definition less_multiset :: "'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool"
   where "M < N \<longleftrightarrow> multp (<) M N"
 
 definition less_eq_multiset :: "'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool"
   where "less_eq_multiset M N \<longleftrightarrow> M < N \<or> M = N"
 
 instance
 proof intro_classes
   fix M N :: "'a multiset"
   show "(M < N) = (M \<le> N \<and> \<not> N \<le> M)"
     unfolding less_eq_multiset_def less_multiset_def
     by (metis irreflp_def irreflp_on_less irreflp_multp transpE transp_on_less transp_multp)
 next
   fix M :: "'a multiset"
   show "M \<le> M"
     unfolding less_eq_multiset_def
     by simp
 next
   fix M1 M2 M3 :: "'a multiset"
   show "M1 \<le> M2 \<Longrightarrow> M2 \<le> M3 \<Longrightarrow> M1 \<le> M3"
     unfolding less_eq_multiset_def less_multiset_def
     using transp_multp[OF transp_on_less, THEN transpD]
     by blast
 next
   fix M N :: "'a multiset"
   show "M \<le> N \<Longrightarrow> N \<le> M \<Longrightarrow> M = N"
     unfolding less_eq_multiset_def less_multiset_def
     using transp_multp[OF transp_on_less, THEN transpD]
     using irreflp_multp[OF transp_on_less irreflp_on_less, unfolded irreflp_def, rule_format]
     by blast
 qed
 
 end
 
 lemma mset_le_irrefl [elim!]:
   fixes M :: "'a::preorder multiset"
   shows "M < M \<Longrightarrow> R"
   by simp
 
 lemma wfP_less_multiset[simp]:
   assumes wfP_less: "wfP ((<) :: ('a :: preorder) \<Rightarrow> 'a \<Rightarrow> bool)"
   shows "wfP ((<) :: 'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool)"
   using wfP_multp[OF wfP_less] less_multiset_def
   by (metis wfPUNIVI wfP_induct)
 
 
 subsubsection \<open>Strict total-order properties\<close>
 
 lemma total_on_mult:
   assumes "total_on A r" and "trans r" and "\<And>M. M \<in> B \<Longrightarrow> set_mset M \<subseteq> A"
   shows "total_on B (mult r)"
 proof (rule total_onI)
   fix M1 M2 assume "M1 \<in> B" and "M2 \<in> B" and "M1 \<noteq> M2"
   let ?I = "M1 \<inter># M2"
   show "(M1, M2) \<in> mult r \<or> (M2, M1) \<in> mult r"
   proof (cases "M1 - ?I = {#} \<or> M2 - ?I = {#}")
     case True
     with \<open>M1 \<noteq> M2\<close> show ?thesis
       by (metis Diff_eq_empty_iff_mset diff_intersect_left_idem diff_intersect_right_idem
           subset_implies_mult subset_mset.less_le)
   next
     case False
     from assms(1) have "total_on (set_mset (M1 - ?I)) r"
       by (meson \<open>M1 \<in> B\<close> assms(3) diff_subset_eq_self set_mset_mono total_on_subset)
     with False obtain greatest1 where
       greatest1_in: "greatest1 \<in># M1 - ?I" and
       greatest1_greatest: "\<forall>x \<in># M1 - ?I. greatest1 \<noteq> x \<longrightarrow> (x, greatest1) \<in> r"
       using Multiset.bex_greatest_element[to_set, of "M1 - ?I" r]
       by (metis assms(2) subset_UNIV trans_on_subset)
 
     from assms(1) have "total_on (set_mset (M2 - ?I)) r"
       by (meson \<open>M2 \<in> B\<close> assms(3) diff_subset_eq_self set_mset_mono total_on_subset)
     with False obtain greatest2 where
       greatest2_in: "greatest2 \<in># M2 - ?I" and
       greatest2_greatest: "\<forall>x \<in># M2 - ?I. greatest2 \<noteq> x \<longrightarrow> (x, greatest2) \<in> r"
       using Multiset.bex_greatest_element[to_set, of "M2 - ?I" r]
       by (metis assms(2) subset_UNIV trans_on_subset)
 
     have "greatest1 \<noteq> greatest2"
       using greatest1_in \<open>greatest2 \<in># M2 - ?I\<close>
       by (metis diff_intersect_left_idem diff_intersect_right_idem dual_order.eq_iff in_diff_count
           in_diff_countE le_add_same_cancel2 less_irrefl zero_le)
     hence "(greatest1, greatest2) \<in> r \<or> (greatest2, greatest1) \<in> r"
       using \<open>total_on A r\<close>[unfolded total_on_def, rule_format, of greatest1 greatest2]
         \<open>M1 \<in> B\<close> \<open>M2 \<in> B\<close> greatest1_in greatest2_in assms(3)
       by (meson in_diffD in_mono)
     thus ?thesis
     proof (elim disjE)
       assume "(greatest1, greatest2) \<in> r"
       have "(?I + (M1 - ?I), ?I + (M2 - ?I)) \<in> mult r"
       proof (rule one_step_implies_mult[of "M2 - ?I" "M1 - ?I" r ?I])
         show "M2 - ?I \<noteq> {#}"
           using False by force
       next
         show "\<forall>k\<in>#M1 - ?I. \<exists>j\<in>#M2 - ?I. (k, j) \<in> r"
           using \<open>(greatest1, greatest2) \<in> r\<close> greatest2_in greatest1_greatest
           by (metis assms(2) transD)
       qed
       hence "(M1, M2) \<in> mult r"
         by (metis subset_mset.add_diff_inverse subset_mset.inf.cobounded1
             subset_mset.inf.cobounded2)
       thus "(M1, M2) \<in> mult r \<or> (M2, M1) \<in> mult r" ..
     next
       assume "(greatest2, greatest1) \<in> r"
       have "(?I + (M2 - ?I), ?I + (M1 - ?I)) \<in> mult r"
       proof (rule one_step_implies_mult[of "M1 - ?I" "M2 - ?I" r ?I])
         show "M1 - M1 \<inter># M2 \<noteq> {#}"
           using False by force
       next
         show "\<forall>k\<in>#M2 - ?I. \<exists>j\<in>#M1 - ?I. (k, j) \<in> r"
           using \<open>(greatest2, greatest1) \<in> r\<close> greatest1_in greatest2_greatest
           by (metis assms(2) transD)
       qed
       hence "(M2, M1) \<in> mult r"
         by (metis subset_mset.add_diff_inverse subset_mset.inf.cobounded1
             subset_mset.inf.cobounded2)
       thus "(M1, M2) \<in> mult r \<or> (M2, M1) \<in> mult r" ..
     qed
   qed
 qed
 
 lemma total_mult: "total r \<Longrightarrow> trans r \<Longrightarrow> total (mult r)"
   by (rule total_on_mult[of UNIV r UNIV, simplified])
 
 lemma totalp_on_multp:
   "totalp_on A R \<Longrightarrow> transp R \<Longrightarrow> (\<And>M. M \<in> B \<Longrightarrow> set_mset M \<subseteq> A) \<Longrightarrow> totalp_on B (multp R)"
   using total_on_mult[of A "{(x,y). R x y}" B, to_pred]
   by (simp add: multp_def total_on_def totalp_on_def)
 
 lemma totalp_multp: "totalp R \<Longrightarrow> transp R \<Longrightarrow> totalp (multp R)"
   by (rule totalp_on_multp[of UNIV R UNIV, simplified])
 
 
 subsection \<open>Quasi-executable version of the multiset extension\<close>
 
 text \<open>
   Predicate variants of \<open>mult\<close> and the reflexive closure of \<open>mult\<close>, which are
   executable whenever the given predicate \<open>P\<close> is. Together with the standard
   code equations for \<open>(\<inter>#\<close>) and \<open>(-\<close>) this should yield quadratic
   (with respect to calls to \<open>P\<close>) implementations of \<open>multp_code\<close> and \<open>multeqp_code\<close>.
 \<close>
 
 definition multp_code :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool" where
   "multp_code P N M =
     (let Z = M \<inter># N; X = M - Z in
     X \<noteq> {#} \<and> (let Y = N - Z in (\<forall>y \<in> set_mset Y. \<exists>x \<in> set_mset X. P y x)))"
 
 definition multeqp_code :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool" where
   "multeqp_code P N M =
     (let Z = M \<inter># N; X = M - Z; Y = N - Z in
     (\<forall>y \<in> set_mset Y. \<exists>x \<in> set_mset X. P y x))"
 
 lemma multp_code_iff_mult:
   assumes "irrefl_on (set_mset N \<inter> set_mset M) R" and "trans R" and
     [simp]: "\<And>x y. P x y \<longleftrightarrow> (x, y) \<in> R"
   shows "multp_code P N M \<longleftrightarrow> (N, M) \<in> mult R" (is "?L \<longleftrightarrow> ?R")
 proof -
   have *: "M \<inter># N + (N - M \<inter># N) = N" "M \<inter># N + (M - M \<inter># N) = M"
     "(M - M \<inter># N) \<inter># (N - M \<inter># N) = {#}" by (auto simp flip: count_inject)
   show ?thesis
   proof
     assume ?L thus ?R
       using one_step_implies_mult[of "M - M \<inter># N" "N - M \<inter># N" R "M \<inter># N"] *
       by (auto simp: multp_code_def Let_def)
   next
     { fix I J K :: "'a multiset" assume "(I + J) \<inter># (I + K) = {#}"
       then have "I = {#}" by (metis inter_union_distrib_right union_eq_empty)
     } note [dest!] = this
     assume ?R thus ?L
       using mult_cancel_max
       using mult_implies_one_step[OF assms(2), of "N - M \<inter># N" "M - M \<inter># N"]
         mult_cancel_max[OF assms(2,1)] * by (auto simp: multp_code_def)
   qed
 qed
 
 lemma multp_code_iff_multp:
   "irreflp_on (set_mset M \<inter> set_mset N) R \<Longrightarrow> transp R \<Longrightarrow> multp_code R M N \<longleftrightarrow> multp R M N"
   using multp_code_iff_mult[simplified, to_pred, of M N R R] by simp
 
 lemma multp_code_eq_multp:
   assumes "irreflp R" and "transp R"
   shows "multp_code R = multp R"
 proof (intro ext)
   fix M N
   show "multp_code R M N = multp R M N"
   proof (rule multp_code_iff_multp)
     from assms show "irreflp_on (set_mset M \<inter> set_mset N) R"
       by (auto intro: irreflp_on_subset)
   next
     from assms show "transp R"
       by simp
   qed
 qed
 
 lemma multeqp_code_iff_reflcl_mult:
   assumes "irrefl_on (set_mset N \<inter> set_mset M) R" and "trans R" and "\<And>x y. P x y \<longleftrightarrow> (x, y) \<in> R"
   shows "multeqp_code P N M \<longleftrightarrow> (N, M) \<in> (mult R)\<^sup>="
 proof -
   { assume "N \<noteq> M" "M - M \<inter># N = {#}"
     then obtain y where "count N y \<noteq> count M y" by (auto simp flip: count_inject)
     then have "\<exists>y. count M y < count N y" using \<open>M - M \<inter># N = {#}\<close>
       by (auto simp flip: count_inject dest!: le_neq_implies_less fun_cong[of _ _ y])
   }
   then have "multeqp_code P N M \<longleftrightarrow> multp_code P N M \<or> N = M"
     by (auto simp: multeqp_code_def multp_code_def Let_def in_diff_count)
   thus ?thesis
     using multp_code_iff_mult[OF assms] by simp
 qed
 
 lemma multeqp_code_iff_reflclp_multp:
   "irreflp_on (set_mset M \<inter> set_mset N) R \<Longrightarrow> transp R \<Longrightarrow> multeqp_code R M N \<longleftrightarrow> (multp R)\<^sup>=\<^sup>= M N"
   using multeqp_code_iff_reflcl_mult[simplified, to_pred, of M N R R] by simp
 
 lemma multeqp_code_eq_reflclp_multp:
   assumes "irreflp R" and "transp R"
   shows "multeqp_code R = (multp R)\<^sup>=\<^sup>="
 proof (intro ext)
   fix M N
   show "multeqp_code R M N \<longleftrightarrow> (multp R)\<^sup>=\<^sup>= M N"
   proof (rule multeqp_code_iff_reflclp_multp)
     from assms show "irreflp_on (set_mset M \<inter> set_mset N) R"
       by (auto intro: irreflp_on_subset)
   next
     from assms show "transp R"
       by simp
   qed
 qed
 
 
 subsubsection \<open>Monotonicity of multiset union\<close>
 
 lemma mult1_union: "(B, D) \<in> mult1 r \<Longrightarrow> (C + B, C + D) \<in> mult1 r"
   by (force simp: mult1_def)
 
 lemma union_le_mono2: "B < D \<Longrightarrow> C + B < C + (D::'a::preorder multiset)"
 apply (unfold less_multiset_def multp_def mult_def)
 apply (erule trancl_induct)
  apply (blast intro: mult1_union)
 apply (blast intro: mult1_union trancl_trans)
 done
 
 lemma union_le_mono1: "B < D \<Longrightarrow> B + C < D + (C::'a::preorder multiset)"
 apply (subst add.commute [of B C])
 apply (subst add.commute [of D C])
 apply (erule union_le_mono2)
 done
 
 lemma union_less_mono:
   fixes A B C D :: "'a::preorder multiset"
   shows "A < C \<Longrightarrow> B < D \<Longrightarrow> A + B < C + D"
   by (blast intro!: union_le_mono1 union_le_mono2 less_trans)
 
 instantiation multiset :: (preorder) ordered_ab_semigroup_add
 begin
 instance
   by standard (auto simp add: less_eq_multiset_def intro: union_le_mono2)
 end
 
 
 subsubsection \<open>Termination proofs with multiset orders\<close>
 
 lemma multi_member_skip: "x \<in># XS \<Longrightarrow> x \<in># {# y #} + XS"
   and multi_member_this: "x \<in># {# x #} + XS"
   and multi_member_last: "x \<in># {# x #}"
   by auto
 
 definition "ms_strict = mult pair_less"
 definition "ms_weak = ms_strict \<union> Id"
 
 lemma ms_reduction_pair: "reduction_pair (ms_strict, ms_weak)"
 unfolding reduction_pair_def ms_strict_def ms_weak_def pair_less_def
 by (auto intro: wf_mult1 wf_trancl simp: mult_def)
 
 lemma smsI:
   "(set_mset A, set_mset B) \<in> max_strict \<Longrightarrow> (Z + A, Z + B) \<in> ms_strict"
   unfolding ms_strict_def
 by (rule one_step_implies_mult) (auto simp add: max_strict_def pair_less_def elim!:max_ext.cases)
 
 lemma wmsI:
   "(set_mset A, set_mset B) \<in> max_strict \<or> A = {#} \<and> B = {#}
   \<Longrightarrow> (Z + A, Z + B) \<in> ms_weak"
 unfolding ms_weak_def ms_strict_def
 by (auto simp add: pair_less_def max_strict_def elim!:max_ext.cases intro: one_step_implies_mult)
 
 inductive pw_leq
 where
   pw_leq_empty: "pw_leq {#} {#}"
 | pw_leq_step:  "\<lbrakk>(x,y) \<in> pair_leq; pw_leq X Y \<rbrakk> \<Longrightarrow> pw_leq ({#x#} + X) ({#y#} + Y)"
 
 lemma pw_leq_lstep:
   "(x, y) \<in> pair_leq \<Longrightarrow> pw_leq {#x#} {#y#}"
 by (drule pw_leq_step) (rule pw_leq_empty, simp)
 
 lemma pw_leq_split:
   assumes "pw_leq X Y"
   shows "\<exists>A B Z. X = A + Z \<and> Y = B + Z \<and> ((set_mset A, set_mset B) \<in> max_strict \<or> (B = {#} \<and> A = {#}))"
   using assms
 proof induct
   case pw_leq_empty thus ?case by auto
 next
   case (pw_leq_step x y X Y)
   then obtain A B Z where
     [simp]: "X = A + Z" "Y = B + Z"
       and 1[simp]: "(set_mset A, set_mset B) \<in> max_strict \<or> (B = {#} \<and> A = {#})"
     by auto
   from pw_leq_step consider "x = y" | "(x, y) \<in> pair_less"
     unfolding pair_leq_def by auto
   thus ?case
   proof cases
     case [simp]: 1
     have "{#x#} + X = A + ({#y#}+Z) \<and> {#y#} + Y = B + ({#y#}+Z) \<and>
       ((set_mset A, set_mset B) \<in> max_strict \<or> (B = {#} \<and> A = {#}))"
       by auto
     thus ?thesis by blast
   next
     case 2
     let ?A' = "{#x#} + A" and ?B' = "{#y#} + B"
     have "{#x#} + X = ?A' + Z"
       "{#y#} + Y = ?B' + Z"
       by auto
     moreover have
       "(set_mset ?A', set_mset ?B') \<in> max_strict"
       using 1 2 unfolding max_strict_def
       by (auto elim!: max_ext.cases)
     ultimately show ?thesis by blast
   qed
 qed
 
 lemma
   assumes pwleq: "pw_leq Z Z'"
   shows ms_strictI: "(set_mset A, set_mset B) \<in> max_strict \<Longrightarrow> (Z + A, Z' + B) \<in> ms_strict"
     and ms_weakI1:  "(set_mset A, set_mset B) \<in> max_strict \<Longrightarrow> (Z + A, Z' + B) \<in> ms_weak"
     and ms_weakI2:  "(Z + {#}, Z' + {#}) \<in> ms_weak"
 proof -
   from pw_leq_split[OF pwleq]
   obtain A' B' Z''
     where [simp]: "Z = A' + Z''" "Z' = B' + Z''"
     and mx_or_empty: "(set_mset A', set_mset B') \<in> max_strict \<or> (A' = {#} \<and> B' = {#})"
     by blast
   {
     assume max: "(set_mset A, set_mset B) \<in> max_strict"
     from mx_or_empty
     have "(Z'' + (A + A'), Z'' + (B + B')) \<in> ms_strict"
     proof
       assume max': "(set_mset A', set_mset B') \<in> max_strict"
       with max have "(set_mset (A + A'), set_mset (B + B')) \<in> max_strict"
         by (auto simp: max_strict_def intro: max_ext_additive)
       thus ?thesis by (rule smsI)
     next
       assume [simp]: "A' = {#} \<and> B' = {#}"
       show ?thesis by (rule smsI) (auto intro: max)
     qed
     thus "(Z + A, Z' + B) \<in> ms_strict" by (simp add: ac_simps)
     thus "(Z + A, Z' + B) \<in> ms_weak" by (simp add: ms_weak_def)
   }
   from mx_or_empty
   have "(Z'' + A', Z'' + B') \<in> ms_weak" by (rule wmsI)
   thus "(Z + {#}, Z' + {#}) \<in> ms_weak" by (simp add: ac_simps)
 qed
 
 lemma empty_neutral: "{#} + x = x" "x + {#} = x"
 and nonempty_plus: "{# x #} + rs \<noteq> {#}"
 and nonempty_single: "{# x #} \<noteq> {#}"
 by auto
 
 setup \<open>
   let
     fun msetT T = \<^Type>\<open>multiset T\<close>;
 
     fun mk_mset T [] = \<^instantiate>\<open>'a = T in term \<open>{#}\<close>\<close>
       | mk_mset T [x] = \<^instantiate>\<open>'a = T and x in term \<open>{#x#}\<close>\<close>
       | mk_mset T (x :: xs) = \<^Const>\<open>plus \<open>msetT T\<close> for \<open>mk_mset T [x]\<close> \<open>mk_mset T xs\<close>\<close>
 
     fun mset_member_tac ctxt m i =
       if m <= 0 then
         resolve_tac ctxt @{thms multi_member_this} i ORELSE
         resolve_tac ctxt @{thms multi_member_last} i
       else
         resolve_tac ctxt @{thms multi_member_skip} i THEN mset_member_tac ctxt (m - 1) i
 
     fun mset_nonempty_tac ctxt =
       resolve_tac ctxt @{thms nonempty_plus} ORELSE'
       resolve_tac ctxt @{thms nonempty_single}
 
     fun regroup_munion_conv ctxt =
       Function_Lib.regroup_conv ctxt \<^const_abbrev>\<open>empty_mset\<close> \<^const_name>\<open>plus\<close>
         (map (fn t => t RS eq_reflection) (@{thms ac_simps} @ @{thms empty_neutral}))
 
     fun unfold_pwleq_tac ctxt i =
       (resolve_tac ctxt @{thms pw_leq_step} i THEN (fn st => unfold_pwleq_tac ctxt (i + 1) st))
         ORELSE (resolve_tac ctxt @{thms pw_leq_lstep} i)
         ORELSE (resolve_tac ctxt @{thms pw_leq_empty} i)
 
     val set_mset_simps = [@{thm set_mset_empty}, @{thm set_mset_single}, @{thm set_mset_union},
                         @{thm Un_insert_left}, @{thm Un_empty_left}]
   in
     ScnpReconstruct.multiset_setup (ScnpReconstruct.Multiset
     {
       msetT=msetT, mk_mset=mk_mset, mset_regroup_conv=regroup_munion_conv,
       mset_member_tac=mset_member_tac, mset_nonempty_tac=mset_nonempty_tac,
       mset_pwleq_tac=unfold_pwleq_tac, set_of_simps=set_mset_simps,
       smsI'= @{thm ms_strictI}, wmsI2''= @{thm ms_weakI2}, wmsI1= @{thm ms_weakI1},
       reduction_pair = @{thm ms_reduction_pair}
     })
   end
 \<close>
 
 
 subsection \<open>Legacy theorem bindings\<close>
 
 lemmas multi_count_eq = multiset_eq_iff [symmetric]
 
 lemma union_commute: "M + N = N + (M::'a multiset)"
   by (fact add.commute)
 
 lemma union_assoc: "(M + N) + K = M + (N + (K::'a multiset))"
   by (fact add.assoc)
 
 lemma union_lcomm: "M + (N + K) = N + (M + (K::'a multiset))"
   by (fact add.left_commute)
 
 lemmas union_ac = union_assoc union_commute union_lcomm add_mset_commute
 
 lemma union_right_cancel: "M + K = N + K \<longleftrightarrow> M = (N::'a multiset)"
   by (fact add_right_cancel)
 
 lemma union_left_cancel: "K + M = K + N \<longleftrightarrow> M = (N::'a multiset)"
   by (fact add_left_cancel)
 
 lemma multi_union_self_other_eq: "(A::'a multiset) + X = A + Y \<Longrightarrow> X = Y"
   by (fact add_left_imp_eq)
 
 lemma mset_subset_trans: "(M::'a multiset) \<subset># K \<Longrightarrow> K \<subset># N \<Longrightarrow> M \<subset># N"
   by (fact subset_mset.less_trans)
 
 lemma multiset_inter_commute: "A \<inter># B = B \<inter># A"
   by (fact subset_mset.inf.commute)
 
 lemma multiset_inter_assoc: "A \<inter># (B \<inter># C) = A \<inter># B \<inter># C"
   by (fact subset_mset.inf.assoc [symmetric])
 
 lemma multiset_inter_left_commute: "A \<inter># (B \<inter># C) = B \<inter># (A \<inter># C)"
   by (fact subset_mset.inf.left_commute)
 
 lemmas multiset_inter_ac =
   multiset_inter_commute
   multiset_inter_assoc
   multiset_inter_left_commute
 
 lemma mset_le_not_refl: "\<not> M < (M::'a::preorder multiset)"
   by (fact less_irrefl)
 
 lemma mset_le_trans: "K < M \<Longrightarrow> M < N \<Longrightarrow> K < (N::'a::preorder multiset)"
   by (fact less_trans)
 
 lemma mset_le_not_sym: "M < N \<Longrightarrow> \<not> N < (M::'a::preorder multiset)"
   by (fact less_not_sym)
 
 lemma mset_le_asym: "M < N \<Longrightarrow> (\<not> P \<Longrightarrow> N < (M::'a::preorder multiset)) \<Longrightarrow> P"
   by (fact less_asym)
 
 declaration \<open>
   let
     fun multiset_postproc _ maybe_name all_values (T as Type (_, [elem_T])) (Const _ $ t') =
           let
             val (maybe_opt, ps) =
               Nitpick_Model.dest_plain_fun t'
               ||> (~~)
               ||> map (apsnd (snd o HOLogic.dest_number))
             fun elems_for t =
               (case AList.lookup (=) ps t of
                 SOME n => replicate n t
               | NONE => [Const (maybe_name, elem_T --> elem_T) $ t])
           in
             (case maps elems_for (all_values elem_T) @
                  (if maybe_opt then [Const (Nitpick_Model.unrep_mixfix (), elem_T)] else []) of
               [] => \<^Const>\<open>Groups.zero T\<close>
             | ts => foldl1 (fn (s, t) => \<^Const>\<open>add_mset elem_T for s t\<close>) ts)
           end
       | multiset_postproc _ _ _ _ t = t
   in Nitpick_Model.register_term_postprocessor \<^typ>\<open>'a multiset\<close> multiset_postproc end
 \<close>
 
 
 subsection \<open>Naive implementation using lists\<close>
 
 code_datatype mset
 
 lemma [code]: "{#} = mset []"
   by simp
 
 lemma [code]: "add_mset x (mset xs) = mset (x # xs)"
   by simp
 
 lemma [code]: "Multiset.is_empty (mset xs) \<longleftrightarrow> List.null xs"
   by (simp add: Multiset.is_empty_def List.null_def)
 
 lemma union_code [code]: "mset xs + mset ys = mset (xs @ ys)"
   by simp
 
 lemma [code]: "image_mset f (mset xs) = mset (map f xs)"
   by simp
 
 lemma [code]: "filter_mset f (mset xs) = mset (filter f xs)"
   by simp
 
 lemma [code]: "mset xs - mset ys = mset (fold remove1 ys xs)"
   by (rule sym, induct ys arbitrary: xs) (simp_all add: diff_add diff_right_commute diff_diff_add)
 
 lemma [code]:
   "mset xs \<inter># mset ys =
     mset (snd (fold (\<lambda>x (ys, zs).
       if x \<in> set ys then (remove1 x ys, x # zs) else (ys, zs)) xs (ys, [])))"
 proof -
   have "\<And>zs. mset (snd (fold (\<lambda>x (ys, zs).
     if x \<in> set ys then (remove1 x ys, x # zs) else (ys, zs)) xs (ys, zs))) =
       (mset xs \<inter># mset ys) + mset zs"
     by (induct xs arbitrary: ys)
       (auto simp add: inter_add_right1 inter_add_right2 ac_simps)
   then show ?thesis by simp
 qed
 
 lemma [code]:
   "mset xs \<union># mset ys =
     mset (case_prod append (fold (\<lambda>x (ys, zs). (remove1 x ys, x # zs)) xs (ys, [])))"
 proof -
   have "\<And>zs. mset (case_prod append (fold (\<lambda>x (ys, zs). (remove1 x ys, x # zs)) xs (ys, zs))) =
       (mset xs \<union># mset ys) + mset zs"
     by (induct xs arbitrary: ys) (simp_all add: multiset_eq_iff)
   then show ?thesis by simp
 qed
 
 declare in_multiset_in_set [code_unfold]
 
 lemma [code]: "count (mset xs) x = fold (\<lambda>y. if x = y then Suc else id) xs 0"
 proof -
   have "\<And>n. fold (\<lambda>y. if x = y then Suc else id) xs n = count (mset xs) x + n"
     by (induct xs) simp_all
   then show ?thesis by simp
 qed
 
 declare set_mset_mset [code]
 
 declare sorted_list_of_multiset_mset [code]
 
 lemma [code]: \<comment> \<open>not very efficient, but representation-ignorant!\<close>
   "mset_set A = mset (sorted_list_of_set A)"
   apply (cases "finite A")
   apply simp_all
   apply (induct A rule: finite_induct)
   apply simp_all
   done
 
 declare size_mset [code]
 
 fun subset_eq_mset_impl :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool option" where
   "subset_eq_mset_impl [] ys = Some (ys \<noteq> [])"
 | "subset_eq_mset_impl (Cons x xs) ys = (case List.extract ((=) x) ys of
      None \<Rightarrow> None
    | Some (ys1,_,ys2) \<Rightarrow> subset_eq_mset_impl xs (ys1 @ ys2))"
 
 lemma subset_eq_mset_impl: "(subset_eq_mset_impl xs ys = None \<longleftrightarrow> \<not> mset xs \<subseteq># mset ys) \<and>
   (subset_eq_mset_impl xs ys = Some True \<longleftrightarrow> mset xs \<subset># mset ys) \<and>
   (subset_eq_mset_impl xs ys = Some False \<longrightarrow> mset xs = mset ys)"
 proof (induct xs arbitrary: ys)
   case (Nil ys)
   show ?case by (auto simp: subset_mset.zero_less_iff_neq_zero)
 next
   case (Cons x xs ys)
   show ?case
   proof (cases "List.extract ((=) x) ys")
     case None
     hence x: "x \<notin> set ys" by (simp add: extract_None_iff)
     {
       assume "mset (x # xs) \<subseteq># mset ys"
       from set_mset_mono[OF this] x have False by simp
     } note nle = this
     moreover
     {
       assume "mset (x # xs) \<subset># mset ys"
       hence "mset (x # xs) \<subseteq># mset ys" by auto
       from nle[OF this] have False .
     }
     ultimately show ?thesis using None by auto
   next
     case (Some res)
     obtain ys1 y ys2 where res: "res = (ys1,y,ys2)" by (cases res, auto)
     note Some = Some[unfolded res]
     from extract_SomeE[OF Some] have "ys = ys1 @ x # ys2" by simp
     hence id: "mset ys = add_mset x (mset (ys1 @ ys2))"
       by auto
     show ?thesis unfolding subset_eq_mset_impl.simps
       unfolding Some option.simps split
       unfolding id
       using Cons[of "ys1 @ ys2"]
       unfolding subset_mset_def subseteq_mset_def by auto
   qed
 qed
 
 lemma [code]: "mset xs \<subseteq># mset ys \<longleftrightarrow> subset_eq_mset_impl xs ys \<noteq> None"
   using subset_eq_mset_impl[of xs ys] by (cases "subset_eq_mset_impl xs ys", auto)
 
 lemma [code]: "mset xs \<subset># mset ys \<longleftrightarrow> subset_eq_mset_impl xs ys = Some True"
   using subset_eq_mset_impl[of xs ys] by (cases "subset_eq_mset_impl xs ys", auto)
 
 instantiation multiset :: (equal) equal
 begin
 
 definition
   [code del]: "HOL.equal A (B :: 'a multiset) \<longleftrightarrow> A = B"
 lemma [code]: "HOL.equal (mset xs) (mset ys) \<longleftrightarrow> subset_eq_mset_impl xs ys = Some False"
   unfolding equal_multiset_def
   using subset_eq_mset_impl[of xs ys] by (cases "subset_eq_mset_impl xs ys", auto)
 
 instance
   by standard (simp add: equal_multiset_def)
 
 end
 
 declare sum_mset_sum_list [code]
 
 lemma [code]: "prod_mset (mset xs) = fold times xs 1"
 proof -
   have "\<And>x. fold times xs x = prod_mset (mset xs) * x"
     by (induct xs) (simp_all add: ac_simps)
   then show ?thesis by simp
 qed
 
 text \<open>
   Exercise for the casual reader: add implementations for \<^term>\<open>(\<le>)\<close>
   and \<^term>\<open>(<)\<close> (multiset order).
 \<close>
 
 text \<open>Quickcheck generators\<close>
 
 context
   includes term_syntax
 begin
 
 definition
   msetify :: "'a::typerep list \<times> (unit \<Rightarrow> Code_Evaluation.term)
     \<Rightarrow> 'a multiset \<times> (unit \<Rightarrow> Code_Evaluation.term)" where
   [code_unfold]: "msetify xs = Code_Evaluation.valtermify mset {\<cdot>} xs"
 
 end
 
 instantiation multiset :: (random) random
 begin
 
 context
   includes state_combinator_syntax
 begin
 
 definition
   "Quickcheck_Random.random i = Quickcheck_Random.random i \<circ>\<rightarrow> (\<lambda>xs. Pair (msetify xs))"
 
 instance ..
 
 end
 
 end
 
 instantiation multiset :: (full_exhaustive) full_exhaustive
 begin
 
 definition full_exhaustive_multiset :: "('a multiset \<times> (unit \<Rightarrow> term) \<Rightarrow> (bool \<times> term list) option) \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
 where
   "full_exhaustive_multiset f i = Quickcheck_Exhaustive.full_exhaustive (\<lambda>xs. f (msetify xs)) i"
 
 instance ..
 
 end
 
 hide_const (open) msetify
 
 
 subsection \<open>BNF setup\<close>
 
 definition rel_mset where
   "rel_mset R X Y \<longleftrightarrow> (\<exists>xs ys. mset xs = X \<and> mset ys = Y \<and> list_all2 R xs ys)"
 
 lemma mset_zip_take_Cons_drop_twice:
   assumes "length xs = length ys" "j \<le> length xs"
   shows "mset (zip (take j xs @ x # drop j xs) (take j ys @ y # drop j ys)) =
     add_mset (x,y) (mset (zip xs ys))"
   using assms
 proof (induct xs ys arbitrary: x y j rule: list_induct2)
   case Nil
   thus ?case
     by simp
 next
   case (Cons x xs y ys)
   thus ?case
   proof (cases "j = 0")
     case True
     thus ?thesis
       by simp
   next
     case False
     then obtain k where k: "j = Suc k"
       by (cases j) simp
     hence "k \<le> length xs"
       using Cons.prems by auto
     hence "mset (zip (take k xs @ x # drop k xs) (take k ys @ y # drop k ys)) =
       add_mset (x,y) (mset (zip xs ys))"
       by (rule Cons.hyps(2))
     thus ?thesis
       unfolding k by auto
   qed
 qed
 
 lemma ex_mset_zip_left:
   assumes "length xs = length ys" "mset xs' = mset xs"
   shows "\<exists>ys'. length ys' = length xs' \<and> mset (zip xs' ys') = mset (zip xs ys)"
 using assms
 proof (induct xs ys arbitrary: xs' rule: list_induct2)
   case Nil
   thus ?case
     by auto
 next
   case (Cons x xs y ys xs')
   obtain j where j_len: "j < length xs'" and nth_j: "xs' ! j = x"
     by (metis Cons.prems in_set_conv_nth list.set_intros(1) mset_eq_setD)
 
   define xsa where "xsa = take j xs' @ drop (Suc j) xs'"
   have "mset xs' = {#x#} + mset xsa"
     unfolding xsa_def using j_len nth_j
     by (metis Cons_nth_drop_Suc union_mset_add_mset_right add_mset_remove_trivial add_diff_cancel_left'
         append_take_drop_id mset.simps(2) mset_append)
   hence ms_x: "mset xsa = mset xs"
     by (simp add: Cons.prems)
   then obtain ysa where
     len_a: "length ysa = length xsa" and ms_a: "mset (zip xsa ysa) = mset (zip xs ys)"
     using Cons.hyps(2) by blast
 
   define ys' where "ys' = take j ysa @ y # drop j ysa"
   have xs': "xs' = take j xsa @ x # drop j xsa"
     using ms_x j_len nth_j Cons.prems xsa_def
     by (metis append_eq_append_conv append_take_drop_id diff_Suc_Suc Cons_nth_drop_Suc length_Cons
       length_drop size_mset)
   have j_len': "j \<le> length xsa"
     using j_len xs' xsa_def
     by (metis add_Suc_right append_take_drop_id length_Cons length_append less_eq_Suc_le not_less)
   have "length ys' = length xs'"
     unfolding ys'_def using Cons.prems len_a ms_x
     by (metis add_Suc_right append_take_drop_id length_Cons length_append mset_eq_length)
   moreover have "mset (zip xs' ys') = mset (zip (x # xs) (y # ys))"
     unfolding xs' ys'_def
     by (rule trans[OF mset_zip_take_Cons_drop_twice])
       (auto simp: len_a ms_a j_len')
   ultimately show ?case
     by blast
 qed
 
 lemma list_all2_reorder_left_invariance:
   assumes rel: "list_all2 R xs ys" and ms_x: "mset xs' = mset xs"
   shows "\<exists>ys'. list_all2 R xs' ys' \<and> mset ys' = mset ys"
 proof -
   have len: "length xs = length ys"
     using rel list_all2_conv_all_nth by auto
   obtain ys' where
     len': "length xs' = length ys'" and ms_xy: "mset (zip xs' ys') = mset (zip xs ys)"
     using len ms_x by (metis ex_mset_zip_left)
   have "list_all2 R xs' ys'"
     using assms(1) len' ms_xy unfolding list_all2_iff by (blast dest: mset_eq_setD)
   moreover have "mset ys' = mset ys"
     using len len' ms_xy map_snd_zip mset_map by metis
   ultimately show ?thesis
     by blast
 qed
 
 lemma ex_mset: "\<exists>xs. mset xs = X"
   by (induct X) (simp, metis mset.simps(2))
 
 inductive pred_mset :: "('a \<Rightarrow> bool) \<Rightarrow> 'a multiset \<Rightarrow> bool" 
 where
   "pred_mset P {#}"
 | "\<lbrakk>P a; pred_mset P M\<rbrakk> \<Longrightarrow> pred_mset P (add_mset a M)"
 
 lemma pred_mset_iff: \<comment> \<open>TODO: alias for \<^const>\<open>Multiset.Ball\<close>\<close>
   \<open>pred_mset P M \<longleftrightarrow> Multiset.Ball M P\<close>  (is \<open>?P \<longleftrightarrow> ?Q\<close>)
 proof
   assume ?P
   then show ?Q by induction simp_all
 next
   assume ?Q
   then show ?P
     by (induction M) (auto intro: pred_mset.intros)
 qed
 
 bnf "'a multiset"
   map: image_mset
   sets: set_mset
   bd: natLeq
   wits: "{#}"
   rel: rel_mset
   pred: pred_mset
 proof -
   show "image_mset id = id"
     by (rule image_mset.id)
   show "image_mset (g \<circ> f) = image_mset g \<circ> image_mset f" for f g
     unfolding comp_def by (rule ext) (simp add: comp_def image_mset.compositionality)
   show "(\<And>z. z \<in> set_mset X \<Longrightarrow> f z = g z) \<Longrightarrow> image_mset f X = image_mset g X" for f g X
     by (induct X) simp_all
   show "set_mset \<circ> image_mset f = (`) f \<circ> set_mset" for f
     by auto
   show "card_order natLeq"
     by (rule natLeq_card_order)
   show "BNF_Cardinal_Arithmetic.cinfinite natLeq"
     by (rule natLeq_cinfinite)
   show "regularCard natLeq"
     by (rule regularCard_natLeq)
   show "ordLess2 (card_of (set_mset X)) natLeq" for X
     by transfer
       (auto simp: finite_iff_ordLess_natLeq[symmetric])
   show "rel_mset R OO rel_mset S \<le> rel_mset (R OO S)" for R S
     unfolding rel_mset_def[abs_def] OO_def
     apply clarify
     subgoal for X Z Y xs ys' ys zs
       apply (drule list_all2_reorder_left_invariance [where xs = ys' and ys = zs and xs' = ys])
       apply (auto intro: list_all2_trans)
       done
     done
   show "rel_mset R =
     (\<lambda>x y. \<exists>z. set_mset z \<subseteq> {(x, y). R x y} \<and>
     image_mset fst z = x \<and> image_mset snd z = y)" for R
     unfolding rel_mset_def[abs_def]
     apply (rule ext)+
     apply safe
      apply (rule_tac x = "mset (zip xs ys)" in exI;
        auto simp: in_set_zip list_all2_iff simp flip: mset_map)
     apply (rename_tac XY)
     apply (cut_tac X = XY in ex_mset)
     apply (erule exE)
     apply (rename_tac xys)
     apply (rule_tac x = "map fst xys" in exI)
     apply (auto simp: mset_map)
     apply (rule_tac x = "map snd xys" in exI)
     apply (auto simp: mset_map list_all2I subset_eq zip_map_fst_snd)
     done
   show "z \<in> set_mset {#} \<Longrightarrow> False" for z
     by auto
   show "pred_mset P = (\<lambda>x. Ball (set_mset x) P)" for P
     by (simp add: fun_eq_iff pred_mset_iff)
 qed
 
 inductive rel_mset' :: \<open>('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a multiset \<Rightarrow> 'b multiset \<Rightarrow> bool\<close>
 where
   Zero[intro]: "rel_mset' R {#} {#}"
 | Plus[intro]: "\<lbrakk>R a b; rel_mset' R M N\<rbrakk> \<Longrightarrow> rel_mset' R (add_mset a M) (add_mset b N)"
 
 lemma rel_mset_Zero: "rel_mset R {#} {#}"
 unfolding rel_mset_def Grp_def by auto
 
 declare multiset.count[simp]
 declare count_Abs_multiset[simp]
 declare multiset.count_inverse[simp]
 
 lemma rel_mset_Plus:
   assumes ab: "R a b"
     and MN: "rel_mset R M N"
   shows "rel_mset R (add_mset a M) (add_mset b N)"
 proof -
   have "\<exists>ya. add_mset a (image_mset fst y) = image_mset fst ya \<and>
     add_mset b (image_mset snd y) = image_mset snd ya \<and>
     set_mset ya \<subseteq> {(x, y). R x y}"
     if "R a b" and "set_mset y \<subseteq> {(x, y). R x y}" for y
     using that by (intro exI[of _ "add_mset (a,b) y"]) auto
   thus ?thesis
   using assms
   unfolding multiset.rel_compp_Grp Grp_def by blast
 qed
 
 lemma rel_mset'_imp_rel_mset: "rel_mset' R M N \<Longrightarrow> rel_mset R M N"
   by (induct rule: rel_mset'.induct) (auto simp: rel_mset_Zero rel_mset_Plus)
 
 lemma rel_mset_size: "rel_mset R M N \<Longrightarrow> size M = size N"
   unfolding multiset.rel_compp_Grp Grp_def by auto
 
 lemma rel_mset_Zero_iff [simp]:
   shows "rel_mset rel {#} Y \<longleftrightarrow> Y = {#}" and "rel_mset rel X {#} \<longleftrightarrow> X = {#}"
   by (auto simp add: rel_mset_Zero dest: rel_mset_size)
 
 lemma multiset_induct2[case_names empty addL addR]:
   assumes empty: "P {#} {#}"
     and addL: "\<And>a M N. P M N \<Longrightarrow> P (add_mset a M) N"
     and addR: "\<And>a M N. P M N \<Longrightarrow> P M (add_mset a N)"
   shows "P M N"
 apply(induct N rule: multiset_induct)
   apply(induct M rule: multiset_induct, rule empty, erule addL)
   apply(induct M rule: multiset_induct, erule addR, erule addR)
 done
 
 lemma multiset_induct2_size[consumes 1, case_names empty add]:
   assumes c: "size M = size N"
     and empty: "P {#} {#}"
     and add: "\<And>a b M N a b. P M N \<Longrightarrow> P (add_mset a M) (add_mset b N)"
   shows "P M N"
   using c
 proof (induct M arbitrary: N rule: measure_induct_rule[of size])
   case (less M)
   show ?case
   proof(cases "M = {#}")
     case True hence "N = {#}" using less.prems by auto
     thus ?thesis using True empty by auto
   next
     case False then obtain M1 a where M: "M = add_mset a M1" by (metis multi_nonempty_split)
     have "N \<noteq> {#}" using False less.prems by auto
     then obtain N1 b where N: "N = add_mset b N1" by (metis multi_nonempty_split)
     have "size M1 = size N1" using less.prems unfolding M N by auto
     thus ?thesis using M N less.hyps add by auto
   qed
 qed
 
 lemma msed_map_invL:
   assumes "image_mset f (add_mset a M) = N"
   shows "\<exists>N1. N = add_mset (f a) N1 \<and> image_mset f M = N1"
 proof -
   have "f a \<in># N"
     using assms multiset.set_map[of f "add_mset a M"] by auto
   then obtain N1 where N: "N = add_mset (f a) N1" using multi_member_split by metis
   have "image_mset f M = N1" using assms unfolding N by simp
   thus ?thesis using N by blast
 qed
 
 lemma msed_map_invR:
   assumes "image_mset f M = add_mset b N"
   shows "\<exists>M1 a. M = add_mset a M1 \<and> f a = b \<and> image_mset f M1 = N"
 proof -
   obtain a where a: "a \<in># M" and fa: "f a = b"
     using multiset.set_map[of f M] unfolding assms
     by (metis image_iff union_single_eq_member)
   then obtain M1 where M: "M = add_mset a M1" using multi_member_split by metis
   have "image_mset f M1 = N" using assms unfolding M fa[symmetric] by simp
   thus ?thesis using M fa by blast
 qed
 
 lemma msed_rel_invL:
   assumes "rel_mset R (add_mset a M) N"
   shows "\<exists>N1 b. N = add_mset b N1 \<and> R a b \<and> rel_mset R M N1"
 proof -
   obtain K where KM: "image_mset fst K = add_mset a M"
     and KN: "image_mset snd K = N" and sK: "set_mset K \<subseteq> {(a, b). R a b}"
     using assms
     unfolding multiset.rel_compp_Grp Grp_def by auto
   obtain K1 ab where K: "K = add_mset ab K1" and a: "fst ab = a"
     and K1M: "image_mset fst K1 = M" using msed_map_invR[OF KM] by auto
   obtain N1 where N: "N = add_mset (snd ab) N1" and K1N1: "image_mset snd K1 = N1"
     using msed_map_invL[OF KN[unfolded K]] by auto
   have Rab: "R a (snd ab)" using sK a unfolding K by auto
   have "rel_mset R M N1" using sK K1M K1N1
     unfolding K multiset.rel_compp_Grp Grp_def by auto
   thus ?thesis using N Rab by auto
 qed
 
 lemma msed_rel_invR:
   assumes "rel_mset R M (add_mset b N)"
   shows "\<exists>M1 a. M = add_mset a M1 \<and> R a b \<and> rel_mset R M1 N"
 proof -
   obtain K where KN: "image_mset snd K = add_mset b N"
     and KM: "image_mset fst K = M" and sK: "set_mset K \<subseteq> {(a, b). R a b}"
     using assms
     unfolding multiset.rel_compp_Grp Grp_def by auto
   obtain K1 ab where K: "K = add_mset ab K1" and b: "snd ab = b"
     and K1N: "image_mset snd K1 = N" using msed_map_invR[OF KN] by auto
   obtain M1 where M: "M = add_mset (fst ab) M1" and K1M1: "image_mset fst K1 = M1"
     using msed_map_invL[OF KM[unfolded K]] by auto
   have Rab: "R (fst ab) b" using sK b unfolding K by auto
   have "rel_mset R M1 N" using sK K1N K1M1
     unfolding K multiset.rel_compp_Grp Grp_def by auto
   thus ?thesis using M Rab by auto
 qed
 
 lemma rel_mset_imp_rel_mset':
   assumes "rel_mset R M N"
   shows "rel_mset' R M N"
 using assms proof(induct M arbitrary: N rule: measure_induct_rule[of size])
   case (less M)
   have c: "size M = size N" using rel_mset_size[OF less.prems] .
   show ?case
   proof(cases "M = {#}")
     case True hence "N = {#}" using c by simp
     thus ?thesis using True rel_mset'.Zero by auto
   next
     case False then obtain M1 a where M: "M = add_mset a M1" by (metis multi_nonempty_split)
     obtain N1 b where N: "N = add_mset b N1" and R: "R a b" and ms: "rel_mset R M1 N1"
       using msed_rel_invL[OF less.prems[unfolded M]] by auto
     have "rel_mset' R M1 N1" using less.hyps[of M1 N1] ms unfolding M by simp
     thus ?thesis using rel_mset'.Plus[of R a b, OF R] unfolding M N by simp
   qed
 qed
 
 lemma rel_mset_rel_mset': "rel_mset R M N = rel_mset' R M N"
   using rel_mset_imp_rel_mset' rel_mset'_imp_rel_mset by auto
 
 text \<open>The main end product for \<^const>\<open>rel_mset\<close>: inductive characterization:\<close>
 lemmas rel_mset_induct[case_names empty add, induct pred: rel_mset] =
   rel_mset'.induct[unfolded rel_mset_rel_mset'[symmetric]]
 
 
 subsection \<open>Size setup\<close>
 
 lemma size_multiset_o_map: "size_multiset g \<circ> image_mset f = size_multiset (g \<circ> f)"
   apply (rule ext)
   subgoal for x by (induct x) auto
   done
 
 setup \<open>
   BNF_LFP_Size.register_size_global \<^type_name>\<open>multiset\<close> \<^const_name>\<open>size_multiset\<close>
     @{thm size_multiset_overloaded_def}
     @{thms size_multiset_empty size_multiset_single size_multiset_union size_empty size_single
       size_union}
     @{thms size_multiset_o_map}
 \<close>
 
 subsection \<open>Lemmas about Size\<close>
 
 lemma size_mset_SucE: "size A = Suc n \<Longrightarrow> (\<And>a B. A = {#a#} + B \<Longrightarrow> size B = n \<Longrightarrow> P) \<Longrightarrow> P"
   by (cases A) (auto simp add: ac_simps)
 
 lemma size_Suc_Diff1: "x \<in># M \<Longrightarrow> Suc (size (M - {#x#})) = size M"
   using arg_cong[OF insert_DiffM, of _ _ size] by simp
 
 lemma size_Diff_singleton: "x \<in># M \<Longrightarrow> size (M - {#x#}) = size M - 1"
   by (simp flip: size_Suc_Diff1)
 
 lemma size_Diff_singleton_if: "size (A - {#x#}) = (if x \<in># A then size A - 1 else size A)"
   by (simp add: diff_single_trivial size_Diff_singleton)
 
 lemma size_Un_Int: "size A + size B = size (A \<union># B) + size (A \<inter># B)"
   by (metis inter_subset_eq_union size_union subset_mset.diff_add union_diff_inter_eq_sup)
 
 lemma size_Un_disjoint: "A \<inter># B = {#} \<Longrightarrow> size (A \<union># B) = size A + size B"
   using size_Un_Int[of A B] by simp
 
 lemma size_Diff_subset_Int: "size (M - M') = size M - size (M \<inter># M')"
   by (metis diff_intersect_left_idem size_Diff_submset subset_mset.inf_le1)
 
 lemma diff_size_le_size_Diff: "size (M :: _ multiset) - size M' \<le> size (M - M')"
   by (simp add: diff_le_mono2 size_Diff_subset_Int size_mset_mono)
 
 lemma size_Diff1_less: "x\<in># M \<Longrightarrow> size (M - {#x#}) < size M"
   by (rule Suc_less_SucD) (simp add: size_Suc_Diff1)
 
 lemma size_Diff2_less: "x\<in># M \<Longrightarrow> y\<in># M \<Longrightarrow> size (M - {#x#} - {#y#}) < size M"
   by (metis less_imp_diff_less size_Diff1_less size_Diff_subset_Int)
 
 lemma size_Diff1_le: "size (M - {#x#}) \<le> size M"
   by (cases "x \<in># M") (simp_all add: size_Diff1_less less_imp_le diff_single_trivial)
 
 lemma size_psubset: "M \<subseteq># M' \<Longrightarrow> size M < size M' \<Longrightarrow> M \<subset># M'"
   using less_irrefl subset_mset_def by blast
 
 lifting_update multiset.lifting
 lifting_forget multiset.lifting
 
 hide_const (open) wcount
 
 end
diff --git a/src/HOL/Library/Multiset_Order.thy b/src/HOL/Library/Multiset_Order.thy
--- a/src/HOL/Library/Multiset_Order.thy
+++ b/src/HOL/Library/Multiset_Order.thy
@@ -1,856 +1,856 @@
 (*  Title:      HOL/Library/Multiset_Order.thy
     Author:     Dmitriy Traytel, TU Muenchen
     Author:     Jasmin Blanchette, Inria, LORIA, MPII
     Author:     Martin Desharnais, MPI-INF Saarbruecken
 *)
 
 section \<open>More Theorems about the Multiset Order\<close>
 
 theory Multiset_Order
 imports Multiset
 begin
 
 subsection \<open>Alternative Characterizations\<close>
 
 subsubsection \<open>The Dershowitz--Manna Ordering\<close>
 
 definition multp\<^sub>D\<^sub>M where
   "multp\<^sub>D\<^sub>M r M N \<longleftrightarrow>
    (\<exists>X Y. X \<noteq> {#} \<and> X \<subseteq># N \<and> M = (N - X) + Y \<and> (\<forall>k. k \<in># Y \<longrightarrow> (\<exists>a. a \<in># X \<and> r k a)))"
 
 lemma multp\<^sub>D\<^sub>M_imp_multp:
   "multp\<^sub>D\<^sub>M r M N \<Longrightarrow> multp r M N"
 proof -
   assume "multp\<^sub>D\<^sub>M r M N"
   then obtain X Y where
     "X \<noteq> {#}" and "X \<subseteq># N" and "M = N - X + Y" and "\<forall>k. k \<in># Y \<longrightarrow> (\<exists>a. a \<in># X \<and> r k a)"
     unfolding multp\<^sub>D\<^sub>M_def by blast
   then have "multp r (N - X + Y) (N - X + X)"
     by (intro one_step_implies_multp) (auto simp: Bex_def trans_def)
   with \<open>M = N - X + Y\<close> \<open>X \<subseteq># N\<close> show "multp r M N"
     by (metis subset_mset.diff_add)
 qed
 
 subsubsection \<open>The Huet--Oppen Ordering\<close>
 
 definition multp\<^sub>H\<^sub>O where
   "multp\<^sub>H\<^sub>O r M N \<longleftrightarrow> M \<noteq> N \<and> (\<forall>y. count N y < count M y \<longrightarrow> (\<exists>x. r y x \<and> count M x < count N x))"
 
 lemma multp_imp_multp\<^sub>H\<^sub>O:
   assumes "asymp r" and "transp r"
   shows "multp r M N \<Longrightarrow> multp\<^sub>H\<^sub>O r M N"
   unfolding multp_def mult_def
 proof (induction rule: trancl_induct)
   case (base P)
   then show ?case
     using \<open>asymp r\<close>
     by (auto elim!: mult1_lessE simp: count_eq_zero_iff multp\<^sub>H\<^sub>O_def split: if_splits
         dest!: Suc_lessD)
 next
   case (step N P)
   from step(3) have "M \<noteq> N" and
     **: "\<And>y. count N y < count M y \<Longrightarrow> (\<exists>x. r y x \<and> count M x < count N x)"
     by (simp_all add: multp\<^sub>H\<^sub>O_def)
   from step(2) obtain M0 a K where
     *: "P = add_mset a M0" "N = M0 + K" "a \<notin># K" "\<And>b. b \<in># K \<Longrightarrow> r b a"
     using \<open>asymp r\<close> by (auto elim: mult1_lessE)
   from \<open>M \<noteq> N\<close> ** *(1,2,3) have "M \<noteq> P"
     using *(4) \<open>asymp r\<close>
     by (metis asympD add_cancel_right_right add_diff_cancel_left' add_mset_add_single count_inI
         count_union diff_diff_add_mset diff_single_trivial in_diff_count multi_member_last)
   moreover
   { assume "count P a \<le> count M a"
     with \<open>a \<notin># K\<close> have "count N a < count M a" unfolding *(1,2)
       by (auto simp add: not_in_iff)
       with ** obtain z where z: "r a z" "count M z < count N z"
         by blast
       with * have "count N z \<le> count P z"
         using \<open>asymp r\<close>
         by (metis add_diff_cancel_left' add_mset_add_single asympD diff_diff_add_mset
             diff_single_trivial in_diff_count not_le_imp_less)
       with z have "\<exists>z. r a z \<and> count M z < count P z" by auto
   } note count_a = this
   { fix y
     assume count_y: "count P y < count M y"
     have "\<exists>x. r y x \<and> count M x < count P x"
     proof (cases "y = a")
       case True
       with count_y count_a show ?thesis by auto
     next
       case False
       show ?thesis
       proof (cases "y \<in># K")
         case True
         with *(4) have "r y a" by simp
         then show ?thesis
           by (cases "count P a \<le> count M a") (auto dest: count_a intro: \<open>transp r\<close>[THEN transpD])
       next
         case False
         with \<open>y \<noteq> a\<close> have "count P y = count N y" unfolding *(1,2)
           by (simp add: not_in_iff)
         with count_y ** obtain z where z: "r y z" "count M z < count N z" by auto
         show ?thesis
         proof (cases "z \<in># K")
           case True
           with *(4) have "r z a" by simp
           with z(1) show ?thesis
             by (cases "count P a \<le> count M a") (auto dest!: count_a intro: \<open>transp r\<close>[THEN transpD])
         next
           case False
           with \<open>a \<notin># K\<close> have "count N z \<le> count P z" unfolding *
             by (auto simp add: not_in_iff)
           with z show ?thesis by auto
         qed
       qed
     qed
   }
   ultimately show ?case unfolding multp\<^sub>H\<^sub>O_def by blast
 qed
 
 lemma multp\<^sub>H\<^sub>O_imp_multp\<^sub>D\<^sub>M: "multp\<^sub>H\<^sub>O r M N \<Longrightarrow> multp\<^sub>D\<^sub>M r M N"
 unfolding multp\<^sub>D\<^sub>M_def
 proof (intro iffI exI conjI)
   assume "multp\<^sub>H\<^sub>O r M N"
   then obtain z where z: "count M z < count N z"
     unfolding multp\<^sub>H\<^sub>O_def by (auto simp: multiset_eq_iff nat_neq_iff)
   define X where "X = N - M"
   define Y where "Y = M - N"
   from z show "X \<noteq> {#}" unfolding X_def by (auto simp: multiset_eq_iff not_less_eq_eq Suc_le_eq)
   from z show "X \<subseteq># N" unfolding X_def by auto
   show "M = (N - X) + Y" unfolding X_def Y_def multiset_eq_iff count_union count_diff by force
   show "\<forall>k. k \<in># Y \<longrightarrow> (\<exists>a. a \<in># X \<and> r k a)"
   proof (intro allI impI)
     fix k
     assume "k \<in># Y"
     then have "count N k < count M k" unfolding Y_def
       by (auto simp add: in_diff_count)
     with \<open>multp\<^sub>H\<^sub>O r M N\<close> obtain a where "r k a" and "count M a < count N a"
       unfolding multp\<^sub>H\<^sub>O_def by blast
     then show "\<exists>a. a \<in># X \<and> r k a" unfolding X_def
       by (auto simp add: in_diff_count)
   qed
 qed
 
 lemma multp_eq_multp\<^sub>D\<^sub>M: "asymp r \<Longrightarrow> transp r \<Longrightarrow> multp r = multp\<^sub>D\<^sub>M r"
   using multp\<^sub>D\<^sub>M_imp_multp multp_imp_multp\<^sub>H\<^sub>O[THEN multp\<^sub>H\<^sub>O_imp_multp\<^sub>D\<^sub>M]
   by blast
 
 lemma multp_eq_multp\<^sub>H\<^sub>O: "asymp r \<Longrightarrow> transp r \<Longrightarrow> multp r = multp\<^sub>H\<^sub>O r"
   using multp\<^sub>H\<^sub>O_imp_multp\<^sub>D\<^sub>M[THEN multp\<^sub>D\<^sub>M_imp_multp] multp_imp_multp\<^sub>H\<^sub>O
   by blast
 
 lemma multp\<^sub>D\<^sub>M_plus_plusI[simp]:
   assumes "multp\<^sub>D\<^sub>M R M1 M2"
   shows "multp\<^sub>D\<^sub>M R (M + M1) (M + M2)"
 proof -
   from assms obtain X Y where
     "X \<noteq> {#}" and "X \<subseteq># M2" and "M1 = M2 - X + Y" and "\<forall>k. k \<in># Y \<longrightarrow> (\<exists>a. a \<in># X \<and> R k a)"
   unfolding multp\<^sub>D\<^sub>M_def by auto
 
   show "multp\<^sub>D\<^sub>M R (M + M1) (M + M2)"
     unfolding multp\<^sub>D\<^sub>M_def
   proof (intro exI conjI)
     show "X \<noteq> {#}"
       using \<open>X \<noteq> {#}\<close> by simp
   next
     show "X \<subseteq># M + M2"
       using \<open>X \<subseteq># M2\<close>
       by (simp add: subset_mset.add_increasing)
   next
     show "M + M1 = M + M2 - X + Y"
       using \<open>X \<subseteq># M2\<close> \<open>M1 = M2 - X + Y\<close>
       by (metis multiset_diff_union_assoc union_assoc)
   next
     show "\<forall>k. k \<in># Y \<longrightarrow> (\<exists>a. a \<in># X \<and> R k a)"
       using \<open>\<forall>k. k \<in># Y \<longrightarrow> (\<exists>a. a \<in># X \<and> R k a)\<close> by simp
   qed
 qed
 
 lemma multp\<^sub>H\<^sub>O_plus_plus[simp]: "multp\<^sub>H\<^sub>O R (M + M1) (M + M2) \<longleftrightarrow> multp\<^sub>H\<^sub>O R M1 M2"
   unfolding multp\<^sub>H\<^sub>O_def by simp
 
 lemma strict_subset_implies_multp\<^sub>D\<^sub>M: "A \<subset># B \<Longrightarrow> multp\<^sub>D\<^sub>M r A B"
   unfolding multp\<^sub>D\<^sub>M_def
   by (metis add.right_neutral add_diff_cancel_right' empty_iff mset_subset_eq_add_right
       set_mset_empty subset_mset.lessE)
 
 lemma strict_subset_implies_multp\<^sub>H\<^sub>O: "A \<subset># B \<Longrightarrow> multp\<^sub>H\<^sub>O r A B"
   unfolding multp\<^sub>H\<^sub>O_def
   by (simp add: leD mset_subset_eq_count)
 
 lemma multp\<^sub>H\<^sub>O_implies_one_step_strong:
   assumes "multp\<^sub>H\<^sub>O R A B"
   defines "J \<equiv> B - A" and "K \<equiv> A - B"
   shows "J \<noteq> {#}" and "\<forall>k \<in># K. \<exists>x \<in># J. R k x"
 proof -
   show "J \<noteq> {#}"
   using \<open>multp\<^sub>H\<^sub>O R A B\<close>
   by (metis Diff_eq_empty_iff_mset J_def add.right_neutral multp\<^sub>D\<^sub>M_def multp\<^sub>H\<^sub>O_imp_multp\<^sub>D\<^sub>M
       multp\<^sub>H\<^sub>O_plus_plus subset_mset.add_diff_inverse subset_mset.le_zero_eq)
 
   show "\<forall>k\<in>#K. \<exists>x\<in>#J. R k x"
     using \<open>multp\<^sub>H\<^sub>O R A B\<close>
     by (metis J_def K_def in_diff_count multp\<^sub>H\<^sub>O_def)
 qed
 
 lemma multp\<^sub>H\<^sub>O_minus_inter_minus_inter_iff:
   fixes M1 M2 :: "_ multiset"
   shows "multp\<^sub>H\<^sub>O R (M1 - M2) (M2 - M1) \<longleftrightarrow> multp\<^sub>H\<^sub>O R M1 M2"
   by (metis diff_intersect_left_idem multiset_inter_commute multp\<^sub>H\<^sub>O_plus_plus
       subset_mset.add_diff_inverse subset_mset.inf.cobounded1)
 
 lemma multp\<^sub>H\<^sub>O_iff_set_mset_less\<^sub>H\<^sub>O_set_mset:
   "multp\<^sub>H\<^sub>O R M1 M2 \<longleftrightarrow> (set_mset (M1 - M2) \<noteq> set_mset (M2 - M1) \<and>
     (\<forall>y \<in># M1 - M2. (\<exists>x \<in># M2 - M1. R y x)))"
   unfolding multp\<^sub>H\<^sub>O_minus_inter_minus_inter_iff[of R M1 M2, symmetric]
   unfolding multp\<^sub>H\<^sub>O_def
   unfolding count_minus_inter_lt_count_minus_inter_iff
   unfolding minus_inter_eq_minus_inter_iff
   by auto
 
 
 subsubsection \<open>Monotonicity\<close>
 
 lemma multp\<^sub>D\<^sub>M_mono_strong:
   "multp\<^sub>D\<^sub>M R M1 M2 \<Longrightarrow> (\<And>x y. x \<in># M1 \<Longrightarrow> y \<in># M2 \<Longrightarrow> R x y \<Longrightarrow> S x y) \<Longrightarrow> multp\<^sub>D\<^sub>M S M1 M2"
   unfolding multp\<^sub>D\<^sub>M_def
   by (metis add_diff_cancel_left' in_diffD subset_mset.diff_add)
 
 lemma multp\<^sub>H\<^sub>O_mono_strong:
   "multp\<^sub>H\<^sub>O R M1 M2 \<Longrightarrow> (\<And>x y. x \<in># M1 \<Longrightarrow> y \<in># M2 \<Longrightarrow> R x y \<Longrightarrow> S x y) \<Longrightarrow> multp\<^sub>H\<^sub>O S M1 M2"
   unfolding multp\<^sub>H\<^sub>O_def
   by (metis count_inI less_zeroE)
 
 
 subsubsection \<open>Properties of Orders\<close>
 
 paragraph \<open>Asymmetry\<close>
 
 text \<open>The following lemma is a negative result stating that asymmetry of an arbitrary binary
 relation cannot be simply lifted to @{const multp\<^sub>H\<^sub>O}. It suffices to have four distinct values to
 build a counterexample.\<close>
 
 lemma asymp_not_liftable_to_multp\<^sub>H\<^sub>O:
   fixes a b c d :: 'a
   assumes "distinct [a, b, c, d]"
   shows "\<not> (\<forall>(R :: 'a \<Rightarrow> 'a \<Rightarrow> bool). asymp R \<longrightarrow> asymp (multp\<^sub>H\<^sub>O R))"
 proof -
   define R :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
     "R = (\<lambda>x y. x = a \<and> y = c \<or> x = b \<and> y = d \<or> x = c \<and> y = b \<or> x = d \<and> y = a)"
 
   from assms(1) have "{#a, b#} \<noteq> {#c, d#}"
     by (metis add_mset_add_single distinct.simps(2) list.set(1) list.simps(15) multi_member_this
         set_mset_add_mset_insert set_mset_single)
 
   from assms(1) have "asymp R"
     by (auto simp: R_def intro: asymp_onI)
   moreover have "\<not> asymp (multp\<^sub>H\<^sub>O R)"
     unfolding asymp_on_def Set.ball_simps not_all not_imp not_not
   proof (intro exI conjI)
     show "multp\<^sub>H\<^sub>O R {#a, b#} {#c, d#}"
       unfolding multp\<^sub>H\<^sub>O_def
       using \<open>{#a, b#} \<noteq> {#c, d#}\<close> R_def assms by auto
   next
     show "multp\<^sub>H\<^sub>O R {#c, d#} {#a, b#}"
       unfolding multp\<^sub>H\<^sub>O_def
       using \<open>{#a, b#} \<noteq> {#c, d#}\<close> R_def assms by auto
   qed
   ultimately show ?thesis
     unfolding not_all not_imp by auto
 qed
 
 text \<open>However, if the binary relation is both asymmetric and transitive, then @{const multp\<^sub>H\<^sub>O} is
 also asymmetric.\<close>
 
 lemma asymp_on_multp\<^sub>H\<^sub>O:
   assumes "asymp_on A R" and "transp_on A R" and
     B_sub_A: "\<And>M. M \<in> B \<Longrightarrow> set_mset M \<subseteq> A"
   shows "asymp_on B (multp\<^sub>H\<^sub>O R)"
 proof (rule asymp_onI)
   fix M1 M2 :: "'a multiset"
   assume "M1 \<in> B" "M2 \<in> B" "multp\<^sub>H\<^sub>O R M1 M2"
 
   from \<open>transp_on A R\<close> B_sub_A have tran: "transp_on (set_mset (M1 - M2)) R"
     using \<open>M1 \<in> B\<close>
     by (meson in_diffD subset_eq transp_on_subset)
 
   from \<open>asymp_on A R\<close> B_sub_A have asym: "asymp_on (set_mset (M1 - M2)) R"
     using \<open>M1 \<in> B\<close>
     by (meson in_diffD subset_eq asymp_on_subset)
 
   show "\<not> multp\<^sub>H\<^sub>O R M2 M1"
   proof (cases "M1 - M2 = {#}")
     case True
     then show ?thesis
       using multp\<^sub>H\<^sub>O_implies_one_step_strong(1) by metis
   next
     case False
     hence "\<exists>m\<in>#M1 - M2. \<forall>x\<in>#M1 - M2. x \<noteq> m \<longrightarrow> \<not> R m x"
       using Finite_Set.bex_max_element[of "set_mset (M1 - M2)" R, OF finite_set_mset asym tran]
       by simp
     with \<open>transp_on A R\<close> B_sub_A have "\<exists>y\<in>#M2 - M1. \<forall>x\<in>#M1 - M2. \<not> R y x"
       using \<open>multp\<^sub>H\<^sub>O R M1 M2\<close>[THEN multp\<^sub>H\<^sub>O_implies_one_step_strong(2)]
       using asym[THEN irreflp_on_if_asymp_on, THEN irreflp_onD]
       by (metis \<open>M1 \<in> B\<close> \<open>M2 \<in> B\<close> in_diffD subsetD transp_onD)
     thus ?thesis
       unfolding multp\<^sub>H\<^sub>O_iff_set_mset_less\<^sub>H\<^sub>O_set_mset by simp
   qed
 qed
 
 lemma asymp_multp\<^sub>H\<^sub>O:
   assumes "asymp R" and "transp R"
   shows "asymp (multp\<^sub>H\<^sub>O R)"
   using assms asymp_on_multp\<^sub>H\<^sub>O[of UNIV, simplified] by metis
 
 
 paragraph \<open>Irreflexivity\<close>
 
 lemma irreflp_on_multp\<^sub>H\<^sub>O[simp]: "irreflp_on B (multp\<^sub>H\<^sub>O R)"
     by (simp add: irreflp_onI multp\<^sub>H\<^sub>O_def)
 
 
 paragraph \<open>Transitivity\<close>
 
 lemma transp_on_multp\<^sub>H\<^sub>O:
   assumes "asymp_on A R" and "transp_on A R" and
     B_sub_A: "\<And>M. M \<in> B \<Longrightarrow> set_mset M \<subseteq> A"
   shows "transp_on B (multp\<^sub>H\<^sub>O R)"
 proof (rule transp_onI)
   from assms have "asymp_on B (multp\<^sub>H\<^sub>O R)"
     using asymp_on_multp\<^sub>H\<^sub>O by metis
 
   fix M1 M2 M3
   assume hyps: "M1 \<in> B" "M2 \<in> B" "M3 \<in> B" "multp\<^sub>H\<^sub>O R M1 M2" "multp\<^sub>H\<^sub>O R M2 M3"
 
   from assms have
     [intro]: "asymp_on (set_mset M1 \<union> set_mset M2) R" "transp_on (set_mset M1 \<union> set_mset M2) R"
     using \<open>M1 \<in> B\<close> \<open>M2 \<in> B\<close>
     by (simp_all add: asymp_on_subset transp_on_subset)
 
   from assms have "transp_on (set_mset M1) R"
     by (meson transp_on_subset hyps(1))
 
   from \<open>multp\<^sub>H\<^sub>O R M1 M2\<close> have
     "M1 \<noteq> M2" and
     "\<forall>y. count M2 y < count M1 y \<longrightarrow> (\<exists>x. R y x \<and> count M1 x < count M2 x)"
     unfolding multp\<^sub>H\<^sub>O_def by simp_all
 
   from \<open>multp\<^sub>H\<^sub>O R M2 M3\<close> have
     "M2 \<noteq> M3" and
     "\<forall>y. count M3 y < count M2 y \<longrightarrow> (\<exists>x. R y x \<and> count M2 x < count M3 x)"
     unfolding multp\<^sub>H\<^sub>O_def by simp_all
 
   show "multp\<^sub>H\<^sub>O R M1 M3"
   proof (rule ccontr)
     let ?P = "\<lambda>x. count M3 x < count M1 x \<and> (\<forall>y. R x y \<longrightarrow> count M1 y \<ge> count M3 y)"
 
     assume "\<not> multp\<^sub>H\<^sub>O R M1 M3"
     hence "M1 = M3 \<or> (\<exists>x. ?P x)"
       unfolding multp\<^sub>H\<^sub>O_def by force
     thus False
     proof (elim disjE)
       assume "M1 = M3"
       thus False
         using \<open>asymp_on B (multp\<^sub>H\<^sub>O R)\<close>[THEN asymp_onD]
         using \<open>M2 \<in> B\<close> \<open>M3 \<in> B\<close> \<open>multp\<^sub>H\<^sub>O R M1 M2\<close> \<open>multp\<^sub>H\<^sub>O R M2 M3\<close>
         by metis
     next
       assume "\<exists>x. ?P x"
       hence "\<exists>x \<in># M1 + M2. ?P x"
         by (auto simp: count_inI)
       have "\<exists>y \<in># M1 + M2. ?P y \<and> (\<forall>z \<in># M1 + M2. R y z \<longrightarrow> \<not> ?P z)"
       proof (rule Finite_Set.bex_max_element_with_property)
         show "\<exists>x \<in># M1 + M2. ?P x"
           using \<open>\<exists>x. ?P x\<close>
           by (auto simp: count_inI)
       qed auto
       then obtain x where
         "x \<in># M1 + M2" and
         "count M3 x < count M1 x" and
         "\<forall>y. R x y \<longrightarrow> count M1 y \<ge> count M3 y" and
         "\<forall>y \<in># M1 + M2. R x y \<longrightarrow> count M3 y < count M1 y \<longrightarrow> (\<exists>z. R y z \<and> count M1 z < count M3 z)"
         by force
 
       let ?Q = "\<lambda>x'. R\<^sup>=\<^sup>= x x' \<and> count M3 x' < count M2 x'"
       show False
       proof (cases "\<exists>x'. ?Q x'")
         case True
         have "\<exists>y \<in># M1 + M2. ?Q y \<and> (\<forall>z \<in># M1 + M2. R y z \<longrightarrow> \<not> ?Q z)"
         proof (rule Finite_Set.bex_max_element_with_property)
           show "\<exists>x \<in># M1 + M2. ?Q x"
             using \<open>\<exists>x. ?Q x\<close>
             by (auto simp: count_inI)
         qed auto
         then obtain x' where
           "x' \<in># M1 + M2" and
           "R\<^sup>=\<^sup>= x x'" and
           "count M3 x' < count M2 x'" and
           maximality_x': "\<forall>z \<in># M1 + M2. R x' z \<longrightarrow> \<not> (R\<^sup>=\<^sup>= x z) \<or> count M3 z \<ge> count M2 z"
           by (auto simp: linorder_not_less)
         with \<open>multp\<^sub>H\<^sub>O R M2 M3\<close> obtain y' where
           "R x' y'" and "count M2 y' < count M3 y'"
           unfolding multp\<^sub>H\<^sub>O_def by auto
         hence "count M2 y' < count M1 y'"
           by (smt (verit) \<open>R\<^sup>=\<^sup>= x x'\<close> \<open>\<forall>y. R x y \<longrightarrow> count M3 y \<le> count M1 y\<close>
               \<open>count M3 x < count M1 x\<close> \<open>count M3 x' < count M2 x'\<close> assms(2) count_inI
               dual_order.strict_trans1 hyps(1) hyps(2) hyps(3) less_nat_zero_code B_sub_A subsetD
               sup2E transp_onD)
         with \<open>multp\<^sub>H\<^sub>O R M1 M2\<close> obtain y'' where
           "R y' y''" and "count M1 y'' < count M2 y''"
           unfolding multp\<^sub>H\<^sub>O_def by auto
         hence "count M3 y'' < count M2 y''"
           by (smt (verit, del_insts) \<open>R x' y'\<close> \<open>R\<^sup>=\<^sup>= x x'\<close> \<open>\<forall>y. R x y \<longrightarrow> count M3 y \<le> count M1 y\<close>
               \<open>count M2 y' < count M3 y'\<close> \<open>count M3 x < count M1 x\<close> \<open>count M3 x' < count M2 x'\<close>
               assms(2) count_greater_zero_iff dual_order.strict_trans1 hyps(1) hyps(2) hyps(3)
               less_nat_zero_code linorder_not_less B_sub_A subset_iff sup2E transp_onD)
 
         moreover have "count M2 y'' \<le> count M3 y''"
         proof -
           have "y'' \<in># M1 + M2"
             by (metis \<open>count M1 y'' < count M2 y''\<close> count_inI not_less_iff_gr_or_eq union_iff)
 
           moreover have "R x' y''"
             by (metis \<open>R x' y'\<close> \<open>R y' y''\<close> \<open>count M2 y' < count M1 y'\<close>
                 \<open>transp_on (set_mset M1 \<union> set_mset M2) R\<close> \<open>x' \<in># M1 + M2\<close> calculation count_inI
                 nat_neq_iff set_mset_union transp_onD union_iff)
 
           moreover have "R\<^sup>=\<^sup>= x y''"
             using \<open>R\<^sup>=\<^sup>= x x'\<close>
             by (metis (mono_tags, opaque_lifting) \<open>transp_on (set_mset M1 \<union> set_mset M2) R\<close>
                 \<open>x \<in># M1 + M2\<close> \<open>x' \<in># M1 + M2\<close> calculation(1) calculation(2) set_mset_union sup2I1
                 transp_onD transp_on_reflclp)
 
           ultimately show ?thesis
             using maximality_x'[rule_format, of y''] by metis
         qed
 
         ultimately show ?thesis
           by linarith
       next
         case False
         hence "\<And>x'. R\<^sup>=\<^sup>= x x' \<Longrightarrow> count M2 x' \<le> count M3 x'"
           by auto
         hence "count M2 x \<le> count M3 x"
           by simp
         hence "count M2 x < count M1 x"
           using \<open>count M3 x < count M1 x\<close> by linarith
         with \<open>multp\<^sub>H\<^sub>O R M1 M2\<close> obtain y where
           "R x y" and "count M1 y < count M2 y"
           unfolding multp\<^sub>H\<^sub>O_def by auto
         hence "count M3 y < count M2 y"
           using \<open>\<forall>y. R x y \<longrightarrow> count M3 y \<le> count M1 y\<close> dual_order.strict_trans2 by metis
         then show ?thesis
           using False \<open>R x y\<close> by auto
       qed
     qed
   qed
 qed
 
 lemma transp_multp\<^sub>H\<^sub>O:
   assumes "asymp R" and "transp R"
   shows "transp (multp\<^sub>H\<^sub>O R)"
   using assms transp_on_multp\<^sub>H\<^sub>O[of UNIV, simplified] by metis
 
 
 paragraph \<open>Totality\<close>
 
 lemma totalp_on_multp\<^sub>D\<^sub>M:
   "totalp_on A R \<Longrightarrow> (\<And>M. M \<in> B \<Longrightarrow> set_mset M \<subseteq> A) \<Longrightarrow> totalp_on B (multp\<^sub>D\<^sub>M R)"
   by (smt (verit, ccfv_SIG) count_inI in_mono multp\<^sub>H\<^sub>O_def multp\<^sub>H\<^sub>O_imp_multp\<^sub>D\<^sub>M not_less_iff_gr_or_eq
       totalp_onD totalp_onI)
 
 lemma totalp_multp\<^sub>D\<^sub>M: "totalp R \<Longrightarrow> totalp (multp\<^sub>D\<^sub>M R)"
   by (rule totalp_on_multp\<^sub>D\<^sub>M[of UNIV R UNIV, simplified])
 
 lemma totalp_on_multp\<^sub>H\<^sub>O:
   "totalp_on A R \<Longrightarrow> (\<And>M. M \<in> B \<Longrightarrow> set_mset M \<subseteq> A) \<Longrightarrow> totalp_on B (multp\<^sub>H\<^sub>O R)"
   by (smt (verit, ccfv_SIG) count_inI in_mono multp\<^sub>H\<^sub>O_def not_less_iff_gr_or_eq totalp_onD
       totalp_onI)
 
 lemma totalp_multp\<^sub>H\<^sub>O: "totalp R \<Longrightarrow> totalp (multp\<^sub>H\<^sub>O R)"
   by (rule totalp_on_multp\<^sub>H\<^sub>O[of UNIV R UNIV, simplified])
 
 
 paragraph \<open>Type Classes\<close>
 
 context preorder
 begin
 
 lemma order_mult: "class.order
   (\<lambda>M N. (M, N) \<in> mult {(x, y). x < y} \<or> M = N)
   (\<lambda>M N. (M, N) \<in> mult {(x, y). x < y})"
   (is "class.order ?le ?less")
 proof -
   have irrefl: "\<And>M :: 'a multiset. \<not> ?less M M"
   proof
     fix M :: "'a multiset"
     have "trans {(x'::'a, x). x' < x}"
       by (rule transI) (blast intro: less_trans)
     moreover
     assume "(M, M) \<in> mult {(x, y). x < y}"
     ultimately have "\<exists>I J K. M = I + J \<and> M = I + K
       \<and> J \<noteq> {#} \<and> (\<forall>k\<in>set_mset K. \<exists>j\<in>set_mset J. (k, j) \<in> {(x, y). x < y})"
       by (rule mult_implies_one_step)
     then obtain I J K where "M = I + J" and "M = I + K"
       and "J \<noteq> {#}" and "(\<forall>k\<in>set_mset K. \<exists>j\<in>set_mset J. (k, j) \<in> {(x, y). x < y})" by blast
     then have aux1: "K \<noteq> {#}" and aux2: "\<forall>k\<in>set_mset K. \<exists>j\<in>set_mset K. k < j" by auto
     have "finite (set_mset K)" by simp
     moreover note aux2
     ultimately have "set_mset K = {}"
       by (induct rule: finite_induct)
        (simp, metis (mono_tags) insert_absorb insert_iff insert_not_empty less_irrefl less_trans)
     with aux1 show False by simp
   qed
   have trans: "\<And>K M N :: 'a multiset. ?less K M \<Longrightarrow> ?less M N \<Longrightarrow> ?less K N"
     unfolding mult_def by (blast intro: trancl_trans)
   show "class.order ?le ?less"
     by standard (auto simp add: less_eq_multiset_def irrefl dest: trans)
 qed
 
 text \<open>The Dershowitz--Manna ordering:\<close>
 
 definition less_multiset\<^sub>D\<^sub>M where
   "less_multiset\<^sub>D\<^sub>M M N \<longleftrightarrow>
    (\<exists>X Y. X \<noteq> {#} \<and> X \<subseteq># N \<and> M = (N - X) + Y \<and> (\<forall>k. k \<in># Y \<longrightarrow> (\<exists>a. a \<in># X \<and> k < a)))"
 
 
 text \<open>The Huet--Oppen ordering:\<close>
 
 definition less_multiset\<^sub>H\<^sub>O where
   "less_multiset\<^sub>H\<^sub>O M N \<longleftrightarrow> M \<noteq> N \<and> (\<forall>y. count N y < count M y \<longrightarrow> (\<exists>x. y < x \<and> count M x < count N x))"
 
 lemma mult_imp_less_multiset\<^sub>H\<^sub>O:
   "(M, N) \<in> mult {(x, y). x < y} \<Longrightarrow> less_multiset\<^sub>H\<^sub>O M N"
   unfolding multp_def[of "(<)", symmetric]
   using multp_imp_multp\<^sub>H\<^sub>O[of "(<)"]
   by (simp add: less_multiset\<^sub>H\<^sub>O_def multp\<^sub>H\<^sub>O_def)
 
 lemma less_multiset\<^sub>D\<^sub>M_imp_mult:
   "less_multiset\<^sub>D\<^sub>M M N \<Longrightarrow> (M, N) \<in> mult {(x, y). x < y}"
   unfolding multp_def[of "(<)", symmetric]
   by (rule multp\<^sub>D\<^sub>M_imp_multp[of "(<)" M N]) (simp add: less_multiset\<^sub>D\<^sub>M_def multp\<^sub>D\<^sub>M_def)
 
 lemma less_multiset\<^sub>H\<^sub>O_imp_less_multiset\<^sub>D\<^sub>M: "less_multiset\<^sub>H\<^sub>O M N \<Longrightarrow> less_multiset\<^sub>D\<^sub>M M N"
   unfolding less_multiset\<^sub>D\<^sub>M_def less_multiset\<^sub>H\<^sub>O_def
   unfolding multp\<^sub>D\<^sub>M_def[symmetric] multp\<^sub>H\<^sub>O_def[symmetric]
   by (rule multp\<^sub>H\<^sub>O_imp_multp\<^sub>D\<^sub>M)
 
 lemma mult_less_multiset\<^sub>D\<^sub>M: "(M, N) \<in> mult {(x, y). x < y} \<longleftrightarrow> less_multiset\<^sub>D\<^sub>M M N"
   unfolding multp_def[of "(<)", symmetric]
   using multp_eq_multp\<^sub>D\<^sub>M[of "(<)", simplified]
   by (simp add: multp\<^sub>D\<^sub>M_def less_multiset\<^sub>D\<^sub>M_def)
 
 lemma mult_less_multiset\<^sub>H\<^sub>O: "(M, N) \<in> mult {(x, y). x < y} \<longleftrightarrow> less_multiset\<^sub>H\<^sub>O M N"
   unfolding multp_def[of "(<)", symmetric]
   using multp_eq_multp\<^sub>H\<^sub>O[of "(<)", simplified]
   by (simp add: multp\<^sub>H\<^sub>O_def less_multiset\<^sub>H\<^sub>O_def)
 
 lemmas mult\<^sub>D\<^sub>M = mult_less_multiset\<^sub>D\<^sub>M[unfolded less_multiset\<^sub>D\<^sub>M_def]
 lemmas mult\<^sub>H\<^sub>O = mult_less_multiset\<^sub>H\<^sub>O[unfolded less_multiset\<^sub>H\<^sub>O_def]
 
 end
 
 lemma less_multiset_less_multiset\<^sub>H\<^sub>O: "M < N \<longleftrightarrow> less_multiset\<^sub>H\<^sub>O M N"
   unfolding less_multiset_def multp_def mult\<^sub>H\<^sub>O less_multiset\<^sub>H\<^sub>O_def ..
 
 lemma less_multiset\<^sub>D\<^sub>M:
   "M < N \<longleftrightarrow> (\<exists>X Y. X \<noteq> {#} \<and> X \<subseteq># N \<and> M = N - X + Y \<and> (\<forall>k. k \<in># Y \<longrightarrow> (\<exists>a. a \<in># X \<and> k < a)))"
   by (rule mult\<^sub>D\<^sub>M[folded multp_def less_multiset_def])
 
 lemma less_multiset\<^sub>H\<^sub>O:
   "M < N \<longleftrightarrow> M \<noteq> N \<and> (\<forall>y. count N y < count M y \<longrightarrow> (\<exists>x>y. count M x < count N x))"
   by (rule mult\<^sub>H\<^sub>O[folded multp_def less_multiset_def])
 
 lemma subset_eq_imp_le_multiset:
   shows "M \<subseteq># N \<Longrightarrow> M \<le> N"
   unfolding less_eq_multiset_def less_multiset\<^sub>H\<^sub>O
   by (simp add: less_le_not_le subseteq_mset_def)
 
 (* FIXME: "le" should be "less" in this and other names *)
 lemma le_multiset_right_total: "M < add_mset x M"
   unfolding less_eq_multiset_def less_multiset\<^sub>H\<^sub>O by simp
 
 lemma less_eq_multiset_empty_left[simp]:
   shows "{#} \<le> M"
   by (simp add: subset_eq_imp_le_multiset)
 
 lemma ex_gt_imp_less_multiset: "(\<exists>y. y \<in># N \<and> (\<forall>x. x \<in># M \<longrightarrow> x < y)) \<Longrightarrow> M < N"
   unfolding less_multiset\<^sub>H\<^sub>O
   by (metis count_eq_zero_iff count_greater_zero_iff less_le_not_le)
 
 lemma less_eq_multiset_empty_right[simp]: "M \<noteq> {#} \<Longrightarrow> \<not> M \<le> {#}"
   by (metis less_eq_multiset_empty_left antisym)
 
 (* FIXME: "le" should be "less" in this and other names *)
 lemma le_multiset_empty_left[simp]: "M \<noteq> {#} \<Longrightarrow> {#} < M"
   by (simp add: less_multiset\<^sub>H\<^sub>O)
 
 (* FIXME: "le" should be "less" in this and other names *)
 lemma le_multiset_empty_right[simp]: "\<not> M < {#}"
   using subset_mset.le_zero_eq less_multiset_def multp_def less_multiset\<^sub>D\<^sub>M by blast
 
 (* FIXME: "le" should be "less" in this and other names *)
 lemma union_le_diff_plus: "P \<subseteq># M \<Longrightarrow> N < P \<Longrightarrow> M - P + N < M"
   by (drule subset_mset.diff_add[symmetric]) (metis union_le_mono2)
 
 instantiation multiset :: (preorder) ordered_ab_semigroup_monoid_add_imp_le
 begin
 
 lemma less_eq_multiset\<^sub>H\<^sub>O:
   "M \<le> N \<longleftrightarrow> (\<forall>y. count N y < count M y \<longrightarrow> (\<exists>x. y < x \<and> count M x < count N x))"
   by (auto simp: less_eq_multiset_def less_multiset\<^sub>H\<^sub>O)
 
 instance by standard (auto simp: less_eq_multiset\<^sub>H\<^sub>O)
 
 lemma
   fixes M N :: "'a multiset"
   shows
     less_eq_multiset_plus_left: "N \<le> (M + N)" and
     less_eq_multiset_plus_right: "M \<le> (M + N)"
   by simp_all
 
 lemma
   fixes M N :: "'a multiset"
   shows
     le_multiset_plus_left_nonempty: "M \<noteq> {#} \<Longrightarrow> N < M + N" and
     le_multiset_plus_right_nonempty: "N \<noteq> {#} \<Longrightarrow> M < M + N"
     by simp_all
 
 end
 
 lemma all_lt_Max_imp_lt_mset: "N \<noteq> {#} \<Longrightarrow> (\<forall>a \<in># M. a < Max (set_mset N)) \<Longrightarrow> M < N"
   by (meson Max_in[OF finite_set_mset] ex_gt_imp_less_multiset set_mset_eq_empty_iff)
 
 lemma lt_imp_ex_count_lt: "M < N \<Longrightarrow> \<exists>y. count M y < count N y"
   by (meson less_eq_multiset\<^sub>H\<^sub>O less_le_not_le)
 
 lemma subset_imp_less_mset: "A \<subset># B \<Longrightarrow> A < B"
   by (simp add: order.not_eq_order_implies_strict subset_eq_imp_le_multiset)
 
 lemma image_mset_strict_mono:
   assumes
     mono_f: "\<forall>x \<in> set_mset M. \<forall>y \<in> set_mset N. x < y \<longrightarrow> f x < f y" and
     less: "M < N"
   shows "image_mset f M < image_mset f N"
 proof -
   obtain Y X where
     y_nemp: "Y \<noteq> {#}" and y_sub_N: "Y \<subseteq># N" and M_eq: "M = N - Y + X" and
     ex_y: "\<forall>x. x \<in># X \<longrightarrow> (\<exists>y. y \<in># Y \<and> x < y)"
     using less[unfolded less_multiset\<^sub>D\<^sub>M] by blast
 
   have x_sub_M: "X \<subseteq># M"
     using M_eq by simp
 
   let ?fY = "image_mset f Y"
   let ?fX = "image_mset f X"
 
   show ?thesis
     unfolding less_multiset\<^sub>D\<^sub>M
   proof (intro exI conjI)
     show "image_mset f M = image_mset f N - ?fY + ?fX"
       using M_eq[THEN arg_cong, of "image_mset f"] y_sub_N
       by (metis image_mset_Diff image_mset_union)
   next
     obtain y where y: "\<forall>x. x \<in># X \<longrightarrow> y x \<in># Y \<and> x < y x"
       using ex_y by moura
 
     show "\<forall>fx. fx \<in># ?fX \<longrightarrow> (\<exists>fy. fy \<in># ?fY \<and> fx < fy)"
     proof (intro allI impI)
       fix fx
       assume "fx \<in># ?fX"
       then obtain x where fx: "fx = f x" and x_in: "x \<in># X"
         by auto
       hence y_in: "y x \<in># Y" and y_gt: "x < y x"
         using y[rule_format, OF x_in] by blast+
       hence "f (y x) \<in># ?fY \<and> f x < f (y x)"
         using mono_f y_sub_N x_sub_M x_in
         by (metis image_eqI in_image_mset mset_subset_eqD)
       thus "\<exists>fy. fy \<in># ?fY \<and> fx < fy"
         unfolding fx by auto
     qed
   qed (auto simp: y_nemp y_sub_N image_mset_subseteq_mono)
 qed
 
 lemma image_mset_mono:
   assumes
     mono_f: "\<forall>x \<in> set_mset M. \<forall>y \<in> set_mset N. x < y \<longrightarrow> f x < f y" and
     less: "M \<le> N"
   shows "image_mset f M \<le> image_mset f N"
   by (metis eq_iff image_mset_strict_mono less less_imp_le mono_f order.not_eq_order_implies_strict)
 
 lemma mset_lt_single_right_iff[simp]: "M < {#y#} \<longleftrightarrow> (\<forall>x \<in># M. x < y)" for y :: "'a::linorder"
 proof (rule iffI)
   assume M_lt_y: "M < {#y#}"
   show "\<forall>x \<in># M. x < y"
   proof
     fix x
     assume x_in: "x \<in># M"
     hence M: "M - {#x#} + {#x#} = M"
       by (meson insert_DiffM2)
     hence "\<not> {#x#} < {#y#} \<Longrightarrow> x < y"
       using x_in M_lt_y
       by (metis diff_single_eq_union le_multiset_empty_left less_add_same_cancel2 mset_le_trans)
     also have "\<not> {#y#} < M"
       using M_lt_y mset_le_not_sym by blast
     ultimately show "x < y"
       by (metis (no_types) Max_ge all_lt_Max_imp_lt_mset empty_iff finite_set_mset insertE
         less_le_trans linorder_less_linear mset_le_not_sym set_mset_add_mset_insert
         set_mset_eq_empty_iff x_in)
   qed
 next
   assume y_max: "\<forall>x \<in># M. x < y"
   show "M < {#y#}"
     by (rule all_lt_Max_imp_lt_mset) (auto intro!: y_max)
 qed
 
 lemma mset_le_single_right_iff[simp]:
   "M \<le> {#y#} \<longleftrightarrow> M = {#y#} \<or> (\<forall>x \<in># M. x < y)" for y :: "'a::linorder"
   by (meson less_eq_multiset_def mset_lt_single_right_iff)
 
 
 subsubsection \<open>Simplifications\<close>
 
 lemma multp\<^sub>H\<^sub>O_repeat_mset_repeat_mset[simp]:
   assumes "n \<noteq> 0"
   shows "multp\<^sub>H\<^sub>O R (repeat_mset n A) (repeat_mset n B) \<longleftrightarrow> multp\<^sub>H\<^sub>O R A B"
 proof (rule iffI)
   assume hyp: "multp\<^sub>H\<^sub>O R (repeat_mset n A) (repeat_mset n B)"
   hence
     1: "repeat_mset n A \<noteq> repeat_mset n B" and
     2: "\<forall>y. n * count B y < n * count A y \<longrightarrow> (\<exists>x. R y x \<and> n * count A x < n * count B x)"
     by (simp_all add: multp\<^sub>H\<^sub>O_def)
 
   from 1 \<open>n \<noteq> 0\<close> have "A \<noteq> B"
     by auto
 
   moreover from 2 \<open>n \<noteq> 0\<close> have "\<forall>y. count B y < count A y \<longrightarrow> (\<exists>x. R y x \<and> count A x < count B x)"
     by auto
 
   ultimately show "multp\<^sub>H\<^sub>O R A B"
     by (simp add: multp\<^sub>H\<^sub>O_def)
 next
   assume "multp\<^sub>H\<^sub>O R A B"
   hence 1: "A \<noteq> B" and 2: "\<forall>y. count B y < count A y \<longrightarrow> (\<exists>x. R y x \<and> count A x < count B x)"
     by (simp_all add: multp\<^sub>H\<^sub>O_def)
 
   from 1 have "repeat_mset n A \<noteq> repeat_mset n B"
     by (simp add: assms repeat_mset_cancel1)
 
   moreover from 2 have "\<forall>y. n * count B y < n * count A y \<longrightarrow>
     (\<exists>x. R y x \<and> n * count A x < n * count B x)"
     by auto
 
   ultimately show "multp\<^sub>H\<^sub>O R (repeat_mset n A) (repeat_mset n B)"
     by (simp add: multp\<^sub>H\<^sub>O_def)
 qed
 
 lemma multp\<^sub>H\<^sub>O_double_double[simp]: "multp\<^sub>H\<^sub>O R (A + A) (B + B) \<longleftrightarrow> multp\<^sub>H\<^sub>O R A B"
   using multp\<^sub>H\<^sub>O_repeat_mset_repeat_mset[of 2]
   by (simp add: numeral_Bit0)
 
 
 subsection \<open>Simprocs\<close>
 
 lemma mset_le_add_iff1:
   "j \<le> (i::nat) \<Longrightarrow> (repeat_mset i u + m \<le> repeat_mset j u + n) = (repeat_mset (i-j) u + m \<le> n)"
 proof -
   assume "j \<le> i"
   then have "j + (i - j) = i"
     using le_add_diff_inverse by blast
   then show ?thesis
     by (metis (no_types) add_le_cancel_left left_add_mult_distrib_mset)
 qed
 
 lemma mset_le_add_iff2:
   "i \<le> (j::nat) \<Longrightarrow> (repeat_mset i u + m \<le> repeat_mset j u + n) = (m \<le> repeat_mset (j-i) u + n)"
 proof -
   assume "i \<le> j"
   then have "i + (j - i) = j"
     using le_add_diff_inverse by blast
   then show ?thesis
     by (metis (no_types) add_le_cancel_left left_add_mult_distrib_mset)
 qed
 
 simproc_setup msetless_cancel
   ("(l::'a::preorder multiset) + m < n" | "(l::'a multiset) < m + n" |
    "add_mset a m < n" | "m < add_mset a n" |
    "replicate_mset p a < n" | "m < replicate_mset p a" |
    "repeat_mset p m < n" | "m < repeat_mset p n") =
-  \<open>fn phi => Cancel_Simprocs.less_cancel\<close>
+  \<open>K Cancel_Simprocs.less_cancel\<close>
 
 simproc_setup msetle_cancel
   ("(l::'a::preorder multiset) + m \<le> n" | "(l::'a multiset) \<le> m + n" |
    "add_mset a m \<le> n" | "m \<le> add_mset a n" |
    "replicate_mset p a \<le> n" | "m \<le> replicate_mset p a" |
    "repeat_mset p m \<le> n" | "m \<le> repeat_mset p n") =
-  \<open>fn phi => Cancel_Simprocs.less_eq_cancel\<close>
+  \<open>K Cancel_Simprocs.less_eq_cancel\<close>
 
 
 subsection \<open>Additional facts and instantiations\<close>
 
 lemma ex_gt_count_imp_le_multiset:
   "(\<forall>y :: 'a :: order. y \<in># M + N \<longrightarrow> y \<le> x) \<Longrightarrow> count M x < count N x \<Longrightarrow> M < N"
   unfolding less_multiset\<^sub>H\<^sub>O
   by (metis count_greater_zero_iff le_imp_less_or_eq less_imp_not_less not_gr_zero union_iff)
 
 lemma mset_lt_single_iff[iff]: "{#x#} < {#y#} \<longleftrightarrow> x < y"
   unfolding less_multiset\<^sub>H\<^sub>O by simp
 
 lemma mset_le_single_iff[iff]: "{#x#} \<le> {#y#} \<longleftrightarrow> x \<le> y" for x y :: "'a::order"
   unfolding less_eq_multiset\<^sub>H\<^sub>O by force
 
 instance multiset :: (linorder) linordered_cancel_ab_semigroup_add
   by standard (metis less_eq_multiset\<^sub>H\<^sub>O not_less_iff_gr_or_eq)
 
 lemma less_eq_multiset_total:
   fixes M N :: "'a :: linorder multiset"
   shows "\<not> M \<le> N \<Longrightarrow> N \<le> M"
   by simp
 
 instantiation multiset :: (wellorder) wellorder
 begin
 
 lemma wf_less_multiset: "wf {(M :: 'a multiset, N). M < N}"
   unfolding less_multiset_def multp_def by (auto intro: wf_mult wf)
 
 instance by standard (metis less_multiset_def multp_def wf wf_def wf_mult)
 
 end
 
 instantiation multiset :: (preorder) order_bot
 begin
 
 definition bot_multiset :: "'a multiset" where "bot_multiset = {#}"
 
 instance by standard (simp add: bot_multiset_def)
 
 end
 
 instance multiset :: (preorder) no_top
 proof standard
   fix x :: "'a multiset"
   obtain a :: 'a where True by simp
   have "x < x + (x + {#a#})"
     by simp
   then show "\<exists>y. x < y"
     by blast
 qed
 
 instance multiset :: (preorder) ordered_cancel_comm_monoid_add
   by standard
 
 instantiation multiset :: (linorder) distrib_lattice
 begin
 
 definition inf_multiset :: "'a multiset \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset" where
   "inf_multiset A B = (if A < B then A else B)"
 
 definition sup_multiset :: "'a multiset \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset" where
   "sup_multiset A B = (if B > A then B else A)"
 
 instance
   by intro_classes (auto simp: inf_multiset_def sup_multiset_def)
 
 end
 
 end
diff --git a/src/HOL/List.thy b/src/HOL/List.thy
--- a/src/HOL/List.thy
+++ b/src/HOL/List.thy
@@ -1,8354 +1,8354 @@
 (*  Title:      HOL/List.thy
     Author:     Tobias Nipkow; proofs tidied by LCP
 *)
 
 section \<open>The datatype of finite lists\<close>
 
 theory List
 imports Sledgehammer Lifting_Set
 begin
 
 datatype (set: 'a) list =
     Nil  ("[]")
   | Cons (hd: 'a) (tl: "'a list")  (infixr "#" 65)
 for
   map: map
   rel: list_all2
   pred: list_all
 where
   "tl [] = []"
 
 datatype_compat list
 
 lemma [case_names Nil Cons, cases type: list]:
   \<comment> \<open>for backward compatibility -- names of variables differ\<close>
   "(y = [] \<Longrightarrow> P) \<Longrightarrow> (\<And>a list. y = a # list \<Longrightarrow> P) \<Longrightarrow> P"
 by (rule list.exhaust)
 
 lemma [case_names Nil Cons, induct type: list]:
   \<comment> \<open>for backward compatibility -- names of variables differ\<close>
   "P [] \<Longrightarrow> (\<And>a list. P list \<Longrightarrow> P (a # list)) \<Longrightarrow> P list"
 by (rule list.induct)
 
 text \<open>Compatibility:\<close>
 
 setup \<open>Sign.mandatory_path "list"\<close>
 
 lemmas inducts = list.induct
 lemmas recs = list.rec
 lemmas cases = list.case
 
 setup \<open>Sign.parent_path\<close>
 
 lemmas set_simps = list.set (* legacy *)
 
 syntax
   \<comment> \<open>list Enumeration\<close>
   "_list" :: "args => 'a list"    ("[(_)]")
 
 translations
   "[x, xs]" == "x#[xs]"
   "[x]" == "x#[]"
 
 
 subsection \<open>Basic list processing functions\<close>
 
 primrec (nonexhaustive) last :: "'a list \<Rightarrow> 'a" where
 "last (x # xs) = (if xs = [] then x else last xs)"
 
 primrec butlast :: "'a list \<Rightarrow> 'a list" where
 "butlast [] = []" |
 "butlast (x # xs) = (if xs = [] then [] else x # butlast xs)"
 
 lemma set_rec: "set xs = rec_list {} (\<lambda>x _. insert x) xs"
   by (induct xs) auto
 
 definition coset :: "'a list \<Rightarrow> 'a set" where
 [simp]: "coset xs = - set xs"
 
 primrec append :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixr "@" 65) where
 append_Nil: "[] @ ys = ys" |
 append_Cons: "(x#xs) @ ys = x # xs @ ys"
 
 primrec rev :: "'a list \<Rightarrow> 'a list" where
 "rev [] = []" |
 "rev (x # xs) = rev xs @ [x]"
 
 primrec filter:: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
 "filter P [] = []" |
 "filter P (x # xs) = (if P x then x # filter P xs else filter P xs)"
 
 text \<open>Special input syntax for filter:\<close>
 syntax (ASCII)
   "_filter" :: "[pttrn, 'a list, bool] => 'a list"  ("(1[_<-_./ _])")
 syntax
   "_filter" :: "[pttrn, 'a list, bool] => 'a list"  ("(1[_\<leftarrow>_ ./ _])")
 translations
   "[x<-xs . P]" \<rightharpoonup> "CONST filter (\<lambda>x. P) xs"
 
 primrec fold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> 'b" where
 fold_Nil:  "fold f [] = id" |
 fold_Cons: "fold f (x # xs) = fold f xs \<circ> f x"
 
 primrec foldr :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> 'b" where
 foldr_Nil:  "foldr f [] = id" |
 foldr_Cons: "foldr f (x # xs) = f x \<circ> foldr f xs"
 
 primrec foldl :: "('b \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a list \<Rightarrow> 'b" where
 foldl_Nil:  "foldl f a [] = a" |
 foldl_Cons: "foldl f a (x # xs) = foldl f (f a x) xs"
 
 primrec concat:: "'a list list \<Rightarrow> 'a list" where
 "concat [] = []" |
 "concat (x # xs) = x @ concat xs"
 
 primrec drop:: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
 drop_Nil: "drop n [] = []" |
 drop_Cons: "drop n (x # xs) = (case n of 0 \<Rightarrow> x # xs | Suc m \<Rightarrow> drop m xs)"
   \<comment> \<open>Warning: simpset does not contain this definition, but separate
        theorems for \<open>n = 0\<close> and \<open>n = Suc k\<close>\<close>
 
 primrec take:: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
 take_Nil:"take n [] = []" |
 take_Cons: "take n (x # xs) = (case n of 0 \<Rightarrow> [] | Suc m \<Rightarrow> x # take m xs)"
   \<comment> \<open>Warning: simpset does not contain this definition, but separate
        theorems for \<open>n = 0\<close> and \<open>n = Suc k\<close>\<close>
 
 primrec (nonexhaustive) nth :: "'a list => nat => 'a" (infixl "!" 100) where
 nth_Cons: "(x # xs) ! n = (case n of 0 \<Rightarrow> x | Suc k \<Rightarrow> xs ! k)"
   \<comment> \<open>Warning: simpset does not contain this definition, but separate
        theorems for \<open>n = 0\<close> and \<open>n = Suc k\<close>\<close>
 
 primrec list_update :: "'a list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a list" where
 "list_update [] i v = []" |
 "list_update (x # xs) i v =
   (case i of 0 \<Rightarrow> v # xs | Suc j \<Rightarrow> x # list_update xs j v)"
 
 nonterminal lupdbinds and lupdbind
 
 syntax
   "_lupdbind":: "['a, 'a] => lupdbind"    ("(2_ :=/ _)")
   "" :: "lupdbind => lupdbinds"    ("_")
   "_lupdbinds" :: "[lupdbind, lupdbinds] => lupdbinds"    ("_,/ _")
   "_LUpdate" :: "['a, lupdbinds] => 'a"    ("_/[(_)]" [1000,0] 900)
 
 translations
   "_LUpdate xs (_lupdbinds b bs)" == "_LUpdate (_LUpdate xs b) bs"
   "xs[i:=x]" == "CONST list_update xs i x"
 
 primrec takeWhile :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
 "takeWhile P [] = []" |
 "takeWhile P (x # xs) = (if P x then x # takeWhile P xs else [])"
 
 primrec dropWhile :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
 "dropWhile P [] = []" |
 "dropWhile P (x # xs) = (if P x then dropWhile P xs else x # xs)"
 
 primrec zip :: "'a list \<Rightarrow> 'b list \<Rightarrow> ('a \<times> 'b) list" where
 "zip xs [] = []" |
 zip_Cons: "zip xs (y # ys) =
   (case xs of [] \<Rightarrow> [] | z # zs \<Rightarrow> (z, y) # zip zs ys)"
   \<comment> \<open>Warning: simpset does not contain this definition, but separate
        theorems for \<open>xs = []\<close> and \<open>xs = z # zs\<close>\<close>
 
 abbreviation map2 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list" where
 "map2 f xs ys \<equiv> map (\<lambda>(x,y). f x y) (zip xs ys)"
 
 primrec product :: "'a list \<Rightarrow> 'b list \<Rightarrow> ('a \<times> 'b) list" where
 "product [] _ = []" |
 "product (x#xs) ys = map (Pair x) ys @ product xs ys"
 
 hide_const (open) product
 
 primrec product_lists :: "'a list list \<Rightarrow> 'a list list" where
 "product_lists [] = [[]]" |
 "product_lists (xs # xss) = concat (map (\<lambda>x. map (Cons x) (product_lists xss)) xs)"
 
 primrec upt :: "nat \<Rightarrow> nat \<Rightarrow> nat list" ("(1[_..</_'])") where
 upt_0: "[i..<0] = []" |
 upt_Suc: "[i..<(Suc j)] = (if i \<le> j then [i..<j] @ [j] else [])"
 
 definition insert :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
 "insert x xs = (if x \<in> set xs then xs else x # xs)"
 
 definition union :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
 "union = fold insert"
 
 hide_const (open) insert union
 hide_fact (open) insert_def union_def
 
 primrec find :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a option" where
 "find _ [] = None" |
 "find P (x#xs) = (if P x then Some x else find P xs)"
 
 text \<open>In the context of multisets, \<open>count_list\<close> is equivalent to
   \<^term>\<open>count \<circ> mset\<close> and it it advisable to use the latter.\<close>
 primrec count_list :: "'a list \<Rightarrow> 'a \<Rightarrow> nat" where
 "count_list [] y = 0" |
 "count_list (x#xs) y = (if x=y then count_list xs y + 1 else count_list xs y)"
 
 definition
    "extract" :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> ('a list * 'a * 'a list) option"
 where "extract P xs =
   (case dropWhile (Not \<circ> P) xs of
      [] \<Rightarrow> None |
      y#ys \<Rightarrow> Some(takeWhile (Not \<circ> P) xs, y, ys))"
 
 hide_const (open) "extract"
 
 primrec those :: "'a option list \<Rightarrow> 'a list option"
 where
 "those [] = Some []" |
 "those (x # xs) = (case x of
   None \<Rightarrow> None
 | Some y \<Rightarrow> map_option (Cons y) (those xs))"
 
 primrec remove1 :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
 "remove1 x [] = []" |
 "remove1 x (y # xs) = (if x = y then xs else y # remove1 x xs)"
 
 primrec removeAll :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
 "removeAll x [] = []" |
 "removeAll x (y # xs) = (if x = y then removeAll x xs else y # removeAll x xs)"
 
 primrec distinct :: "'a list \<Rightarrow> bool" where
 "distinct [] \<longleftrightarrow> True" |
 "distinct (x # xs) \<longleftrightarrow> x \<notin> set xs \<and> distinct xs"
 
 fun successively :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
 "successively P []  = True" |
 "successively P [x] = True" |
 "successively P (x # y # xs) = (P x y \<and> successively P (y#xs))"
 
 definition distinct_adj where
 "distinct_adj = successively (\<noteq>)"
 
 primrec remdups :: "'a list \<Rightarrow> 'a list" where
 "remdups [] = []" |
 "remdups (x # xs) = (if x \<in> set xs then remdups xs else x # remdups xs)"
 
 fun remdups_adj :: "'a list \<Rightarrow> 'a list" where
 "remdups_adj [] = []" |
 "remdups_adj [x] = [x]" |
 "remdups_adj (x # y # xs) = (if x = y then remdups_adj (x # xs) else x # remdups_adj (y # xs))"
 
 primrec replicate :: "nat \<Rightarrow> 'a \<Rightarrow> 'a list" where
 replicate_0: "replicate 0 x = []" |
 replicate_Suc: "replicate (Suc n) x = x # replicate n x"
 
 text \<open>
   Function \<open>size\<close> is overloaded for all datatypes. Users may
   refer to the list version as \<open>length\<close>.\<close>
 
 abbreviation length :: "'a list \<Rightarrow> nat" where
 "length \<equiv> size"
 
 definition enumerate :: "nat \<Rightarrow> 'a list \<Rightarrow> (nat \<times> 'a) list" where
 enumerate_eq_zip: "enumerate n xs = zip [n..<n + length xs] xs"
 
 primrec rotate1 :: "'a list \<Rightarrow> 'a list" where
 "rotate1 [] = []" |
 "rotate1 (x # xs) = xs @ [x]"
 
 definition rotate :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
 "rotate n = rotate1 ^^ n"
 
 definition nths :: "'a list => nat set => 'a list" where
 "nths xs A = map fst (filter (\<lambda>p. snd p \<in> A) (zip xs [0..<size xs]))"
 
 primrec subseqs :: "'a list \<Rightarrow> 'a list list" where
 "subseqs [] = [[]]" |
 "subseqs (x#xs) = (let xss = subseqs xs in map (Cons x) xss @ xss)"
 
 primrec n_lists :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list list" where
 "n_lists 0 xs = [[]]" |
 "n_lists (Suc n) xs = concat (map (\<lambda>ys. map (\<lambda>y. y # ys) xs) (n_lists n xs))"
 
 hide_const (open) n_lists
 
 function splice :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
 "splice [] ys = ys" |
 "splice (x#xs) ys = x # splice ys xs"
 by pat_completeness auto
 
 termination
 by(relation "measure(\<lambda>(xs,ys). size xs + size ys)") auto
 
 function shuffles where
   "shuffles [] ys = {ys}"
 | "shuffles xs [] = {xs}"
 | "shuffles (x # xs) (y # ys) = (#) x ` shuffles xs (y # ys) \<union> (#) y ` shuffles (x # xs) ys"
   by pat_completeness simp_all
 termination by lexicographic_order
 
 text\<open>Use only if you cannot use \<^const>\<open>Min\<close> instead:\<close>
 fun min_list :: "'a::ord list \<Rightarrow> 'a" where
 "min_list (x # xs) = (case xs of [] \<Rightarrow> x | _ \<Rightarrow> min x (min_list xs))"
 
 text\<open>Returns first minimum:\<close>
 fun arg_min_list :: "('a \<Rightarrow> ('b::linorder)) \<Rightarrow> 'a list \<Rightarrow> 'a" where
 "arg_min_list f [x] = x" |
 "arg_min_list f (x#y#zs) = (let m = arg_min_list f (y#zs) in if f x \<le> f m then x else m)"
 
 text\<open>
 \begin{figure}[htbp]
 \fbox{
 \begin{tabular}{l}
 @{lemma "[a,b]@[c,d] = [a,b,c,d]" by simp}\\
 @{lemma "length [a,b,c] = 3" by simp}\\
 @{lemma "set [a,b,c] = {a,b,c}" by simp}\\
 @{lemma "map f [a,b,c] = [f a, f b, f c]" by simp}\\
 @{lemma "rev [a,b,c] = [c,b,a]" by simp}\\
 @{lemma "hd [a,b,c,d] = a" by simp}\\
 @{lemma "tl [a,b,c,d] = [b,c,d]" by simp}\\
 @{lemma "last [a,b,c,d] = d" by simp}\\
 @{lemma "butlast [a,b,c,d] = [a,b,c]" by simp}\\
 @{lemma[source] "filter (\<lambda>n::nat. n<2) [0,2,1] = [0,1]" by simp}\\
 @{lemma "concat [[a,b],[c,d,e],[],[f]] = [a,b,c,d,e,f]" by simp}\\
 @{lemma "fold f [a,b,c] x = f c (f b (f a x))" by simp}\\
 @{lemma "foldr f [a,b,c] x = f a (f b (f c x))" by simp}\\
 @{lemma "foldl f x [a,b,c] = f (f (f x a) b) c" by simp}\\
 @{lemma "successively (\<noteq>) [True,False,True,False]" by simp}\\
 @{lemma "zip [a,b,c] [x,y,z] = [(a,x),(b,y),(c,z)]" by simp}\\
 @{lemma "zip [a,b] [x,y,z] = [(a,x),(b,y)]" by simp}\\
 @{lemma "enumerate 3 [a,b,c] = [(3,a),(4,b),(5,c)]" by normalization}\\
 @{lemma "List.product [a,b] [c,d] = [(a, c), (a, d), (b, c), (b, d)]" by simp}\\
 @{lemma "product_lists [[a,b], [c], [d,e]] = [[a,c,d], [a,c,e], [b,c,d], [b,c,e]]" by simp}\\
 @{lemma "splice [a,b,c] [x,y,z] = [a,x,b,y,c,z]" by simp}\\
 @{lemma "splice [a,b,c,d] [x,y] = [a,x,b,y,c,d]" by simp}\\
 @{lemma "shuffles [a,b] [c,d] =  {[a,b,c,d],[a,c,b,d],[a,c,d,b],[c,a,b,d],[c,a,d,b],[c,d,a,b]}"
     by (simp add: insert_commute)}\\
 @{lemma "take 2 [a,b,c,d] = [a,b]" by simp}\\
 @{lemma "take 6 [a,b,c,d] = [a,b,c,d]" by simp}\\
 @{lemma "drop 2 [a,b,c,d] = [c,d]" by simp}\\
 @{lemma "drop 6 [a,b,c,d] = []" by simp}\\
 @{lemma "takeWhile (%n::nat. n<3) [1,2,3,0] = [1,2]" by simp}\\
 @{lemma "dropWhile (%n::nat. n<3) [1,2,3,0] = [3,0]" by simp}\\
 @{lemma "distinct [2,0,1::nat]" by simp}\\
 @{lemma "remdups [2,0,2,1::nat,2] = [0,1,2]" by simp}\\
 @{lemma "remdups_adj [2,2,3,1,1::nat,2,1] = [2,3,1,2,1]" by simp}\\
 @{lemma "List.insert 2 [0::nat,1,2] = [0,1,2]" by (simp add: List.insert_def)}\\
 @{lemma "List.insert 3 [0::nat,1,2] = [3,0,1,2]" by (simp add: List.insert_def)}\\
 @{lemma "List.union [2,3,4] [0::int,1,2] = [4,3,0,1,2]" by (simp add: List.insert_def List.union_def)}\\
 @{lemma "List.find (%i::int. i>0) [0,0] = None" by simp}\\
 @{lemma "List.find (%i::int. i>0) [0,1,0,2] = Some 1" by simp}\\
 @{lemma "count_list [0,1,0,2::int] 0 = 2" by (simp)}\\
 @{lemma "List.extract (%i::int. i>0) [0,0] = None" by(simp add: extract_def)}\\
 @{lemma "List.extract (%i::int. i>0) [0,1,0,2] = Some([0], 1, [0,2])" by(simp add: extract_def)}\\
 @{lemma "remove1 2 [2,0,2,1::nat,2] = [0,2,1,2]" by simp}\\
 @{lemma "removeAll 2 [2,0,2,1::nat,2] = [0,1]" by simp}\\
 @{lemma "nth [a,b,c,d] 2 = c" by simp}\\
 @{lemma "[a,b,c,d][2 := x] = [a,b,x,d]" by simp}\\
 @{lemma "nths [a,b,c,d,e] {0,2,3} = [a,c,d]" by (simp add:nths_def)}\\
 @{lemma "subseqs [a,b] = [[a, b], [a], [b], []]" by simp}\\
 @{lemma "List.n_lists 2 [a,b,c] = [[a, a], [b, a], [c, a], [a, b], [b, b], [c, b], [a, c], [b, c], [c, c]]" by (simp add: eval_nat_numeral)}\\
 @{lemma "rotate1 [a,b,c,d] = [b,c,d,a]" by simp}\\
 @{lemma "rotate 3 [a,b,c,d] = [d,a,b,c]" by (simp add:rotate_def eval_nat_numeral)}\\
 @{lemma "replicate 4 a = [a,a,a,a]" by (simp add:eval_nat_numeral)}\\
 @{lemma "[2..<5] = [2,3,4]" by (simp add:eval_nat_numeral)}\\
 @{lemma "min_list [3,1,-2::int] = -2" by (simp)}\\
 @{lemma "arg_min_list (\<lambda>i. i*i) [3,-1,1,-2::int] = -1" by (simp)}
 \end{tabular}}
 \caption{Characteristic examples}
 \label{fig:Characteristic}
 \end{figure}
 Figure~\ref{fig:Characteristic} shows characteristic examples
 that should give an intuitive understanding of the above functions.
 \<close>
 
 text\<open>The following simple sort(ed) functions are intended for proofs,
 not for efficient implementations.\<close>
 
 text \<open>A sorted predicate w.r.t. a relation:\<close>
 
 fun sorted_wrt :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
 "sorted_wrt P [] = True" |
 "sorted_wrt P (x # ys) = ((\<forall>y \<in> set ys. P x y) \<and> sorted_wrt P ys)"
 
 text \<open>A class-based sorted predicate:\<close>
 
 context linorder
 begin
 
 abbreviation sorted :: "'a list \<Rightarrow> bool" where
   "sorted \<equiv> sorted_wrt (\<le>)"
 
 lemma sorted_simps: "sorted [] = True" "sorted (x # ys) = ((\<forall>y \<in> set ys. x\<le>y) \<and> sorted ys)"
   by auto
 
 lemma strict_sorted_simps: "sorted_wrt (<) [] = True" "sorted_wrt (<) (x # ys) = ((\<forall>y \<in> set ys. x<y) \<and> sorted_wrt (<) ys)"
   by auto
 
 primrec insort_key :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> 'b list \<Rightarrow> 'b list" where
   "insort_key f x [] = [x]" |
   "insort_key f x (y#ys) =
   (if f x \<le> f y then (x#y#ys) else y#(insort_key f x ys))"
 
 definition sort_key :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b list \<Rightarrow> 'b list" where
   "sort_key f xs = foldr (insort_key f) xs []"
 
 definition insort_insert_key :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> 'b list \<Rightarrow> 'b list" where
   "insort_insert_key f x xs =
   (if f x \<in> f ` set xs then xs else insort_key f x xs)"
 
 abbreviation "sort \<equiv> sort_key (\<lambda>x. x)"
 abbreviation "insort \<equiv> insort_key (\<lambda>x. x)"
 abbreviation "insort_insert \<equiv> insort_insert_key (\<lambda>x. x)"
 
 definition stable_sort_key :: "(('b \<Rightarrow> 'a) \<Rightarrow> 'b list \<Rightarrow> 'b list) \<Rightarrow> bool" where
   "stable_sort_key sk =
    (\<forall>f xs k. filter (\<lambda>y. f y = k) (sk f xs) = filter (\<lambda>y. f y = k) xs)"
 
 lemma strict_sorted_iff: "sorted_wrt (<) l \<longleftrightarrow> sorted l \<and> distinct l"
   by (induction l) (auto iff: antisym_conv1)
 
 lemma strict_sorted_imp_sorted: "sorted_wrt (<) xs \<Longrightarrow> sorted xs"
   by (auto simp: strict_sorted_iff)
 
 end
 
 
 subsubsection \<open>List comprehension\<close>
 
 text\<open>Input syntax for Haskell-like list comprehension notation.
 Typical example: \<open>[(x,y). x \<leftarrow> xs, y \<leftarrow> ys, x \<noteq> y]\<close>,
 the list of all pairs of distinct elements from \<open>xs\<close> and \<open>ys\<close>.
 The syntax is as in Haskell, except that \<open>|\<close> becomes a dot
 (like in Isabelle's set comprehension): \<open>[e. x \<leftarrow> xs, \<dots>]\<close> rather than
 \verb![e| x <- xs, ...]!.
 
 The qualifiers after the dot are
 \begin{description}
 \item[generators] \<open>p \<leftarrow> xs\<close>,
  where \<open>p\<close> is a pattern and \<open>xs\<close> an expression of list type, or
 \item[guards] \<open>b\<close>, where \<open>b\<close> is a boolean expression.
 %\item[local bindings] @ {text"let x = e"}.
 \end{description}
 
 Just like in Haskell, list comprehension is just a shorthand. To avoid
 misunderstandings, the translation into desugared form is not reversed
 upon output. Note that the translation of \<open>[e. x \<leftarrow> xs]\<close> is
 optmized to \<^term>\<open>map (%x. e) xs\<close>.
 
 It is easy to write short list comprehensions which stand for complex
 expressions. During proofs, they may become unreadable (and
 mangled). In such cases it can be advisable to introduce separate
 definitions for the list comprehensions in question.\<close>
 
 nonterminal lc_qual and lc_quals
 
 syntax
   "_listcompr" :: "'a \<Rightarrow> lc_qual \<Rightarrow> lc_quals \<Rightarrow> 'a list"  ("[_ . __")
   "_lc_gen" :: "'a \<Rightarrow> 'a list \<Rightarrow> lc_qual"  ("_ \<leftarrow> _")
   "_lc_test" :: "bool \<Rightarrow> lc_qual" ("_")
   (*"_lc_let" :: "letbinds => lc_qual"  ("let _")*)
   "_lc_end" :: "lc_quals" ("]")
   "_lc_quals" :: "lc_qual \<Rightarrow> lc_quals \<Rightarrow> lc_quals"  (", __")
 
 syntax (ASCII)
   "_lc_gen" :: "'a \<Rightarrow> 'a list \<Rightarrow> lc_qual"  ("_ <- _")
 
 parse_translation \<open>
 let
   val NilC = Syntax.const \<^const_syntax>\<open>Nil\<close>;
   val ConsC = Syntax.const \<^const_syntax>\<open>Cons\<close>;
   val mapC = Syntax.const \<^const_syntax>\<open>map\<close>;
   val concatC = Syntax.const \<^const_syntax>\<open>concat\<close>;
   val IfC = Syntax.const \<^const_syntax>\<open>If\<close>;
   val dummyC = Syntax.const \<^const_syntax>\<open>Pure.dummy_pattern\<close>
 
   fun single x = ConsC $ x $ NilC;
 
   fun pat_tr ctxt p e opti = (* %x. case x of p => e | _ => [] *)
     let
       (* FIXME proper name context!? *)
       val x =
         Free (singleton (Name.variant_list (fold Term.add_free_names [p, e] [])) "x", dummyT);
       val e = if opti then single e else e;
       val case1 = Syntax.const \<^syntax_const>\<open>_case1\<close> $ p $ e;
       val case2 =
         Syntax.const \<^syntax_const>\<open>_case1\<close> $ dummyC $ NilC;
       val cs = Syntax.const \<^syntax_const>\<open>_case2\<close> $ case1 $ case2;
     in Syntax_Trans.abs_tr [x, Case_Translation.case_tr false ctxt [x, cs]] end;
 
   fun pair_pat_tr (x as Free _) e = Syntax_Trans.abs_tr [x, e]
     | pair_pat_tr (_ $ p1 $ p2) e =
         Syntax.const \<^const_syntax>\<open>case_prod\<close> $ pair_pat_tr p1 (pair_pat_tr p2 e)
     | pair_pat_tr dummy e = Syntax_Trans.abs_tr [Syntax.const "_idtdummy", e]
 
   fun pair_pat ctxt (Const (\<^const_syntax>\<open>Pair\<close>,_) $ s $ t) =
         pair_pat ctxt s andalso pair_pat ctxt t
     | pair_pat ctxt (Free (s,_)) =
         let
           val thy = Proof_Context.theory_of ctxt;
           val s' = Proof_Context.intern_const ctxt s;
         in not (Sign.declared_const thy s') end
     | pair_pat _ t = (t = dummyC);
 
   fun abs_tr ctxt p e opti =
     let val p = Term_Position.strip_positions p
     in if pair_pat ctxt p
        then (pair_pat_tr p e, true)
        else (pat_tr ctxt p e opti, false)
     end
 
   fun lc_tr ctxt [e, Const (\<^syntax_const>\<open>_lc_test\<close>, _) $ b, qs] =
     let
       val res =
         (case qs of
            Const (\<^syntax_const>\<open>_lc_end\<close>, _) => single e
          | Const (\<^syntax_const>\<open>_lc_quals\<close>, _) $ q $ qs => lc_tr ctxt [e, q, qs]);
     in IfC $ b $ res $ NilC end
   | lc_tr ctxt
       [e, Const (\<^syntax_const>\<open>_lc_gen\<close>, _) $ p $ es,
           Const(\<^syntax_const>\<open>_lc_end\<close>, _)] =
       (case abs_tr ctxt p e true of
          (f, true) => mapC $ f $ es
        | (f, false) => concatC $ (mapC $ f $ es))
   | lc_tr ctxt
       [e, Const (\<^syntax_const>\<open>_lc_gen\<close>, _) $ p $ es,
           Const (\<^syntax_const>\<open>_lc_quals\<close>, _) $ q $ qs] =
       let val e' = lc_tr ctxt [e, q, qs];
       in concatC $ (mapC $ (fst (abs_tr ctxt p e' false)) $ es) end;
 
 in [(\<^syntax_const>\<open>_listcompr\<close>, lc_tr)] end
 \<close>
 
 ML_val \<open>
   let
     val read = Syntax.read_term \<^context> o Syntax.implode_input;
     fun check s1 s2 =
       read s1 aconv read s2 orelse
         error ("Check failed: " ^
           quote (#1 (Input.source_content s1)) ^ Position.here_list [Input.pos_of s1, Input.pos_of s2]);
   in
     check \<open>[(x,y,z). b]\<close> \<open>if b then [(x, y, z)] else []\<close>;
     check \<open>[(x,y,z). (x,_,y)\<leftarrow>xs]\<close> \<open>map (\<lambda>(x,_,y). (x, y, z)) xs\<close>;
     check \<open>[e x y. (x,_)\<leftarrow>xs, y\<leftarrow>ys]\<close> \<open>concat (map (\<lambda>(x,_). map (\<lambda>y. e x y) ys) xs)\<close>;
     check \<open>[(x,y,z). x<a, x>b]\<close> \<open>if x < a then if b < x then [(x, y, z)] else [] else []\<close>;
     check \<open>[(x,y,z). x\<leftarrow>xs, x>b]\<close> \<open>concat (map (\<lambda>x. if b < x then [(x, y, z)] else []) xs)\<close>;
     check \<open>[(x,y,z). x<a, x\<leftarrow>xs]\<close> \<open>if x < a then map (\<lambda>x. (x, y, z)) xs else []\<close>;
     check \<open>[(x,y). Cons True x \<leftarrow> xs]\<close>
       \<open>concat (map (\<lambda>xa. case xa of [] \<Rightarrow> [] | True # x \<Rightarrow> [(x, y)] | False # x \<Rightarrow> []) xs)\<close>;
     check \<open>[(x,y,z). Cons x [] \<leftarrow> xs]\<close>
       \<open>concat (map (\<lambda>xa. case xa of [] \<Rightarrow> [] | [x] \<Rightarrow> [(x, y, z)] | x # aa # lista \<Rightarrow> []) xs)\<close>;
     check \<open>[(x,y,z). x<a, x>b, x=d]\<close>
       \<open>if x < a then if b < x then if x = d then [(x, y, z)] else [] else [] else []\<close>;
     check \<open>[(x,y,z). x<a, x>b, y\<leftarrow>ys]\<close>
       \<open>if x < a then if b < x then map (\<lambda>y. (x, y, z)) ys else [] else []\<close>;
     check \<open>[(x,y,z). x<a, (_,x)\<leftarrow>xs,y>b]\<close>
       \<open>if x < a then concat (map (\<lambda>(_,x). if b < y then [(x, y, z)] else []) xs) else []\<close>;
     check \<open>[(x,y,z). x<a, x\<leftarrow>xs, y\<leftarrow>ys]\<close>
       \<open>if x < a then concat (map (\<lambda>x. map (\<lambda>y. (x, y, z)) ys) xs) else []\<close>;
     check \<open>[(x,y,z). x\<leftarrow>xs, x>b, y<a]\<close>
       \<open>concat (map (\<lambda>x. if b < x then if y < a then [(x, y, z)] else [] else []) xs)\<close>;
     check \<open>[(x,y,z). x\<leftarrow>xs, x>b, y\<leftarrow>ys]\<close>
       \<open>concat (map (\<lambda>x. if b < x then map (\<lambda>y. (x, y, z)) ys else []) xs)\<close>;
     check \<open>[(x,y,z). x\<leftarrow>xs, (y,_)\<leftarrow>ys,y>x]\<close>
       \<open>concat (map (\<lambda>x. concat (map (\<lambda>(y,_). if x < y then [(x, y, z)] else []) ys)) xs)\<close>;
     check \<open>[(x,y,z). x\<leftarrow>xs, y\<leftarrow>ys,z\<leftarrow>zs]\<close>
       \<open>concat (map (\<lambda>x. concat (map (\<lambda>y. map (\<lambda>z. (x, y, z)) zs) ys)) xs)\<close>
   end;
 \<close>
 
 ML \<open>
 (* Simproc for rewriting list comprehensions applied to List.set to set
    comprehension. *)
 
 signature LIST_TO_SET_COMPREHENSION =
 sig
   val simproc : Proof.context -> cterm -> thm option
 end
 
 structure List_to_Set_Comprehension : LIST_TO_SET_COMPREHENSION =
 struct
 
 (* conversion *)
 
 fun all_exists_conv cv ctxt ct =
   (case Thm.term_of ct of
     Const (\<^const_name>\<open>Ex\<close>, _) $ Abs _ =>
       Conv.arg_conv (Conv.abs_conv (all_exists_conv cv o #2) ctxt) ct
   | _ => cv ctxt ct)
 
 fun all_but_last_exists_conv cv ctxt ct =
   (case Thm.term_of ct of
     Const (\<^const_name>\<open>Ex\<close>, _) $ Abs (_, _, Const (\<^const_name>\<open>Ex\<close>, _) $ _) =>
       Conv.arg_conv (Conv.abs_conv (all_but_last_exists_conv cv o #2) ctxt) ct
   | _ => cv ctxt ct)
 
 fun Collect_conv cv ctxt ct =
   (case Thm.term_of ct of
     Const (\<^const_name>\<open>Collect\<close>, _) $ Abs _ => Conv.arg_conv (Conv.abs_conv cv ctxt) ct
   | _ => raise CTERM ("Collect_conv", [ct]))
 
 fun rewr_conv' th = Conv.rewr_conv (mk_meta_eq th)
 
 fun conjunct_assoc_conv ct =
   Conv.try_conv
     (rewr_conv' @{thm conj_assoc} then_conv HOLogic.conj_conv Conv.all_conv conjunct_assoc_conv) ct
 
 fun right_hand_set_comprehension_conv conv ctxt =
   HOLogic.Trueprop_conv (HOLogic.eq_conv Conv.all_conv
     (Collect_conv (all_exists_conv conv o #2) ctxt))
 
 
 (* term abstraction of list comprehension patterns *)
 
 datatype termlets = If | Case of typ * int
 
 local
 
 val set_Nil_I = @{lemma "set [] = {x. False}" by (simp add: empty_def [symmetric])}
 val set_singleton = @{lemma "set [a] = {x. x = a}" by simp}
 val inst_Collect_mem_eq = @{lemma "set A = {x. x \<in> set A}" by simp}
 val del_refl_eq = @{lemma "(t = t \<and> P) \<equiv> P" by simp}
 
 fun mk_set T = Const (\<^const_name>\<open>set\<close>, HOLogic.listT T --> HOLogic.mk_setT T)
 fun dest_set (Const (\<^const_name>\<open>set\<close>, _) $ xs) = xs
 
 fun dest_singleton_list (Const (\<^const_name>\<open>Cons\<close>, _) $ t $ (Const (\<^const_name>\<open>Nil\<close>, _))) = t
   | dest_singleton_list t = raise TERM ("dest_singleton_list", [t])
 
 (*We check that one case returns a singleton list and all other cases
   return [], and return the index of the one singleton list case.*)
 fun possible_index_of_singleton_case cases =
   let
     fun check (i, case_t) s =
       (case strip_abs_body case_t of
         (Const (\<^const_name>\<open>Nil\<close>, _)) => s
       | _ => (case s of SOME NONE => SOME (SOME i) | _ => NONE))
   in
     fold_index check cases (SOME NONE) |> the_default NONE
   end
 
 (*returns condition continuing term option*)
 fun dest_if (Const (\<^const_name>\<open>If\<close>, _) $ cond $ then_t $ Const (\<^const_name>\<open>Nil\<close>, _)) =
       SOME (cond, then_t)
   | dest_if _ = NONE
 
 (*returns (case_expr type index chosen_case constr_name) option*)
 fun dest_case ctxt case_term =
   let
     val (case_const, args) = strip_comb case_term
   in
     (case try dest_Const case_const of
       SOME (c, T) =>
         (case Ctr_Sugar.ctr_sugar_of_case ctxt c of
           SOME {ctrs, ...} =>
             (case possible_index_of_singleton_case (fst (split_last args)) of
               SOME i =>
                 let
                   val constr_names = map (fst o dest_Const) ctrs
                   val (Ts, _) = strip_type T
                   val T' = List.last Ts
                 in SOME (List.last args, T', i, nth args i, nth constr_names i) end
             | NONE => NONE)
         | NONE => NONE)
     | NONE => NONE)
   end
 
 fun tac ctxt [] =
       resolve_tac ctxt [set_singleton] 1 ORELSE
       resolve_tac ctxt [inst_Collect_mem_eq] 1
   | tac ctxt (If :: cont) =
       Splitter.split_tac ctxt @{thms if_split} 1
       THEN resolve_tac ctxt @{thms conjI} 1
       THEN resolve_tac ctxt @{thms impI} 1
       THEN Subgoal.FOCUS (fn {prems, context = ctxt', ...} =>
         CONVERSION (right_hand_set_comprehension_conv (K
           (HOLogic.conj_conv (Conv.rewr_conv (List.last prems RS @{thm Eq_TrueI})) Conv.all_conv
            then_conv
            rewr_conv' @{lemma "(True \<and> P) = P" by simp})) ctxt') 1) ctxt 1
       THEN tac ctxt cont
       THEN resolve_tac ctxt @{thms impI} 1
       THEN Subgoal.FOCUS (fn {prems, context = ctxt', ...} =>
           CONVERSION (right_hand_set_comprehension_conv (K
             (HOLogic.conj_conv (Conv.rewr_conv (List.last prems RS @{thm Eq_FalseI})) Conv.all_conv
              then_conv rewr_conv' @{lemma "(False \<and> P) = False" by simp})) ctxt') 1) ctxt 1
       THEN resolve_tac ctxt [set_Nil_I] 1
   | tac ctxt (Case (T, i) :: cont) =
       let
         val SOME {injects, distincts, case_thms, split, ...} =
           Ctr_Sugar.ctr_sugar_of ctxt (fst (dest_Type T))
       in
         (* do case distinction *)
         Splitter.split_tac ctxt [split] 1
         THEN EVERY (map_index (fn (i', _) =>
           (if i' < length case_thms - 1 then resolve_tac ctxt @{thms conjI} 1 else all_tac)
           THEN REPEAT_DETERM (resolve_tac ctxt @{thms allI} 1)
           THEN resolve_tac ctxt @{thms impI} 1
           THEN (if i' = i then
             (* continue recursively *)
             Subgoal.FOCUS (fn {prems, context = ctxt', ...} =>
               CONVERSION (Thm.eta_conversion then_conv right_hand_set_comprehension_conv (K
                   ((HOLogic.conj_conv
                     (HOLogic.eq_conv Conv.all_conv (rewr_conv' (List.last prems)) then_conv
                       (Conv.try_conv (Conv.rewrs_conv (map mk_meta_eq injects))))
                     Conv.all_conv)
                     then_conv (Conv.try_conv (Conv.rewr_conv del_refl_eq))
                     then_conv conjunct_assoc_conv)) ctxt'
                 then_conv
                   (HOLogic.Trueprop_conv
                     (HOLogic.eq_conv Conv.all_conv (Collect_conv (fn (_, ctxt'') =>
                       Conv.repeat_conv
                         (all_but_last_exists_conv
                           (K (rewr_conv'
                             @{lemma "(\<exists>x. x = t \<and> P x) = P t" by simp})) ctxt'')) ctxt')))) 1) ctxt 1
             THEN tac ctxt cont
           else
             Subgoal.FOCUS (fn {prems, context = ctxt', ...} =>
               CONVERSION
                 (right_hand_set_comprehension_conv (K
                   (HOLogic.conj_conv
                     ((HOLogic.eq_conv Conv.all_conv
                       (rewr_conv' (List.last prems))) then_conv
                       (Conv.rewrs_conv (map (fn th => th RS @{thm Eq_FalseI}) distincts)))
                     Conv.all_conv then_conv
                     (rewr_conv' @{lemma "(False \<and> P) = False" by simp}))) ctxt' then_conv
                   HOLogic.Trueprop_conv
                     (HOLogic.eq_conv Conv.all_conv
                       (Collect_conv (fn (_, ctxt'') =>
                         Conv.repeat_conv
                           (Conv.bottom_conv
                             (K (rewr_conv' @{lemma "(\<exists>x. P) = P" by simp})) ctxt'')) ctxt'))) 1) ctxt 1
             THEN resolve_tac ctxt [set_Nil_I] 1)) case_thms)
       end
 
 in
 
 fun simproc ctxt redex =
   let
     fun make_inner_eqs bound_vs Tis eqs t =
       (case dest_case ctxt t of
         SOME (x, T, i, cont, constr_name) =>
           let
             val (vs, body) = strip_abs (Envir.eta_long (map snd bound_vs) cont)
             val x' = incr_boundvars (length vs) x
             val eqs' = map (incr_boundvars (length vs)) eqs
             val constr_t =
               list_comb
                 (Const (constr_name, map snd vs ---> T), map Bound (((length vs) - 1) downto 0))
             val constr_eq = Const (\<^const_name>\<open>HOL.eq\<close>, T --> T --> \<^typ>\<open>bool\<close>) $ constr_t $ x'
           in
             make_inner_eqs (rev vs @ bound_vs) (Case (T, i) :: Tis) (constr_eq :: eqs') body
           end
       | NONE =>
           (case dest_if t of
             SOME (condition, cont) => make_inner_eqs bound_vs (If :: Tis) (condition :: eqs) cont
           | NONE =>
             if null eqs then NONE (*no rewriting, nothing to be done*)
             else
               let
                 val Type (\<^type_name>\<open>list\<close>, [rT]) = fastype_of1 (map snd bound_vs, t)
                 val pat_eq =
                   (case try dest_singleton_list t of
                     SOME t' =>
                       Const (\<^const_name>\<open>HOL.eq\<close>, rT --> rT --> \<^typ>\<open>bool\<close>) $
                         Bound (length bound_vs) $ t'
                   | NONE =>
                       Const (\<^const_name>\<open>Set.member\<close>, rT --> HOLogic.mk_setT rT --> \<^typ>\<open>bool\<close>) $
                         Bound (length bound_vs) $ (mk_set rT $ t))
                 val reverse_bounds = curry subst_bounds
                   ((map Bound ((length bound_vs - 1) downto 0)) @ [Bound (length bound_vs)])
                 val eqs' = map reverse_bounds eqs
                 val pat_eq' = reverse_bounds pat_eq
                 val inner_t =
                   fold (fn (_, T) => fn t => HOLogic.exists_const T $ absdummy T t)
                     (rev bound_vs) (fold (curry HOLogic.mk_conj) eqs' pat_eq')
                 val lhs = Thm.term_of redex
                 val rhs = HOLogic.mk_Collect ("x", rT, inner_t)
                 val rewrite_rule_t = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs))
               in
                 SOME
                   ((Goal.prove ctxt [] [] rewrite_rule_t
                     (fn {context = ctxt', ...} => tac ctxt' (rev Tis))) RS @{thm eq_reflection})
               end))
   in
     make_inner_eqs [] [] [] (dest_set (Thm.term_of redex))
   end
 
 end
 
 end
 \<close>
 
 simproc_setup list_to_set_comprehension ("set xs") =
   \<open>K List_to_Set_Comprehension.simproc\<close>
 
 code_datatype set coset
 hide_const (open) coset
 
 
 subsubsection \<open>\<^const>\<open>Nil\<close> and \<^const>\<open>Cons\<close>\<close>
 
 lemma not_Cons_self [simp]:
   "xs \<noteq> x # xs"
 by (induct xs) auto
 
 lemma not_Cons_self2 [simp]: "x # xs \<noteq> xs"
 by (rule not_Cons_self [symmetric])
 
 lemma neq_Nil_conv: "(xs \<noteq> []) = (\<exists>y ys. xs = y # ys)"
 by (induct xs) auto
 
 lemma tl_Nil: "tl xs = [] \<longleftrightarrow> xs = [] \<or> (\<exists>x. xs = [x])"
 by (cases xs) auto
 
 lemmas Nil_tl = tl_Nil[THEN eq_iff_swap]
 
 lemma length_induct:
   "(\<And>xs. \<forall>ys. length ys < length xs \<longrightarrow> P ys \<Longrightarrow> P xs) \<Longrightarrow> P xs"
 by (fact measure_induct)
 
 lemma induct_list012:
   "\<lbrakk>P []; \<And>x. P [x]; \<And>x y zs. \<lbrakk> P zs; P (y # zs) \<rbrakk> \<Longrightarrow> P (x # y # zs)\<rbrakk> \<Longrightarrow> P xs"
 by induction_schema (pat_completeness, lexicographic_order)
 
 lemma list_nonempty_induct [consumes 1, case_names single cons]:
   "\<lbrakk> xs \<noteq> []; \<And>x. P [x]; \<And>x xs. xs \<noteq> [] \<Longrightarrow> P xs \<Longrightarrow> P (x # xs)\<rbrakk> \<Longrightarrow> P xs"
 by(induction xs rule: induct_list012) auto
 
 lemma inj_split_Cons: "inj_on (\<lambda>(xs, n). n#xs) X"
   by (auto intro!: inj_onI)
 
 lemma inj_on_Cons1 [simp]: "inj_on ((#) x) A"
 by(simp add: inj_on_def)
 
 
 subsubsection \<open>\<^const>\<open>length\<close>\<close>
 
 text \<open>
   Needs to come before \<open>@\<close> because of theorem \<open>append_eq_append_conv\<close>.
 \<close>
 
 lemma length_append [simp]: "length (xs @ ys) = length xs + length ys"
 by (induct xs) auto
 
 lemma length_map [simp]: "length (map f xs) = length xs"
 by (induct xs) auto
 
 lemma length_rev [simp]: "length (rev xs) = length xs"
 by (induct xs) auto
 
 lemma length_tl [simp]: "length (tl xs) = length xs - 1"
 by (cases xs) auto
 
 lemma length_0_conv [iff]: "(length xs = 0) = (xs = [])"
 by (induct xs) auto
 
 lemma length_greater_0_conv [iff]: "(0 < length xs) = (xs \<noteq> [])"
 by (induct xs) auto
 
 lemma length_pos_if_in_set: "x \<in> set xs \<Longrightarrow> length xs > 0"
 by auto
 
 lemma length_Suc_conv: "(length xs = Suc n) = (\<exists>y ys. xs = y # ys \<and> length ys = n)"
 by (induct xs) auto
 
 lemmas Suc_length_conv = length_Suc_conv[THEN eq_iff_swap]
 
 lemma Suc_le_length_iff:
   "(Suc n \<le> length xs) = (\<exists>x ys. xs = x # ys \<and> n \<le> length ys)"
 by (metis Suc_le_D[of n] Suc_le_mono[of n] Suc_length_conv[of _ xs])
 
 lemma impossible_Cons: "length xs \<le> length ys \<Longrightarrow> xs = x # ys = False"
 by (induct xs) auto
 
 lemma list_induct2 [consumes 1, case_names Nil Cons]:
   "length xs = length ys \<Longrightarrow> P [] [] \<Longrightarrow>
    (\<And>x xs y ys. length xs = length ys \<Longrightarrow> P xs ys \<Longrightarrow> P (x#xs) (y#ys))
    \<Longrightarrow> P xs ys"
 proof (induct xs arbitrary: ys)
   case (Cons x xs ys) then show ?case by (cases ys) simp_all
 qed simp
 
 lemma list_induct3 [consumes 2, case_names Nil Cons]:
   "length xs = length ys \<Longrightarrow> length ys = length zs \<Longrightarrow> P [] [] [] \<Longrightarrow>
    (\<And>x xs y ys z zs. length xs = length ys \<Longrightarrow> length ys = length zs \<Longrightarrow> P xs ys zs \<Longrightarrow> P (x#xs) (y#ys) (z#zs))
    \<Longrightarrow> P xs ys zs"
 proof (induct xs arbitrary: ys zs)
   case Nil then show ?case by simp
 next
   case (Cons x xs ys zs) then show ?case by (cases ys, simp_all)
     (cases zs, simp_all)
 qed
 
 lemma list_induct4 [consumes 3, case_names Nil Cons]:
   "length xs = length ys \<Longrightarrow> length ys = length zs \<Longrightarrow> length zs = length ws \<Longrightarrow>
    P [] [] [] [] \<Longrightarrow> (\<And>x xs y ys z zs w ws. length xs = length ys \<Longrightarrow>
    length ys = length zs \<Longrightarrow> length zs = length ws \<Longrightarrow> P xs ys zs ws \<Longrightarrow>
    P (x#xs) (y#ys) (z#zs) (w#ws)) \<Longrightarrow> P xs ys zs ws"
 proof (induct xs arbitrary: ys zs ws)
   case Nil then show ?case by simp
 next
   case (Cons x xs ys zs ws) then show ?case by ((cases ys, simp_all), (cases zs,simp_all)) (cases ws, simp_all)
 qed
 
 lemma list_induct2':
   "\<lbrakk> P [] [];
   \<And>x xs. P (x#xs) [];
   \<And>y ys. P [] (y#ys);
    \<And>x xs y ys. P xs ys  \<Longrightarrow> P (x#xs) (y#ys) \<rbrakk>
  \<Longrightarrow> P xs ys"
 by (induct xs arbitrary: ys) (case_tac x, auto)+
 
 lemma list_all2_iff:
   "list_all2 P xs ys \<longleftrightarrow> length xs = length ys \<and> (\<forall>(x, y) \<in> set (zip xs ys). P x y)"
 by (induct xs ys rule: list_induct2') auto
 
 lemma neq_if_length_neq: "length xs \<noteq> length ys \<Longrightarrow> (xs = ys) == False"
 by (rule Eq_FalseI) auto
 
 
 subsubsection \<open>\<open>@\<close> -- append\<close>
 
 global_interpretation append: monoid append Nil
 proof
   fix xs ys zs :: "'a list"
   show "(xs @ ys) @ zs = xs @ (ys @ zs)"
     by (induct xs) simp_all
   show "xs @ [] = xs"
     by (induct xs) simp_all
 qed simp
 
 lemma append_assoc [simp]: "(xs @ ys) @ zs = xs @ (ys @ zs)"
   by (fact append.assoc)
 
 lemma append_Nil2: "xs @ [] = xs"
   by (fact append.right_neutral)
 
 lemma append_is_Nil_conv [iff]: "(xs @ ys = []) = (xs = [] \<and> ys = [])"
 by (induct xs) auto
 
 lemmas Nil_is_append_conv [iff] = append_is_Nil_conv[THEN eq_iff_swap]
 
 lemma append_self_conv [iff]: "(xs @ ys = xs) = (ys = [])"
 by (induct xs) auto
 
 lemmas self_append_conv [iff] = append_self_conv[THEN eq_iff_swap]
 
 lemma append_eq_append_conv [simp]:
   "length xs = length ys \<or> length us = length vs
   \<Longrightarrow> (xs@us = ys@vs) = (xs=ys \<and> us=vs)"
   by (induct xs arbitrary: ys; case_tac ys; force)
 
 lemma append_eq_append_conv2: "(xs @ ys = zs @ ts) =
   (\<exists>us. xs = zs @ us \<and> us @ ys = ts \<or> xs @ us = zs \<and> ys = us @ ts)"
 proof (induct xs arbitrary: ys zs ts)
   case (Cons x xs)
   then show ?case
     by (cases zs) auto
 qed fastforce
 
 lemma same_append_eq [iff, induct_simp]: "(xs @ ys = xs @ zs) = (ys = zs)"
 by simp
 
 lemma append1_eq_conv [iff]: "(xs @ [x] = ys @ [y]) = (xs = ys \<and> x = y)"
 by simp
 
 lemma append_same_eq [iff, induct_simp]: "(ys @ xs = zs @ xs) = (ys = zs)"
 by simp
 
 lemma append_self_conv2 [iff]: "(xs @ ys = ys) = (xs = [])"
 using append_same_eq [of _ _ "[]"] by auto
 
 lemmas self_append_conv2 [iff] = append_self_conv2[THEN eq_iff_swap]
 
 lemma hd_Cons_tl: "xs \<noteq> [] \<Longrightarrow> hd xs # tl xs = xs"
   by (fact list.collapse)
 
 lemma hd_append: "hd (xs @ ys) = (if xs = [] then hd ys else hd xs)"
 by (induct xs) auto
 
 lemma hd_append2 [simp]: "xs \<noteq> [] \<Longrightarrow> hd (xs @ ys) = hd xs"
 by (simp add: hd_append split: list.split)
 
 lemma tl_append: "tl (xs @ ys) = (case xs of [] \<Rightarrow> tl ys | z#zs \<Rightarrow> zs @ ys)"
 by (simp split: list.split)
 
 lemma tl_append2 [simp]: "xs \<noteq> [] \<Longrightarrow> tl (xs @ ys) = tl xs @ ys"
 by (simp add: tl_append split: list.split)
 
 lemma tl_append_if: "tl (xs @ ys) = (if xs = [] then tl ys else tl xs @ ys)"
 by (simp)
 
 lemma Cons_eq_append_conv: "x#xs = ys@zs =
  (ys = [] \<and> x#xs = zs \<or> (\<exists>ys'. x#ys' = ys \<and> xs = ys'@zs))"
 by(cases ys) auto
 
 lemma append_eq_Cons_conv: "(ys@zs = x#xs) =
  (ys = [] \<and> zs = x#xs \<or> (\<exists>ys'. ys = x#ys' \<and> ys'@zs = xs))"
 by(cases ys) auto
 
 lemma longest_common_prefix:
   "\<exists>ps xs' ys'. xs = ps @ xs' \<and> ys = ps @ ys'
        \<and> (xs' = [] \<or> ys' = [] \<or> hd xs' \<noteq> hd ys')"
 by (induct xs ys rule: list_induct2')
    (blast, blast, blast,
     metis (no_types, opaque_lifting) append_Cons append_Nil list.sel(1))
 
 text \<open>Trivial rules for solving \<open>@\<close>-equations automatically.\<close>
 
 lemma eq_Nil_appendI: "xs = ys \<Longrightarrow> xs = [] @ ys"
   by simp
 
 lemma Cons_eq_appendI: "\<lbrakk>x # xs1 = ys; xs = xs1 @ zs\<rbrakk> \<Longrightarrow> x # xs = ys @ zs"
   by auto
 
 lemma append_eq_appendI: "\<lbrakk>xs @ xs1 = zs; ys = xs1 @ us\<rbrakk> \<Longrightarrow> xs @ ys = zs @ us"
   by auto
 
 
 text \<open>
 Simplification procedure for all list equalities.
 Currently only tries to rearrange \<open>@\<close> to see if
 - both lists end in a singleton list,
 - or both lists end in the same list.
 \<close>
 
 simproc_setup list_eq ("(xs::'a list) = ys")  = \<open>
   let
     fun last (cons as Const (\<^const_name>\<open>Cons\<close>, _) $ _ $ xs) =
           (case xs of Const (\<^const_name>\<open>Nil\<close>, _) => cons | _ => last xs)
       | last (Const(\<^const_name>\<open>append\<close>,_) $ _ $ ys) = last ys
       | last t = t;
 
     fun list1 (Const(\<^const_name>\<open>Cons\<close>,_) $ _ $ Const(\<^const_name>\<open>Nil\<close>,_)) = true
       | list1 _ = false;
 
     fun butlast ((cons as Const(\<^const_name>\<open>Cons\<close>,_) $ x) $ xs) =
           (case xs of Const (\<^const_name>\<open>Nil\<close>, _) => xs | _ => cons $ butlast xs)
       | butlast ((app as Const (\<^const_name>\<open>append\<close>, _) $ xs) $ ys) = app $ butlast ys
       | butlast xs = Const(\<^const_name>\<open>Nil\<close>, fastype_of xs);
 
     val rearr_ss =
       simpset_of (put_simpset HOL_basic_ss \<^context>
         addsimps [@{thm append_assoc}, @{thm append_Nil}, @{thm append_Cons}]);
 
     fun list_eq ctxt (F as (eq as Const(_,eqT)) $ lhs $ rhs) =
       let
         val lastl = last lhs and lastr = last rhs;
         fun rearr conv =
           let
             val lhs1 = butlast lhs and rhs1 = butlast rhs;
             val Type(_,listT::_) = eqT
             val appT = [listT,listT] ---> listT
             val app = Const(\<^const_name>\<open>append\<close>,appT)
             val F2 = eq $ (app$lhs1$lastl) $ (app$rhs1$lastr)
             val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (F,F2));
             val thm = Goal.prove ctxt [] [] eq
               (K (simp_tac (put_simpset rearr_ss ctxt) 1));
           in SOME ((conv RS (thm RS trans)) RS eq_reflection) end;
       in
         if list1 lastl andalso list1 lastr then rearr @{thm append1_eq_conv}
         else if lastl aconv lastr then rearr @{thm append_same_eq}
         else NONE
       end;
-  in fn _ => fn ctxt => fn ct => list_eq ctxt (Thm.term_of ct) end
+  in K (fn ctxt => fn ct => list_eq ctxt (Thm.term_of ct)) end
 \<close>
 
 
 subsubsection \<open>\<^const>\<open>map\<close>\<close>
 
 lemma hd_map: "xs \<noteq> [] \<Longrightarrow> hd (map f xs) = f (hd xs)"
 by (cases xs) simp_all
 
 lemma map_tl: "map f (tl xs) = tl (map f xs)"
 by (cases xs) simp_all
 
 lemma map_ext: "(\<And>x. x \<in> set xs \<longrightarrow> f x = g x) \<Longrightarrow> map f xs = map g xs"
 by (induct xs) simp_all
 
 lemma map_ident [simp]: "map (\<lambda>x. x) = (\<lambda>xs. xs)"
 by (rule ext, induct_tac xs) auto
 
 lemma map_append [simp]: "map f (xs @ ys) = map f xs @ map f ys"
 by (induct xs) auto
 
 lemma map_map [simp]: "map f (map g xs) = map (f \<circ> g) xs"
 by (induct xs) auto
 
 lemma map_comp_map[simp]: "((map f) \<circ> (map g)) = map(f \<circ> g)"
 by (rule ext) simp
 
 lemma rev_map: "rev (map f xs) = map f (rev xs)"
 by (induct xs) auto
 
 lemma map_eq_conv[simp]: "(map f xs = map g xs) = (\<forall>x \<in> set xs. f x = g x)"
 by (induct xs) auto
 
 lemma map_cong [fundef_cong]:
   "xs = ys \<Longrightarrow> (\<And>x. x \<in> set ys \<Longrightarrow> f x = g x) \<Longrightarrow> map f xs = map g ys"
 by simp
 
 lemma map_is_Nil_conv [iff]: "(map f xs = []) = (xs = [])"
 by (rule list.map_disc_iff)
 
 lemmas Nil_is_map_conv [iff] = map_is_Nil_conv[THEN eq_iff_swap]
 
 lemma map_eq_Cons_conv:
   "(map f xs = y#ys) = (\<exists>z zs. xs = z#zs \<and> f z = y \<and> map f zs = ys)"
 by (cases xs) auto
 
 lemma Cons_eq_map_conv:
   "(x#xs = map f ys) = (\<exists>z zs. ys = z#zs \<and> x = f z \<and> xs = map f zs)"
 by (cases ys) auto
 
 lemmas map_eq_Cons_D = map_eq_Cons_conv [THEN iffD1]
 lemmas Cons_eq_map_D = Cons_eq_map_conv [THEN iffD1]
 declare map_eq_Cons_D [dest!]  Cons_eq_map_D [dest!]
 
 lemma ex_map_conv:
   "(\<exists>xs. ys = map f xs) = (\<forall>y \<in> set ys. \<exists>x. y = f x)"
 by(induct ys, auto simp add: Cons_eq_map_conv)
 
 lemma map_eq_imp_length_eq:
   assumes "map f xs = map g ys"
   shows "length xs = length ys"
   using assms
 proof (induct ys arbitrary: xs)
   case Nil then show ?case by simp
 next
   case (Cons y ys) then obtain z zs where xs: "xs = z # zs" by auto
   from Cons xs have "map f zs = map g ys" by simp
   with Cons have "length zs = length ys" by blast
   with xs show ?case by simp
 qed
 
 lemma map_inj_on:
   assumes map: "map f xs = map f ys" and inj: "inj_on f (set xs Un set ys)"
   shows "xs = ys"
   using map_eq_imp_length_eq [OF map] assms
 proof (induct rule: list_induct2)
   case (Cons x xs y ys)
   then show ?case
     by (auto intro: sym)
 qed auto
 
 lemma inj_on_map_eq_map:
   "inj_on f (set xs Un set ys) \<Longrightarrow> (map f xs = map f ys) = (xs = ys)"
 by(blast dest:map_inj_on)
 
 lemma map_injective:
   "map f xs = map f ys \<Longrightarrow> inj f \<Longrightarrow> xs = ys"
 by (induct ys arbitrary: xs) (auto dest!:injD)
 
 lemma inj_map_eq_map[simp]: "inj f \<Longrightarrow> (map f xs = map f ys) = (xs = ys)"
 by(blast dest:map_injective)
 
 lemma inj_mapI: "inj f \<Longrightarrow> inj (map f)"
 by (iprover dest: map_injective injD intro: inj_onI)
 
 lemma inj_mapD: "inj (map f) \<Longrightarrow> inj f"
   by (metis (no_types, opaque_lifting) injI list.inject list.simps(9) the_inv_f_f)
 
 lemma inj_map[iff]: "inj (map f) = inj f"
 by (blast dest: inj_mapD intro: inj_mapI)
 
 lemma inj_on_mapI: "inj_on f (\<Union>(set ` A)) \<Longrightarrow> inj_on (map f) A"
   by (blast intro:inj_onI dest:inj_onD map_inj_on)
 
 lemma map_idI: "(\<And>x. x \<in> set xs \<Longrightarrow> f x = x) \<Longrightarrow> map f xs = xs"
 by (induct xs, auto)
 
 lemma map_fun_upd [simp]: "y \<notin> set xs \<Longrightarrow> map (f(y:=v)) xs = map f xs"
 by (induct xs) auto
 
 lemma map_fst_zip[simp]:
   "length xs = length ys \<Longrightarrow> map fst (zip xs ys) = xs"
 by (induct rule:list_induct2, simp_all)
 
 lemma map_snd_zip[simp]:
   "length xs = length ys \<Longrightarrow> map snd (zip xs ys) = ys"
 by (induct rule:list_induct2, simp_all)
 
 lemma map_fst_zip_take:
   "map fst (zip xs ys) = take (min (length xs) (length ys)) xs"
 by (induct xs ys rule: list_induct2') simp_all
 
 lemma map_snd_zip_take:
   "map snd (zip xs ys) = take (min (length xs) (length ys)) ys"
 by (induct xs ys rule: list_induct2') simp_all
 
 lemma map2_map_map: "map2 h (map f xs) (map g xs) = map (\<lambda>x. h (f x) (g x)) xs"
 by (induction xs) (auto)
 
 functor map: map
 by (simp_all add: id_def)
 
 declare map.id [simp]
 
 
 subsubsection \<open>\<^const>\<open>rev\<close>\<close>
 
 lemma rev_append [simp]: "rev (xs @ ys) = rev ys @ rev xs"
 by (induct xs) auto
 
 lemma rev_rev_ident [simp]: "rev (rev xs) = xs"
 by (induct xs) auto
 
 lemma rev_swap: "(rev xs = ys) = (xs = rev ys)"
 by auto
 
 lemma rev_is_Nil_conv [iff]: "(rev xs = []) = (xs = [])"
 by (induct xs) auto
 
 lemmas Nil_is_rev_conv [iff] = rev_is_Nil_conv[THEN eq_iff_swap]
 
 lemma rev_singleton_conv [simp]: "(rev xs = [x]) = (xs = [x])"
 by (cases xs) auto
 
 lemma singleton_rev_conv [simp]: "([x] = rev xs) = ([x] = xs)"
 by (cases xs) auto
 
 lemma rev_is_rev_conv [iff]: "(rev xs = rev ys) = (xs = ys)"
 proof (induct xs arbitrary: ys)
   case Nil
   then show ?case by force
 next
   case Cons
   then show ?case by (cases ys) auto
 qed
 
 lemma inj_on_rev[iff]: "inj_on rev A"
 by(simp add:inj_on_def)
 
 lemma rev_induct [case_names Nil snoc]:
   assumes "P []" and "\<And>x xs. P xs \<Longrightarrow> P (xs @ [x])"
   shows "P xs"
 proof -
   have "P (rev (rev xs))"
     by (rule_tac list = "rev xs" in list.induct, simp_all add: assms)
   then show ?thesis by simp
 qed
 
 lemma rev_exhaust [case_names Nil snoc]:
   "(xs = [] \<Longrightarrow> P) \<Longrightarrow>(\<And>ys y. xs = ys @ [y] \<Longrightarrow> P) \<Longrightarrow> P"
 by (induct xs rule: rev_induct) auto
 
 lemmas rev_cases = rev_exhaust
 
 lemma rev_nonempty_induct [consumes 1, case_names single snoc]:
   assumes "xs \<noteq> []"
   and single: "\<And>x. P [x]"
   and snoc': "\<And>x xs. xs \<noteq> [] \<Longrightarrow> P xs \<Longrightarrow> P (xs@[x])"
   shows "P xs"
 using \<open>xs \<noteq> []\<close> proof (induct xs rule: rev_induct)
   case (snoc x xs) then show ?case
   proof (cases xs)
     case Nil thus ?thesis by (simp add: single)
   next
     case Cons with snoc show ?thesis by (fastforce intro!: snoc')
   qed
 qed simp
 
 lemma rev_eq_Cons_iff[iff]: "(rev xs = y#ys) = (xs = rev ys @ [y])"
 by(rule rev_cases[of xs]) auto
 
 lemma length_Suc_conv_rev: "(length xs = Suc n) = (\<exists>y ys. xs = ys @ [y] \<and> length ys = n)"
 by (induct xs rule: rev_induct) auto
 
 
 subsubsection \<open>\<^const>\<open>set\<close>\<close>
 
 declare list.set[code_post]  \<comment> \<open>pretty output\<close>
 
 lemma finite_set [iff]: "finite (set xs)"
 by (induct xs) auto
 
 lemma set_append [simp]: "set (xs @ ys) = (set xs \<union> set ys)"
 by (induct xs) auto
 
 lemma hd_in_set[simp]: "xs \<noteq> [] \<Longrightarrow> hd xs \<in> set xs"
 by(cases xs) auto
 
 lemma set_subset_Cons: "set xs \<subseteq> set (x # xs)"
 by auto
 
 lemma set_ConsD: "y \<in> set (x # xs) \<Longrightarrow> y=x \<or> y \<in> set xs"
 by auto
 
 lemma set_empty [iff]: "(set xs = {}) = (xs = [])"
 by (induct xs) auto
 
 lemmas set_empty2[iff] = set_empty[THEN eq_iff_swap]
 
 lemma set_rev [simp]: "set (rev xs) = set xs"
 by (induct xs) auto
 
 lemma set_map [simp]: "set (map f xs) = f`(set xs)"
 by (induct xs) auto
 
 lemma set_filter [simp]: "set (filter P xs) = {x. x \<in> set xs \<and> P x}"
 by (induct xs) auto
 
 lemma set_upt [simp]: "set[i..<j] = {i..<j}"
 by (induct j) auto
 
 
 lemma split_list: "x \<in> set xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs"
 proof (induct xs)
   case Nil thus ?case by simp
 next
   case Cons thus ?case by (auto intro: Cons_eq_appendI)
 qed
 
 lemma in_set_conv_decomp: "x \<in> set xs \<longleftrightarrow> (\<exists>ys zs. xs = ys @ x # zs)"
   by (auto elim: split_list)
 
 lemma split_list_first: "x \<in> set xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> set ys"
 proof (induct xs)
   case Nil thus ?case by simp
 next
   case (Cons a xs)
   show ?case
   proof cases
     assume "x = a" thus ?case using Cons by fastforce
   next
     assume "x \<noteq> a" thus ?case using Cons by(fastforce intro!: Cons_eq_appendI)
   qed
 qed
 
 lemma in_set_conv_decomp_first:
   "(x \<in> set xs) = (\<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> set ys)"
   by (auto dest!: split_list_first)
 
 lemma split_list_last: "x \<in> set xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> set zs"
 proof (induct xs rule: rev_induct)
   case Nil thus ?case by simp
 next
   case (snoc a xs)
   show ?case
   proof cases
     assume "x = a" thus ?case using snoc by (auto intro!: exI)
   next
     assume "x \<noteq> a" thus ?case using snoc by fastforce
   qed
 qed
 
 lemma in_set_conv_decomp_last:
   "(x \<in> set xs) = (\<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> set zs)"
   by (auto dest!: split_list_last)
 
 lemma split_list_prop: "\<exists>x \<in> set xs. P x \<Longrightarrow> \<exists>ys x zs. xs = ys @ x # zs \<and> P x"
 proof (induct xs)
   case Nil thus ?case by simp
 next
   case Cons thus ?case
     by(simp add:Bex_def)(metis append_Cons append.simps(1))
 qed
 
 lemma split_list_propE:
   assumes "\<exists>x \<in> set xs. P x"
   obtains ys x zs where "xs = ys @ x # zs" and "P x"
 using split_list_prop [OF assms] by blast
 
 lemma split_list_first_prop:
   "\<exists>x \<in> set xs. P x \<Longrightarrow>
    \<exists>ys x zs. xs = ys@x#zs \<and> P x \<and> (\<forall>y \<in> set ys. \<not> P y)"
 proof (induct xs)
   case Nil thus ?case by simp
 next
   case (Cons x xs)
   show ?case
   proof cases
     assume "P x"
     hence "x # xs = [] @ x # xs \<and> P x \<and> (\<forall>y\<in>set []. \<not> P y)" by simp
     thus ?thesis by fast
   next
     assume "\<not> P x"
     hence "\<exists>x\<in>set xs. P x" using Cons(2) by simp
     thus ?thesis using \<open>\<not> P x\<close> Cons(1) by (metis append_Cons set_ConsD)
   qed
 qed
 
 lemma split_list_first_propE:
   assumes "\<exists>x \<in> set xs. P x"
   obtains ys x zs where "xs = ys @ x # zs" and "P x" and "\<forall>y \<in> set ys. \<not> P y"
 using split_list_first_prop [OF assms] by blast
 
 lemma split_list_first_prop_iff:
   "(\<exists>x \<in> set xs. P x) \<longleftrightarrow>
    (\<exists>ys x zs. xs = ys@x#zs \<and> P x \<and> (\<forall>y \<in> set ys. \<not> P y))"
 by (rule, erule split_list_first_prop) auto
 
 lemma split_list_last_prop:
   "\<exists>x \<in> set xs. P x \<Longrightarrow>
    \<exists>ys x zs. xs = ys@x#zs \<and> P x \<and> (\<forall>z \<in> set zs. \<not> P z)"
 proof(induct xs rule:rev_induct)
   case Nil thus ?case by simp
 next
   case (snoc x xs)
   show ?case
   proof cases
     assume "P x" thus ?thesis by (auto intro!: exI)
   next
     assume "\<not> P x"
     hence "\<exists>x\<in>set xs. P x" using snoc(2) by simp
     thus ?thesis using \<open>\<not> P x\<close> snoc(1) by fastforce
   qed
 qed
 
 lemma split_list_last_propE:
   assumes "\<exists>x \<in> set xs. P x"
   obtains ys x zs where "xs = ys @ x # zs" and "P x" and "\<forall>z \<in> set zs. \<not> P z"
 using split_list_last_prop [OF assms] by blast
 
 lemma split_list_last_prop_iff:
   "(\<exists>x \<in> set xs. P x) \<longleftrightarrow>
    (\<exists>ys x zs. xs = ys@x#zs \<and> P x \<and> (\<forall>z \<in> set zs. \<not> P z))"
   by rule (erule split_list_last_prop, auto)
 
 
 lemma finite_list: "finite A \<Longrightarrow> \<exists>xs. set xs = A"
   by (erule finite_induct) (auto simp add: list.set(2)[symmetric] simp del: list.set(2))
 
 lemma card_length: "card (set xs) \<le> length xs"
 by (induct xs) (auto simp add: card_insert_if)
 
 lemma set_minus_filter_out:
   "set xs - {y} = set (filter (\<lambda>x. \<not> (x = y)) xs)"
   by (induct xs) auto
 
 lemma append_Cons_eq_iff:
   "\<lbrakk> x \<notin> set xs; x \<notin> set ys \<rbrakk> \<Longrightarrow>
    xs @ x # ys = xs' @ x # ys' \<longleftrightarrow> (xs = xs' \<and> ys = ys')"
 by(auto simp: append_eq_Cons_conv Cons_eq_append_conv append_eq_append_conv2)
 
 
 subsubsection \<open>\<^const>\<open>concat\<close>\<close>
 
 lemma concat_append [simp]: "concat (xs @ ys) = concat xs @ concat ys"
   by (induct xs) auto
 
 lemma concat_eq_Nil_conv [simp]: "(concat xss = []) = (\<forall>xs \<in> set xss. xs = [])"
   by (induct xss) auto
 
 lemmas Nil_eq_concat_conv [simp] = concat_eq_Nil_conv[THEN eq_iff_swap]
 
 lemma set_concat [simp]: "set (concat xs) = (\<Union>x\<in>set xs. set x)"
   by (induct xs) auto
 
 lemma concat_map_singleton[simp]: "concat(map (%x. [f x]) xs) = map f xs"
   by (induct xs) auto
 
 lemma map_concat: "map f (concat xs) = concat (map (map f) xs)"
   by (induct xs) auto
 
 lemma rev_concat: "rev (concat xs) = concat (map rev (rev xs))"
   by (induct xs) auto
 
 lemma length_concat_rev[simp]: "length (concat (rev xs)) = length (concat xs)"
 by (induction xs) auto
 
 lemma concat_eq_concat_iff: "\<forall>(x, y) \<in> set (zip xs ys). length x = length y \<Longrightarrow> length xs = length ys \<Longrightarrow> (concat xs = concat ys) = (xs = ys)"
 proof (induct xs arbitrary: ys)
   case (Cons x xs ys)
   thus ?case by (cases ys) auto
 qed (auto)
 
 lemma concat_injective: "concat xs = concat ys \<Longrightarrow> length xs = length ys \<Longrightarrow> \<forall>(x, y) \<in> set (zip xs ys). length x = length y \<Longrightarrow> xs = ys"
   by (simp add: concat_eq_concat_iff)
 
 lemma concat_eq_appendD:
   assumes "concat xss = ys @ zs" "xss \<noteq> []"
   shows "\<exists>xss1 xs xs' xss2. xss = xss1 @ (xs @ xs') # xss2 \<and> ys = concat xss1 @ xs \<and> zs = xs' @ concat xss2"
   using assms
 proof(induction xss arbitrary: ys)
   case (Cons xs xss)
   from Cons.prems consider
     us where "xs @ us = ys" "concat xss = us @ zs" |
     us where "xs = ys @ us" "us @ concat xss = zs"
     by(auto simp add: append_eq_append_conv2)
   then show ?case
   proof cases
     case 1
     then show ?thesis using Cons.IH[OF 1(2)]
       by(cases xss)(auto intro: exI[where x="[]"], metis append.assoc append_Cons concat.simps(2))
   qed(auto intro: exI[where x="[]"])
 qed simp
 
 lemma concat_eq_append_conv:
   "concat xss = ys @ zs \<longleftrightarrow>
   (if xss = [] then ys = [] \<and> zs = []
    else \<exists>xss1 xs xs' xss2. xss = xss1 @ (xs @ xs') # xss2 \<and> ys = concat xss1 @ xs \<and> zs = xs' @ concat xss2)"
   by(auto dest: concat_eq_appendD)
 
 lemma hd_concat: "\<lbrakk>xs \<noteq> []; hd xs \<noteq> []\<rbrakk> \<Longrightarrow> hd (concat xs) = hd (hd xs)"
   by (metis concat.simps(2) hd_Cons_tl hd_append2)
 
 
 simproc_setup list_neq ("(xs::'a list) = ys") = \<open>
 (*
 Reduces xs=ys to False if xs and ys cannot be of the same length.
 This is the case if the atomic sublists of one are a submultiset
 of those of the other list and there are fewer Cons's in one than the other.
 *)
 
 let
 
 fun len (Const(\<^const_name>\<open>Nil\<close>,_)) acc = acc
   | len (Const(\<^const_name>\<open>Cons\<close>,_) $ _ $ xs) (ts,n) = len xs (ts,n+1)
   | len (Const(\<^const_name>\<open>append\<close>,_) $ xs $ ys) acc = len xs (len ys acc)
   | len (Const(\<^const_name>\<open>rev\<close>,_) $ xs) acc = len xs acc
   | len (Const(\<^const_name>\<open>map\<close>,_) $ _ $ xs) acc = len xs acc
   | len (Const(\<^const_name>\<open>concat\<close>,T) $ (Const(\<^const_name>\<open>rev\<close>,_) $ xss)) acc
     = len (Const(\<^const_name>\<open>concat\<close>,T) $ xss) acc
   | len t (ts,n) = (t::ts,n);
 
 val ss = simpset_of \<^context>;
 
 fun list_neq ctxt ct =
   let
     val (Const(_,eqT) $ lhs $ rhs) = Thm.term_of ct;
     val (ls,m) = len lhs ([],0) and (rs,n) = len rhs ([],0);
     fun prove_neq() =
       let
         val Type(_,listT::_) = eqT;
         val size = HOLogic.size_const listT;
         val eq_len = HOLogic.mk_eq (size $ lhs, size $ rhs);
         val neq_len = HOLogic.mk_Trueprop (HOLogic.Not $ eq_len);
         val thm = Goal.prove ctxt [] [] neq_len
           (K (simp_tac (put_simpset ss ctxt) 1));
       in SOME (thm RS @{thm neq_if_length_neq}) end
   in
     if m < n andalso submultiset (op aconv) (ls,rs) orelse
        n < m andalso submultiset (op aconv) (rs,ls)
     then prove_neq() else NONE
   end;
 in K list_neq end
 \<close>
 
 subsubsection \<open>\<^const>\<open>filter\<close>\<close>
 
 lemma filter_append [simp]: "filter P (xs @ ys) = filter P xs @ filter P ys"
 by (induct xs) auto
 
 lemma rev_filter: "rev (filter P xs) = filter P (rev xs)"
 by (induct xs) simp_all
 
 lemma filter_filter [simp]: "filter P (filter Q xs) = filter (\<lambda>x. Q x \<and> P x) xs"
 by (induct xs) auto
 
 lemma filter_concat: "filter p (concat xs) = concat (map (filter p) xs)"
 by (induct xs) auto
 
 lemma length_filter_le [simp]: "length (filter P xs) \<le> length xs"
 by (induct xs) (auto simp add: le_SucI)
 
 lemma sum_length_filter_compl:
   "length(filter P xs) + length(filter (\<lambda>x. \<not>P x) xs) = length xs"
 by(induct xs) simp_all
 
 lemma filter_True [simp]: "\<forall>x \<in> set xs. P x \<Longrightarrow> filter P xs = xs"
 by (induct xs) auto
 
 lemma filter_False [simp]: "\<forall>x \<in> set xs. \<not> P x \<Longrightarrow> filter P xs = []"
 by (induct xs) auto
 
 lemma filter_empty_conv: "(filter P xs = []) = (\<forall>x\<in>set xs. \<not> P x)"
 by (induct xs) simp_all
 
 lemmas empty_filter_conv = filter_empty_conv[THEN eq_iff_swap]
 
 lemma filter_id_conv: "(filter P xs = xs) = (\<forall>x\<in>set xs. P x)"
 proof (induct xs)
   case (Cons x xs)
   then show ?case
     using length_filter_le
     by (simp add: impossible_Cons)
 qed auto
 
 lemma filter_map: "filter P (map f xs) = map f (filter (P \<circ> f) xs)"
 by (induct xs) simp_all
 
 lemma length_filter_map[simp]:
   "length (filter P (map f xs)) = length(filter (P \<circ> f) xs)"
 by (simp add:filter_map)
 
 lemma filter_is_subset [simp]: "set (filter P xs) \<le> set xs"
 by auto
 
 lemma length_filter_less:
   "\<lbrakk> x \<in> set xs; \<not> P x \<rbrakk> \<Longrightarrow> length(filter P xs) < length xs"
 proof (induct xs)
   case Nil thus ?case by simp
 next
   case (Cons x xs) thus ?case
     using Suc_le_eq by fastforce
 qed
 
 lemma length_filter_conv_card:
   "length(filter p xs) = card{i. i < length xs \<and> p(xs!i)}"
 proof (induct xs)
   case Nil thus ?case by simp
 next
   case (Cons x xs)
   let ?S = "{i. i < length xs \<and> p(xs!i)}"
   have fin: "finite ?S" by(fast intro: bounded_nat_set_is_finite)
   show ?case (is "?l = card ?S'")
   proof (cases)
     assume "p x"
     hence eq: "?S' = insert 0 (Suc ` ?S)"
       by(auto simp: image_def split:nat.split dest:gr0_implies_Suc)
     have "length (filter p (x # xs)) = Suc(card ?S)"
       using Cons \<open>p x\<close> by simp
     also have "\<dots> = Suc(card(Suc ` ?S))" using fin
       by (simp add: card_image)
     also have "\<dots> = card ?S'" using eq fin
       by (simp add:card_insert_if)
     finally show ?thesis .
   next
     assume "\<not> p x"
     hence eq: "?S' = Suc ` ?S"
       by(auto simp add: image_def split:nat.split elim:lessE)
     have "length (filter p (x # xs)) = card ?S"
       using Cons \<open>\<not> p x\<close> by simp
     also have "\<dots> = card(Suc ` ?S)" using fin
       by (simp add: card_image)
     also have "\<dots> = card ?S'" using eq fin
       by (simp add:card_insert_if)
     finally show ?thesis .
   qed
 qed
 
 lemma Cons_eq_filterD:
   "x#xs = filter P ys \<Longrightarrow>
   \<exists>us vs. ys = us @ x # vs \<and> (\<forall>u\<in>set us. \<not> P u) \<and> P x \<and> xs = filter P vs"
   (is "_ \<Longrightarrow> \<exists>us vs. ?P ys us vs")
 proof(induct ys)
   case Nil thus ?case by simp
 next
   case (Cons y ys)
   show ?case (is "\<exists>x. ?Q x")
   proof cases
     assume Py: "P y"
     show ?thesis
     proof cases
       assume "x = y"
       with Py Cons.prems have "?Q []" by simp
       then show ?thesis ..
     next
       assume "x \<noteq> y"
       with Py Cons.prems show ?thesis by simp
     qed
   next
     assume "\<not> P y"
     with Cons obtain us vs where "?P (y#ys) (y#us) vs" by fastforce
     then have "?Q (y#us)" by simp
     then show ?thesis ..
   qed
 qed
 
 lemma filter_eq_ConsD:
   "filter P ys = x#xs \<Longrightarrow>
   \<exists>us vs. ys = us @ x # vs \<and> (\<forall>u\<in>set us. \<not> P u) \<and> P x \<and> xs = filter P vs"
   by(rule Cons_eq_filterD) simp
 
 lemma filter_eq_Cons_iff:
   "(filter P ys = x#xs) =
   (\<exists>us vs. ys = us @ x # vs \<and> (\<forall>u\<in>set us. \<not> P u) \<and> P x \<and> xs = filter P vs)"
   by(auto dest:filter_eq_ConsD)
 
 lemmas Cons_eq_filter_iff = filter_eq_Cons_iff[THEN eq_iff_swap]
 
 lemma inj_on_filter_key_eq:
   assumes "inj_on f (insert y (set xs))"
   shows "filter (\<lambda>x. f y = f x) xs = filter (HOL.eq y) xs"
   using assms by (induct xs) auto
 
 lemma filter_cong[fundef_cong]:
   "xs = ys \<Longrightarrow> (\<And>x. x \<in> set ys \<Longrightarrow> P x = Q x) \<Longrightarrow> filter P xs = filter Q ys"
   by (induct ys arbitrary: xs) auto
 
 
 subsubsection \<open>List partitioning\<close>
 
 primrec partition :: "('a \<Rightarrow> bool) \<Rightarrow>'a list \<Rightarrow> 'a list \<times> 'a list" where
   "partition P [] = ([], [])" |
   "partition P (x # xs) =
   (let (yes, no) = partition P xs
    in if P x then (x # yes, no) else (yes, x # no))"
 
 lemma partition_filter1: "fst (partition P xs) = filter P xs"
   by (induct xs) (auto simp add: Let_def split_def)
 
 lemma partition_filter2: "snd (partition P xs) = filter (Not \<circ> P) xs"
   by (induct xs) (auto simp add: Let_def split_def)
 
 lemma partition_P:
   assumes "partition P xs = (yes, no)"
   shows "(\<forall>p \<in> set yes.  P p) \<and> (\<forall>p  \<in> set no. \<not> P p)"
 proof -
   from assms have "yes = fst (partition P xs)" and "no = snd (partition P xs)"
     by simp_all
   then show ?thesis by (simp_all add: partition_filter1 partition_filter2)
 qed
 
 lemma partition_set:
   assumes "partition P xs = (yes, no)"
   shows "set yes \<union> set no = set xs"
 proof -
   from assms have "yes = fst (partition P xs)" and "no = snd (partition P xs)"
     by simp_all
   then show ?thesis by (auto simp add: partition_filter1 partition_filter2)
 qed
 
 lemma partition_filter_conv[simp]:
   "partition f xs = (filter f xs,filter (Not \<circ> f) xs)"
   unfolding partition_filter2[symmetric]
   unfolding partition_filter1[symmetric] by simp
 
 declare partition.simps[simp del]
 
 
 subsubsection \<open>\<^const>\<open>nth\<close>\<close>
 
 lemma nth_Cons_0 [simp, code]: "(x # xs)!0 = x"
   by auto
 
 lemma nth_Cons_Suc [simp, code]: "(x # xs)!(Suc n) = xs!n"
   by auto
 
 declare nth.simps [simp del]
 
 lemma nth_Cons_pos[simp]: "0 < n \<Longrightarrow> (x#xs) ! n = xs ! (n - 1)"
   by(auto simp: Nat.gr0_conv_Suc)
 
 lemma nth_append:
   "(xs @ ys)!n = (if n < length xs then xs!n else ys!(n - length xs))"
 proof (induct xs arbitrary: n)
   case (Cons x xs)
   then show ?case
     using less_Suc_eq_0_disj by auto
 qed simp
 
 lemma nth_append_length [simp]: "(xs @ x # ys) ! length xs = x"
   by (induct xs) auto
 
 lemma nth_append_length_plus[simp]: "(xs @ ys) ! (length xs + n) = ys ! n"
   by (induct xs) auto
 
 lemma nth_map [simp]: "n < length xs \<Longrightarrow> (map f xs)!n = f(xs!n)"
 proof (induct xs arbitrary: n)
   case (Cons x xs)
   then show ?case
     using less_Suc_eq_0_disj by auto
 qed simp
 
 lemma nth_tl: "n < length (tl xs) \<Longrightarrow> tl xs ! n = xs ! Suc n"
   by (induction xs) auto
 
 lemma hd_conv_nth: "xs \<noteq> [] \<Longrightarrow> hd xs = xs!0"
   by(cases xs) simp_all
 
 lemma list_eq_iff_nth_eq:
   "(xs = ys) = (length xs = length ys \<and> (\<forall>i<length xs. xs!i = ys!i))"
 proof (induct xs arbitrary: ys)
   case (Cons x xs ys)
   show ?case
   proof (cases ys)
     case (Cons y ys)
     with Cons.hyps show ?thesis by fastforce
   qed simp
 qed force
 
 lemma map_equality_iff:
   "map f xs = map g ys \<longleftrightarrow> length xs = length ys \<and> (\<forall>i<length ys. f (xs!i) = g (ys!i))"
   by (fastforce simp: list_eq_iff_nth_eq)
 
 lemma set_conv_nth: "set xs = {xs!i | i. i < length xs}"
 proof (induct xs)
   case (Cons x xs)
   have "insert x {xs ! i |i. i < length xs} = {(x # xs) ! i |i. i < Suc (length xs)}" (is "?L=?R")
   proof
     show "?L \<subseteq> ?R"
       by force
     show "?R \<subseteq> ?L"
       using less_Suc_eq_0_disj by auto
   qed
   with Cons show ?case
     by simp
 qed simp
 
 lemma in_set_conv_nth: "(x \<in> set xs) = (\<exists>i < length xs. xs!i = x)"
   by(auto simp:set_conv_nth)
 
 lemma nth_equal_first_eq:
   assumes "x \<notin> set xs"
   assumes "n \<le> length xs"
   shows "(x # xs) ! n = x \<longleftrightarrow> n = 0" (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume ?lhs
   show ?rhs
   proof (rule ccontr)
     assume "n \<noteq> 0"
     then have "n > 0" by simp
     with \<open>?lhs\<close> have "xs ! (n - 1) = x" by simp
     moreover from \<open>n > 0\<close> \<open>n \<le> length xs\<close> have "n - 1 < length xs" by simp
     ultimately have "\<exists>i<length xs. xs ! i = x" by auto
     with \<open>x \<notin> set xs\<close> in_set_conv_nth [of x xs] show False by simp
   qed
 next
   assume ?rhs then show ?lhs by simp
 qed
 
 lemma nth_non_equal_first_eq:
   assumes "x \<noteq> y"
   shows "(x # xs) ! n = y \<longleftrightarrow> xs ! (n - 1) = y \<and> n > 0" (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume "?lhs" with assms have "n > 0" by (cases n) simp_all
   with \<open>?lhs\<close> show ?rhs by simp
 next
   assume "?rhs" then show "?lhs" by simp
 qed
 
 lemma list_ball_nth: "\<lbrakk>n < length xs; \<forall>x \<in> set xs. P x\<rbrakk> \<Longrightarrow> P(xs!n)"
   by (auto simp add: set_conv_nth)
 
 lemma nth_mem [simp]: "n < length xs \<Longrightarrow> xs!n \<in> set xs"
   by (auto simp add: set_conv_nth)
 
 lemma all_nth_imp_all_set:
   "\<lbrakk>\<forall>i < length xs. P(xs!i); x \<in> set xs\<rbrakk> \<Longrightarrow> P x"
   by (auto simp add: set_conv_nth)
 
 lemma all_set_conv_all_nth:
   "(\<forall>x \<in> set xs. P x) = (\<forall>i. i < length xs \<longrightarrow> P (xs ! i))"
   by (auto simp add: set_conv_nth)
 
 lemma rev_nth:
   "n < size xs \<Longrightarrow> rev xs ! n = xs ! (length xs - Suc n)"
 proof (induct xs arbitrary: n)
   case Nil thus ?case by simp
 next
   case (Cons x xs)
   hence n: "n < Suc (length xs)" by simp
   moreover
   { assume "n < length xs"
     with n obtain n' where n': "length xs - n = Suc n'"
       by (cases "length xs - n", auto)
     moreover
     from n' have "length xs - Suc n = n'" by simp
     ultimately
     have "xs ! (length xs - Suc n) = (x # xs) ! (length xs - n)" by simp
   }
   ultimately
   show ?case by (clarsimp simp add: Cons nth_append)
 qed
 
 lemma Skolem_list_nth:
   "(\<forall>i<k. \<exists>x. P i x) = (\<exists>xs. size xs = k \<and> (\<forall>i<k. P i (xs!i)))"
   (is "_ = (\<exists>xs. ?P k xs)")
 proof(induct k)
   case 0 show ?case by simp
 next
   case (Suc k)
   show ?case (is "?L = ?R" is "_ = (\<exists>xs. ?P' xs)")
   proof
     assume "?R" thus "?L" using Suc by auto
   next
     assume "?L"
     with Suc obtain x xs where "?P k xs \<and> P k x" by (metis less_Suc_eq)
     hence "?P'(xs@[x])" by(simp add:nth_append less_Suc_eq)
     thus "?R" ..
   qed
 qed
 
 
 subsubsection \<open>\<^const>\<open>list_update\<close>\<close>
 
 lemma length_list_update [simp]: "length(xs[i:=x]) = length xs"
   by (induct xs arbitrary: i) (auto split: nat.split)
 
 lemma nth_list_update:
   "i < length xs\<Longrightarrow> (xs[i:=x])!j = (if i = j then x else xs!j)"
   by (induct xs arbitrary: i j) (auto simp add: nth_Cons split: nat.split)
 
 lemma nth_list_update_eq [simp]: "i < length xs \<Longrightarrow> (xs[i:=x])!i = x"
   by (simp add: nth_list_update)
 
 lemma nth_list_update_neq [simp]: "i \<noteq> j \<Longrightarrow> xs[i:=x]!j = xs!j"
   by (induct xs arbitrary: i j) (auto simp add: nth_Cons split: nat.split)
 
 lemma list_update_id[simp]: "xs[i := xs!i] = xs"
   by (induct xs arbitrary: i) (simp_all split:nat.splits)
 
 lemma list_update_beyond[simp]: "length xs \<le> i \<Longrightarrow> xs[i:=x] = xs"
 proof (induct xs arbitrary: i)
   case (Cons x xs i)
   then show ?case
     by (metis leD length_list_update list_eq_iff_nth_eq nth_list_update_neq)
 qed simp
 
 lemma list_update_nonempty[simp]: "xs[k:=x] = [] \<longleftrightarrow> xs=[]"
   by (simp only: length_0_conv[symmetric] length_list_update)
 
 lemma list_update_same_conv:
   "i < length xs \<Longrightarrow> (xs[i := x] = xs) = (xs!i = x)"
   by (induct xs arbitrary: i) (auto split: nat.split)
 
 lemma list_update_append1:
   "i < size xs \<Longrightarrow> (xs @ ys)[i:=x] = xs[i:=x] @ ys"
   by (induct xs arbitrary: i)(auto split:nat.split)
 
 lemma list_update_append:
   "(xs @ ys) [n:= x] =
   (if n < length xs then xs[n:= x] @ ys else xs @ (ys [n-length xs:= x]))"
   by (induct xs arbitrary: n) (auto split:nat.splits)
 
 lemma list_update_length [simp]:
   "(xs @ x # ys)[length xs := y] = (xs @ y # ys)"
   by (induct xs, auto)
 
 lemma map_update: "map f (xs[k:= y]) = (map f xs)[k := f y]"
   by(induct xs arbitrary: k)(auto split:nat.splits)
 
 lemma rev_update:
   "k < length xs \<Longrightarrow> rev (xs[k:= y]) = (rev xs)[length xs - k - 1 := y]"
   by (induct xs arbitrary: k) (auto simp: list_update_append split:nat.splits)
 
 lemma update_zip:
   "(zip xs ys)[i:=xy] = zip (xs[i:=fst xy]) (ys[i:=snd xy])"
   by (induct ys arbitrary: i xy xs) (auto, case_tac xs, auto split: nat.split)
 
 lemma set_update_subset_insert: "set(xs[i:=x]) \<le> insert x (set xs)"
   by (induct xs arbitrary: i) (auto split: nat.split)
 
 lemma set_update_subsetI: "\<lbrakk>set xs \<subseteq> A; x \<in> A\<rbrakk> \<Longrightarrow> set(xs[i := x]) \<subseteq> A"
   by (blast dest!: set_update_subset_insert [THEN subsetD])
 
 lemma set_update_memI: "n < length xs \<Longrightarrow> x \<in> set (xs[n := x])"
   by (induct xs arbitrary: n) (auto split:nat.splits)
 
 lemma list_update_overwrite[simp]:
   "xs [i := x, i := y] = xs [i := y]"
   by (induct xs arbitrary: i) (simp_all split: nat.split)
 
 lemma list_update_swap:
   "i \<noteq> i' \<Longrightarrow> xs [i := x, i' := x'] = xs [i' := x', i := x]"
   by (induct xs arbitrary: i i') (simp_all split: nat.split)
 
 lemma list_update_code [code]:
   "[][i := y] = []"
   "(x # xs)[0 := y] = y # xs"
   "(x # xs)[Suc i := y] = x # xs[i := y]"
   by simp_all
 
 
 subsubsection \<open>\<^const>\<open>last\<close> and \<^const>\<open>butlast\<close>\<close>
 
 lemma hd_Nil_eq_last: "hd Nil = last Nil"
   unfolding hd_def last_def by simp
 
 lemma last_snoc [simp]: "last (xs @ [x]) = x"
   by (induct xs) auto
 
 lemma butlast_snoc [simp]: "butlast (xs @ [x]) = xs"
   by (induct xs) auto
 
 lemma last_ConsL: "xs = [] \<Longrightarrow> last(x#xs) = x"
   by simp
 
 lemma last_ConsR: "xs \<noteq> [] \<Longrightarrow> last(x#xs) = last xs"
   by simp
 
 lemma last_append: "last(xs @ ys) = (if ys = [] then last xs else last ys)"
   by (induct xs) (auto)
 
 lemma last_appendL[simp]: "ys = [] \<Longrightarrow> last(xs @ ys) = last xs"
   by(simp add:last_append)
 
 lemma last_appendR[simp]: "ys \<noteq> [] \<Longrightarrow> last(xs @ ys) = last ys"
   by(simp add:last_append)
 
 lemma last_tl: "xs = [] \<or> tl xs \<noteq> [] \<Longrightarrow>last (tl xs) = last xs"
   by (induct xs) simp_all
 
 lemma butlast_tl: "butlast (tl xs) = tl (butlast xs)"
   by (induct xs) simp_all
 
 lemma hd_rev: "hd(rev xs) = last xs"
   by (metis hd_Cons_tl hd_Nil_eq_last last_snoc rev_eq_Cons_iff rev_is_Nil_conv)
 
 lemma last_rev: "last(rev xs) = hd xs"
   by (metis hd_rev rev_swap)
 
 lemma last_in_set[simp]: "as \<noteq> [] \<Longrightarrow> last as \<in> set as"
   by (induct as) auto
 
 lemma length_butlast [simp]: "length (butlast xs) = length xs - 1"
   by (induct xs rule: rev_induct) auto
 
 lemma butlast_append:
   "butlast (xs @ ys) = (if ys = [] then butlast xs else xs @ butlast ys)"
   by (induct xs arbitrary: ys) auto
 
 lemma append_butlast_last_id [simp]:
   "xs \<noteq> [] \<Longrightarrow> butlast xs @ [last xs] = xs"
   by (induct xs) auto
 
 lemma in_set_butlastD: "x \<in> set (butlast xs) \<Longrightarrow> x \<in> set xs"
   by (induct xs) (auto split: if_split_asm)
 
 lemma in_set_butlast_appendI:
   "x \<in> set (butlast xs) \<or> x \<in> set (butlast ys) \<Longrightarrow> x \<in> set (butlast (xs @ ys))"
   by (auto dest: in_set_butlastD simp add: butlast_append)
 
 lemma last_drop[simp]: "n < length xs \<Longrightarrow> last (drop n xs) = last xs"
   by (induct xs arbitrary: n)(auto split:nat.split)
 
 lemma nth_butlast:
   assumes "n < length (butlast xs)" shows "butlast xs ! n = xs ! n"
 proof (cases xs)
   case (Cons y ys)
   moreover from assms have "butlast xs ! n = (butlast xs @ [last xs]) ! n"
     by (simp add: nth_append)
   ultimately show ?thesis using append_butlast_last_id by simp
 qed simp
 
 lemma last_conv_nth: "xs\<noteq>[] \<Longrightarrow> last xs = xs!(length xs - 1)"
   by(induct xs)(auto simp:neq_Nil_conv)
 
 lemma butlast_conv_take: "butlast xs = take (length xs - 1) xs"
   by (induction xs rule: induct_list012) simp_all
 
 lemma last_list_update:
   "xs \<noteq> [] \<Longrightarrow> last(xs[k:=x]) = (if k = size xs - 1 then x else last xs)"
   by (auto simp: last_conv_nth)
 
 lemma butlast_list_update:
   "butlast(xs[k:=x]) =
   (if k = size xs - 1 then butlast xs else (butlast xs)[k:=x])"
   by(cases xs rule:rev_cases)(auto simp: list_update_append split: nat.splits)
 
 lemma last_map: "xs \<noteq> [] \<Longrightarrow> last (map f xs) = f (last xs)"
   by (cases xs rule: rev_cases) simp_all
 
 lemma map_butlast: "map f (butlast xs) = butlast (map f xs)"
   by (induct xs) simp_all
 
 lemma snoc_eq_iff_butlast:
   "xs @ [x] = ys \<longleftrightarrow> (ys \<noteq> [] \<and> butlast ys = xs \<and> last ys = x)"
   by fastforce
 
 corollary longest_common_suffix:
   "\<exists>ss xs' ys'. xs = xs' @ ss \<and> ys = ys' @ ss
        \<and> (xs' = [] \<or> ys' = [] \<or> last xs' \<noteq> last ys')"
   using longest_common_prefix[of "rev xs" "rev ys"]
   unfolding rev_swap rev_append by (metis last_rev rev_is_Nil_conv)
 
 lemma butlast_rev [simp]: "butlast (rev xs) = rev (tl xs)"
   by (cases xs) simp_all
 
 
 subsubsection \<open>\<^const>\<open>take\<close> and \<^const>\<open>drop\<close>\<close>
 
 lemma take_0: "take 0 xs = []"
   by (induct xs) auto
 
 lemma drop_0: "drop 0 xs = xs"
   by (induct xs) auto
 
 lemma take0[simp]: "take 0 = (\<lambda>xs. [])"
   by(rule ext) (rule take_0)
 
 lemma drop0[simp]: "drop 0 = (\<lambda>x. x)"
   by(rule ext) (rule drop_0)
 
 lemma take_Suc_Cons [simp]: "take (Suc n) (x # xs) = x # take n xs"
   by simp
 
 lemma drop_Suc_Cons [simp]: "drop (Suc n) (x # xs) = drop n xs"
   by simp
 
 declare take_Cons [simp del] and drop_Cons [simp del]
 
 lemma take_Suc: "xs \<noteq> [] \<Longrightarrow> take (Suc n) xs = hd xs # take n (tl xs)"
   by(clarsimp simp add:neq_Nil_conv)
 
 lemma drop_Suc: "drop (Suc n) xs = drop n (tl xs)"
   by(cases xs, simp_all)
 
 lemma hd_take[simp]: "j > 0 \<Longrightarrow> hd (take j xs) = hd xs"
   by (metis gr0_conv_Suc list.sel(1) take.simps(1) take_Suc)
 
 lemma take_tl: "take n (tl xs) = tl (take (Suc n) xs)"
   by (induct xs arbitrary: n) simp_all
 
 lemma drop_tl: "drop n (tl xs) = tl(drop n xs)"
   by(induct xs arbitrary: n, simp_all add:drop_Cons drop_Suc split:nat.split)
 
 lemma tl_take: "tl (take n xs) = take (n - 1) (tl xs)"
   by (cases n, simp, cases xs, auto)
 
 lemma tl_drop: "tl (drop n xs) = drop n (tl xs)"
   by (simp only: drop_tl)
 
 lemma nth_via_drop: "drop n xs = y#ys \<Longrightarrow> xs!n = y"
   by (induct xs arbitrary: n, simp)(auto simp: drop_Cons nth_Cons split: nat.splits)
 
 lemma take_Suc_conv_app_nth:
   "i < length xs \<Longrightarrow> take (Suc i) xs = take i xs @ [xs!i]"
 proof (induct xs arbitrary: i)
   case Nil
   then show ?case by simp
 next
   case Cons
   then show ?case by (cases i) auto
 qed
 
 lemma Cons_nth_drop_Suc:
   "i < length xs \<Longrightarrow> (xs!i) # (drop (Suc i) xs) = drop i xs"
 proof (induct xs arbitrary: i)
   case Nil
   then show ?case by simp
 next
   case Cons
   then show ?case by (cases i) auto
 qed
 
 lemma length_take [simp]: "length (take n xs) = min (length xs) n"
   by (induct n arbitrary: xs) (auto, case_tac xs, auto)
 
 lemma length_drop [simp]: "length (drop n xs) = (length xs - n)"
   by (induct n arbitrary: xs) (auto, case_tac xs, auto)
 
 lemma take_all [simp]: "length xs \<le> n \<Longrightarrow> take n xs = xs"
   by (induct n arbitrary: xs) (auto, case_tac xs, auto)
 
 lemma drop_all [simp]: "length xs \<le> n \<Longrightarrow> drop n xs = []"
   by (induct n arbitrary: xs) (auto, case_tac xs, auto)
 
 lemma take_all_iff [simp]: "take n xs = xs \<longleftrightarrow> length xs \<le> n"
 by (metis length_take min.order_iff take_all)
 
 (* Looks like a good simp rule but can cause looping;
    too much interaction between take and length
 lemmas take_all_iff2[simp] = take_all_iff[THEN eq_iff_swap]
 *)
 
 lemma take_eq_Nil[simp]: "(take n xs = []) = (n = 0 \<or> xs = [])"
   by(induct xs arbitrary: n)(auto simp: take_Cons split:nat.split)
 
 lemmas take_eq_Nil2[simp] = take_eq_Nil[THEN eq_iff_swap]
 
 lemma drop_eq_Nil [simp]: "drop n xs = [] \<longleftrightarrow> length xs \<le> n"
 by (metis diff_is_0_eq drop_all length_drop list.size(3))
 
 lemmas drop_eq_Nil2 [simp] = drop_eq_Nil[THEN eq_iff_swap]
 
 lemma take_append [simp]:
   "take n (xs @ ys) = (take n xs @ take (n - length xs) ys)"
   by (induct n arbitrary: xs) (auto, case_tac xs, auto)
 
 lemma drop_append [simp]:
   "drop n (xs @ ys) = drop n xs @ drop (n - length xs) ys"
   by (induct n arbitrary: xs) (auto, case_tac xs, auto)
 
 lemma take_take [simp]: "take n (take m xs) = take (min n m) xs"
 proof (induct m arbitrary: xs n)
   case 0
   then show ?case by simp
 next
   case Suc
   then show ?case by (cases xs; cases n) simp_all
 qed
 
 lemma drop_drop [simp]: "drop n (drop m xs) = drop (n + m) xs"
 proof (induct m arbitrary: xs)
   case 0
   then show ?case by simp
 next
   case Suc
   then show ?case by (cases xs) simp_all
 qed
 
 lemma take_drop: "take n (drop m xs) = drop m (take (n + m) xs)"
 proof (induct m arbitrary: xs n)
   case 0
   then show ?case by simp
 next
   case Suc
   then show ?case by (cases xs; cases n) simp_all
 qed
 
 lemma drop_take: "drop n (take m xs) = take (m-n) (drop n xs)"
   by(induct xs arbitrary: m n)(auto simp: take_Cons drop_Cons split: nat.split)
 
 lemma append_take_drop_id [simp]: "take n xs @ drop n xs = xs"
 proof (induct n arbitrary: xs)
   case 0
   then show ?case by simp
 next
   case Suc
   then show ?case by (cases xs) simp_all
 qed
 
 lemma take_map: "take n (map f xs) = map f (take n xs)"
 proof (induct n arbitrary: xs)
   case 0
   then show ?case by simp
 next
   case Suc
   then show ?case by (cases xs) simp_all
 qed
 
 lemma drop_map: "drop n (map f xs) = map f (drop n xs)"
 proof (induct n arbitrary: xs)
   case 0
   then show ?case by simp
 next
   case Suc
   then show ?case by (cases xs) simp_all
 qed
 
 lemma rev_take: "rev (take i xs) = drop (length xs - i) (rev xs)"
 proof (induct xs arbitrary: i)
   case Nil
   then show ?case by simp
 next
   case Cons
   then show ?case by (cases i) auto
 qed
 
 lemma rev_drop: "rev (drop i xs) = take (length xs - i) (rev xs)"
 proof (induct xs arbitrary: i)
   case Nil
   then show ?case by simp
 next
   case Cons
   then show ?case by (cases i) auto
 qed
 
 lemma drop_rev: "drop n (rev xs) = rev (take (length xs - n) xs)"
   by (cases "length xs < n") (auto simp: rev_take)
 
 lemma take_rev: "take n (rev xs) = rev (drop (length xs - n) xs)"
   by (cases "length xs < n") (auto simp: rev_drop)
 
 lemma nth_take [simp]: "i < n \<Longrightarrow> (take n xs)!i = xs!i"
 proof (induct xs arbitrary: i n)
   case Nil
   then show ?case by simp
 next
   case Cons
   then show ?case by (cases n; cases i) simp_all
 qed
 
 lemma nth_drop [simp]:
   "n \<le> length xs \<Longrightarrow> (drop n xs)!i = xs!(n + i)"
 proof (induct n arbitrary: xs)
   case 0
   then show ?case by simp
 next
   case Suc
   then show ?case by (cases xs) simp_all
 qed
 
 lemma butlast_take:
   "n \<le> length xs \<Longrightarrow> butlast (take n xs) = take (n - 1) xs"
   by (simp add: butlast_conv_take)
 
 lemma butlast_drop: "butlast (drop n xs) = drop n (butlast xs)"
   by (simp add: butlast_conv_take drop_take ac_simps)
 
 lemma take_butlast: "n < length xs \<Longrightarrow> take n (butlast xs) = take n xs"
   by (simp add: butlast_conv_take)
 
 lemma drop_butlast: "drop n (butlast xs) = butlast (drop n xs)"
   by (simp add: butlast_conv_take drop_take ac_simps)
 
 lemma butlast_power: "(butlast ^^ n) xs = take (length xs - n) xs"
   by (induct n) (auto simp: butlast_take)
 
 lemma hd_drop_conv_nth: "n < length xs \<Longrightarrow> hd(drop n xs) = xs!n"
   by(simp add: hd_conv_nth)
 
 lemma set_take_subset_set_take:
   "m \<le> n \<Longrightarrow> set(take m xs) \<le> set(take n xs)"
 proof (induct xs arbitrary: m n)
   case (Cons x xs m n) then show ?case
     by (cases n) (auto simp: take_Cons)
 qed simp
 
 lemma set_take_subset: "set(take n xs) \<subseteq> set xs"
   by(induct xs arbitrary: n)(auto simp:take_Cons split:nat.split)
 
 lemma set_drop_subset: "set(drop n xs) \<subseteq> set xs"
   by(induct xs arbitrary: n)(auto simp:drop_Cons split:nat.split)
 
 lemma set_drop_subset_set_drop:
   "m \<ge> n \<Longrightarrow> set(drop m xs) \<le> set(drop n xs)"
 proof (induct xs arbitrary: m n)
   case (Cons x xs m n)
   then show ?case
     by (clarsimp simp: drop_Cons split: nat.split) (metis set_drop_subset subset_iff)
 qed simp
 
 lemma in_set_takeD: "x \<in> set(take n xs) \<Longrightarrow> x \<in> set xs"
   using set_take_subset by fast
 
 lemma in_set_dropD: "x \<in> set(drop n xs) \<Longrightarrow> x \<in> set xs"
   using set_drop_subset by fast
 
 lemma append_eq_conv_conj:
   "(xs @ ys = zs) = (xs = take (length xs) zs \<and> ys = drop (length xs) zs)"
 proof (induct xs arbitrary: zs)
   case (Cons x xs zs) then show ?case
     by (cases zs, auto)
 qed auto
 
 lemma map_eq_append_conv:
   "map f xs = ys @ zs \<longleftrightarrow> (\<exists>us vs. xs = us @ vs \<and> ys = map f us \<and> zs = map f vs)"
 proof -
   have "map f xs \<noteq> ys @ zs \<and> map f xs \<noteq> ys @ zs \<or> map f xs \<noteq> ys @ zs \<or> map f xs = ys @ zs \<and>
     (\<exists>bs bsa. xs = bs @ bsa \<and> ys = map f bs \<and> zs = map f bsa)"
     by (metis append_eq_conv_conj append_take_drop_id drop_map take_map)
   then show ?thesis
     using map_append by blast
 qed
 
 lemmas append_eq_map_conv = map_eq_append_conv[THEN eq_iff_swap]
 
 lemma take_add:  "take (i+j) xs = take i xs @ take j (drop i xs)"
 proof (induct xs arbitrary: i)
   case (Cons x xs i) then show ?case
     by (cases i, auto)
 qed auto
 
 lemma append_eq_append_conv_if:
   "(xs\<^sub>1 @ xs\<^sub>2 = ys\<^sub>1 @ ys\<^sub>2) =
   (if size xs\<^sub>1 \<le> size ys\<^sub>1
    then xs\<^sub>1 = take (size xs\<^sub>1) ys\<^sub>1 \<and> xs\<^sub>2 = drop (size xs\<^sub>1) ys\<^sub>1 @ ys\<^sub>2
    else take (size ys\<^sub>1) xs\<^sub>1 = ys\<^sub>1 \<and> drop (size ys\<^sub>1) xs\<^sub>1 @ xs\<^sub>2 = ys\<^sub>2)"
 proof (induct xs\<^sub>1 arbitrary: ys\<^sub>1)
   case (Cons a xs\<^sub>1 ys\<^sub>1) then show ?case
     by (cases ys\<^sub>1, auto)
 qed auto
 
 lemma take_hd_drop:
   "n < length xs \<Longrightarrow> take n xs @ [hd (drop n xs)] = take (Suc n) xs"
   by (induct xs arbitrary: n) (simp_all add:drop_Cons split:nat.split)
 
 lemma id_take_nth_drop:
   "i < length xs \<Longrightarrow> xs = take i xs @ xs!i # drop (Suc i) xs"
 proof -
   assume si: "i < length xs"
   hence "xs = take (Suc i) xs @ drop (Suc i) xs" by auto
   moreover
   from si have "take (Suc i) xs = take i xs @ [xs!i]"
     using take_Suc_conv_app_nth by blast
   ultimately show ?thesis by auto
 qed
 
 lemma take_update_cancel[simp]: "n \<le> m \<Longrightarrow> take n (xs[m := y]) = take n xs"
   by(simp add: list_eq_iff_nth_eq)
 
 lemma drop_update_cancel[simp]: "n < m \<Longrightarrow> drop m (xs[n := x]) = drop m xs"
   by(simp add: list_eq_iff_nth_eq)
 
 lemma upd_conv_take_nth_drop:
   "i < length xs \<Longrightarrow> xs[i:=a] = take i xs @ a # drop (Suc i) xs"
 proof -
   assume i: "i < length xs"
   have "xs[i:=a] = (take i xs @ xs!i # drop (Suc i) xs)[i:=a]"
     by(rule arg_cong[OF id_take_nth_drop[OF i]])
   also have "\<dots> = take i xs @ a # drop (Suc i) xs"
     using i by (simp add: list_update_append)
   finally show ?thesis .
 qed
 
 lemma take_update_swap: "take m (xs[n := x]) = (take m xs)[n := x]"
 proof (cases "n \<ge> length xs")
   case False
   then show ?thesis
     by (simp add: upd_conv_take_nth_drop take_Cons drop_take min_def diff_Suc split: nat.split)
 qed auto
 
 lemma drop_update_swap:
   assumes "m \<le> n" shows "drop m (xs[n := x]) = (drop m xs)[n-m := x]"
 proof (cases "n \<ge> length xs")
   case False
   with assms show ?thesis
     by (simp add: upd_conv_take_nth_drop drop_take)
 qed auto
 
 lemma nth_image: "l \<le> size xs \<Longrightarrow> nth xs ` {0..<l} = set(take l xs)"
   by (simp add: set_conv_nth) force
 
 
 subsubsection \<open>\<^const>\<open>takeWhile\<close> and \<^const>\<open>dropWhile\<close>\<close>
 
 lemma length_takeWhile_le: "length (takeWhile P xs) \<le> length xs"
   by (induct xs) auto
 
 lemma takeWhile_dropWhile_id [simp]: "takeWhile P xs @ dropWhile P xs = xs"
   by (induct xs) auto
 
 lemma takeWhile_append1 [simp]:
   "\<lbrakk>x \<in> set xs; \<not>P(x)\<rbrakk> \<Longrightarrow> takeWhile P (xs @ ys) = takeWhile P xs"
   by (induct xs) auto
 
 lemma takeWhile_append2 [simp]:
   "(\<And>x. x \<in> set xs \<Longrightarrow> P x) \<Longrightarrow> takeWhile P (xs @ ys) = xs @ takeWhile P ys"
   by (induct xs) auto
 
 lemma takeWhile_append:
   "takeWhile P (xs @ ys) = (if \<forall>x\<in>set xs. P x then xs @ takeWhile P ys else takeWhile P xs)"
 using takeWhile_append1[of _ xs P ys] takeWhile_append2[of xs P ys] by auto
 
 lemma takeWhile_tail: "\<not> P x \<Longrightarrow> takeWhile P (xs @ (x#l)) = takeWhile P xs"
   by (induct xs) auto
 
 lemma takeWhile_eq_Nil_iff: "takeWhile P xs = [] \<longleftrightarrow> xs = [] \<or> \<not>P (hd xs)"
 by (cases xs) auto
 
 lemma takeWhile_nth: "j < length (takeWhile P xs) \<Longrightarrow> takeWhile P xs ! j = xs ! j"
   by (metis nth_append takeWhile_dropWhile_id)
 
 lemma takeWhile_takeWhile: "takeWhile Q (takeWhile P xs) = takeWhile (\<lambda>x. P x \<and> Q x) xs"
 by(induct xs) simp_all
 
 lemma dropWhile_nth: "j < length (dropWhile P xs) \<Longrightarrow>
   dropWhile P xs ! j = xs ! (j + length (takeWhile P xs))"
   by (metis add.commute nth_append_length_plus takeWhile_dropWhile_id)
 
 lemma length_dropWhile_le: "length (dropWhile P xs) \<le> length xs"
   by (induct xs) auto
 
 lemma dropWhile_append1 [simp]:
   "\<lbrakk>x \<in> set xs; \<not>P(x)\<rbrakk> \<Longrightarrow> dropWhile P (xs @ ys) = (dropWhile P xs)@ys"
   by (induct xs) auto
 
 lemma dropWhile_append2 [simp]:
   "(\<And>x. x \<in> set xs \<Longrightarrow> P(x)) \<Longrightarrow> dropWhile P (xs @ ys) = dropWhile P ys"
   by (induct xs) auto
 
 lemma dropWhile_append3:
   "\<not> P y \<Longrightarrow>dropWhile P (xs @ y # ys) = dropWhile P xs @ y # ys"
   by (induct xs) auto
 
 lemma dropWhile_append:
   "dropWhile P (xs @ ys) = (if \<forall>x\<in>set xs. P x then dropWhile P ys else dropWhile P xs @ ys)"
 using dropWhile_append1[of _ xs P ys] dropWhile_append2[of xs P ys] by auto
 
 lemma dropWhile_last:
   "x \<in> set xs \<Longrightarrow> \<not> P x \<Longrightarrow> last (dropWhile P xs) = last xs"
   by (auto simp add: dropWhile_append3 in_set_conv_decomp)
 
 lemma set_dropWhileD: "x \<in> set (dropWhile P xs) \<Longrightarrow> x \<in> set xs"
   by (induct xs) (auto split: if_split_asm)
 
 lemma set_takeWhileD: "x \<in> set (takeWhile P xs) \<Longrightarrow> x \<in> set xs \<and> P x"
   by (induct xs) (auto split: if_split_asm)
 
 lemma takeWhile_eq_all_conv[simp]:
   "(takeWhile P xs = xs) = (\<forall>x \<in> set xs. P x)"
   by(induct xs, auto)
 
 lemma dropWhile_eq_Nil_conv[simp]:
   "(dropWhile P xs = []) = (\<forall>x \<in> set xs. P x)"
   by(induct xs, auto)
 
 lemma dropWhile_eq_Cons_conv:
   "(dropWhile P xs = y#ys) = (xs = takeWhile P xs @ y # ys \<and> \<not> P y)"
   by(induct xs, auto)
 
 lemma dropWhile_eq_self_iff: "dropWhile P xs = xs \<longleftrightarrow> xs = [] \<or> \<not>P (hd xs)"
 by (cases xs) (auto simp: dropWhile_eq_Cons_conv)
 
 lemma dropWhile_dropWhile1: "(\<And>x. Q x \<Longrightarrow> P x) \<Longrightarrow> dropWhile Q (dropWhile P xs) = dropWhile P xs"
 by(induct xs) simp_all
 
 lemma dropWhile_dropWhile2: "(\<And>x. P x \<Longrightarrow> Q x) \<Longrightarrow> takeWhile P (takeWhile Q xs) = takeWhile P xs"
 by(induct xs) simp_all
 
 lemma dropWhile_takeWhile:
   "(\<And>x. P x \<Longrightarrow> Q x) \<Longrightarrow> dropWhile P (takeWhile Q xs) = takeWhile Q (dropWhile P xs)"
 by (induction xs) auto
 
 lemma distinct_takeWhile[simp]: "distinct xs \<Longrightarrow> distinct (takeWhile P xs)"
   by (induct xs) (auto dest: set_takeWhileD)
 
 lemma distinct_dropWhile[simp]: "distinct xs \<Longrightarrow> distinct (dropWhile P xs)"
   by (induct xs) auto
 
 lemma takeWhile_map: "takeWhile P (map f xs) = map f (takeWhile (P \<circ> f) xs)"
   by (induct xs) auto
 
 lemma dropWhile_map: "dropWhile P (map f xs) = map f (dropWhile (P \<circ> f) xs)"
   by (induct xs) auto
 
 lemma takeWhile_eq_take: "takeWhile P xs = take (length (takeWhile P xs)) xs"
   by (induct xs) auto
 
 lemma dropWhile_eq_drop: "dropWhile P xs = drop (length (takeWhile P xs)) xs"
   by (induct xs) auto
 
 lemma hd_dropWhile: "dropWhile P xs \<noteq> [] \<Longrightarrow> \<not> P (hd (dropWhile P xs))"
   by (induct xs) auto
 
 lemma takeWhile_eq_filter:
   assumes "\<And> x. x \<in> set (dropWhile P xs) \<Longrightarrow> \<not> P x"
   shows "takeWhile P xs = filter P xs"
 proof -
   have A: "filter P xs = filter P (takeWhile P xs @ dropWhile P xs)"
     by simp
   have B: "filter P (dropWhile P xs) = []"
     unfolding filter_empty_conv using assms by blast
   have "filter P xs = takeWhile P xs"
     unfolding A filter_append B
     by (auto simp add: filter_id_conv dest: set_takeWhileD)
   thus ?thesis ..
 qed
 
 lemma takeWhile_eq_take_P_nth:
   "\<lbrakk> \<And> i. \<lbrakk> i < n ; i < length xs \<rbrakk> \<Longrightarrow> P (xs ! i) ; n < length xs \<Longrightarrow> \<not> P (xs ! n) \<rbrakk> \<Longrightarrow>
   takeWhile P xs = take n xs"
 proof (induct xs arbitrary: n)
   case Nil
   thus ?case by simp
 next
   case (Cons x xs)
   show ?case
   proof (cases n)
     case 0
     with Cons show ?thesis by simp
   next
     case [simp]: (Suc n')
     have "P x" using Cons.prems(1)[of 0] by simp
     moreover have "takeWhile P xs = take n' xs"
     proof (rule Cons.hyps)
       fix i
       assume "i < n'" "i < length xs"
       thus "P (xs ! i)" using Cons.prems(1)[of "Suc i"] by simp
     next
       assume "n' < length xs"
       thus "\<not> P (xs ! n')" using Cons by auto
     qed
     ultimately show ?thesis by simp
   qed
 qed
 
 lemma nth_length_takeWhile:
   "length (takeWhile P xs) < length xs \<Longrightarrow> \<not> P (xs ! length (takeWhile P xs))"
   by (induct xs) auto
 
 lemma length_takeWhile_less_P_nth:
   assumes all: "\<And> i. i < j \<Longrightarrow> P (xs ! i)" and "j \<le> length xs"
   shows "j \<le> length (takeWhile P xs)"
 proof (rule classical)
   assume "\<not> ?thesis"
   hence "length (takeWhile P xs) < length xs" using assms by simp
   thus ?thesis using all \<open>\<not> ?thesis\<close> nth_length_takeWhile[of P xs] by auto
 qed
 
 lemma takeWhile_neq_rev: "\<lbrakk>distinct xs; x \<in> set xs\<rbrakk> \<Longrightarrow>
   takeWhile (\<lambda>y. y \<noteq> x) (rev xs) = rev (tl (dropWhile (\<lambda>y. y \<noteq> x) xs))"
   by(induct xs) (auto simp: takeWhile_tail[where l="[]"])
 
 lemma dropWhile_neq_rev: "\<lbrakk>distinct xs; x \<in> set xs\<rbrakk> \<Longrightarrow>
   dropWhile (\<lambda>y. y \<noteq> x) (rev xs) = x # rev (takeWhile (\<lambda>y. y \<noteq> x) xs)"
 proof (induct xs)
   case (Cons a xs)
   then show ?case
     by(auto, subst dropWhile_append2, auto)
 qed simp
 
 lemma takeWhile_not_last:
   "distinct xs \<Longrightarrow> takeWhile (\<lambda>y. y \<noteq> last xs) xs = butlast xs"
   by(induction xs rule: induct_list012) auto
 
 lemma takeWhile_cong [fundef_cong]:
   "\<lbrakk>l = k; \<And>x. x \<in> set l \<Longrightarrow> P x = Q x\<rbrakk>
   \<Longrightarrow> takeWhile P l = takeWhile Q k"
   by (induct k arbitrary: l) (simp_all)
 
 lemma dropWhile_cong [fundef_cong]:
   "\<lbrakk>l = k; \<And>x. x \<in> set l \<Longrightarrow> P x = Q x\<rbrakk>
   \<Longrightarrow> dropWhile P l = dropWhile Q k"
   by (induct k arbitrary: l, simp_all)
 
 lemma takeWhile_idem [simp]:
   "takeWhile P (takeWhile P xs) = takeWhile P xs"
   by (induct xs) auto
 
 lemma dropWhile_idem [simp]:
   "dropWhile P (dropWhile P xs) = dropWhile P xs"
   by (induct xs) auto
 
 
 subsubsection \<open>\<^const>\<open>zip\<close>\<close>
 
 lemma zip_Nil [simp]: "zip [] ys = []"
   by (induct ys) auto
 
 lemma zip_Cons_Cons [simp]: "zip (x # xs) (y # ys) = (x, y) # zip xs ys"
   by simp
 
 declare zip_Cons [simp del]
 
 lemma [code]:
   "zip [] ys = []"
   "zip xs [] = []"
   "zip (x # xs) (y # ys) = (x, y) # zip xs ys"
   by (fact zip_Nil zip.simps(1) zip_Cons_Cons)+
 
 lemma zip_Cons1:
   "zip (x#xs) ys = (case ys of [] \<Rightarrow> [] | y#ys \<Rightarrow> (x,y)#zip xs ys)"
   by(auto split:list.split)
 
 lemma length_zip [simp]:
   "length (zip xs ys) = min (length xs) (length ys)"
   by (induct xs ys rule:list_induct2') auto
 
 lemma zip_obtain_same_length:
   assumes "\<And>zs ws n. length zs = length ws \<Longrightarrow> n = min (length xs) (length ys)
     \<Longrightarrow> zs = take n xs \<Longrightarrow> ws = take n ys \<Longrightarrow> P (zip zs ws)"
   shows "P (zip xs ys)"
 proof -
   let ?n = "min (length xs) (length ys)"
   have "P (zip (take ?n xs) (take ?n ys))"
     by (rule assms) simp_all
   moreover have "zip xs ys = zip (take ?n xs) (take ?n ys)"
   proof (induct xs arbitrary: ys)
     case Nil then show ?case by simp
   next
     case (Cons x xs) then show ?case by (cases ys) simp_all
   qed
   ultimately show ?thesis by simp
 qed
 
 lemma zip_append1:
   "zip (xs @ ys) zs =
   zip xs (take (length xs) zs) @ zip ys (drop (length xs) zs)"
   by (induct xs zs rule:list_induct2') auto
 
 lemma zip_append2:
   "zip xs (ys @ zs) =
   zip (take (length ys) xs) ys @ zip (drop (length ys) xs) zs"
   by (induct xs ys rule:list_induct2') auto
 
 lemma zip_append [simp]:
   "\<lbrakk>length xs = length us\<rbrakk> \<Longrightarrow>
   zip (xs@ys) (us@vs) = zip xs us @ zip ys vs"
   by (simp add: zip_append1)
 
 lemma zip_rev:
   "length xs = length ys \<Longrightarrow> zip (rev xs) (rev ys) = rev (zip xs ys)"
   by (induct rule:list_induct2, simp_all)
 
 lemma zip_map_map:
   "zip (map f xs) (map g ys) = map (\<lambda> (x, y). (f x, g y)) (zip xs ys)"
 proof (induct xs arbitrary: ys)
   case (Cons x xs) note Cons_x_xs = Cons.hyps
   show ?case
   proof (cases ys)
     case (Cons y ys')
     show ?thesis unfolding Cons using Cons_x_xs by simp
   qed simp
 qed simp
 
 lemma zip_map1:
   "zip (map f xs) ys = map (\<lambda>(x, y). (f x, y)) (zip xs ys)"
   using zip_map_map[of f xs "\<lambda>x. x" ys] by simp
 
 lemma zip_map2:
   "zip xs (map f ys) = map (\<lambda>(x, y). (x, f y)) (zip xs ys)"
   using zip_map_map[of "\<lambda>x. x" xs f ys] by simp
 
 lemma map_zip_map:
   "map f (zip (map g xs) ys) = map (%(x,y). f(g x, y)) (zip xs ys)"
   by (auto simp: zip_map1)
 
 lemma map_zip_map2:
   "map f (zip xs (map g ys)) = map (%(x,y). f(x, g y)) (zip xs ys)"
   by (auto simp: zip_map2)
 
 text\<open>Courtesy of Andreas Lochbihler:\<close>
 lemma zip_same_conv_map: "zip xs xs = map (\<lambda>x. (x, x)) xs"
   by(induct xs) auto
 
 lemma nth_zip [simp]:
   "\<lbrakk>i < length xs; i < length ys\<rbrakk> \<Longrightarrow> (zip xs ys)!i = (xs!i, ys!i)"
 proof (induct ys arbitrary: i xs)
   case (Cons y ys)
   then show ?case
     by (cases xs) (simp_all add: nth.simps split: nat.split)
 qed auto
 
 lemma set_zip:
   "set (zip xs ys) = {(xs!i, ys!i) | i. i < min (length xs) (length ys)}"
   by(simp add: set_conv_nth cong: rev_conj_cong)
 
 lemma zip_same: "((a,b) \<in> set (zip xs xs)) = (a \<in> set xs \<and> a = b)"
   by(induct xs) auto
 
 lemma zip_update: "zip (xs[i:=x]) (ys[i:=y]) = (zip xs ys)[i:=(x,y)]"
   by (simp add: update_zip)
 
 lemma zip_replicate [simp]:
   "zip (replicate i x) (replicate j y) = replicate (min i j) (x,y)"
 proof (induct i arbitrary: j)
   case (Suc i)
   then show ?case
     by (cases j, auto)
 qed auto
 
 lemma zip_replicate1: "zip (replicate n x) ys = map (Pair x) (take n ys)"
   by(induction ys arbitrary: n)(case_tac [2] n, simp_all)
 
 lemma take_zip: "take n (zip xs ys) = zip (take n xs) (take n ys)"
 proof (induct n arbitrary: xs ys)
   case 0
   then show ?case by simp
 next
   case Suc
   then show ?case by (cases xs; cases ys) simp_all
 qed
 
 lemma drop_zip: "drop n (zip xs ys) = zip (drop n xs) (drop n ys)"
 proof (induct n arbitrary: xs ys)
   case 0
   then show ?case by simp
 next
   case Suc
   then show ?case by (cases xs; cases ys) simp_all
 qed
 
 lemma zip_takeWhile_fst: "zip (takeWhile P xs) ys = takeWhile (P \<circ> fst) (zip xs ys)"
 proof (induct xs arbitrary: ys)
   case Nil
   then show ?case by simp
 next
   case Cons
   then show ?case by (cases ys) auto
 qed
 
 lemma zip_takeWhile_snd: "zip xs (takeWhile P ys) = takeWhile (P \<circ> snd) (zip xs ys)"
 proof (induct xs arbitrary: ys)
   case Nil
   then show ?case by simp
 next
   case Cons
   then show ?case by (cases ys) auto
 qed
 
 lemma set_zip_leftD: "(x,y)\<in> set (zip xs ys) \<Longrightarrow> x \<in> set xs"
   by (induct xs ys rule:list_induct2') auto
 
 lemma set_zip_rightD: "(x,y)\<in> set (zip xs ys) \<Longrightarrow> y \<in> set ys"
   by (induct xs ys rule:list_induct2') auto
 
 lemma in_set_zipE:
   "(x,y) \<in> set(zip xs ys) \<Longrightarrow> (\<lbrakk> x \<in> set xs; y \<in> set ys \<rbrakk> \<Longrightarrow> R) \<Longrightarrow> R"
   by(blast dest: set_zip_leftD set_zip_rightD)
 
 lemma zip_map_fst_snd: "zip (map fst zs) (map snd zs) = zs"
   by (induct zs) simp_all
 
 lemma zip_eq_conv:
   "length xs = length ys \<Longrightarrow> zip xs ys = zs \<longleftrightarrow> map fst zs = xs \<and> map snd zs = ys"
   by (auto simp add: zip_map_fst_snd)
 
 lemma in_set_zip:
   "p \<in> set (zip xs ys) \<longleftrightarrow> (\<exists>n. xs ! n = fst p \<and> ys ! n = snd p
   \<and> n < length xs \<and> n < length ys)"
   by (cases p) (auto simp add: set_zip)
 
 lemma in_set_impl_in_set_zip1:
   assumes "length xs = length ys"
   assumes "x \<in> set xs"
   obtains y where "(x, y) \<in> set (zip xs ys)"
 proof -
   from assms have "x \<in> set (map fst (zip xs ys))" by simp
   from this that show ?thesis by fastforce
 qed
 
 lemma in_set_impl_in_set_zip2:
   assumes "length xs = length ys"
   assumes "y \<in> set ys"
   obtains x where "(x, y) \<in> set (zip xs ys)"
 proof -
   from assms have "y \<in> set (map snd (zip xs ys))" by simp
   from this that show ?thesis by fastforce
 qed
 
 lemma zip_eq_Nil_iff[simp]:
   "zip xs ys = [] \<longleftrightarrow> xs = [] \<or> ys = []"
   by (cases xs; cases ys) simp_all
 
 lemmas Nil_eq_zip_iff[simp] = zip_eq_Nil_iff[THEN eq_iff_swap]
 
 lemma zip_eq_ConsE:
   assumes "zip xs ys = xy # xys"
   obtains x xs' y ys' where "xs = x # xs'"
     and "ys = y # ys'" and "xy = (x, y)"
     and "xys = zip xs' ys'"
 proof -
   from assms have "xs \<noteq> []" and "ys \<noteq> []"
     using zip_eq_Nil_iff [of xs ys] by simp_all
   then obtain x xs' y ys'  where xs: "xs = x # xs'"
     and ys: "ys = y # ys'"
     by (cases xs; cases ys) auto
   with assms have "xy = (x, y)" and "xys = zip xs' ys'"
     by simp_all
   with xs ys show ?thesis ..
 qed
 
 lemma semilattice_map2:
   "semilattice (map2 (\<^bold>*))" if "semilattice (\<^bold>*)"
     for f (infixl "\<^bold>*" 70)
 proof -
   from that interpret semilattice f .
   show ?thesis
   proof
     show "map2 (\<^bold>*) (map2 (\<^bold>*) xs ys) zs = map2 (\<^bold>*) xs (map2 (\<^bold>*) ys zs)"
       for xs ys zs :: "'a list"
     proof (induction "zip xs (zip ys zs)" arbitrary: xs ys zs)
       case Nil
       from Nil [symmetric] show ?case
         by auto
     next
       case (Cons xyz xyzs)
       from Cons.hyps(2) [symmetric] show ?case
         by (rule zip_eq_ConsE) (erule zip_eq_ConsE,
           auto intro: Cons.hyps(1) simp add: ac_simps)
     qed
     show "map2 (\<^bold>*) xs ys = map2 (\<^bold>*) ys xs"
       for xs ys :: "'a list"
     proof (induction "zip xs ys" arbitrary: xs ys)
       case Nil
       then show ?case
         by auto
     next
       case (Cons xy xys)
       from Cons.hyps(2) [symmetric] show ?case
         by (rule zip_eq_ConsE) (auto intro: Cons.hyps(1) simp add: ac_simps)
     qed
     show "map2 (\<^bold>*) xs xs = xs"
       for xs :: "'a list"
       by (induction xs) simp_all
   qed
 qed
 
 lemma pair_list_eqI:
   assumes "map fst xs = map fst ys" and "map snd xs = map snd ys"
   shows "xs = ys"
 proof -
   from assms(1) have "length xs = length ys" by (rule map_eq_imp_length_eq)
   from this assms show ?thesis
     by (induct xs ys rule: list_induct2) (simp_all add: prod_eqI)
 qed
 
 lemma hd_zip:
   \<open>hd (zip xs ys) = (hd xs, hd ys)\<close> if \<open>xs \<noteq> []\<close> and \<open>ys \<noteq> []\<close>
   using that by (cases xs; cases ys) simp_all
 
 lemma last_zip:
   \<open>last (zip xs ys) = (last xs, last ys)\<close> if \<open>xs \<noteq> []\<close> and \<open>ys \<noteq> []\<close>
     and \<open>length xs = length ys\<close>
   using that by (cases xs rule: rev_cases; cases ys rule: rev_cases) simp_all
 
 
 subsubsection \<open>\<^const>\<open>list_all2\<close>\<close>
 
 lemma list_all2_lengthD [intro?]:
   "list_all2 P xs ys \<Longrightarrow> length xs = length ys"
   by (simp add: list_all2_iff)
 
 lemma list_all2_Nil [iff, code]: "list_all2 P [] ys = (ys = [])"
   by (simp add: list_all2_iff)
 
 lemma list_all2_Nil2 [iff, code]: "list_all2 P xs [] = (xs = [])"
   by (simp add: list_all2_iff)
 
 lemma list_all2_Cons [iff, code]:
   "list_all2 P (x # xs) (y # ys) = (P x y \<and> list_all2 P xs ys)"
   by (auto simp add: list_all2_iff)
 
 lemma list_all2_Cons1:
   "list_all2 P (x # xs) ys = (\<exists>z zs. ys = z # zs \<and> P x z \<and> list_all2 P xs zs)"
   by (cases ys) auto
 
 lemma list_all2_Cons2:
   "list_all2 P xs (y # ys) = (\<exists>z zs. xs = z # zs \<and> P z y \<and> list_all2 P zs ys)"
   by (cases xs) auto
 
 lemma list_all2_induct
   [consumes 1, case_names Nil Cons, induct set: list_all2]:
   assumes P: "list_all2 P xs ys"
   assumes Nil: "R [] []"
   assumes Cons: "\<And>x xs y ys.
     \<lbrakk>P x y; list_all2 P xs ys; R xs ys\<rbrakk> \<Longrightarrow> R (x # xs) (y # ys)"
   shows "R xs ys"
   using P
   by (induct xs arbitrary: ys) (auto simp add: list_all2_Cons1 Nil Cons)
 
 lemma list_all2_rev [iff]:
   "list_all2 P (rev xs) (rev ys) = list_all2 P xs ys"
   by (simp add: list_all2_iff zip_rev cong: conj_cong)
 
 lemma list_all2_rev1:
   "list_all2 P (rev xs) ys = list_all2 P xs (rev ys)"
   by (subst list_all2_rev [symmetric]) simp
 
 lemma list_all2_append1:
   "list_all2 P (xs @ ys) zs =
   (\<exists>us vs. zs = us @ vs \<and> length us = length xs \<and> length vs = length ys \<and>
     list_all2 P xs us \<and> list_all2 P ys vs)" (is "?lhs = ?rhs")
 proof
   assume ?lhs
   then show ?rhs
     apply (rule_tac x = "take (length xs) zs" in exI)
     apply (rule_tac x = "drop (length xs) zs" in exI)
     apply (force split: nat_diff_split simp add: list_all2_iff zip_append1)
     done
 next
   assume ?rhs
   then show ?lhs
     by (auto simp add: list_all2_iff)
 qed
 
 lemma list_all2_append2:
   "list_all2 P xs (ys @ zs) =
   (\<exists>us vs. xs = us @ vs \<and> length us = length ys \<and> length vs = length zs \<and>
     list_all2 P us ys \<and> list_all2 P vs zs)" (is "?lhs = ?rhs")
 proof
   assume ?lhs
   then show ?rhs
     apply (rule_tac x = "take (length ys) xs" in exI)
     apply (rule_tac x = "drop (length ys) xs" in exI)
     apply (force split: nat_diff_split simp add: list_all2_iff zip_append2)
     done
 next
   assume ?rhs
   then show ?lhs
     by (auto simp add: list_all2_iff)
 qed
 
 lemma list_all2_append:
   "length xs = length ys \<Longrightarrow>
   list_all2 P (xs@us) (ys@vs) = (list_all2 P xs ys \<and> list_all2 P us vs)"
   by (induct rule:list_induct2, simp_all)
 
 lemma list_all2_appendI [intro?, trans]:
   "\<lbrakk> list_all2 P a b; list_all2 P c d \<rbrakk> \<Longrightarrow> list_all2 P (a@c) (b@d)"
   by (simp add: list_all2_append list_all2_lengthD)
 
 lemma list_all2_conv_all_nth:
   "list_all2 P xs ys =
   (length xs = length ys \<and> (\<forall>i < length xs. P (xs!i) (ys!i)))"
   by (force simp add: list_all2_iff set_zip)
 
 lemma list_all2_trans:
   assumes tr: "!!a b c. P1 a b \<Longrightarrow> P2 b c \<Longrightarrow> P3 a c"
   shows "!!bs cs. list_all2 P1 as bs \<Longrightarrow> list_all2 P2 bs cs \<Longrightarrow> list_all2 P3 as cs"
     (is "!!bs cs. PROP ?Q as bs cs")
 proof (induct as)
   fix x xs bs assume I1: "!!bs cs. PROP ?Q xs bs cs"
   show "!!cs. PROP ?Q (x # xs) bs cs"
   proof (induct bs)
     fix y ys cs assume I2: "!!cs. PROP ?Q (x # xs) ys cs"
     show "PROP ?Q (x # xs) (y # ys) cs"
       by (induct cs) (auto intro: tr I1 I2)
   qed simp
 qed simp
 
 lemma list_all2_all_nthI [intro?]:
   "length a = length b \<Longrightarrow> (\<And>n. n < length a \<Longrightarrow> P (a!n) (b!n)) \<Longrightarrow> list_all2 P a b"
   by (simp add: list_all2_conv_all_nth)
 
 lemma list_all2I:
   "\<forall>x \<in> set (zip a b). case_prod P x \<Longrightarrow> length a = length b \<Longrightarrow> list_all2 P a b"
   by (simp add: list_all2_iff)
 
 lemma list_all2_nthD:
   "\<lbrakk> list_all2 P xs ys; p < size xs \<rbrakk> \<Longrightarrow> P (xs!p) (ys!p)"
   by (simp add: list_all2_conv_all_nth)
 
 lemma list_all2_nthD2:
   "\<lbrakk>list_all2 P xs ys; p < size ys\<rbrakk> \<Longrightarrow> P (xs!p) (ys!p)"
   by (frule list_all2_lengthD) (auto intro: list_all2_nthD)
 
 lemma list_all2_map1:
   "list_all2 P (map f as) bs = list_all2 (\<lambda>x y. P (f x) y) as bs"
   by (simp add: list_all2_conv_all_nth)
 
 lemma list_all2_map2:
   "list_all2 P as (map f bs) = list_all2 (\<lambda>x y. P x (f y)) as bs"
   by (auto simp add: list_all2_conv_all_nth)
 
 lemma list_all2_refl [intro?]:
   "(\<And>x. P x x) \<Longrightarrow> list_all2 P xs xs"
   by (simp add: list_all2_conv_all_nth)
 
 lemma list_all2_update_cong:
   "\<lbrakk> list_all2 P xs ys; P x y \<rbrakk> \<Longrightarrow> list_all2 P (xs[i:=x]) (ys[i:=y])"
   by (cases "i < length ys") (auto simp add: list_all2_conv_all_nth nth_list_update)
 
 lemma list_all2_takeI [simp,intro?]:
   "list_all2 P xs ys \<Longrightarrow> list_all2 P (take n xs) (take n ys)"
 proof (induct xs arbitrary: n ys)
   case (Cons x xs)
   then show ?case
     by (cases n) (auto simp: list_all2_Cons1)
 qed auto
 
 lemma list_all2_dropI [simp,intro?]:
   "list_all2 P xs ys \<Longrightarrow> list_all2 P (drop n xs) (drop n ys)"
 proof (induct xs arbitrary: n ys)
   case (Cons x xs)
   then show ?case
     by (cases n) (auto simp: list_all2_Cons1)
 qed auto
 
 lemma list_all2_mono [intro?]:
   "list_all2 P xs ys \<Longrightarrow> (\<And>xs ys. P xs ys \<Longrightarrow> Q xs ys) \<Longrightarrow> list_all2 Q xs ys"
   by (rule list.rel_mono_strong)
 
 lemma list_all2_eq:
   "xs = ys \<longleftrightarrow> list_all2 (=) xs ys"
   by (induct xs ys rule: list_induct2') auto
 
 lemma list_eq_iff_zip_eq:
   "xs = ys \<longleftrightarrow> length xs = length ys \<and> (\<forall>(x,y) \<in> set (zip xs ys). x = y)"
   by(auto simp add: set_zip list_all2_eq list_all2_conv_all_nth cong: conj_cong)
 
 lemma list_all2_same: "list_all2 P xs xs \<longleftrightarrow> (\<forall>x\<in>set xs. P x x)"
   by(auto simp add: list_all2_conv_all_nth set_conv_nth)
 
 lemma zip_assoc:
   "zip xs (zip ys zs) = map (\<lambda>((x, y), z). (x, y, z)) (zip (zip xs ys) zs)"
   by(rule list_all2_all_nthI[where P="(=)", unfolded list.rel_eq]) simp_all
 
 lemma zip_commute: "zip xs ys = map (\<lambda>(x, y). (y, x)) (zip ys xs)"
   by(rule list_all2_all_nthI[where P="(=)", unfolded list.rel_eq]) simp_all
 
 lemma zip_left_commute:
   "zip xs (zip ys zs) = map (\<lambda>(y, (x, z)). (x, y, z)) (zip ys (zip xs zs))"
   by(rule list_all2_all_nthI[where P="(=)", unfolded list.rel_eq]) simp_all
 
 lemma zip_replicate2: "zip xs (replicate n y) = map (\<lambda>x. (x, y)) (take n xs)"
   by(subst zip_commute)(simp add: zip_replicate1)
 
 subsubsection \<open>\<^const>\<open>List.product\<close> and \<^const>\<open>product_lists\<close>\<close>
 
 lemma product_concat_map:
   "List.product xs ys = concat (map (\<lambda>x. map (\<lambda>y. (x,y)) ys) xs)"
   by(induction xs) (simp)+
 
 lemma set_product[simp]: "set (List.product xs ys) = set xs \<times> set ys"
   by (induct xs) auto
 
 lemma length_product [simp]:
   "length (List.product xs ys) = length xs * length ys"
   by (induct xs) simp_all
 
 lemma product_nth:
   assumes "n < length xs * length ys"
   shows "List.product xs ys ! n = (xs ! (n div length ys), ys ! (n mod length ys))"
   using assms proof (induct xs arbitrary: n)
   case Nil then show ?case by simp
 next
   case (Cons x xs n)
   then have "length ys > 0" by auto
   with Cons show ?case
     by (auto simp add: nth_append not_less le_mod_geq le_div_geq)
 qed
 
 lemma in_set_product_lists_length:
   "xs \<in> set (product_lists xss) \<Longrightarrow> length xs = length xss"
   by (induct xss arbitrary: xs) auto
 
 lemma product_lists_set:
   "set (product_lists xss) = {xs. list_all2 (\<lambda>x ys. x \<in> set ys) xs xss}" (is "?L = Collect ?R")
 proof (intro equalityI subsetI, unfold mem_Collect_eq)
   fix xs assume "xs \<in> ?L"
   then have "length xs = length xss" by (rule in_set_product_lists_length)
   from this \<open>xs \<in> ?L\<close> show "?R xs" by (induct xs xss rule: list_induct2) auto
 next
   fix xs assume "?R xs"
   then show "xs \<in> ?L" by induct auto
 qed
 
 
 subsubsection \<open>\<^const>\<open>fold\<close> with natural argument order\<close>
 
 lemma fold_simps [code]: \<comment> \<open>eta-expanded variant for generated code -- enables tail-recursion optimisation in Scala\<close>
   "fold f [] s = s"
   "fold f (x # xs) s = fold f xs (f x s)"
   by simp_all
 
 lemma fold_remove1_split:
   "\<lbrakk> \<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> f x \<circ> f y = f y \<circ> f x;
     x \<in> set xs \<rbrakk>
   \<Longrightarrow> fold f xs = fold f (remove1 x xs) \<circ> f x"
   by (induct xs) (auto simp add: comp_assoc)
 
 lemma fold_cong [fundef_cong]:
   "a = b \<Longrightarrow> xs = ys \<Longrightarrow> (\<And>x. x \<in> set xs \<Longrightarrow> f x = g x)
     \<Longrightarrow> fold f xs a = fold g ys b"
   by (induct ys arbitrary: a b xs) simp_all
 
 lemma fold_id: "(\<And>x. x \<in> set xs \<Longrightarrow> f x = id) \<Longrightarrow> fold f xs = id"
   by (induct xs) simp_all
 
 lemma fold_commute:
   "(\<And>x. x \<in> set xs \<Longrightarrow> h \<circ> g x = f x \<circ> h) \<Longrightarrow> h \<circ> fold g xs = fold f xs \<circ> h"
   by (induct xs) (simp_all add: fun_eq_iff)
 
 lemma fold_commute_apply:
   assumes "\<And>x. x \<in> set xs \<Longrightarrow> h \<circ> g x = f x \<circ> h"
   shows "h (fold g xs s) = fold f xs (h s)"
 proof -
   from assms have "h \<circ> fold g xs = fold f xs \<circ> h" by (rule fold_commute)
   then show ?thesis by (simp add: fun_eq_iff)
 qed
 
 lemma fold_invariant:
   "\<lbrakk> \<And>x. x \<in> set xs \<Longrightarrow> Q x;  P s;  \<And>x s. Q x \<Longrightarrow> P s \<Longrightarrow> P (f x s) \<rbrakk>
   \<Longrightarrow> P (fold f xs s)"
   by (induct xs arbitrary: s) simp_all
 
 lemma fold_append [simp]: "fold f (xs @ ys) = fold f ys \<circ> fold f xs"
   by (induct xs) simp_all
 
 lemma fold_map [code_unfold]: "fold g (map f xs) = fold (g \<circ> f) xs"
   by (induct xs) simp_all
 
 lemma fold_filter:
   "fold f (filter P xs) = fold (\<lambda>x. if P x then f x else id) xs"
   by (induct xs) simp_all
 
 lemma fold_rev:
   "(\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> f y \<circ> f x = f x \<circ> f y)
   \<Longrightarrow> fold f (rev xs) = fold f xs"
   by (induct xs) (simp_all add: fold_commute_apply fun_eq_iff)
 
 lemma fold_Cons_rev: "fold Cons xs = append (rev xs)"
   by (induct xs) simp_all
 
 lemma rev_conv_fold [code]: "rev xs = fold Cons xs []"
   by (simp add: fold_Cons_rev)
 
 lemma fold_append_concat_rev: "fold append xss = append (concat (rev xss))"
   by (induct xss) simp_all
 
 text \<open>\<^const>\<open>Finite_Set.fold\<close> and \<^const>\<open>fold\<close>\<close>
 
 lemma (in comp_fun_commute_on) fold_set_fold_remdups:
   assumes "set xs \<subseteq> S"
   shows "Finite_Set.fold f y (set xs) = fold f (remdups xs) y"
   by (rule sym, use assms in \<open>induct xs arbitrary: y\<close>)
      (simp_all add: insert_absorb fold_fun_left_comm)
 
 lemma (in comp_fun_idem_on) fold_set_fold:
   assumes "set xs \<subseteq> S"
   shows "Finite_Set.fold f y (set xs) = fold f xs y"
   by (rule sym, use assms in \<open>induct xs arbitrary: y\<close>) (simp_all add: fold_fun_left_comm)
 
 lemma union_set_fold [code]: "set xs \<union> A = fold Set.insert xs A"
 proof -
   interpret comp_fun_idem Set.insert
     by (fact comp_fun_idem_insert)
   show ?thesis by (simp add: union_fold_insert fold_set_fold)
 qed
 
 lemma union_coset_filter [code]:
   "List.coset xs \<union> A = List.coset (List.filter (\<lambda>x. x \<notin> A) xs)"
   by auto
 
 lemma minus_set_fold [code]: "A - set xs = fold Set.remove xs A"
 proof -
   interpret comp_fun_idem Set.remove
     by (fact comp_fun_idem_remove)
   show ?thesis
     by (simp add: minus_fold_remove [of _ A] fold_set_fold)
 qed
 
 lemma minus_coset_filter [code]:
   "A - List.coset xs = set (List.filter (\<lambda>x. x \<in> A) xs)"
   by auto
 
 lemma inter_set_filter [code]:
   "A \<inter> set xs = set (List.filter (\<lambda>x. x \<in> A) xs)"
   by auto
 
 lemma inter_coset_fold [code]:
   "A \<inter> List.coset xs = fold Set.remove xs A"
   by (simp add: Diff_eq [symmetric] minus_set_fold)
 
 lemma (in semilattice_set) set_eq_fold [code]:
   "F (set (x # xs)) = fold f xs x"
 proof -
   interpret comp_fun_idem f
     by standard (simp_all add: fun_eq_iff left_commute)
   show ?thesis by (simp add: eq_fold fold_set_fold)
 qed
 
 lemma (in complete_lattice) Inf_set_fold:
   "Inf (set xs) = fold inf xs top"
 proof -
   interpret comp_fun_idem "inf :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"
     by (fact comp_fun_idem_inf)
   show ?thesis by (simp add: Inf_fold_inf fold_set_fold inf_commute)
 qed
 
 declare Inf_set_fold [where 'a = "'a set", code]
 
 lemma (in complete_lattice) Sup_set_fold:
   "Sup (set xs) = fold sup xs bot"
 proof -
   interpret comp_fun_idem "sup :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"
     by (fact comp_fun_idem_sup)
   show ?thesis by (simp add: Sup_fold_sup fold_set_fold sup_commute)
 qed
 
 declare Sup_set_fold [where 'a = "'a set", code]
 
 lemma (in complete_lattice) INF_set_fold:
   "\<Sqinter>(f ` set xs) = fold (inf \<circ> f) xs top"
   using Inf_set_fold [of "map f xs"] by (simp add: fold_map)
 
 lemma (in complete_lattice) SUP_set_fold:
   "\<Squnion>(f ` set xs) = fold (sup \<circ> f) xs bot"
   using Sup_set_fold [of "map f xs"] by (simp add: fold_map)
 
 
 subsubsection \<open>Fold variants: \<^const>\<open>foldr\<close> and \<^const>\<open>foldl\<close>\<close>
 
 text \<open>Correspondence\<close>
 
 lemma foldr_conv_fold [code_abbrev]: "foldr f xs = fold f (rev xs)"
   by (induct xs) simp_all
 
 lemma foldl_conv_fold: "foldl f s xs = fold (\<lambda>x s. f s x) xs s"
   by (induct xs arbitrary: s) simp_all
 
 lemma foldr_conv_foldl: \<comment> \<open>The ``Third Duality Theorem'' in Bird \& Wadler:\<close>
   "foldr f xs a = foldl (\<lambda>x y. f y x) a (rev xs)"
   by (simp add: foldr_conv_fold foldl_conv_fold)
 
 lemma foldl_conv_foldr:
   "foldl f a xs = foldr (\<lambda>x y. f y x) (rev xs) a"
   by (simp add: foldr_conv_fold foldl_conv_fold)
 
 lemma foldr_fold:
   "(\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> f y \<circ> f x = f x \<circ> f y)
   \<Longrightarrow> foldr f xs = fold f xs"
   unfolding foldr_conv_fold by (rule fold_rev)
 
 lemma foldr_cong [fundef_cong]:
   "a = b \<Longrightarrow> l = k \<Longrightarrow> (\<And>a x. x \<in> set l \<Longrightarrow> f x a = g x a) \<Longrightarrow> foldr f l a = foldr g k b"
   by (auto simp add: foldr_conv_fold intro!: fold_cong)
 
 lemma foldl_cong [fundef_cong]:
   "a = b \<Longrightarrow> l = k \<Longrightarrow> (\<And>a x. x \<in> set l \<Longrightarrow> f a x = g a x) \<Longrightarrow> foldl f a l = foldl g b k"
   by (auto simp add: foldl_conv_fold intro!: fold_cong)
 
 lemma foldr_append [simp]: "foldr f (xs @ ys) a = foldr f xs (foldr f ys a)"
   by (simp add: foldr_conv_fold)
 
 lemma foldl_append [simp]: "foldl f a (xs @ ys) = foldl f (foldl f a xs) ys"
   by (simp add: foldl_conv_fold)
 
 lemma foldr_map [code_unfold]: "foldr g (map f xs) a = foldr (g \<circ> f) xs a"
   by (simp add: foldr_conv_fold fold_map rev_map)
 
 lemma foldr_filter:
   "foldr f (filter P xs) = foldr (\<lambda>x. if P x then f x else id) xs"
   by (simp add: foldr_conv_fold rev_filter fold_filter)
 
 lemma foldl_map [code_unfold]:
   "foldl g a (map f xs) = foldl (\<lambda>a x. g a (f x)) a xs"
   by (simp add: foldl_conv_fold fold_map comp_def)
 
 lemma concat_conv_foldr [code]:
   "concat xss = foldr append xss []"
   by (simp add: fold_append_concat_rev foldr_conv_fold)
 
 
 subsubsection \<open>\<^const>\<open>upt\<close>\<close>
 
 lemma upt_rec[code]: "[i..<j] = (if i<j then i#[Suc i..<j] else [])"
   \<comment> \<open>simp does not terminate!\<close>
   by (induct j) auto
 
 lemmas upt_rec_numeral[simp] = upt_rec[of "numeral m" "numeral n"] for m n
 
 lemma upt_conv_Nil [simp]: "j \<le> i \<Longrightarrow> [i..<j] = []"
   by (subst upt_rec) simp
 
 lemma upt_eq_Nil_conv[simp]: "([i..<j] = []) = (j = 0 \<or> j \<le> i)"
   by(induct j)simp_all
 
 lemma upt_eq_Cons_conv:
   "([i..<j] = x#xs) = (i < j \<and> i = x \<and> [i+1..<j] = xs)"
 proof (induct j arbitrary: x xs)
   case (Suc j)
   then show ?case
     by (simp add: upt_rec)
 qed simp
 
 lemma upt_Suc_append: "i \<le> j \<Longrightarrow> [i..<(Suc j)] = [i..<j]@[j]"
   \<comment> \<open>Only needed if \<open>upt_Suc\<close> is deleted from the simpset.\<close>
   by simp
 
 lemma upt_conv_Cons: "i < j \<Longrightarrow> [i..<j] = i # [Suc i..<j]"
   by (simp add: upt_rec)
 
 lemma upt_conv_Cons_Cons: \<comment> \<open>no precondition\<close>
   "m # n # ns = [m..<q] \<longleftrightarrow> n # ns = [Suc m..<q]"
 proof (cases "m < q")
   case False then show ?thesis by simp
 next
   case True then show ?thesis by (simp add: upt_conv_Cons)
 qed
 
 lemma upt_add_eq_append: "i<=j \<Longrightarrow> [i..<j+k] = [i..<j]@[j..<j+k]"
   \<comment> \<open>LOOPS as a simprule, since \<open>j \<le> j\<close>.\<close>
   by (induct k) auto
 
 lemma length_upt [simp]: "length [i..<j] = j - i"
   by (induct j) (auto simp add: Suc_diff_le)
 
 lemma nth_upt [simp]: "i + k < j \<Longrightarrow> [i..<j] ! k = i + k"
   by (induct j) (auto simp add: less_Suc_eq nth_append split: nat_diff_split)
 
 lemma hd_upt[simp]: "i < j \<Longrightarrow> hd[i..<j] = i"
   by(simp add:upt_conv_Cons)
 
 lemma tl_upt [simp]: "tl [m..<n] = [Suc m..<n]"
   by (simp add: upt_rec)
 
 lemma last_upt[simp]: "i < j \<Longrightarrow> last[i..<j] = j - 1"
   by(cases j)(auto simp: upt_Suc_append)
 
 lemma take_upt [simp]: "i+m \<le> n \<Longrightarrow> take m [i..<n] = [i..<i+m]"
 proof (induct m arbitrary: i)
   case (Suc m)
   then show ?case
     by (subst take_Suc_conv_app_nth) auto
 qed simp
 
 lemma drop_upt[simp]: "drop m [i..<j] = [i+m..<j]"
   by(induct j) auto
 
 lemma map_Suc_upt: "map Suc [m..<n] = [Suc m..<Suc n]"
   by (induct n) auto
 
 lemma map_add_upt: "map (\<lambda>i. i + n) [0..<m] = [n..<m + n]"
   by (induct m) simp_all
 
 lemma nth_map_upt: "i < n-m \<Longrightarrow> (map f [m..<n]) ! i = f(m+i)"
 proof (induct n m  arbitrary: i rule: diff_induct)
   case (3 x y)
   then show ?case
     by (metis add.commute length_upt less_diff_conv nth_map nth_upt)
 qed auto
 
 lemma map_decr_upt: "map (\<lambda>n. n - Suc 0) [Suc m..<Suc n] = [m..<n]"
   by (induct n) simp_all
 
 lemma map_upt_Suc: "map f [0 ..< Suc n] = f 0 # map (\<lambda>i. f (Suc i)) [0 ..< n]"
   by (induct n arbitrary: f) auto
 
 lemma nth_take_lemma:
   "k \<le> length xs \<Longrightarrow> k \<le> length ys \<Longrightarrow>
      (\<And>i. i < k \<longrightarrow> xs!i = ys!i) \<Longrightarrow> take k xs = take k ys"
 proof (induct k arbitrary: xs ys)
   case (Suc k)
   then show ?case
     apply (simp add: less_Suc_eq_0_disj)
     by (simp add: Suc.prems(3) take_Suc_conv_app_nth)
 qed simp
 
 lemma nth_equalityI:
   "\<lbrakk>length xs = length ys; \<And>i. i < length xs \<Longrightarrow> xs!i = ys!i\<rbrakk> \<Longrightarrow> xs = ys"
   by (frule nth_take_lemma [OF le_refl eq_imp_le]) simp_all
 
 lemma map_nth:
   "map (\<lambda>i. xs ! i) [0..<length xs] = xs"
   by (rule nth_equalityI, auto)
 
 lemma list_all2_antisym:
   "\<lbrakk> (\<And>x y. \<lbrakk>P x y; Q y x\<rbrakk> \<Longrightarrow> x = y); list_all2 P xs ys; list_all2 Q ys xs \<rbrakk>
   \<Longrightarrow> xs = ys"
   by (simp add: list_all2_conv_all_nth nth_equalityI)
 
 lemma take_equalityI: "(\<forall>i. take i xs = take i ys) \<Longrightarrow> xs = ys"
 \<comment> \<open>The famous take-lemma.\<close>
   by (metis length_take min.commute order_refl take_all)
 
 lemma take_Cons':
   "take n (x # xs) = (if n = 0 then [] else x # take (n - 1) xs)"
 by (cases n) simp_all
 
 lemma drop_Cons':
   "drop n (x # xs) = (if n = 0 then x # xs else drop (n - 1) xs)"
 by (cases n) simp_all
 
 lemma nth_Cons': "(x # xs)!n = (if n = 0 then x else xs!(n - 1))"
 by (cases n) simp_all
 
 lemma take_Cons_numeral [simp]:
   "take (numeral v) (x # xs) = x # take (numeral v - 1) xs"
 by (simp add: take_Cons')
 
 lemma drop_Cons_numeral [simp]:
   "drop (numeral v) (x # xs) = drop (numeral v - 1) xs"
 by (simp add: drop_Cons')
 
 lemma nth_Cons_numeral [simp]:
   "(x # xs) ! numeral v = xs ! (numeral v - 1)"
   by (simp add: nth_Cons')
 
 lemma map_upt_eqI:
   \<open>map f [m..<n] = xs\<close> if \<open>length xs = n - m\<close>
     \<open>\<And>i. i < length xs \<Longrightarrow> xs ! i = f (m + i)\<close>
 proof (rule nth_equalityI)
   from \<open>length xs = n - m\<close> show \<open>length (map f [m..<n]) = length xs\<close>
     by simp
 next
   fix i
   assume \<open>i < length (map f [m..<n])\<close>
   then have \<open>i < n - m\<close>
     by simp
   with that have \<open>xs ! i = f (m + i)\<close>
     by simp
   with \<open>i < n - m\<close> show \<open>map f [m..<n] ! i = xs ! i\<close>
     by simp
 qed
 
 
 subsubsection \<open>\<open>upto\<close>: interval-list on \<^typ>\<open>int\<close>\<close>
 
 function upto :: "int \<Rightarrow> int \<Rightarrow> int list" ("(1[_../_])") where
   "upto i j = (if i \<le> j then i # [i+1..j] else [])"
 by auto
 termination
 by(relation "measure(%(i::int,j). nat(j - i + 1))") auto
 
 declare upto.simps[simp del]
 
 lemmas upto_rec_numeral [simp] =
   upto.simps[of "numeral m" "numeral n"]
   upto.simps[of "numeral m" "- numeral n"]
   upto.simps[of "- numeral m" "numeral n"]
   upto.simps[of "- numeral m" "- numeral n"] for m n
 
 lemma upto_empty[simp]: "j < i \<Longrightarrow> [i..j] = []"
 by(simp add: upto.simps)
 
 lemma upto_single[simp]: "[i..i] = [i]"
 by(simp add: upto.simps)
 
 lemma upto_Nil[simp]: "[i..j] = [] \<longleftrightarrow> j < i"
 by (simp add: upto.simps)
 
 lemmas upto_Nil2[simp] = upto_Nil[THEN eq_iff_swap]
 
 lemma upto_rec1: "i \<le> j \<Longrightarrow> [i..j] = i#[i+1..j]"
 by(simp add: upto.simps)
 
 lemma upto_rec2: "i \<le> j \<Longrightarrow> [i..j] = [i..j - 1]@[j]"
 proof(induct "nat(j-i)" arbitrary: i j)
   case 0 thus ?case by(simp add: upto.simps)
 next
   case (Suc n)
   hence "n = nat (j - (i + 1))" "i < j" by linarith+
   from this(2) Suc.hyps(1)[OF this(1)] Suc(2,3) upto_rec1 show ?case by simp
 qed
 
 lemma length_upto[simp]: "length [i..j] = nat(j - i + 1)"
 by(induction i j rule: upto.induct) (auto simp: upto.simps)
 
 lemma set_upto[simp]: "set[i..j] = {i..j}"
 proof(induct i j rule:upto.induct)
   case (1 i j)
   from this show ?case
     unfolding upto.simps[of i j] by auto
 qed
 
 lemma nth_upto[simp]: "i + int k \<le> j \<Longrightarrow> [i..j] ! k = i + int k"
 proof(induction i j arbitrary: k rule: upto.induct)
   case (1 i j)
   then show ?case
     by (auto simp add: upto_rec1 [of i j] nth_Cons')
 qed
 
 lemma upto_split1:
   "i \<le> j \<Longrightarrow> j \<le> k \<Longrightarrow> [i..k] = [i..j-1] @ [j..k]"
 proof (induction j rule: int_ge_induct)
   case base thus ?case by (simp add: upto_rec1)
 next
   case step thus ?case using upto_rec1 upto_rec2 by simp
 qed
 
 lemma upto_split2:
   "i \<le> j \<Longrightarrow> j \<le> k \<Longrightarrow> [i..k] = [i..j] @ [j+1..k]"
 using upto_rec1 upto_rec2 upto_split1 by auto
 
 lemma upto_split3: "\<lbrakk> i \<le> j; j \<le> k \<rbrakk> \<Longrightarrow> [i..k] = [i..j-1] @ j # [j+1..k]"
 using upto_rec1 upto_split1 by auto
 
 text\<open>Tail recursive version for code generation:\<close>
 
 definition upto_aux :: "int \<Rightarrow> int \<Rightarrow> int list \<Rightarrow> int list" where
   "upto_aux i j js = [i..j] @ js"
 
 lemma upto_aux_rec [code]:
   "upto_aux i j js = (if j<i then js else upto_aux i (j - 1) (j#js))"
 by (simp add: upto_aux_def upto_rec2)
 
 lemma upto_code[code]: "[i..j] = upto_aux i j []"
 by(simp add: upto_aux_def)
 
 
 
 subsubsection \<open>\<^const>\<open>successively\<close>\<close>
 
 lemma successively_Cons:
   "successively P (x # xs) \<longleftrightarrow> xs = [] \<or> P x (hd xs) \<and> successively P xs"
 by (cases xs) auto
 
 lemma successively_cong [cong]:
   assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> P x y \<longleftrightarrow> Q x y" "xs = ys"
   shows   "successively P xs \<longleftrightarrow> successively Q ys"
   unfolding assms(2) [symmetric] using assms(1)
   by (induction xs) (auto simp: successively_Cons)
 
 
 lemma successively_append_iff:
   "successively P (xs @ ys) \<longleftrightarrow>
      successively P xs \<and> successively P ys \<and>
      (xs = [] \<or> ys = [] \<or> P (last xs) (hd ys))"
 by (induction xs) (auto simp: successively_Cons)
 
 lemma successively_if_sorted_wrt: "sorted_wrt P xs \<Longrightarrow> successively P xs"
 by (induction xs rule: induct_list012) auto
 
 
 lemma successively_iff_sorted_wrt_strong:
   assumes "\<And>x y z. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> z \<in> set xs \<Longrightarrow>
                      P x y \<Longrightarrow> P y z \<Longrightarrow> P x z"
   shows   "successively P xs \<longleftrightarrow> sorted_wrt P xs"
 proof
   assume "successively P xs"
   from this and assms show "sorted_wrt P xs"
   proof (induction xs rule: induct_list012)
     case (3 x y xs)
     from "3.prems" have "P x y"
       by auto
     have IH: "sorted_wrt P (y # xs)"
       using "3.prems"
       by(intro "3.IH"(2) list.set_intros(2))(simp, blast intro: list.set_intros(2))
     have "P x z" if asm: "z \<in> set xs" for z
     proof -
       from IH and asm have "P y z"
         by auto
       with \<open>P x y\<close> show "P x z"
         using "3.prems" asm by auto
     qed
     with IH and \<open>P x y\<close> show ?case by auto
   qed auto
 qed (use successively_if_sorted_wrt in blast)
 
 lemma successively_conv_sorted_wrt:
   assumes "transp P"
   shows   "successively P xs \<longleftrightarrow> sorted_wrt P xs"
   using assms unfolding transp_def
   by (intro successively_iff_sorted_wrt_strong) blast
 
 lemma successively_rev [simp]: "successively P (rev xs) \<longleftrightarrow> successively (\<lambda>x y. P y x) xs"
   by (induction xs rule: remdups_adj.induct)
      (auto simp: successively_append_iff successively_Cons)
 
 lemma successively_map: "successively P (map f xs) \<longleftrightarrow> successively (\<lambda>x y. P (f x) (f y)) xs"
   by (induction xs rule: induct_list012) auto
 
 lemma successively_mono:
   assumes "successively P xs"
   assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> P x y \<Longrightarrow> Q x y"
   shows   "successively Q xs"
   using assms by (induction Q xs rule: successively.induct) auto
 
 lemma successively_altdef:
   "successively = (\<lambda>P. rec_list True (\<lambda>x xs b. case xs of [] \<Rightarrow> True | y # _ \<Rightarrow> P x y \<and> b))"
 proof (intro ext)
   fix P and xs :: "'a list"
   show "successively P xs = rec_list True (\<lambda>x xs b. case xs of [] \<Rightarrow> True | y # _ \<Rightarrow> P x y \<and> b) xs"
     by (induction xs) (auto simp: successively_Cons split: list.splits)
 qed
 
 
 subsubsection \<open>\<^const>\<open>distinct\<close> and \<^const>\<open>remdups\<close> and \<^const>\<open>remdups_adj\<close>\<close>
 
 lemma distinct_tl: "distinct xs \<Longrightarrow> distinct (tl xs)"
 by (cases xs) simp_all
 
 lemma distinct_append [simp]:
   "distinct (xs @ ys) = (distinct xs \<and> distinct ys \<and> set xs \<inter> set ys = {})"
 by (induct xs) auto
 
 lemma distinct_rev[simp]: "distinct(rev xs) = distinct xs"
 by(induct xs) auto
 
 lemma set_remdups [simp]: "set (remdups xs) = set xs"
 by (induct xs) (auto simp add: insert_absorb)
 
 lemma distinct_remdups [iff]: "distinct (remdups xs)"
 by (induct xs) auto
 
 lemma distinct_remdups_id: "distinct xs \<Longrightarrow> remdups xs = xs"
 by (induct xs, auto)
 
 lemma remdups_id_iff_distinct [simp]: "remdups xs = xs \<longleftrightarrow> distinct xs"
 by (metis distinct_remdups distinct_remdups_id)
 
 lemma finite_distinct_list: "finite A \<Longrightarrow> \<exists>xs. set xs = A \<and> distinct xs"
 by (metis distinct_remdups finite_list set_remdups)
 
 lemma remdups_eq_nil_iff [simp]: "(remdups x = []) = (x = [])"
 by (induct x, auto)
 
 lemmas remdups_eq_nil_right_iff [simp] = remdups_eq_nil_iff[THEN eq_iff_swap]
 
 lemma length_remdups_leq[iff]: "length(remdups xs) \<le> length xs"
 by (induct xs) auto
 
 lemma length_remdups_eq[iff]:
   "(length (remdups xs) = length xs) = (remdups xs = xs)"
 proof (induct xs)
   case (Cons a xs)
   then show ?case
     by simp (metis Suc_n_not_le_n impossible_Cons length_remdups_leq)
 qed auto
 
 lemma remdups_filter: "remdups(filter P xs) = filter P (remdups xs)"
 by (induct xs) auto
 
 lemma distinct_map:
   "distinct(map f xs) = (distinct xs \<and> inj_on f (set xs))"
 by (induct xs) auto
 
 lemma distinct_map_filter:
   "distinct (map f xs) \<Longrightarrow> distinct (map f (filter P xs))"
 by (induct xs) auto
 
 lemma distinct_filter [simp]: "distinct xs \<Longrightarrow> distinct (filter P xs)"
 by (induct xs) auto
 
 lemma distinct_upt[simp]: "distinct[i..<j]"
 by (induct j) auto
 
 lemma distinct_upto[simp]: "distinct[i..j]"
 proof (induction i j rule: upto.induct)
   case (1 i j)
   then show ?case
     by (simp add: upto.simps [of i])
 qed
 
 lemma distinct_take[simp]: "distinct xs \<Longrightarrow> distinct (take i xs)"
 proof (induct xs arbitrary: i)
   case (Cons a xs)
   then show ?case
     by (metis Cons.prems append_take_drop_id distinct_append)
 qed auto
 
 lemma distinct_drop[simp]: "distinct xs \<Longrightarrow> distinct (drop i xs)"
 proof (induct xs arbitrary: i)
   case (Cons a xs)
   then show ?case
     by (metis Cons.prems append_take_drop_id distinct_append)
 qed auto
 
 lemma distinct_list_update:
   assumes d: "distinct xs" and a: "a \<notin> set xs - {xs!i}"
   shows "distinct (xs[i:=a])"
 proof (cases "i < length xs")
   case True
   with a have anot: "a \<notin> set (take i xs @ xs ! i # drop (Suc i) xs) - {xs!i}"
     by simp (metis in_set_dropD in_set_takeD)
   show ?thesis
   proof (cases "a = xs!i")
     case True
     with d show ?thesis
       by auto
   next
     case False
     have "set (take i xs) \<inter> set (drop (Suc i) xs) = {}"
       by (metis True d disjoint_insert(1) distinct_append id_take_nth_drop list.set(2))
     then show ?thesis
       using d False anot \<open>i < length xs\<close> by (simp add: upd_conv_take_nth_drop)
   qed
 next
   case False with d show ?thesis by auto
 qed
 
 lemma distinct_concat:
   "\<lbrakk> distinct xs;
      \<And> ys. ys \<in> set xs \<Longrightarrow> distinct ys;
      \<And> ys zs. \<lbrakk> ys \<in> set xs ; zs \<in> set xs ; ys \<noteq> zs \<rbrakk> \<Longrightarrow> set ys \<inter> set zs = {}
    \<rbrakk> \<Longrightarrow> distinct (concat xs)"
 by (induct xs) auto
 
 text \<open>An iff-version of @{thm distinct_concat} is available further down as \<open>distinct_concat_iff\<close>.\<close>
 
 text \<open>It is best to avoid the following indexed version of distinct, but sometimes it is useful.\<close>
 
 lemma distinct_conv_nth: "distinct xs = (\<forall>i < size xs. \<forall>j < size xs. i \<noteq> j \<longrightarrow> xs!i \<noteq> xs!j)"
 proof (induct xs)
   case (Cons x xs)
   show ?case
     apply (auto simp add: Cons nth_Cons less_Suc_eq_le split: nat.split_asm)
     apply (metis Suc_leI in_set_conv_nth length_pos_if_in_set lessI less_imp_le_nat less_nat_zero_code)
     apply (metis Suc_le_eq)
     done
 qed auto
 
 lemma nth_eq_iff_index_eq:
   "\<lbrakk> distinct xs; i < length xs; j < length xs \<rbrakk> \<Longrightarrow> (xs!i = xs!j) = (i = j)"
 by(auto simp: distinct_conv_nth)
 
 lemma distinct_Ex1:
   "distinct xs \<Longrightarrow> x \<in> set xs \<Longrightarrow> (\<exists>!i. i < length xs \<and> xs ! i = x)"
   by (auto simp: in_set_conv_nth nth_eq_iff_index_eq)
 
 lemma inj_on_nth: "distinct xs \<Longrightarrow> \<forall>i \<in> I. i < length xs \<Longrightarrow> inj_on (nth xs) I"
 by (rule inj_onI) (simp add: nth_eq_iff_index_eq)
 
 lemma bij_betw_nth:
   assumes "distinct xs" "A = {..<length xs}" "B = set xs"
   shows   "bij_betw ((!) xs) A B"
   using assms unfolding bij_betw_def
   by (auto intro!: inj_on_nth simp: set_conv_nth)
 
 lemma set_update_distinct: "\<lbrakk> distinct xs;  n < length xs \<rbrakk> \<Longrightarrow>
   set(xs[n := x]) = insert x (set xs - {xs!n})"
 by(auto simp: set_eq_iff in_set_conv_nth nth_list_update nth_eq_iff_index_eq)
 
 lemma distinct_swap[simp]: "\<lbrakk> i < size xs; j < size xs\<rbrakk> \<Longrightarrow>
   distinct(xs[i := xs!j, j := xs!i]) = distinct xs"
   apply (simp add: distinct_conv_nth nth_list_update)
   apply (safe; metis)
   done
 
 lemma set_swap[simp]:
   "\<lbrakk> i < size xs; j < size xs \<rbrakk> \<Longrightarrow> set(xs[i := xs!j, j := xs!i]) = set xs"
 by(simp add: set_conv_nth nth_list_update) metis
 
 lemma distinct_card: "distinct xs \<Longrightarrow> card (set xs) = size xs"
 by (induct xs) auto
 
 lemma card_distinct: "card (set xs) = size xs \<Longrightarrow> distinct xs"
 proof (induct xs)
   case (Cons x xs)
   show ?case
   proof (cases "x \<in> set xs")
     case False with Cons show ?thesis by simp
   next
     case True with Cons.prems
     have "card (set xs) = Suc (length xs)"
       by (simp add: card_insert_if split: if_split_asm)
     moreover have "card (set xs) \<le> length xs" by (rule card_length)
     ultimately have False by simp
     thus ?thesis ..
   qed
 qed simp
 
 lemma distinct_length_filter: "distinct xs \<Longrightarrow> length (filter P xs) = card ({x. P x} Int set xs)"
 by (induct xs) (auto)
 
 lemma not_distinct_decomp: "\<not> distinct ws \<Longrightarrow> \<exists>xs ys zs y. ws = xs@[y]@ys@[y]@zs"
 proof (induct n == "length ws" arbitrary:ws)
   case (Suc n ws)
   then show ?case
     using length_Suc_conv [of ws n]
     apply (auto simp: eq_commute)
      apply (metis append_Nil in_set_conv_decomp_first)
     by (metis append_Cons)
 qed simp
 
 lemma not_distinct_conv_prefix:
   defines "dec as xs y ys \<equiv> y \<in> set xs \<and> distinct xs \<and> as = xs @ y # ys"
   shows "\<not>distinct as \<longleftrightarrow> (\<exists>xs y ys. dec as xs y ys)" (is "?L = ?R")
 proof
   assume "?L" then show "?R"
   proof (induct "length as" arbitrary: as rule: less_induct)
     case less
     obtain xs ys zs y where decomp: "as = (xs @ y # ys) @ y # zs"
       using not_distinct_decomp[OF less.prems] by auto
     show ?case
     proof (cases "distinct (xs @ y # ys)")
       case True
       with decomp have "dec as (xs @ y # ys) y zs" by (simp add: dec_def)
       then show ?thesis by blast
     next
       case False
       with less decomp obtain xs' y' ys' where "dec (xs @ y # ys) xs' y' ys'"
         by atomize_elim auto
       with decomp have "dec as xs' y' (ys' @ y # zs)" by (simp add: dec_def)
       then show ?thesis by blast
     qed
   qed
 qed (auto simp: dec_def)
 
 lemma distinct_product:
   "distinct xs \<Longrightarrow> distinct ys \<Longrightarrow> distinct (List.product xs ys)"
 by (induct xs) (auto intro: inj_onI simp add: distinct_map)
 
 lemma distinct_product_lists:
   assumes "\<forall>xs \<in> set xss. distinct xs"
   shows "distinct (product_lists xss)"
 using assms proof (induction xss)
   case (Cons xs xss) note * = this
   then show ?case
   proof (cases "product_lists xss")
     case Nil then show ?thesis by (induct xs) simp_all
   next
     case (Cons ps pss) with * show ?thesis
       by (auto intro!: inj_onI distinct_concat simp add: distinct_map)
   qed
 qed simp
 
 lemma length_remdups_concat:
   "length (remdups (concat xss)) = card (\<Union>xs\<in>set xss. set xs)"
 by (simp add: distinct_card [symmetric])
 
 lemma remdups_append2:
   "remdups (xs @ remdups ys) = remdups (xs @ ys)"
 by(induction xs) auto
 
 lemma length_remdups_card_conv: "length(remdups xs) = card(set xs)"
 proof -
   have xs: "concat[xs] = xs" by simp
   from length_remdups_concat[of "[xs]"] show ?thesis unfolding xs by simp
 qed
 
 lemma remdups_remdups: "remdups (remdups xs) = remdups xs"
 by (induct xs) simp_all
 
 lemma distinct_butlast:
   assumes "distinct xs"
   shows "distinct (butlast xs)"
 proof (cases "xs = []")
   case False
     from \<open>xs \<noteq> []\<close> obtain ys y where "xs = ys @ [y]" by (cases xs rule: rev_cases) auto
     with \<open>distinct xs\<close> show ?thesis by simp
 qed (auto)
 
 lemma remdups_map_remdups:
   "remdups (map f (remdups xs)) = remdups (map f xs)"
 by (induct xs) simp_all
 
 lemma distinct_zipI1:
   assumes "distinct xs"
   shows "distinct (zip xs ys)"
 proof (rule zip_obtain_same_length)
   fix xs' :: "'a list" and ys' :: "'b list" and n
   assume "length xs' = length ys'"
   assume "xs' = take n xs"
   with assms have "distinct xs'" by simp
   with \<open>length xs' = length ys'\<close> show "distinct (zip xs' ys')"
     by (induct xs' ys' rule: list_induct2) (auto elim: in_set_zipE)
 qed
 
 lemma distinct_zipI2:
   assumes "distinct ys"
   shows "distinct (zip xs ys)"
 proof (rule zip_obtain_same_length)
   fix xs' :: "'b list" and ys' :: "'a list" and n
   assume "length xs' = length ys'"
   assume "ys' = take n ys"
   with assms have "distinct ys'" by simp
   with \<open>length xs' = length ys'\<close> show "distinct (zip xs' ys')"
     by (induct xs' ys' rule: list_induct2) (auto elim: in_set_zipE)
 qed
 
 lemma set_take_disj_set_drop_if_distinct:
   "distinct vs \<Longrightarrow> i \<le> j \<Longrightarrow> set (take i vs) \<inter> set (drop j vs) = {}"
 by (auto simp: in_set_conv_nth distinct_conv_nth)
 
 (* The next two lemmas help Sledgehammer. *)
 
 lemma distinct_singleton: "distinct [x]" by simp
 
 lemma distinct_length_2_or_more:
   "distinct (a # b # xs) \<longleftrightarrow> (a \<noteq> b \<and> distinct (a # xs) \<and> distinct (b # xs))"
 by force
 
 lemma remdups_adj_altdef: "(remdups_adj xs = ys) \<longleftrightarrow>
   (\<exists>f::nat => nat. mono f \<and> f ` {0 ..< size xs} = {0 ..< size ys}
     \<and> (\<forall>i < size xs. xs!i = ys!(f i))
     \<and> (\<forall>i. i + 1 < size xs \<longrightarrow> (xs!i = xs!(i+1) \<longleftrightarrow> f i = f(i+1))))" (is "?L \<longleftrightarrow> (\<exists>f. ?p f xs ys)")
 proof
   assume ?L
   then show "\<exists>f. ?p f xs ys"
   proof (induct xs arbitrary: ys rule: remdups_adj.induct)
     case (1 ys)
     thus ?case by (intro exI[of _ id]) (auto simp: mono_def)
   next
     case (2 x ys)
     thus ?case by (intro exI[of _ id]) (auto simp: mono_def)
   next
     case (3 x1 x2 xs ys)
     let ?xs = "x1 # x2 # xs"
     let ?cond = "x1 = x2"
     define zs where "zs = remdups_adj (x2 # xs)"
     from 3(1-2)[of zs]
     obtain f where p: "?p f (x2 # xs) zs" unfolding zs_def by (cases ?cond) auto
     then have f0: "f 0 = 0"
       by (intro mono_image_least[where f=f]) blast+
     from p have mono: "mono f" and f_xs_zs: "f ` {0..<length (x2 # xs)} = {0..<length zs}" by auto
     have ys: "ys = (if x1 = x2 then zs else x1 # zs)"
       unfolding 3(3)[symmetric] zs_def by auto
     have zs0: "zs ! 0 = x2" unfolding zs_def by (induct xs) auto
     have zsne: "zs \<noteq> []" unfolding zs_def by (induct xs) auto
     let ?Succ = "if ?cond then id else Suc"
     let ?x1 = "if ?cond then id else Cons x1"
     let ?f = "\<lambda> i. if i = 0 then 0 else ?Succ (f (i - 1))"
     have ys: "ys = ?x1 zs" unfolding ys by (cases ?cond, auto)
     have mono: "mono ?f" using \<open>mono f\<close> unfolding mono_def by auto
     show ?case unfolding ys
     proof (intro exI[of _ ?f] conjI allI impI)
       show "mono ?f" by fact
     next
       fix i assume i: "i < length ?xs"
       with p show "?xs ! i = ?x1 zs ! (?f i)" using zs0 by auto
     next
       fix i assume i: "i + 1 < length ?xs"
       with p show "(?xs ! i = ?xs ! (i + 1)) = (?f i = ?f (i + 1))"
         by (cases i) (auto simp: f0)
     next
       have id: "{0 ..< length (?x1 zs)} = insert 0 (?Succ ` {0 ..< length zs})"
         using zsne by (cases ?cond, auto)
       { fix i  assume "i < Suc (length xs)"
         hence "Suc i \<in> {0..<Suc (Suc (length xs))} \<inter> Collect ((<) 0)" by auto
         from imageI[OF this, of "\<lambda>i. ?Succ (f (i - Suc 0))"]
         have "?Succ (f i) \<in> (\<lambda>i. ?Succ (f (i - Suc 0))) ` ({0..<Suc (Suc (length xs))} \<inter> Collect ((<) 0))" by auto
       }
       then show "?f ` {0 ..< length ?xs} = {0 ..< length (?x1  zs)}"
         unfolding id f_xs_zs[symmetric] by auto
     qed
   qed
 next
   assume "\<exists> f. ?p f xs ys"
   then show ?L
   proof (induct xs arbitrary: ys rule: remdups_adj.induct)
     case 1 then show ?case by auto
   next
     case (2 x) then obtain f where f_img: "f ` {0 ..< size [x]} = {0 ..< size ys}"
         and f_nth: "\<And>i. i < size [x] \<Longrightarrow> [x]!i = ys!(f i)"
       by blast
 
     have "length ys = card (f ` {0 ..< size [x]})"
       using f_img by auto
     then have *: "length ys = 1" by auto
     then have "f 0 = 0" using f_img by auto
     with * show ?case using f_nth by (cases ys) auto
   next
     case (3 x1 x2 xs)
     from "3.prems" obtain f where f_mono: "mono f"
       and f_img: "f ` {0..<length (x1 # x2 # xs)} = {0..<length ys}"
       and f_nth:
         "\<And>i. i < length (x1 # x2 # xs) \<Longrightarrow> (x1 # x2 # xs) ! i = ys ! f i"
         "\<And>i. i + 1 < length (x1 # x2 #xs) \<Longrightarrow>
           ((x1 # x2 # xs) ! i = (x1 # x2 # xs) ! (i + 1)) = (f i = f (i + 1))"
       by blast
 
     show ?case
     proof cases
       assume "x1 = x2"
 
       let ?f' = "f \<circ> Suc"
 
       have "remdups_adj (x1 # xs) = ys"
       proof (intro "3.hyps" exI conjI impI allI)
         show "mono ?f'"
           using f_mono by (simp add: mono_iff_le_Suc)
       next
         have "?f' ` {0 ..< length (x1 # xs)} = f ` {Suc 0 ..< length (x1 # x2 # xs)}"
           using less_Suc_eq_0_disj by auto
         also have "\<dots> = f ` {0 ..< length (x1 # x2 # xs)}"
         proof -
           have "f 0 = f (Suc 0)" using \<open>x1 = x2\<close> f_nth[of 0] by simp
           then show ?thesis
             using less_Suc_eq_0_disj by auto
         qed
         also have "\<dots> = {0 ..< length ys}" by fact
         finally show  "?f' ` {0 ..< length (x1 # xs)} = {0 ..< length ys}" .
       qed (insert f_nth[of "Suc i" for i], auto simp: \<open>x1 = x2\<close>)
       then show ?thesis using \<open>x1 = x2\<close> by simp
     next
       assume "x1 \<noteq> x2"
 
       have two: "Suc (Suc 0) \<le> length ys"
       proof -
         have "2 = card {f 0, f 1}" using \<open>x1 \<noteq> x2\<close> f_nth[of 0] by auto
         also have "\<dots> \<le> card (f ` {0..< length (x1 # x2 # xs)})"
           by (rule card_mono) auto
         finally show ?thesis using f_img by simp
       qed
 
       have "f 0 = 0" using f_mono f_img by (rule mono_image_least) simp
 
       have "f (Suc 0) = Suc 0"
       proof (rule ccontr)
         assume "f (Suc 0) \<noteq> Suc 0"
         then have "Suc 0 < f (Suc 0)" using f_nth[of 0] \<open>x1 \<noteq> x2\<close> \<open>f 0 = 0\<close> by auto
         then have "\<And>i. Suc 0 < f (Suc i)"
           using f_mono
           by (meson Suc_le_mono le0 less_le_trans monoD)
         then have "Suc 0 \<noteq> f i" for i using \<open>f 0 = 0\<close>
           by (cases i) fastforce+
         then have "Suc 0 \<notin> f ` {0 ..< length (x1 # x2 # xs)}" by auto
         then show False using f_img two by auto
       qed
       obtain ys' where "ys = x1 # x2 # ys'"
         using two f_nth[of 0] f_nth[of 1]
         by (auto simp: Suc_le_length_iff  \<open>f 0 = 0\<close> \<open>f (Suc 0) = Suc 0\<close>)
 
       have Suc0_le_f_Suc: "Suc 0 \<le> f (Suc i)" for i
         by (metis Suc_le_mono \<open>f (Suc 0) = Suc 0\<close> f_mono le0 mono_def)
 
       define f' where "f' x = f (Suc x) - 1" for x
       have f_Suc: "f (Suc i) = Suc (f' i)" for i
           using Suc0_le_f_Suc[of i] by (auto simp: f'_def)
 
       have "remdups_adj (x2 # xs) = (x2 # ys')"
       proof (intro "3.hyps" exI conjI impI allI)
         show "mono f'"
           using Suc0_le_f_Suc f_mono by (auto simp: f'_def mono_iff_le_Suc le_diff_iff)
       next
         have "f' ` {0 ..< length (x2 # xs)} = (\<lambda>x. f x - 1) ` {0 ..< length (x1 # x2 #xs)}"
           by (auto simp: f'_def \<open>f 0 = 0\<close> \<open>f (Suc 0) = Suc 0\<close> image_def Bex_def less_Suc_eq_0_disj)
         also have "\<dots> = (\<lambda>x. x - 1) ` f ` {0 ..< length (x1 # x2 #xs)}"
           by (auto simp: image_comp)
         also have "\<dots> = (\<lambda>x. x - 1) ` {0 ..< length ys}"
           by (simp only: f_img)
         also have "\<dots> = {0 ..< length (x2 # ys')}"
           using \<open>ys = _\<close> by (fastforce intro: rev_image_eqI)
         finally show  "f' ` {0 ..< length (x2 # xs)} = {0 ..< length (x2 # ys')}" .
       qed (insert f_nth[of "Suc i" for i] \<open>x1 \<noteq> x2\<close>, auto simp add: f_Suc \<open>ys = _\<close>)
       then show ?case using \<open>ys = _\<close> \<open>x1 \<noteq> x2\<close> by simp
     qed
   qed
 qed
 
 lemma hd_remdups_adj[simp]: "hd (remdups_adj xs) = hd xs"
   by (induction xs rule: remdups_adj.induct) simp_all
 
 lemma remdups_adj_Cons: "remdups_adj (x # xs) =
   (case remdups_adj xs of [] \<Rightarrow> [x] | y # xs \<Rightarrow> if x = y then y # xs else x # y # xs)"
   by (induct xs arbitrary: x) (auto split: list.splits)
 
 lemma remdups_adj_append_two:
   "remdups_adj (xs @ [x,y]) = remdups_adj (xs @ [x]) @ (if x = y then [] else [y])"
   by (induct xs rule: remdups_adj.induct, simp_all)
 
 lemma remdups_adj_adjacent:
   "Suc i < length (remdups_adj xs) \<Longrightarrow> remdups_adj xs ! i \<noteq> remdups_adj xs ! Suc i"
 proof (induction xs arbitrary: i rule: remdups_adj.induct)
   case (3 x y xs i)
   thus ?case by (cases i, cases "x = y") (simp, auto simp: hd_conv_nth[symmetric])
 qed simp_all
 
 lemma remdups_adj_rev[simp]: "remdups_adj (rev xs) = rev (remdups_adj xs)"
 by (induct xs rule: remdups_adj.induct, simp_all add: remdups_adj_append_two)
 
 lemma remdups_adj_length[simp]: "length (remdups_adj xs) \<le> length xs"
 by (induct xs rule: remdups_adj.induct, auto)
 
 lemma remdups_adj_length_ge1[simp]: "xs \<noteq> [] \<Longrightarrow> length (remdups_adj xs) \<ge> Suc 0"
 by (induct xs rule: remdups_adj.induct, simp_all)
 
 lemma remdups_adj_Nil_iff[simp]: "remdups_adj xs = [] \<longleftrightarrow> xs = []"
 by (induct xs rule: remdups_adj.induct, simp_all)
 
 lemma remdups_adj_set[simp]: "set (remdups_adj xs) = set xs"
 by (induct xs rule: remdups_adj.induct, simp_all)
 
 lemma last_remdups_adj [simp]: "last (remdups_adj xs) = last xs"
   by (induction xs rule: remdups_adj.induct) auto
 
 lemma remdups_adj_Cons_alt[simp]: "x # tl (remdups_adj (x # xs)) = remdups_adj (x # xs)"
 by (induct xs rule: remdups_adj.induct, auto)
 
 lemma remdups_adj_distinct: "distinct xs \<Longrightarrow> remdups_adj xs = xs"
 by (induct xs rule: remdups_adj.induct, simp_all)
 
 lemma remdups_adj_append:
   "remdups_adj (xs\<^sub>1 @ x # xs\<^sub>2) = remdups_adj (xs\<^sub>1 @ [x]) @ tl (remdups_adj (x # xs\<^sub>2))"
 by (induct xs\<^sub>1 rule: remdups_adj.induct, simp_all)
 
 lemma remdups_adj_singleton:
   "remdups_adj xs = [x] \<Longrightarrow> xs = replicate (length xs) x"
 by (induct xs rule: remdups_adj.induct, auto split: if_split_asm)
 
 lemma remdups_adj_map_injective:
   assumes "inj f"
   shows "remdups_adj (map f xs) = map f (remdups_adj xs)"
 by (induct xs rule: remdups_adj.induct) (auto simp add: injD[OF assms])
 
 lemma remdups_adj_replicate:
   "remdups_adj (replicate n x) = (if n = 0 then [] else [x])"
   by (induction n) (auto simp: remdups_adj_Cons)
 
 lemma remdups_upt [simp]: "remdups [m..<n] = [m..<n]"
 proof (cases "m \<le> n")
   case False then show ?thesis by simp
 next
   case True then obtain q where "n = m + q"
     by (auto simp add: le_iff_add)
   moreover have "remdups [m..<m + q] = [m..<m + q]"
     by (induct q) simp_all
   ultimately show ?thesis by simp
 qed
 
 lemma successively_remdups_adjI:
   "successively P xs \<Longrightarrow> successively P (remdups_adj xs)"
 by (induction xs rule: remdups_adj.induct) (auto simp: successively_Cons)
 
 lemma successively_remdups_adj_iff:
   "(\<And>x. x \<in> set xs \<Longrightarrow> P x x) \<Longrightarrow>
   successively P (remdups_adj xs) \<longleftrightarrow> successively P xs"
 by (induction xs rule: remdups_adj.induct)(auto simp: successively_Cons)
 
 lemma remdups_adj_Cons':
   "remdups_adj (x # xs) = x # remdups_adj (dropWhile (\<lambda>y. y = x) xs)"
 by (induction xs) auto
 
 lemma remdups_adj_singleton_iff:
   "length (remdups_adj xs) = Suc 0 \<longleftrightarrow> xs \<noteq> [] \<and> xs = replicate (length xs) (hd xs)"
 proof safe
   assume *: "xs = replicate (length xs) (hd xs)" and [simp]: "xs \<noteq> []"
   show "length (remdups_adj xs) = Suc 0"
     by (subst *) (auto simp: remdups_adj_replicate)
 next
   assume "length (remdups_adj xs) = Suc 0"
   thus "xs = replicate (length xs) (hd xs)"
     by (induction xs rule: remdups_adj.induct) (auto split: if_splits)
 qed auto
 
 lemma tl_remdups_adj:
   "ys \<noteq> [] \<Longrightarrow> tl (remdups_adj ys) = remdups_adj (dropWhile (\<lambda>x. x = hd ys) (tl ys))"
 by (cases ys) (simp_all add: remdups_adj_Cons')
 
 lemma remdups_adj_append_dropWhile:
   "remdups_adj (xs @ y # ys) = remdups_adj (xs @ [y]) @ remdups_adj (dropWhile (\<lambda>x. x = y) ys)"
 by (subst remdups_adj_append) (simp add: tl_remdups_adj)
 
 lemma remdups_adj_append':
   assumes "xs = [] \<or> ys = [] \<or> last xs \<noteq> hd ys"
   shows   "remdups_adj (xs @ ys) = remdups_adj xs @ remdups_adj ys"
 proof -
   have ?thesis if [simp]: "xs \<noteq> []" "ys \<noteq> []" and "last xs \<noteq> hd ys"
   proof -
     obtain x xs' where xs: "xs = xs' @ [x]"
       by (cases xs rule: rev_cases) auto
     have "remdups_adj (xs' @ x # ys) = remdups_adj (xs' @ [x]) @ remdups_adj ys"
       using \<open>last xs \<noteq> hd ys\<close> unfolding xs
       by (metis (full_types) dropWhile_eq_self_iff last_snoc remdups_adj_append_dropWhile)
     thus ?thesis by (simp add: xs)
   qed
   thus ?thesis using assms
     by (cases "xs = []"; cases "ys = []") auto
 qed
 
 lemma remdups_adj_append'': "xs \<noteq> []
   \<Longrightarrow> remdups_adj (xs @ ys) = remdups_adj xs @ remdups_adj (dropWhile (\<lambda>y. y = last xs) ys)"
 by (induction xs rule: remdups_adj.induct) (auto simp: remdups_adj_Cons')
 
 
 subsection \<open>@{const distinct_adj}\<close>
 
 lemma distinct_adj_Nil [simp]: "distinct_adj []"
   and distinct_adj_singleton [simp]: "distinct_adj [x]"
   and distinct_adj_Cons_Cons [simp]: "distinct_adj (x # y # xs) \<longleftrightarrow> x \<noteq> y \<and> distinct_adj (y # xs)"
 by (auto simp: distinct_adj_def)
 
 lemma distinct_adj_Cons: "distinct_adj (x # xs) \<longleftrightarrow> xs = [] \<or> x \<noteq> hd xs \<and> distinct_adj xs"
 by (cases xs) auto
 
 lemma distinct_adj_ConsD: "distinct_adj (x # xs) \<Longrightarrow> distinct_adj xs"
 by (cases xs) auto
 
 lemma distinct_adj_remdups_adj[simp]: "distinct_adj (remdups_adj xs)"
 by (induction xs rule: remdups_adj.induct) (auto simp: distinct_adj_Cons)
 
 lemma distinct_adj_altdef: "distinct_adj xs \<longleftrightarrow> remdups_adj xs = xs"
 proof
   assume "remdups_adj xs = xs"
   with distinct_adj_remdups_adj[of xs] show "distinct_adj xs"
     by simp
 next
   assume "distinct_adj xs"
   thus "remdups_adj xs = xs"
     by (induction xs rule: induct_list012) auto
 qed
 
 lemma distinct_adj_rev [simp]: "distinct_adj (rev xs) \<longleftrightarrow> distinct_adj xs"
 by (simp add: distinct_adj_def eq_commute)
 
 lemma distinct_adj_append_iff:
   "distinct_adj (xs @ ys) \<longleftrightarrow>
      distinct_adj xs \<and> distinct_adj ys \<and> (xs = [] \<or> ys = [] \<or> last xs \<noteq> hd ys)"
 by (auto simp: distinct_adj_def successively_append_iff)
 
 lemma distinct_adj_appendD1 [dest]: "distinct_adj (xs @ ys) \<Longrightarrow> distinct_adj xs"
   and distinct_adj_appendD2 [dest]: "distinct_adj (xs @ ys) \<Longrightarrow> distinct_adj ys"
   by (auto simp: distinct_adj_append_iff)
 
 lemma distinct_adj_mapI: "distinct_adj xs \<Longrightarrow> inj_on f (set xs) \<Longrightarrow> distinct_adj (map f xs)"
   unfolding distinct_adj_def successively_map
   by (erule successively_mono) (auto simp: inj_on_def)
 
 lemma distinct_adj_mapD: "distinct_adj (map f xs) \<Longrightarrow> distinct_adj xs"
 unfolding distinct_adj_def successively_map by (erule successively_mono) auto
 
 lemma distinct_adj_map_iff: "inj_on f (set xs) \<Longrightarrow> distinct_adj (map f xs) \<longleftrightarrow> distinct_adj xs"
 using distinct_adj_mapD distinct_adj_mapI by blast
 
 
 subsubsection \<open>\<^const>\<open>insert\<close>\<close>
 
 lemma in_set_insert [simp]:
   "x \<in> set xs \<Longrightarrow> List.insert x xs = xs"
 by (simp add: List.insert_def)
 
 lemma not_in_set_insert [simp]:
   "x \<notin> set xs \<Longrightarrow> List.insert x xs = x # xs"
 by (simp add: List.insert_def)
 
 lemma insert_Nil [simp]: "List.insert x [] = [x]"
 by simp
 
 lemma set_insert [simp]: "set (List.insert x xs) = insert x (set xs)"
 by (auto simp add: List.insert_def)
 
 lemma distinct_insert [simp]: "distinct (List.insert x xs) = distinct xs"
 by (simp add: List.insert_def)
 
 lemma insert_remdups:
   "List.insert x (remdups xs) = remdups (List.insert x xs)"
 by (simp add: List.insert_def)
 
 
 subsubsection \<open>\<^const>\<open>List.union\<close>\<close>
 
 text\<open>This is all one should need to know about union:\<close>
 lemma set_union[simp]: "set (List.union xs ys) = set xs \<union> set ys"
 unfolding List.union_def
 by(induct xs arbitrary: ys) simp_all
 
 lemma distinct_union[simp]: "distinct(List.union xs ys) = distinct ys"
 unfolding List.union_def
 by(induct xs arbitrary: ys) simp_all
 
 
 subsubsection \<open>\<^const>\<open>List.find\<close>\<close>
 
 lemma find_None_iff: "List.find P xs = None \<longleftrightarrow> \<not> (\<exists>x. x \<in> set xs \<and> P x)"
 proof (induction xs)
   case Nil thus ?case by simp
 next
   case (Cons x xs) thus ?case by (fastforce split: if_splits)
 qed
 
 lemmas find_None_iff2 = find_None_iff[THEN eq_iff_swap]
 
 lemma find_Some_iff:
   "List.find P xs = Some x \<longleftrightarrow>
   (\<exists>i<length xs. P (xs!i) \<and> x = xs!i \<and> (\<forall>j<i. \<not> P (xs!j)))"
 proof (induction xs)
   case Nil thus ?case by simp
 next
   case (Cons x xs) thus ?case
     apply(auto simp: nth_Cons' split: if_splits)
     using diff_Suc_1[unfolded One_nat_def] less_Suc_eq_0_disj by fastforce
 qed
 
 lemmas find_Some_iff2 = find_Some_iff[THEN eq_iff_swap]
 
 lemma find_cong[fundef_cong]:
   assumes "xs = ys" and "\<And>x. x \<in> set ys \<Longrightarrow> P x = Q x"
   shows "List.find P xs = List.find Q ys"
 proof (cases "List.find P xs")
   case None thus ?thesis by (metis find_None_iff assms)
 next
   case (Some x)
   hence "List.find Q ys = Some x" using assms
     by (auto simp add: find_Some_iff)
   thus ?thesis using Some by auto
 qed
 
 lemma find_dropWhile:
   "List.find P xs = (case dropWhile (Not \<circ> P) xs
    of [] \<Rightarrow> None
     | x # _ \<Rightarrow> Some x)"
 by (induct xs) simp_all
 
 
 subsubsection \<open>\<^const>\<open>count_list\<close>\<close>
 
 text \<open>This library is intentionally minimal. See the remark about multisets at the point above where @{const count_list} is defined.\<close>
 
 lemma count_list_append[simp]: "count_list (xs @ ys) x = count_list xs x + count_list ys x"
 by (induction xs) simp_all
 
 lemma count_list_0_iff: "count_list xs x = 0 \<longleftrightarrow> x \<notin> set xs"
 by (induction xs) simp_all
 
 lemma count_notin[simp]: "x \<notin> set xs \<Longrightarrow> count_list xs x = 0"
 by(simp add: count_list_0_iff)
 
 lemma count_le_length: "count_list xs x \<le> length xs"
 by (induction xs) auto
 
 lemma count_list_map_ge: "count_list xs x \<le> count_list (map f xs) (f x)"
 by (induction xs) auto
 
 lemma count_list_inj_map:
   "\<lbrakk> inj_on f (set xs); x \<in> set xs \<rbrakk> \<Longrightarrow> count_list (map f xs) (f x) = count_list xs x"
 by (induction xs) (simp, fastforce)
 
 lemma count_list_rev[simp]: "count_list (rev xs) x = count_list xs x"
 by (induction xs) auto
 
 lemma sum_count_set:
   "set xs \<subseteq> X \<Longrightarrow> finite X \<Longrightarrow> sum (count_list xs) X = length xs"
 proof (induction xs arbitrary: X)
   case (Cons x xs)
   then show ?case
     using sum.remove [of X x "count_list xs"]
     by (auto simp: sum.If_cases simp flip: diff_eq)
 qed simp
 
 
 subsubsection \<open>\<^const>\<open>List.extract\<close>\<close>
 
 lemma extract_None_iff: "List.extract P xs = None \<longleftrightarrow> \<not> (\<exists> x\<in>set xs. P x)"
 by(auto simp: extract_def dropWhile_eq_Cons_conv split: list.splits)
   (metis in_set_conv_decomp)
 
 lemma extract_SomeE:
  "List.extract P xs = Some (ys, y, zs) \<Longrightarrow>
   xs = ys @ y # zs \<and> P y \<and> \<not> (\<exists> y \<in> set ys. P y)"
 by(auto simp: extract_def dropWhile_eq_Cons_conv split: list.splits)
 
 lemma extract_Some_iff:
   "List.extract P xs = Some (ys, y, zs) \<longleftrightarrow>
    xs = ys @ y # zs \<and> P y \<and> \<not> (\<exists> y \<in> set ys. P y)"
 by(auto simp: extract_def dropWhile_eq_Cons_conv dest: set_takeWhileD split: list.splits)
 
 lemma extract_Nil_code[code]: "List.extract P [] = None"
 by(simp add: extract_def)
 
 lemma extract_Cons_code[code]:
   "List.extract P (x # xs) = (if P x then Some ([], x, xs) else
    (case List.extract P xs of
       None \<Rightarrow> None |
       Some (ys, y, zs) \<Rightarrow> Some (x#ys, y, zs)))"
 by(auto simp add: extract_def comp_def split: list.splits)
   (metis dropWhile_eq_Nil_conv list.distinct(1))
 
 
 subsubsection \<open>\<^const>\<open>remove1\<close>\<close>
 
 lemma remove1_append:
   "remove1 x (xs @ ys) =
   (if x \<in> set xs then remove1 x xs @ ys else xs @ remove1 x ys)"
 by (induct xs) auto
 
 lemma remove1_commute: "remove1 x (remove1 y zs) = remove1 y (remove1 x zs)"
 by (induct zs) auto
 
 lemma in_set_remove1[simp]:
   "a \<noteq> b \<Longrightarrow> a \<in> set(remove1 b xs) = (a \<in> set xs)"
   by (induct xs) auto
 
 lemma set_remove1_subset: "set(remove1 x xs) \<subseteq> set xs"
   by (induct xs) auto
 
 lemma set_remove1_eq [simp]: "distinct xs \<Longrightarrow> set(remove1 x xs) = set xs - {x}"
   by (induct xs) auto
 
 lemma length_remove1:
   "length(remove1 x xs) = (if x \<in> set xs then length xs - 1 else length xs)"
 by (induct xs) (auto dest!:length_pos_if_in_set)
 
 lemma remove1_filter_not[simp]:
   "\<not> P x \<Longrightarrow> remove1 x (filter P xs) = filter P xs"
 by(induct xs) auto
 
 lemma filter_remove1:
   "filter Q (remove1 x xs) = remove1 x (filter Q xs)"
 by (induct xs) auto
 
 lemma notin_set_remove1[simp]: "x \<notin> set xs \<Longrightarrow> x \<notin> set(remove1 y xs)"
 by(insert set_remove1_subset) fast
 
 lemma distinct_remove1[simp]: "distinct xs \<Longrightarrow> distinct(remove1 x xs)"
 by (induct xs) simp_all
 
 lemma remove1_remdups:
   "distinct xs \<Longrightarrow> remove1 x (remdups xs) = remdups (remove1 x xs)"
 by (induct xs) simp_all
 
 lemma remove1_idem: "x \<notin> set xs \<Longrightarrow> remove1 x xs = xs"
 by (induct xs) simp_all
 
 lemma remove1_split:
   "a \<in> set xs \<Longrightarrow> remove1 a xs = ys \<longleftrightarrow> (\<exists>ls rs. xs = ls @ a # rs \<and> a \<notin> set ls \<and> ys = ls @ rs)"
 by (metis remove1.simps(2) remove1_append split_list_first)
 
 
 subsubsection \<open>\<^const>\<open>removeAll\<close>\<close>
 
 lemma removeAll_filter_not_eq:
   "removeAll x = filter (\<lambda>y. x \<noteq> y)"
 proof
   fix xs
   show "removeAll x xs = filter (\<lambda>y. x \<noteq> y) xs"
     by (induct xs) auto
 qed
 
 lemma removeAll_append[simp]:
   "removeAll x (xs @ ys) = removeAll x xs @ removeAll x ys"
 by (induct xs) auto
 
 lemma set_removeAll[simp]: "set(removeAll x xs) = set xs - {x}"
 by (induct xs) auto
 
 lemma removeAll_id[simp]: "x \<notin> set xs \<Longrightarrow> removeAll x xs = xs"
 by (induct xs) auto
 
 (* Needs count:: 'a \<Rightarrow> 'a list \<Rightarrow> nat
 lemma length_removeAll:
   "length(removeAll x xs) = length xs - count x xs"
 *)
 
 lemma removeAll_filter_not[simp]:
   "\<not> P x \<Longrightarrow> removeAll x (filter P xs) = filter P xs"
 by(induct xs) auto
 
 lemma distinct_removeAll:
   "distinct xs \<Longrightarrow> distinct (removeAll x xs)"
 by (simp add: removeAll_filter_not_eq)
 
 lemma distinct_remove1_removeAll:
   "distinct xs \<Longrightarrow> remove1 x xs = removeAll x xs"
 by (induct xs) simp_all
 
 lemma map_removeAll_inj_on: "inj_on f (insert x (set xs)) \<Longrightarrow>
   map f (removeAll x xs) = removeAll (f x) (map f xs)"
 by (induct xs) (simp_all add:inj_on_def)
 
 lemma map_removeAll_inj: "inj f \<Longrightarrow>
   map f (removeAll x xs) = removeAll (f x) (map f xs)"
 by (rule map_removeAll_inj_on, erule subset_inj_on, rule subset_UNIV)
 
 lemma length_removeAll_less_eq [simp]:
   "length (removeAll x xs) \<le> length xs"
   by (simp add: removeAll_filter_not_eq)
 
 lemma length_removeAll_less [termination_simp]:
   "x \<in> set xs \<Longrightarrow> length (removeAll x xs) < length xs"
   by (auto dest: length_filter_less simp add: removeAll_filter_not_eq)
 
 lemma distinct_concat_iff: "distinct (concat xs) \<longleftrightarrow>
   distinct (removeAll [] xs) \<and>
   (\<forall>ys. ys \<in> set xs \<longrightarrow> distinct ys) \<and>
   (\<forall>ys zs. ys \<in> set xs \<and> zs \<in> set xs \<and> ys \<noteq> zs \<longrightarrow> set ys \<inter> set zs = {})"
 apply (induct xs)
  apply(simp_all, safe, auto)
 by (metis Int_iff UN_I empty_iff equals0I set_empty)
 
 
 subsubsection \<open>\<^const>\<open>replicate\<close>\<close>
 
 lemma length_replicate [simp]: "length (replicate n x) = n"
 by (induct n) auto
 
 lemma replicate_eqI:
   assumes "length xs = n" and "\<And>y. y \<in> set xs \<Longrightarrow> y = x"
   shows "xs = replicate n x"
   using assms
 proof (induct xs arbitrary: n)
   case Nil then show ?case by simp
 next
   case (Cons x xs) then show ?case by (cases n) simp_all
 qed
 
 lemma Ex_list_of_length: "\<exists>xs. length xs = n"
 by (rule exI[of _ "replicate n undefined"]) simp
 
 lemma map_replicate [simp]: "map f (replicate n x) = replicate n (f x)"
 by (induct n) auto
 
 lemma map_replicate_const:
   "map (\<lambda> x. k) lst = replicate (length lst) k"
 by (induct lst) auto
 
 lemma replicate_app_Cons_same:
 "(replicate n x) @ (x # xs) = x # replicate n x @ xs"
 by (induct n) auto
 
 lemma rev_replicate [simp]: "rev (replicate n x) = replicate n x"
 by (induct n) (auto simp: replicate_app_Cons_same)
 
 lemma replicate_add: "replicate (n + m) x = replicate n x @ replicate m x"
 by (induct n) auto
 
 text\<open>Courtesy of Matthias Daum:\<close>
 lemma append_replicate_commute:
   "replicate n x @ replicate k x = replicate k x @ replicate n x"
   by (metis add.commute replicate_add)
 
 text\<open>Courtesy of Andreas Lochbihler:\<close>
 lemma filter_replicate:
   "filter P (replicate n x) = (if P x then replicate n x else [])"
 by(induct n) auto
 
 lemma hd_replicate [simp]: "n \<noteq> 0 \<Longrightarrow> hd (replicate n x) = x"
 by (induct n) auto
 
 lemma tl_replicate [simp]: "tl (replicate n x) = replicate (n - 1) x"
 by (induct n) auto
 
 lemma last_replicate [simp]: "n \<noteq> 0 \<Longrightarrow> last (replicate n x) = x"
 by (atomize (full), induct n) auto
 
 lemma nth_replicate[simp]: "i < n \<Longrightarrow> (replicate n x)!i = x"
 by (induct n arbitrary: i)(auto simp: nth_Cons split: nat.split)
 
 text\<open>Courtesy of Matthias Daum (2 lemmas):\<close>
 lemma take_replicate[simp]: "take i (replicate k x) = replicate (min i k) x"
 proof (cases "k \<le> i")
   case True
   then show ?thesis
     by (simp add: min_def)
 next
   case False
   then have "replicate k x = replicate i x @ replicate (k - i) x"
     by (simp add: replicate_add [symmetric])
   then show ?thesis
     by (simp add: min_def)
 qed
 
 lemma drop_replicate[simp]: "drop i (replicate k x) = replicate (k-i) x"
 proof (induct k arbitrary: i)
   case (Suc k)
   then show ?case
     by (simp add: drop_Cons')
 qed simp
 
 lemma set_replicate_Suc: "set (replicate (Suc n) x) = {x}"
 by (induct n) auto
 
 lemma set_replicate [simp]: "n \<noteq> 0 \<Longrightarrow> set (replicate n x) = {x}"
 by (fast dest!: not0_implies_Suc intro!: set_replicate_Suc)
 
 lemma set_replicate_conv_if: "set (replicate n x) = (if n = 0 then {} else {x})"
 by auto
 
 lemma in_set_replicate[simp]: "(x \<in> set (replicate n y)) = (x = y \<and> n \<noteq> 0)"
 by (simp add: set_replicate_conv_if)
 
 lemma card_set_1_iff_replicate:
   "card(set xs) = Suc 0 \<longleftrightarrow> xs \<noteq> [] \<and> (\<exists>x. xs = replicate (length xs) x)"
 by (metis card_1_singleton_iff empty_iff insert_iff replicate_eqI set_empty2 set_replicate)      
 
 lemma Ball_set_replicate[simp]:
   "(\<forall>x \<in> set(replicate n a). P x) = (P a \<or> n=0)"
 by(simp add: set_replicate_conv_if)
 
 lemma Bex_set_replicate[simp]:
   "(\<exists>x \<in> set(replicate n a). P x) = (P a \<and> n\<noteq>0)"
 by(simp add: set_replicate_conv_if)
 
 lemma replicate_append_same:
   "replicate i x @ [x] = x # replicate i x"
   by (induct i) simp_all
 
 lemma map_replicate_trivial:
   "map (\<lambda>i. x) [0..<i] = replicate i x"
 by (induct i) (simp_all add: replicate_append_same)
 
 lemma concat_replicate_trivial[simp]:
   "concat (replicate i []) = []"
   by (induct i) (auto simp add: map_replicate_const)
 
 lemma replicate_empty[simp]: "(replicate n x = []) \<longleftrightarrow> n=0"
 by (induct n) auto
 
 lemmas empty_replicate[simp] = replicate_empty[THEN eq_iff_swap]
 
 lemma replicate_eq_replicate[simp]:
   "(replicate m x = replicate n y) \<longleftrightarrow> (m=n \<and> (m\<noteq>0 \<longrightarrow> x=y))"
 proof (induct m arbitrary: n)
   case (Suc m n)
   then show ?case
     by (induct n) auto
 qed simp
 
 lemma takeWhile_replicate[simp]:
   "takeWhile P (replicate n x) = (if P x then replicate n x else [])"
 using takeWhile_eq_Nil_iff by fastforce
 
 lemma dropWhile_replicate[simp]:
   "dropWhile P (replicate n x) = (if P x then [] else replicate n x)"
 using dropWhile_eq_self_iff by fastforce
 
 lemma replicate_length_filter:
   "replicate (length (filter (\<lambda>y. x = y) xs)) x = filter (\<lambda>y. x = y) xs"
   by (induct xs) auto
 
 lemma comm_append_are_replicate:
   "xs @ ys = ys @ xs \<Longrightarrow> \<exists>m n zs. concat (replicate m zs) = xs \<and> concat (replicate n zs) = ys"
 proof (induction "length (xs @ ys) + length xs" arbitrary: xs ys rule: less_induct)
   case less
   consider (1) "length ys < length xs" | (2) "xs = []" | (3) "length xs \<le> length ys \<and> xs \<noteq> []"
     by linarith
   then show ?case
   proof (cases)
     case 1
     then show ?thesis
       using less.hyps[OF _ less.prems[symmetric]] nat_add_left_cancel_less by auto
   next
     case 2
     then have "concat (replicate 0 ys) = xs \<and> concat (replicate 1 ys) = ys"
       by simp
     then show ?thesis
       by blast
   next
     case 3
     then have "length xs \<le> length ys" and "xs \<noteq> []"
       by blast+
     from \<open>length xs \<le> length ys\<close> and  \<open>xs @ ys = ys @ xs\<close>
     obtain ws where "ys = xs @ ws"
       by (auto simp: append_eq_append_conv2)
     from this and \<open>xs \<noteq> []\<close>
     have "length ws < length ys"
       by simp
     from \<open>xs @ ys = ys @ xs\<close>[unfolded \<open>ys = xs @ ws\<close>]
     have "xs @ ws = ws @ xs"
       by simp
     from less.hyps[OF _ this] \<open>length ws < length ys\<close>
     obtain m n' zs where "concat (replicate m zs) = xs" and  "concat (replicate n' zs) = ws"
       by auto
     then have "concat (replicate (m+n') zs) = ys"
       using \<open>ys = xs @ ws\<close>
       by (simp add: replicate_add)
     then show ?thesis
       using \<open>concat (replicate m zs) = xs\<close> by blast
   qed
 qed
 
 lemma comm_append_is_replicate:
   fixes xs ys :: "'a list"
   assumes "xs \<noteq> []" "ys \<noteq> []"
   assumes "xs @ ys = ys @ xs"
   shows "\<exists>n zs. n > 1 \<and> concat (replicate n zs) = xs @ ys"
 proof -
   obtain m n zs where "concat (replicate m zs) = xs"
     and "concat (replicate n zs) = ys"
     using comm_append_are_replicate[OF assms(3)] by blast
   then have "m + n > 1" and "concat (replicate (m+n) zs) = xs @ ys"
     using \<open>xs \<noteq> []\<close> and \<open>ys \<noteq> []\<close>
     by (auto simp: replicate_add)
   then show ?thesis by blast
 qed
 
 lemma Cons_replicate_eq:
   "x # xs = replicate n y \<longleftrightarrow> x = y \<and> n > 0 \<and> xs = replicate (n - 1) x"
 by (induct n) auto
 
 lemma replicate_length_same:
   "(\<forall>y\<in>set xs. y = x) \<Longrightarrow> replicate (length xs) x = xs"
 by (induct xs) simp_all
 
 lemma foldr_replicate [simp]:
   "foldr f (replicate n x) = f x ^^ n"
 by (induct n) (simp_all)
 
 lemma fold_replicate [simp]:
   "fold f (replicate n x) = f x ^^ n"
 by (subst foldr_fold [symmetric]) simp_all
 
 
 subsubsection \<open>\<^const>\<open>enumerate\<close>\<close>
 
 lemma enumerate_simps [simp, code]:
   "enumerate n [] = []"
   "enumerate n (x # xs) = (n, x) # enumerate (Suc n) xs"
   by (simp_all add: enumerate_eq_zip upt_rec)
 
 lemma length_enumerate [simp]:
   "length (enumerate n xs) = length xs"
 by (simp add: enumerate_eq_zip)
 
 lemma map_fst_enumerate [simp]:
   "map fst (enumerate n xs) = [n..<n + length xs]"
 by (simp add: enumerate_eq_zip)
 
 lemma map_snd_enumerate [simp]:
   "map snd (enumerate n xs) = xs"
 by (simp add: enumerate_eq_zip)
 
 lemma in_set_enumerate_eq:
   "p \<in> set (enumerate n xs) \<longleftrightarrow> n \<le> fst p \<and> fst p < length xs + n \<and> nth xs (fst p - n) = snd p"
 proof -
   { fix m
     assume "n \<le> m"
     moreover assume "m < length xs + n"
     ultimately have "[n..<n + length xs] ! (m - n) = m \<and>
       xs ! (m - n) = xs ! (m - n) \<and> m - n < length xs" by auto
     then have "\<exists>q. [n..<n + length xs] ! q = m \<and>
         xs ! q = xs ! (m - n) \<and> q < length xs" ..
   } then show ?thesis by (cases p) (auto simp add: enumerate_eq_zip in_set_zip)
 qed
 
 lemma nth_enumerate_eq: "m < length xs \<Longrightarrow> enumerate n xs ! m = (n + m, xs ! m)"
 by (simp add: enumerate_eq_zip)
 
 lemma enumerate_replicate_eq:
   "enumerate n (replicate m a) = map (\<lambda>q. (q, a)) [n..<n + m]"
 by (rule pair_list_eqI)
    (simp_all add: enumerate_eq_zip comp_def map_replicate_const)
 
 lemma enumerate_Suc_eq:
   "enumerate (Suc n) xs = map (apfst Suc) (enumerate n xs)"
 by (rule pair_list_eqI)
    (simp_all add: not_le, simp del: map_map add: map_Suc_upt map_map [symmetric])
 
 lemma distinct_enumerate [simp]:
   "distinct (enumerate n xs)"
 by (simp add: enumerate_eq_zip distinct_zipI1)
 
 lemma enumerate_append_eq:
   "enumerate n (xs @ ys) = enumerate n xs @ enumerate (n + length xs) ys"
   by (simp add: enumerate_eq_zip add.assoc zip_append2)
 
 lemma enumerate_map_upt:
   "enumerate n (map f [n..<m]) = map (\<lambda>k. (k, f k)) [n..<m]"
 by (cases "n \<le> m") (simp_all add: zip_map2 zip_same_conv_map enumerate_eq_zip)
 
 
 subsubsection \<open>\<^const>\<open>rotate1\<close> and \<^const>\<open>rotate\<close>\<close>
 
 lemma rotate0[simp]: "rotate 0 = id"
 by(simp add:rotate_def)
 
 lemma rotate_Suc[simp]: "rotate (Suc n) xs = rotate1(rotate n xs)"
 by(simp add:rotate_def)
 
 lemma rotate_add:
   "rotate (m+n) = rotate m \<circ> rotate n"
 by(simp add:rotate_def funpow_add)
 
 lemma rotate_rotate: "rotate m (rotate n xs) = rotate (m+n) xs"
 by(simp add:rotate_add)
 
 lemma rotate1_map: "rotate1 (map f xs) = map f (rotate1 xs)"
 by(cases xs) simp_all
 
 lemma rotate1_rotate_swap: "rotate1 (rotate n xs) = rotate n (rotate1 xs)"
 by(simp add:rotate_def funpow_swap1)
 
 lemma rotate1_length01[simp]: "length xs \<le> 1 \<Longrightarrow> rotate1 xs = xs"
 by(cases xs) simp_all
 
 lemma rotate_length01[simp]: "length xs \<le> 1 \<Longrightarrow> rotate n xs = xs"
   by (induct n) (simp_all add:rotate_def)
 
 lemma rotate1_hd_tl: "xs \<noteq> [] \<Longrightarrow> rotate1 xs = tl xs @ [hd xs]"
 by (cases xs) simp_all
 
 lemma rotate_drop_take:
   "rotate n xs = drop (n mod length xs) xs @ take (n mod length xs) xs"
 proof (induct n)
   case (Suc n)
   show ?case
   proof (cases "xs = []")
     case False
     then show ?thesis
     proof (cases "n mod length xs = 0")
       case True
       then show ?thesis
         by (auto simp add: mod_Suc False Suc.hyps drop_Suc rotate1_hd_tl take_Suc Suc_length_conv)
     next
       case False
       with \<open>xs \<noteq> []\<close> Suc
       show ?thesis
         by (simp add: rotate_def mod_Suc rotate1_hd_tl drop_Suc[symmetric] drop_tl[symmetric]
             take_hd_drop linorder_not_le)
     qed
   qed simp
 qed simp
 
 lemma rotate_conv_mod: "rotate n xs = rotate (n mod length xs) xs"
   by(simp add:rotate_drop_take)
 
 lemma rotate_id[simp]: "n mod length xs = 0 \<Longrightarrow> rotate n xs = xs"
   by(simp add:rotate_drop_take)
 
 lemma length_rotate1[simp]: "length(rotate1 xs) = length xs"
   by (cases xs) simp_all
 
 lemma length_rotate[simp]: "length(rotate n xs) = length xs"
   by (induct n arbitrary: xs) (simp_all add:rotate_def)
 
 lemma distinct1_rotate[simp]: "distinct(rotate1 xs) = distinct xs"
   by (cases xs) auto
 
 lemma distinct_rotate[simp]: "distinct(rotate n xs) = distinct xs"
   by (induct n) (simp_all add:rotate_def)
 
 lemma rotate_map: "rotate n (map f xs) = map f (rotate n xs)"
   by(simp add:rotate_drop_take take_map drop_map)
 
 lemma set_rotate1[simp]: "set(rotate1 xs) = set xs"
   by (cases xs) auto
 
 lemma set_rotate[simp]: "set(rotate n xs) = set xs"
   by (induct n) (simp_all add:rotate_def)
 
 lemma rotate1_replicate[simp]: "rotate1 (replicate n a) = replicate n a"
 by (cases n) (simp_all add: replicate_append_same)
 
 lemma rotate1_is_Nil_conv[simp]: "(rotate1 xs = []) = (xs = [])"
   by (cases xs) auto
 
 lemma rotate_is_Nil_conv[simp]: "(rotate n xs = []) = (xs = [])"
   by (induct n) (simp_all add:rotate_def)
 
 lemma rotate_rev:
   "rotate n (rev xs) = rev(rotate (length xs - (n mod length xs)) xs)"
 proof (cases "length xs = 0 \<or> n mod length xs = 0")
   case False
   then show ?thesis
     by(simp add:rotate_drop_take rev_drop rev_take)
 qed force
 
 lemma hd_rotate_conv_nth:
   assumes "xs \<noteq> []" shows "hd(rotate n xs) = xs!(n mod length xs)"
 proof -
   have "n mod length xs < length xs"
     using assms by simp
   then show ?thesis
     by (metis drop_eq_Nil hd_append2 hd_drop_conv_nth leD rotate_drop_take)
 qed
 
 lemma rotate_append: "rotate (length l) (l @ q) = q @ l"
   by (induct l arbitrary: q) (auto simp add: rotate1_rotate_swap)
 
 lemma nth_rotate:
   \<open>rotate m xs ! n = xs ! ((m + n) mod length xs)\<close> if \<open>n < length xs\<close>
   using that apply (auto simp add: rotate_drop_take nth_append not_less less_diff_conv ac_simps dest!: le_Suc_ex)
    apply (metis add.commute mod_add_right_eq mod_less)
   apply (metis (no_types, lifting) Nat.diff_diff_right add.commute add_diff_cancel_right' diff_le_self dual_order.strict_trans2 length_greater_0_conv less_nat_zero_code list.size(3) mod_add_right_eq mod_add_self2 mod_le_divisor mod_less)
   done
 
 lemma nth_rotate1:
   \<open>rotate1 xs ! n = xs ! (Suc n mod length xs)\<close> if \<open>n < length xs\<close>
   using that nth_rotate [of n xs 1] by simp
 
 lemma inj_rotate1: "inj rotate1"
 proof
   fix xs ys :: "'a list" show "rotate1 xs = rotate1 ys \<Longrightarrow> xs = ys"
     by (cases xs; cases ys; simp)
 qed
 
 lemma surj_rotate1: "surj rotate1"
 proof (safe, simp_all)
   fix xs :: "'a list" show "xs \<in> range rotate1"
   proof (cases xs rule: rev_exhaust)
     case Nil
     hence "xs = rotate1 []" by auto
     thus ?thesis by fast
   next
     case (snoc as a)
     hence "xs = rotate1 (a#as)" by force
     thus ?thesis by fast
   qed
 qed
 
 lemma bij_rotate1: "bij (rotate1 :: 'a list \<Rightarrow> 'a list)"
 using bijI inj_rotate1 surj_rotate1 by blast
 
 lemma rotate1_fixpoint_card: "rotate1 xs = xs \<Longrightarrow> xs = [] \<or> card(set xs) = 1"
 by(induction xs) (auto simp: card_insert_if[OF finite_set] append_eq_Cons_conv)
 
 
 subsubsection \<open>\<^const>\<open>nths\<close> --- a generalization of \<^const>\<open>nth\<close> to sets\<close>
 
 lemma nths_empty [simp]: "nths xs {} = []"
   by (auto simp add: nths_def)
 
 lemma nths_nil [simp]: "nths [] A = []"
   by (auto simp add: nths_def)
 
 lemma nths_all: "\<forall>i < length xs. i \<in> I \<Longrightarrow> nths xs I = xs"
 apply (simp add: nths_def)
 apply (subst filter_True)
  apply (auto simp: in_set_zip subset_iff)
 done
 
 lemma length_nths:
   "length (nths xs I) = card{i. i < length xs \<and> i \<in> I}"
   by(simp add: nths_def length_filter_conv_card cong:conj_cong)
 
 lemma nths_shift_lemma_Suc:
   "map fst (filter (\<lambda>p. P(Suc(snd p))) (zip xs is)) =
    map fst (filter (\<lambda>p. P(snd p)) (zip xs (map Suc is)))"
 proof (induct xs arbitrary: "is")
   case (Cons x xs "is")
   show ?case
     by (cases "is") (auto simp add: Cons.hyps)
 qed simp
 
 lemma nths_shift_lemma:
   "map fst (filter (\<lambda>p. snd p \<in> A) (zip xs [i..<i + length xs])) =
    map fst (filter (\<lambda>p. snd p + i \<in> A) (zip xs [0..<length xs]))"
 by (induct xs rule: rev_induct) (simp_all add: add.commute)
 
 lemma nths_append:
   "nths (l @ l') A = nths l A @ nths l' {j. j + length l \<in> A}"
   unfolding nths_def
 proof (induct l' rule: rev_induct)
   case (snoc x xs)
   then show ?case
     by (simp add: upt_add_eq_append[of 0] nths_shift_lemma add.commute)
 qed auto
 
 lemma nths_Cons:
   "nths (x # l) A = (if 0 \<in> A then [x] else []) @ nths l {j. Suc j \<in> A}"
 proof (induct l rule: rev_induct)
   case (snoc x xs)
   then show ?case
     by (simp flip: append_Cons add: nths_append)
 qed (auto simp: nths_def)
 
 lemma nths_map: "nths (map f xs) I = map f (nths xs I)"
   by(induction xs arbitrary: I) (simp_all add: nths_Cons)
 
 lemma set_nths: "set(nths xs I) = {xs!i|i. i<size xs \<and> i \<in> I}"
   by (induct xs arbitrary: I) (auto simp: nths_Cons nth_Cons split:nat.split dest!: gr0_implies_Suc)
 
 lemma set_nths_subset: "set(nths xs I) \<subseteq> set xs"
   by(auto simp add:set_nths)
 
 lemma notin_set_nthsI[simp]: "x \<notin> set xs \<Longrightarrow> x \<notin> set(nths xs I)"
   by(auto simp add:set_nths)
 
 lemma in_set_nthsD: "x \<in> set(nths xs I) \<Longrightarrow> x \<in> set xs"
   by(auto simp add:set_nths)
 
 lemma nths_singleton [simp]: "nths [x] A = (if 0 \<in> A then [x] else [])"
   by (simp add: nths_Cons)
 
 lemma distinct_nthsI[simp]: "distinct xs \<Longrightarrow> distinct (nths xs I)"
   by (induct xs arbitrary: I) (auto simp: nths_Cons)
 
 lemma nths_upt_eq_take [simp]: "nths l {..<n} = take n l"
   by (induct l rule: rev_induct) (simp_all split: nat_diff_split add: nths_append)
 
 lemma nths_nths: "nths (nths xs A) B = nths xs {i \<in> A. \<exists>j \<in> B. card {i' \<in> A. i' < i} = j}"
   by (induction xs arbitrary: A B) (auto simp add: nths_Cons card_less_Suc card_less_Suc2)
 
 lemma drop_eq_nths: "drop n xs = nths xs {i. i \<ge> n}"
   by (induction xs arbitrary: n) (auto simp add: nths_Cons nths_all drop_Cons' intro: arg_cong2[where f=nths, OF refl])
 
 lemma nths_drop: "nths (drop n xs) I = nths xs ((+) n ` I)"
 by(force simp: drop_eq_nths nths_nths simp flip: atLeastLessThan_iff
          intro: arg_cong2[where f=nths, OF refl])
 
 lemma filter_eq_nths: "filter P xs = nths xs {i. i<length xs \<and> P(xs!i)}"
   by(induction xs) (auto simp: nths_Cons)
 
 lemma filter_in_nths:
   "distinct xs \<Longrightarrow> filter (%x. x \<in> set (nths xs s)) xs = nths xs s"
 proof (induct xs arbitrary: s)
   case Nil thus ?case by simp
 next
   case (Cons a xs)
   then have "\<forall>x. x \<in> set xs \<longrightarrow> x \<noteq> a" by auto
   with Cons show ?case by(simp add: nths_Cons cong:filter_cong)
 qed
 
 
 subsubsection \<open>\<^const>\<open>subseqs\<close> and \<^const>\<open>List.n_lists\<close>\<close>
 
 lemma length_subseqs: "length (subseqs xs) = 2 ^ length xs"
   by (induct xs) (simp_all add: Let_def)
 
 lemma subseqs_powset: "set ` set (subseqs xs) = Pow (set xs)"
 proof -
   have aux: "\<And>x A. set ` Cons x ` A = insert x ` set ` A"
     by (auto simp add: image_def)
   have "set (map set (subseqs xs)) = Pow (set xs)"
     by (induct xs) (simp_all add: aux Let_def Pow_insert Un_commute comp_def del: map_map)
   then show ?thesis by simp
 qed
 
 lemma distinct_set_subseqs:
   assumes "distinct xs"
   shows "distinct (map set (subseqs xs))"
   by (simp add: assms card_Pow card_distinct distinct_card length_subseqs subseqs_powset)
 
 lemma n_lists_Nil [simp]: "List.n_lists n [] = (if n = 0 then [[]] else [])"
   by (induct n) simp_all
 
 lemma length_n_lists_elem: "ys \<in> set (List.n_lists n xs) \<Longrightarrow> length ys = n"
   by (induct n arbitrary: ys) auto
 
 lemma set_n_lists: "set (List.n_lists n xs) = {ys. length ys = n \<and> set ys \<subseteq> set xs}"
 proof (rule set_eqI)
   fix ys :: "'a list"
   show "ys \<in> set (List.n_lists n xs) \<longleftrightarrow> ys \<in> {ys. length ys = n \<and> set ys \<subseteq> set xs}"
   proof -
     have "ys \<in> set (List.n_lists n xs) \<Longrightarrow> length ys = n"
       by (induct n arbitrary: ys) auto
     moreover have "\<And>x. ys \<in> set (List.n_lists n xs) \<Longrightarrow> x \<in> set ys \<Longrightarrow> x \<in> set xs"
       by (induct n arbitrary: ys) auto
     moreover have "set ys \<subseteq> set xs \<Longrightarrow> ys \<in> set (List.n_lists (length ys) xs)"
       by (induct ys) auto
     ultimately show ?thesis by auto
   qed
 qed
 
 lemma subseqs_refl: "xs \<in> set (subseqs xs)"
   by (induct xs) (simp_all add: Let_def)
 
 lemma subset_subseqs: "X \<subseteq> set xs \<Longrightarrow> X \<in> set ` set (subseqs xs)"
   unfolding subseqs_powset by simp
 
 lemma Cons_in_subseqsD: "y # ys \<in> set (subseqs xs) \<Longrightarrow> ys \<in> set (subseqs xs)"
   by (induct xs) (auto simp: Let_def)
 
 lemma subseqs_distinctD: "\<lbrakk> ys \<in> set (subseqs xs); distinct xs \<rbrakk> \<Longrightarrow> distinct ys"
 proof (induct xs arbitrary: ys)
   case (Cons x xs ys)
   then show ?case
     by (auto simp: Let_def) (metis Pow_iff contra_subsetD image_eqI subseqs_powset)
 qed simp
 
 
 subsubsection \<open>\<^const>\<open>splice\<close>\<close>
 
 lemma splice_Nil2 [simp]: "splice xs [] = xs"
   by (cases xs) simp_all
 
 lemma length_splice[simp]: "length(splice xs ys) = length xs + length ys"
   by (induct xs ys rule: splice.induct) auto
 
 lemma split_Nil_iff[simp]: "splice xs ys = [] \<longleftrightarrow> xs = [] \<and> ys = []"
   by (induct xs ys rule: splice.induct) auto
 
 lemma splice_replicate[simp]: "splice (replicate m x) (replicate n x) = replicate (m+n) x"
 proof (induction "replicate m x" "replicate n x" arbitrary: m n rule: splice.induct)
   case (2 x xs)
   then show ?case
     by (auto simp add: Cons_replicate_eq dest: gr0_implies_Suc)
 qed auto
 
 subsubsection \<open>\<^const>\<open>shuffles\<close>\<close>
 
 lemma shuffles_commutes: "shuffles xs ys = shuffles ys xs"
 by (induction xs ys rule: shuffles.induct) (simp_all add: Un_commute)
 
 lemma Nil_in_shuffles[simp]: "[] \<in> shuffles xs ys \<longleftrightarrow> xs = [] \<and> ys = []"
   by (induct xs ys rule: shuffles.induct) auto
 
 lemma shufflesE:
   "zs \<in> shuffles xs ys \<Longrightarrow>
     (zs = xs \<Longrightarrow> ys = [] \<Longrightarrow> P) \<Longrightarrow>
     (zs = ys \<Longrightarrow> xs = [] \<Longrightarrow> P) \<Longrightarrow>
     (\<And>x xs' z zs'. xs = x # xs' \<Longrightarrow> zs = z # zs' \<Longrightarrow> x = z \<Longrightarrow> zs' \<in> shuffles xs' ys \<Longrightarrow> P) \<Longrightarrow>
     (\<And>y ys' z zs'. ys = y # ys' \<Longrightarrow> zs = z # zs' \<Longrightarrow> y = z \<Longrightarrow> zs' \<in> shuffles xs ys' \<Longrightarrow> P) \<Longrightarrow> P"
   by (induct xs ys rule: shuffles.induct) auto
 
 lemma Cons_in_shuffles_iff:
   "z # zs \<in> shuffles xs ys \<longleftrightarrow>
     (xs \<noteq> [] \<and> hd xs = z \<and> zs \<in> shuffles (tl xs) ys \<or>
      ys \<noteq> [] \<and> hd ys = z \<and> zs \<in> shuffles xs (tl ys))"
   by (induct xs ys rule: shuffles.induct) auto
 
 lemma splice_in_shuffles [simp, intro]: "splice xs ys \<in> shuffles xs ys"
   by (induction xs ys rule: splice.induct) (simp_all add: Cons_in_shuffles_iff shuffles_commutes)
 
 lemma Nil_in_shufflesI: "xs = [] \<Longrightarrow> ys = [] \<Longrightarrow> [] \<in> shuffles xs ys"
   by simp
 
 lemma Cons_in_shuffles_leftI: "zs \<in> shuffles xs ys \<Longrightarrow> z # zs \<in> shuffles (z # xs) ys"
   by (cases ys) auto
 
 lemma Cons_in_shuffles_rightI: "zs \<in> shuffles xs ys \<Longrightarrow> z # zs \<in> shuffles xs (z # ys)"
   by (cases xs) auto
 
 lemma finite_shuffles [simp, intro]: "finite (shuffles xs ys)"
   by (induction xs ys rule: shuffles.induct) simp_all
 
 lemma length_shuffles: "zs \<in> shuffles xs ys \<Longrightarrow> length zs = length xs + length ys"
   by (induction xs ys arbitrary: zs rule: shuffles.induct) auto
 
 lemma set_shuffles: "zs \<in> shuffles xs ys \<Longrightarrow> set zs = set xs \<union> set ys"
   by (induction xs ys arbitrary: zs rule: shuffles.induct) auto
 
 lemma distinct_disjoint_shuffles:
   assumes "distinct xs" "distinct ys" "set xs \<inter> set ys = {}" "zs \<in> shuffles xs ys"
   shows   "distinct zs"
 using assms
 proof (induction xs ys arbitrary: zs rule: shuffles.induct)
   case (3 x xs y ys)
   show ?case
   proof (cases zs)
     case (Cons z zs')
     with "3.prems" and "3.IH"[of zs'] show ?thesis by (force dest: set_shuffles)
   qed simp_all
 qed simp_all
 
 lemma Cons_shuffles_subset1: "(#) x ` shuffles xs ys \<subseteq> shuffles (x # xs) ys"
   by (cases ys) auto
 
 lemma Cons_shuffles_subset2: "(#) y ` shuffles xs ys \<subseteq> shuffles xs (y # ys)"
   by (cases xs) auto
 
 lemma filter_shuffles:
   "filter P ` shuffles xs ys = shuffles (filter P xs) (filter P ys)"
 proof -
   have *: "filter P ` (#) x ` A = (if P x then (#) x ` filter P ` A else filter P ` A)" for x A
     by (auto simp: image_image)
   show ?thesis
   by (induction xs ys rule: shuffles.induct)
      (simp_all split: if_splits add: image_Un * Un_absorb1 Un_absorb2
            Cons_shuffles_subset1 Cons_shuffles_subset2)
 qed
 
 lemma filter_shuffles_disjoint1:
   assumes "set xs \<inter> set ys = {}" "zs \<in> shuffles xs ys"
   shows   "filter (\<lambda>x. x \<in> set xs) zs = xs" (is "filter ?P _ = _")
     and   "filter (\<lambda>x. x \<notin> set xs) zs = ys" (is "filter ?Q _ = _")
   using assms
 proof -
   from assms have "filter ?P zs \<in> filter ?P ` shuffles xs ys" by blast
   also have "filter ?P ` shuffles xs ys = shuffles (filter ?P xs) (filter ?P ys)"
     by (rule filter_shuffles)
   also have "filter ?P xs = xs" by (rule filter_True) simp_all
   also have "filter ?P ys = []" by (rule filter_False) (insert assms(1), auto)
   also have "shuffles xs [] = {xs}" by simp
   finally show "filter ?P zs = xs" by simp
 next
   from assms have "filter ?Q zs \<in> filter ?Q ` shuffles xs ys" by blast
   also have "filter ?Q ` shuffles xs ys = shuffles (filter ?Q xs) (filter ?Q ys)"
     by (rule filter_shuffles)
   also have "filter ?Q ys = ys" by (rule filter_True) (insert assms(1), auto)
   also have "filter ?Q xs = []" by (rule filter_False) (insert assms(1), auto)
   also have "shuffles [] ys = {ys}" by simp
   finally show "filter ?Q zs = ys" by simp
 qed
 
 lemma filter_shuffles_disjoint2:
   assumes "set xs \<inter> set ys = {}" "zs \<in> shuffles xs ys"
   shows   "filter (\<lambda>x. x \<in> set ys) zs = ys" "filter (\<lambda>x. x \<notin> set ys) zs = xs"
   using filter_shuffles_disjoint1[of ys xs zs] assms
   by (simp_all add: shuffles_commutes Int_commute)
 
 lemma partition_in_shuffles:
   "xs \<in> shuffles (filter P xs) (filter (\<lambda>x. \<not>P x) xs)"
 proof (induction xs)
   case (Cons x xs)
   show ?case
   proof (cases "P x")
     case True
     hence "x # xs \<in> (#) x ` shuffles (filter P xs) (filter (\<lambda>x. \<not>P x) xs)"
       by (intro imageI Cons.IH)
     also have "\<dots> \<subseteq> shuffles (filter P (x # xs)) (filter (\<lambda>x. \<not>P x) (x # xs))"
       by (simp add: True Cons_shuffles_subset1)
     finally show ?thesis .
   next
     case False
     hence "x # xs \<in> (#) x ` shuffles (filter P xs) (filter (\<lambda>x. \<not>P x) xs)"
       by (intro imageI Cons.IH)
     also have "\<dots> \<subseteq> shuffles (filter P (x # xs)) (filter (\<lambda>x. \<not>P x) (x # xs))"
       by (simp add: False Cons_shuffles_subset2)
     finally show ?thesis .
   qed
 qed auto
 
 lemma inv_image_partition:
   assumes "\<And>x. x \<in> set xs \<Longrightarrow> P x" "\<And>y. y \<in> set ys \<Longrightarrow> \<not>P y"
   shows   "partition P -` {(xs, ys)} = shuffles xs ys"
 proof (intro equalityI subsetI)
   fix zs assume zs: "zs \<in> shuffles xs ys"
   hence [simp]: "set zs = set xs \<union> set ys" by (rule set_shuffles)
   from assms have "filter P zs = filter (\<lambda>x. x \<in> set xs) zs"
                   "filter (\<lambda>x. \<not>P x) zs = filter (\<lambda>x. x \<in> set ys) zs"
     by (intro filter_cong refl; force)+
   moreover from assms have "set xs \<inter> set ys = {}" by auto
   ultimately show "zs \<in> partition P -` {(xs, ys)}" using zs
     by (simp add: o_def filter_shuffles_disjoint1 filter_shuffles_disjoint2)
 next
   fix zs assume "zs \<in> partition P -` {(xs, ys)}"
   thus "zs \<in> shuffles xs ys" using partition_in_shuffles[of zs] by (auto simp: o_def)
 qed
 
 
 subsubsection \<open>Transpose\<close>
 
 function transpose where
 "transpose []             = []" |
 "transpose ([]     # xss) = transpose xss" |
 "transpose ((x#xs) # xss) =
   (x # [h. (h#t) \<leftarrow> xss]) # transpose (xs # [t. (h#t) \<leftarrow> xss])"
 by pat_completeness auto
 
 lemma transpose_aux_filter_head:
   "concat (map (case_list [] (\<lambda>h t. [h])) xss) =
   map (\<lambda>xs. hd xs) (filter (\<lambda>ys. ys \<noteq> []) xss)"
   by (induct xss) (auto split: list.split)
 
 lemma transpose_aux_filter_tail:
   "concat (map (case_list [] (\<lambda>h t. [t])) xss) =
   map (\<lambda>xs. tl xs) (filter (\<lambda>ys. ys \<noteq> []) xss)"
   by (induct xss) (auto split: list.split)
 
 lemma transpose_aux_max:
   "max (Suc (length xs)) (foldr (\<lambda>xs. max (length xs)) xss 0) =
   Suc (max (length xs) (foldr (\<lambda>x. max (length x - Suc 0)) (filter (\<lambda>ys. ys \<noteq> []) xss) 0))"
   (is "max _ ?foldB = Suc (max _ ?foldA)")
 proof (cases "(filter (\<lambda>ys. ys \<noteq> []) xss) = []")
   case True
   hence "foldr (\<lambda>xs. max (length xs)) xss 0 = 0"
   proof (induct xss)
     case (Cons x xs)
     then have "x = []" by (cases x) auto
     with Cons show ?case by auto
   qed simp
   thus ?thesis using True by simp
 next
   case False
 
   have foldA: "?foldA = foldr (\<lambda>x. max (length x)) (filter (\<lambda>ys. ys \<noteq> []) xss) 0 - 1"
     by (induct xss) auto
   have foldB: "?foldB = foldr (\<lambda>x. max (length x)) (filter (\<lambda>ys. ys \<noteq> []) xss) 0"
     by (induct xss) auto
 
   have "0 < ?foldB"
   proof -
     from False
     obtain z zs where zs: "(filter (\<lambda>ys. ys \<noteq> []) xss) = z#zs" by (auto simp: neq_Nil_conv)
     hence "z \<in> set (filter (\<lambda>ys. ys \<noteq> []) xss)" by auto
     hence "z \<noteq> []" by auto
     thus ?thesis
       unfolding foldB zs
       by (auto simp: max_def intro: less_le_trans)
   qed
   thus ?thesis
     unfolding foldA foldB max_Suc_Suc[symmetric]
     by simp
 qed
 
 termination transpose
   by (relation "measure (\<lambda>xs. foldr (\<lambda>xs. max (length xs)) xs 0 + length xs)")
      (auto simp: transpose_aux_filter_tail foldr_map comp_def transpose_aux_max less_Suc_eq_le)
 
 lemma transpose_empty: "(transpose xs = []) \<longleftrightarrow> (\<forall>x \<in> set xs. x = [])"
   by (induct rule: transpose.induct) simp_all
 
 lemma length_transpose:
   fixes xs :: "'a list list"
   shows "length (transpose xs) = foldr (\<lambda>xs. max (length xs)) xs 0"
   by (induct rule: transpose.induct)
     (auto simp: transpose_aux_filter_tail foldr_map comp_def transpose_aux_max
                 max_Suc_Suc[symmetric] simp del: max_Suc_Suc)
 
 lemma nth_transpose:
   fixes xs :: "'a list list"
   assumes "i < length (transpose xs)"
   shows "transpose xs ! i = map (\<lambda>xs. xs ! i) (filter (\<lambda>ys. i < length ys) xs)"
 using assms proof (induct arbitrary: i rule: transpose.induct)
   case (3 x xs xss)
   define XS where "XS = (x # xs) # xss"
   hence [simp]: "XS \<noteq> []" by auto
   thus ?case
   proof (cases i)
     case 0
     thus ?thesis by (simp add: transpose_aux_filter_head hd_conv_nth)
   next
     case (Suc j)
     have *: "\<And>xss. xs # map tl xss = map tl ((x#xs)#xss)" by simp
     have **: "\<And>xss. (x#xs) # filter (\<lambda>ys. ys \<noteq> []) xss = filter (\<lambda>ys. ys \<noteq> []) ((x#xs)#xss)" by simp
     { fix xs :: \<open>'a list\<close> have "Suc j < length xs \<longleftrightarrow> xs \<noteq> [] \<and> j < length xs - Suc 0"
       by (cases xs) simp_all
     } note *** = this
 
     have j_less: "j < length (transpose (xs # concat (map (case_list [] (\<lambda>h t. [t])) xss)))"
       using "3.prems" by (simp add: transpose_aux_filter_tail length_transpose Suc)
 
     show ?thesis
       unfolding transpose.simps \<open>i = Suc j\<close> nth_Cons_Suc "3.hyps"[OF j_less]
       apply (auto simp: transpose_aux_filter_tail filter_map comp_def length_transpose * ** *** XS_def[symmetric])
       by (simp add: nth_tl)
   qed
 qed simp_all
 
 lemma transpose_map_map:
   "transpose (map (map f) xs) = map (map f) (transpose xs)"
 proof (rule nth_equalityI)
   have [simp]: "length (transpose (map (map f) xs)) = length (transpose xs)"
     by (simp add: length_transpose foldr_map comp_def)
   show "length (transpose (map (map f) xs)) = length (map (map f) (transpose xs))" by simp
 
   fix i assume "i < length (transpose (map (map f) xs))"
   thus "transpose (map (map f) xs) ! i = map (map f) (transpose xs) ! i"
     by (simp add: nth_transpose filter_map comp_def)
 qed
 
 
 subsubsection \<open>\<^const>\<open>min\<close> and \<^const>\<open>arg_min\<close>\<close>
 
 lemma min_list_Min: "xs \<noteq> [] \<Longrightarrow> min_list xs = Min (set xs)"
   by (induction xs rule: induct_list012)(auto)
 
 lemma f_arg_min_list_f: "xs \<noteq> [] \<Longrightarrow> f (arg_min_list f xs) = Min (f ` (set xs))"
   by(induction f xs rule: arg_min_list.induct) (auto simp: min_def intro!: antisym)
 
 lemma arg_min_list_in: "xs \<noteq> [] \<Longrightarrow> arg_min_list f xs \<in> set xs"
   by(induction xs rule: induct_list012) (auto simp: Let_def)
 
 
 subsubsection \<open>(In)finiteness\<close>
 
 lemma finite_maxlen:
   "finite (M::'a list set) \<Longrightarrow> \<exists>n. \<forall>s\<in>M. size s < n"
 proof (induct rule: finite.induct)
   case emptyI show ?case by simp
 next
   case (insertI M xs)
   then obtain n where "\<forall>s\<in>M. length s < n" by blast
   hence "\<forall>s\<in>insert xs M. size s < max n (size xs) + 1" by auto
   thus ?case ..
 qed
 
 lemma lists_length_Suc_eq:
   "{xs. set xs \<subseteq> A \<and> length xs = Suc n} =
     (\<lambda>(xs, n). n#xs) ` ({xs. set xs \<subseteq> A \<and> length xs = n} \<times> A)"
   by (auto simp: length_Suc_conv)
 
 lemma
   assumes "finite A"
   shows finite_lists_length_eq: "finite {xs. set xs \<subseteq> A \<and> length xs = n}"
   and card_lists_length_eq: "card {xs. set xs \<subseteq> A \<and> length xs = n} = (card A)^n"
   using \<open>finite A\<close>
   by (induct n)
      (auto simp: card_image inj_split_Cons lists_length_Suc_eq cong: conj_cong)
 
 lemma finite_lists_length_le:
   assumes "finite A" shows "finite {xs. set xs \<subseteq> A \<and> length xs \<le> n}"
  (is "finite ?S")
 proof-
   have "?S = (\<Union>n\<in>{0..n}. {xs. set xs \<subseteq> A \<and> length xs = n})" by auto
   thus ?thesis by (auto intro!: finite_lists_length_eq[OF \<open>finite A\<close>] simp only:)
 qed
 
 lemma card_lists_length_le:
   assumes "finite A" shows "card {xs. set xs \<subseteq> A \<and> length xs \<le> n} = (\<Sum>i\<le>n. card A^i)"
 proof -
   have "(\<Sum>i\<le>n. card A^i) = card (\<Union>i\<le>n. {xs. set xs \<subseteq> A \<and> length xs = i})"
     using \<open>finite A\<close>
     by (subst card_UN_disjoint)
        (auto simp add: card_lists_length_eq finite_lists_length_eq)
   also have "(\<Union>i\<le>n. {xs. set xs \<subseteq> A \<and> length xs = i}) = {xs. set xs \<subseteq> A \<and> length xs \<le> n}"
     by auto
   finally show ?thesis by simp
 qed
 
 lemma finite_lists_distinct_length_eq [intro]:
   assumes "finite A"
   shows "finite {xs. length xs = n \<and> distinct xs \<and> set xs \<subseteq> A}" (is "finite ?S")
 proof -
   have "finite {xs. set xs \<subseteq> A \<and> length xs = n}"
     using \<open>finite A\<close> by (rule finite_lists_length_eq)
   moreover have "?S \<subseteq> {xs. set xs \<subseteq> A \<and> length xs = n}" by auto
   ultimately show ?thesis using finite_subset by auto
 qed
 
 lemma card_lists_distinct_length_eq:
   assumes "finite A" "k \<le> card A"
   shows "card {xs. length xs = k \<and> distinct xs \<and> set xs \<subseteq> A} = \<Prod>{card A - k + 1 .. card A}"
 using assms
 proof (induct k)
   case 0
   then have "{xs. length xs = 0 \<and> distinct xs \<and> set xs \<subseteq> A} = {[]}" by auto
   then show ?case by simp
 next
   case (Suc k)
   let "?k_list" = "\<lambda>k xs. length xs = k \<and> distinct xs \<and> set xs \<subseteq> A"
   have inj_Cons: "\<And>A. inj_on (\<lambda>(xs, n). n # xs) A"  by (rule inj_onI) auto
 
   from Suc have "k \<le> card A" by simp
   moreover note \<open>finite A\<close>
   moreover have "finite {xs. ?k_list k xs}"
     by (rule finite_subset) (use finite_lists_length_eq[OF \<open>finite A\<close>, of k] in auto)
   moreover have "\<And>i j. i \<noteq> j \<longrightarrow> {i} \<times> (A - set i) \<inter> {j} \<times> (A - set j) = {}"
     by auto
   moreover have "\<And>i. i \<in> {xs. ?k_list k xs} \<Longrightarrow> card (A - set i) = card A - k"
     by (simp add: card_Diff_subset distinct_card)
   moreover have "{xs. ?k_list (Suc k) xs} =
       (\<lambda>(xs, n). n#xs) ` \<Union>((\<lambda>xs. {xs} \<times> (A - set xs)) ` {xs. ?k_list k xs})"
     by (auto simp: length_Suc_conv)
   moreover have "Suc (card A - Suc k) = card A - k" using Suc.prems by simp
   then have "(card A - k) * \<Prod>{Suc (card A - k)..card A} = \<Prod>{Suc (card A - Suc k)..card A}"
     by (subst prod.insert[symmetric]) (simp add: atLeastAtMost_insertL)+
   ultimately show ?case
     by (simp add: card_image inj_Cons card_UN_disjoint Suc.hyps algebra_simps)
 qed
 
 lemma card_lists_distinct_length_eq':
   assumes "k < card A"
   shows "card {xs. length xs = k \<and> distinct xs \<and> set xs \<subseteq> A} = \<Prod>{card A - k + 1 .. card A}"
 proof -
   from \<open>k < card A\<close> have "finite A" and "k \<le> card A" using card.infinite by force+
   from this show ?thesis by (rule card_lists_distinct_length_eq)
 qed
 
 lemma infinite_UNIV_listI: "\<not> finite(UNIV::'a list set)"
   by (metis UNIV_I finite_maxlen length_replicate less_irrefl)
 
 lemma same_length_different:
   assumes "xs \<noteq> ys" and "length xs = length ys"
   shows "\<exists>pre x xs' y ys'. x\<noteq>y \<and> xs = pre @ [x] @ xs' \<and> ys = pre @ [y] @ ys'"
   using assms
 proof (induction xs arbitrary: ys)
   case Nil
   then show ?case by auto
 next
   case (Cons x xs)
   then obtain z zs where ys: "ys = Cons z zs"
     by (metis length_Suc_conv)
   show ?case
   proof (cases "x=z")
     case True
     then have "xs \<noteq> zs" "length xs = length zs"
       using Cons.prems ys by auto
     then obtain pre u xs' v ys' where "u\<noteq>v" and xs: "xs = pre @ [u] @ xs'" and zs: "zs = pre @ [v] @ys'"
       using Cons.IH by meson
     then have "x # xs = (z#pre) @ [u] @ xs' \<and> ys = (z#pre) @ [v] @ ys'"
       by (simp add: True ys)
     with \<open>u\<noteq>v\<close> show ?thesis
       by blast
   next
     case False
     then have "x # xs = [] @ [x] @ xs \<and> ys = [] @ [z] @ zs"
       by (simp add: ys)
     then show ?thesis
       using False by blast
   qed
 qed
 
 subsection \<open>Sorting\<close>
 
 subsubsection \<open>\<^const>\<open>sorted_wrt\<close>\<close>
 
 text \<open>Sometimes the second equation in the definition of \<^const>\<open>sorted_wrt\<close> is too aggressive
 because it relates each list element to \emph{all} its successors. Then this equation
 should be removed and \<open>sorted_wrt2_simps\<close> should be added instead.\<close>
 
 lemma sorted_wrt1: "sorted_wrt P [x] = True"
 by(simp)
 
 lemma sorted_wrt2: "transp P \<Longrightarrow> sorted_wrt P (x # y # zs) = (P x y \<and> sorted_wrt P (y # zs))"
 proof (induction zs arbitrary: x y)
   case (Cons z zs)
   then show ?case
     by simp (meson transpD)+
 qed auto
 
 lemmas sorted_wrt2_simps = sorted_wrt1 sorted_wrt2
 
 lemma sorted_wrt_true [simp]:
   "sorted_wrt (\<lambda>_ _. True) xs"
 by (induction xs) simp_all
 
 lemma sorted_wrt_append:
   "sorted_wrt P (xs @ ys) \<longleftrightarrow>
   sorted_wrt P xs \<and> sorted_wrt P ys \<and> (\<forall>x\<in>set xs. \<forall>y\<in>set ys. P x y)"
 by (induction xs) auto
 
 lemma sorted_wrt_map:
   "sorted_wrt R (map f xs) = sorted_wrt (\<lambda>x y. R (f x) (f y)) xs"
 by (induction xs) simp_all
 
 lemma
   assumes "sorted_wrt f xs"
   shows sorted_wrt_take: "sorted_wrt f (take n xs)"
   and   sorted_wrt_drop: "sorted_wrt f (drop n xs)"
 proof -
   from assms have "sorted_wrt f (take n xs @ drop n xs)" by simp
   thus "sorted_wrt f (take n xs)" and "sorted_wrt f (drop n xs)"
     unfolding sorted_wrt_append by simp_all
 qed
 
 lemma sorted_wrt_filter:
   "sorted_wrt f xs \<Longrightarrow> sorted_wrt f (filter P xs)"
 by (induction xs) auto
 
 lemma sorted_wrt_rev:
   "sorted_wrt P (rev xs) = sorted_wrt (\<lambda>x y. P y x) xs"
 by (induction xs) (auto simp add: sorted_wrt_append)
 
 lemma sorted_wrt_mono_rel:
   "(\<And>x y. \<lbrakk> x \<in> set xs; y \<in> set xs; P x y \<rbrakk> \<Longrightarrow> Q x y) \<Longrightarrow> sorted_wrt P xs \<Longrightarrow> sorted_wrt Q xs"
 by(induction xs)(auto)
 
 lemma sorted_wrt01: "length xs \<le> 1 \<Longrightarrow> sorted_wrt P xs"
 by(auto simp: le_Suc_eq length_Suc_conv)
 
 lemma sorted_wrt_iff_nth_less:
   "sorted_wrt P xs = (\<forall>i j. i < j \<longrightarrow> j < length xs \<longrightarrow> P (xs ! i) (xs ! j))"
   by (induction xs) (auto simp add: in_set_conv_nth Ball_def nth_Cons split: nat.split)
 
 lemma sorted_wrt_nth_less:
   "\<lbrakk> sorted_wrt P xs; i < j; j < length xs \<rbrakk> \<Longrightarrow> P (xs ! i) (xs ! j)"
 by(auto simp: sorted_wrt_iff_nth_less)
 
 lemma sorted_wrt_iff_nth_Suc_transp: assumes "transp P"
   shows "sorted_wrt P xs \<longleftrightarrow> (\<forall>i.  Suc i < length xs \<longrightarrow> P (xs!i) (xs!(Suc i)))" (is "?L = ?R")
 proof
   assume ?L
   thus ?R
     by (simp add: sorted_wrt_iff_nth_less)
 next
   assume ?R
   have "i < j \<Longrightarrow> j < length xs \<Longrightarrow> P (xs ! i) (xs ! j)" for i j
     by(induct i j rule: less_Suc_induct)(simp add: \<open>?R\<close>, meson assms transpE transp_on_less)
   thus ?L
     by (simp add: sorted_wrt_iff_nth_less)
 qed
 
 lemma sorted_wrt_upt[simp]: "sorted_wrt (<) [m..<n]"
 by(induction n) (auto simp: sorted_wrt_append)
 
 lemma sorted_wrt_upto[simp]: "sorted_wrt (<) [i..j]"
 proof(induct i j rule:upto.induct)
   case (1 i j)
   from this show ?case
     unfolding upto.simps[of i j] by auto
 qed
 
 text \<open>Each element is greater or equal to its index:\<close>
 
 lemma sorted_wrt_less_idx:
   "sorted_wrt (<) ns \<Longrightarrow> i < length ns \<Longrightarrow> i \<le> ns!i"
 proof (induction ns arbitrary: i rule: rev_induct)
   case Nil thus ?case by simp
 next
   case snoc
   thus ?case
     by (simp add: nth_append sorted_wrt_append)
        (metis less_antisym not_less nth_mem)
 qed
 
 
 subsubsection \<open>\<^const>\<open>sorted\<close>\<close>
 
 context linorder
 begin
 
 text \<open>Sometimes the second equation in the definition of \<^const>\<open>sorted\<close> is too aggressive
 because it relates each list element to \emph{all} its successors. Then this equation
 should be removed and \<open>sorted2_simps\<close> should be added instead.
 Executable code is one such use case.\<close>
 
 lemma sorted0: "sorted [] = True"
   by simp
 
 lemma sorted1: "sorted [x] = True"
   by simp
 
 lemma sorted2: "sorted (x # y # zs) = (x \<le> y \<and> sorted (y # zs))"
   by auto
 
 lemmas sorted2_simps = sorted1 sorted2
 
 lemma sorted_append:
   "sorted (xs@ys) = (sorted xs \<and> sorted ys \<and> (\<forall>x \<in> set xs. \<forall>y \<in> set ys. x\<le>y))"
 by (simp add: sorted_wrt_append)
 
 lemma sorted_map:
   "sorted (map f xs) = sorted_wrt (\<lambda>x y. f x \<le> f y) xs"
   by (simp add: sorted_wrt_map)
 
 lemma sorted01: "length xs \<le> 1 \<Longrightarrow> sorted xs"
   by (simp add: sorted_wrt01)
 
 lemma sorted_tl:
   "sorted xs \<Longrightarrow> sorted (tl xs)"
   by (cases xs) (simp_all)
 
 lemma sorted_iff_nth_mono_less:
   "sorted xs = (\<forall>i j. i < j \<longrightarrow> j < length xs \<longrightarrow> xs ! i \<le> xs ! j)"
   by (simp add: sorted_wrt_iff_nth_less)
 
 lemma sorted_iff_nth_mono:
   "sorted xs = (\<forall>i j. i \<le> j \<longrightarrow> j < length xs \<longrightarrow> xs ! i \<le> xs ! j)"
   by (auto simp: sorted_iff_nth_mono_less nat_less_le)
 
 lemma sorted_nth_mono:
   "sorted xs \<Longrightarrow> i \<le> j \<Longrightarrow> j < length xs \<Longrightarrow> xs!i \<le> xs!j"
   by (auto simp: sorted_iff_nth_mono)
 
 lemma sorted_iff_nth_Suc:
   "sorted xs \<longleftrightarrow> (\<forall>i.  Suc i < length xs \<longrightarrow> xs!i \<le> xs!(Suc i))"
   by(simp add: sorted_wrt_iff_nth_Suc_transp)
 
 lemma sorted_rev_nth_mono:
   "sorted (rev xs) \<Longrightarrow> i \<le> j \<Longrightarrow> j < length xs \<Longrightarrow> xs!j \<le> xs!i"
   by (metis local.nle_le order_class.antisym_conv1 sorted_wrt_iff_nth_less sorted_wrt_rev)
 
 lemma sorted_rev_iff_nth_mono:
   "sorted (rev xs) \<longleftrightarrow> (\<forall> i j. i \<le> j \<longrightarrow> j < length xs \<longrightarrow> xs!j \<le> xs!i)" (is "?L = ?R")
 proof
   assume ?L thus ?R
     by (blast intro: sorted_rev_nth_mono)
 next
   assume ?R
   have "rev xs ! k \<le> rev xs ! l" if asms: "k \<le> l" "l < length(rev xs)" for k l
   proof -
     have "k < length xs"  "l < length xs"
       "length xs - Suc l \<le> length xs - Suc k" "length xs - Suc k < length xs"
       using asms by auto
     thus "rev xs ! k \<le> rev xs ! l"
       by (simp add: \<open>?R\<close> rev_nth)
   qed
   thus ?L by (simp add: sorted_iff_nth_mono)
 qed
 
 lemma sorted_rev_iff_nth_Suc:
   "sorted (rev xs) \<longleftrightarrow> (\<forall>i.  Suc i < length xs \<longrightarrow> xs!(Suc i) \<le> xs!i)"
 proof-
   interpret dual: linorder "(\<lambda>x y. y \<le> x)" "(\<lambda>x y. y < x)"
     using dual_linorder .
   show ?thesis
     using dual_linorder dual.sorted_iff_nth_Suc dual.sorted_iff_nth_mono
     unfolding sorted_rev_iff_nth_mono by simp
 qed
 
 lemma sorted_map_remove1:
   "sorted (map f xs) \<Longrightarrow> sorted (map f (remove1 x xs))"
 by (induct xs) (auto)
 
 lemma sorted_remove1: "sorted xs \<Longrightarrow> sorted (remove1 a xs)"
 using sorted_map_remove1 [of "\<lambda>x. x"] by simp
 
 lemma sorted_butlast:
   assumes "sorted xs"
   shows "sorted (butlast xs)"
   by (simp add: assms butlast_conv_take sorted_wrt_take)
 
 lemma sorted_replicate [simp]: "sorted(replicate n x)"
 by(induction n) (auto)
 
 lemma sorted_remdups[simp]:
   "sorted xs \<Longrightarrow> sorted (remdups xs)"
 by (induct xs) (auto)
 
 lemma sorted_remdups_adj[simp]:
   "sorted xs \<Longrightarrow> sorted (remdups_adj xs)"
 by (induct xs rule: remdups_adj.induct, simp_all split: if_split_asm)
 
 lemma sorted_nths: "sorted xs \<Longrightarrow> sorted (nths xs I)"
 by(induction xs arbitrary: I)(auto simp: nths_Cons)
 
 lemma sorted_distinct_set_unique:
 assumes "sorted xs" "distinct xs" "sorted ys" "distinct ys" "set xs = set ys"
 shows "xs = ys"
 proof -
   from assms have 1: "length xs = length ys" by (auto dest!: distinct_card)
   from assms show ?thesis
   proof(induct rule:list_induct2[OF 1])
     case 1 show ?case by simp
   next
     case (2 x xs y ys)
     then show ?case
       by (cases \<open>x = y\<close>) (auto simp add: insert_eq_iff)
   qed
 qed
 
 lemma map_sorted_distinct_set_unique:
   assumes "inj_on f (set xs \<union> set ys)"
   assumes "sorted (map f xs)" "distinct (map f xs)"
     "sorted (map f ys)" "distinct (map f ys)"
   assumes "set xs = set ys"
   shows "xs = ys"
   using assms map_inj_on sorted_distinct_set_unique by fastforce
 
 lemma sorted_dropWhile: "sorted xs \<Longrightarrow> sorted (dropWhile P xs)"
   by (auto dest: sorted_wrt_drop simp add: dropWhile_eq_drop)
 
 lemma sorted_takeWhile: "sorted xs \<Longrightarrow> sorted (takeWhile P xs)"
   by (subst takeWhile_eq_take) (auto dest: sorted_wrt_take)
 
 lemma sorted_filter:
   "sorted (map f xs) \<Longrightarrow> sorted (map f (filter P xs))"
   by (induct xs) simp_all
 
 lemma foldr_max_sorted:
   assumes "sorted (rev xs)"
   shows "foldr max xs y = (if xs = [] then y else max (xs ! 0) y)"
   using assms
 proof (induct xs)
   case (Cons x xs)
   then have "sorted (rev xs)" using sorted_append by auto
   with Cons show ?case
     by (cases xs) (auto simp add: sorted_append max_def)
 qed simp
 
 lemma filter_equals_takeWhile_sorted_rev:
   assumes sorted: "sorted (rev (map f xs))"
   shows "filter (\<lambda>x. t < f x) xs = takeWhile (\<lambda> x. t < f x) xs"
     (is "filter ?P xs = ?tW")
 proof (rule takeWhile_eq_filter[symmetric])
   let "?dW" = "dropWhile ?P xs"
   fix x assume x: "x \<in> set ?dW"
   then obtain i where i: "i < length ?dW" and nth_i: "x = ?dW ! i"
     unfolding in_set_conv_nth by auto
   hence "length ?tW + i < length (?tW @ ?dW)"
     unfolding length_append by simp
   hence i': "length (map f ?tW) + i < length (map f xs)" by simp
   have "(map f ?tW @ map f ?dW) ! (length (map f ?tW) + i) \<le>
         (map f ?tW @ map f ?dW) ! (length (map f ?tW) + 0)"
     using sorted_rev_nth_mono[OF sorted _ i', of "length ?tW"]
     unfolding map_append[symmetric] by simp
   hence "f x \<le> f (?dW ! 0)"
     unfolding nth_append_length_plus nth_i
     using i preorder_class.le_less_trans[OF le0 i] by simp
   also have "... \<le> t"
     by (metis hd_conv_nth hd_dropWhile length_greater_0_conv length_pos_if_in_set local.leI x)
   finally show "\<not> t < f x" by simp
 qed
 
 lemma sorted_map_same:
   "sorted (map f (filter (\<lambda>x. f x = g xs) xs))"
 proof (induct xs arbitrary: g)
   case Nil then show ?case by simp
 next
   case (Cons x xs)
   then have "sorted (map f (filter (\<lambda>y. f y = (\<lambda>xs. f x) xs) xs))" .
   moreover from Cons have "sorted (map f (filter (\<lambda>y. f y = (g \<circ> Cons x) xs) xs))" .
   ultimately show ?case by simp_all
 qed
 
 lemma sorted_same:
   "sorted (filter (\<lambda>x. x = g xs) xs)"
 using sorted_map_same [of "\<lambda>x. x"] by simp
 
 end
 
 lemma sorted_upt[simp]: "sorted [m..<n]"
   by(simp add: sorted_wrt_mono_rel[OF _ sorted_wrt_upt])
 
 lemma sorted_upto[simp]: "sorted [m..n]"
   by(simp add: sorted_wrt_mono_rel[OF _ sorted_wrt_upto])
 
 
 subsubsection \<open>Sorting functions\<close>
 
 text\<open>Currently it is not shown that \<^const>\<open>sort\<close> returns a
 permutation of its input because the nicest proof is via multisets,
 which are not part of Main. Alternatively one could define a function
 that counts the number of occurrences of an element in a list and use
 that instead of multisets to state the correctness property.\<close>
 
 context linorder
 begin
 
 lemma set_insort_key:
   "set (insort_key f x xs) = insert x (set xs)"
 by (induct xs) auto
 
 lemma length_insort [simp]:
   "length (insort_key f x xs) = Suc (length xs)"
 by (induct xs) simp_all
 
 lemma insort_key_left_comm:
   assumes "f x \<noteq> f y"
   shows "insort_key f y (insort_key f x xs) = insort_key f x (insort_key f y xs)"
 by (induct xs) (auto simp add: assms dest: order.antisym)
 
 lemma insort_left_comm:
   "insort x (insort y xs) = insort y (insort x xs)"
 by (cases "x = y") (auto intro: insort_key_left_comm)
 
 lemma comp_fun_commute_insort: "comp_fun_commute insort"
 proof
 qed (simp add: insort_left_comm fun_eq_iff)
 
 lemma sort_key_simps [simp]:
   "sort_key f [] = []"
   "sort_key f (x#xs) = insort_key f x (sort_key f xs)"
 by (simp_all add: sort_key_def)
 
 lemma sort_key_conv_fold:
   assumes "inj_on f (set xs)"
   shows "sort_key f xs = fold (insort_key f) xs []"
 proof -
   have "fold (insort_key f) (rev xs) = fold (insort_key f) xs"
   proof (rule fold_rev, rule ext)
     fix zs
     fix x y
     assume "x \<in> set xs" "y \<in> set xs"
     with assms have *: "f y = f x \<Longrightarrow> y = x" by (auto dest: inj_onD)
     have **: "x = y \<longleftrightarrow> y = x" by auto
     show "(insort_key f y \<circ> insort_key f x) zs = (insort_key f x \<circ> insort_key f y) zs"
       by (induct zs) (auto intro: * simp add: **)
   qed
   then show ?thesis by (simp add: sort_key_def foldr_conv_fold)
 qed
 
 lemma sort_conv_fold:
   "sort xs = fold insort xs []"
 by (rule sort_key_conv_fold) simp
 
 lemma length_sort[simp]: "length (sort_key f xs) = length xs"
 by (induct xs, auto)
 
 lemma set_sort[simp]: "set(sort_key f xs) = set xs"
 by (induct xs) (simp_all add: set_insort_key)
 
 lemma distinct_insort: "distinct (insort_key f x xs) = (x \<notin> set xs \<and> distinct xs)"
 by(induct xs)(auto simp: set_insort_key)
 
 lemma distinct_insort_key:
   "distinct (map f (insort_key f x xs)) = (f x \<notin> f ` set xs \<and> (distinct (map f xs)))"
 by (induct xs) (auto simp: set_insort_key)
 
 lemma distinct_sort[simp]: "distinct (sort_key f xs) = distinct xs"
 by (induct xs) (simp_all add: distinct_insort)
 
 lemma sorted_insort_key: "sorted (map f (insort_key f x xs)) = sorted (map f xs)"
 by (induct xs) (auto simp: set_insort_key)
 
 lemma sorted_insort: "sorted (insort x xs) = sorted xs"
 using sorted_insort_key [where f="\<lambda>x. x"] by simp
 
 theorem sorted_sort_key [simp]: "sorted (map f (sort_key f xs))"
 by (induct xs) (auto simp:sorted_insort_key)
 
 theorem sorted_sort [simp]: "sorted (sort xs)"
 using sorted_sort_key [where f="\<lambda>x. x"] by simp
 
 lemma insort_not_Nil [simp]:
   "insort_key f a xs \<noteq> []"
 by (induction xs) simp_all
 
 lemma insort_is_Cons: "\<forall>x\<in>set xs. f a \<le> f x \<Longrightarrow> insort_key f a xs = a # xs"
 by (cases xs) auto
 
 lemma sort_key_id_if_sorted: "sorted (map f xs) \<Longrightarrow> sort_key f xs = xs"
 by (induction xs) (auto simp add: insort_is_Cons)
 
 text \<open>Subsumed by @{thm sort_key_id_if_sorted} but easier to find:\<close>
 lemma sorted_sort_id: "sorted xs \<Longrightarrow> sort xs = xs"
 by (simp add: sort_key_id_if_sorted)
 
 lemma insort_key_remove1:
   assumes "a \<in> set xs" and "sorted (map f xs)" and "hd (filter (\<lambda>x. f a = f x) xs) = a"
   shows "insort_key f a (remove1 a xs) = xs"
 using assms proof (induct xs)
   case (Cons x xs)
   then show ?case
   proof (cases "x = a")
     case False
     then have "f x \<noteq> f a" using Cons.prems by auto
     then have "f x < f a" using Cons.prems by auto
     with \<open>f x \<noteq> f a\<close> show ?thesis using Cons by (auto simp: insort_is_Cons)
   qed (auto simp: insort_is_Cons)
 qed simp
 
 lemma insort_remove1:
   assumes "a \<in> set xs" and "sorted xs"
   shows "insort a (remove1 a xs) = xs"
 proof (rule insort_key_remove1)
   define n where "n = length (filter ((=) a) xs) - 1"
   from \<open>a \<in> set xs\<close> show "a \<in> set xs" .
   from \<open>sorted xs\<close> show "sorted (map (\<lambda>x. x) xs)" by simp
   from \<open>a \<in> set xs\<close> have "a \<in> set (filter ((=) a) xs)" by auto
   then have "set (filter ((=) a) xs) \<noteq> {}" by auto
   then have "filter ((=) a) xs \<noteq> []" by (auto simp only: set_empty)
   then have "length (filter ((=) a) xs) > 0" by simp
   then have n: "Suc n = length (filter ((=) a) xs)" by (simp add: n_def)
   moreover have "replicate (Suc n) a = a # replicate n a"
     by simp
   ultimately show "hd (filter ((=) a) xs) = a" by (simp add: replicate_length_filter)
 qed
 
 lemma finite_sorted_distinct_unique:
   assumes "finite A" shows "\<exists>!xs. set xs = A \<and> sorted xs \<and> distinct xs"
 proof -
   obtain xs where "distinct xs" "A = set xs"
     using finite_distinct_list [OF assms] by metis
   then show ?thesis
     by (rule_tac a="sort xs" in ex1I) (auto simp: sorted_distinct_set_unique)
 qed
 
 lemma insort_insert_key_triv:
   "f x \<in> f ` set xs \<Longrightarrow> insort_insert_key f x xs = xs"
   by (simp add: insort_insert_key_def)
 
 lemma insort_insert_triv:
   "x \<in> set xs \<Longrightarrow> insort_insert x xs = xs"
   using insort_insert_key_triv [of "\<lambda>x. x"] by simp
 
 lemma insort_insert_insort_key:
   "f x \<notin> f ` set xs \<Longrightarrow> insort_insert_key f x xs = insort_key f x xs"
   by (simp add: insort_insert_key_def)
 
 lemma insort_insert_insort:
   "x \<notin> set xs \<Longrightarrow> insort_insert x xs = insort x xs"
   using insort_insert_insort_key [of "\<lambda>x. x"] by simp
 
 lemma set_insort_insert:
   "set (insort_insert x xs) = insert x (set xs)"
   by (auto simp add: insort_insert_key_def set_insort_key)
 
 lemma distinct_insort_insert:
   assumes "distinct xs"
   shows "distinct (insort_insert_key f x xs)"
 using assms by (induct xs) (auto simp add: insort_insert_key_def set_insort_key)
 
 lemma sorted_insort_insert_key:
   assumes "sorted (map f xs)"
   shows "sorted (map f (insort_insert_key f x xs))"
   using assms by (simp add: insort_insert_key_def sorted_insort_key)
 
 lemma sorted_insort_insert:
   assumes "sorted xs"
   shows "sorted (insort_insert x xs)"
   using assms sorted_insort_insert_key [of "\<lambda>x. x"] by simp
 
 lemma filter_insort_triv:
   "\<not> P x \<Longrightarrow> filter P (insort_key f x xs) = filter P xs"
   by (induct xs) simp_all
 
 lemma filter_insort:
   "sorted (map f xs) \<Longrightarrow> P x \<Longrightarrow> filter P (insort_key f x xs) = insort_key f x (filter P xs)"
   by (induct xs) (auto, subst insort_is_Cons, auto)
 
 lemma filter_sort:
   "filter P (sort_key f xs) = sort_key f (filter P xs)"
   by (induct xs) (simp_all add: filter_insort_triv filter_insort)
 
 lemma remove1_insort_key [simp]:
   "remove1 x (insort_key f x xs) = xs"
   by (induct xs) simp_all
 
 end
 
 lemma sort_upt [simp]: "sort [m..<n] = [m..<n]"
 by (rule sort_key_id_if_sorted) simp
 
 lemma sort_upto [simp]: "sort [i..j] = [i..j]"
 by (rule sort_key_id_if_sorted) simp
 
 lemma sorted_find_Min:
   "sorted xs \<Longrightarrow> \<exists>x \<in> set xs. P x \<Longrightarrow> List.find P xs = Some (Min {x\<in>set xs. P x})"
 proof (induct xs)
   case Nil then show ?case by simp
 next
   case (Cons x xs) show ?case proof (cases "P x")
     case True
     with Cons show ?thesis by (auto intro: Min_eqI [symmetric])
   next
     case False then have "{y. (y = x \<or> y \<in> set xs) \<and> P y} = {y \<in> set xs. P y}"
       by auto
     with Cons False show ?thesis by (simp_all)
   qed
 qed
 
 lemma sorted_enumerate [simp]: "sorted (map fst (enumerate n xs))"
 by (simp add: enumerate_eq_zip)
 
 lemma sorted_insort_is_snoc: "sorted xs \<Longrightarrow> \<forall>x \<in> set xs. a \<ge> x \<Longrightarrow> insort a xs = xs @ [a]"
  by (induct xs) (auto dest!: insort_is_Cons)
 
 text \<open>Stability of \<^const>\<open>sort_key\<close>:\<close>
 
 lemma sort_key_stable: "filter (\<lambda>y. f y = k) (sort_key f xs) = filter (\<lambda>y. f y = k) xs"
 by (induction xs) (auto simp: filter_insort insort_is_Cons filter_insort_triv)
 
 corollary stable_sort_key_sort_key: "stable_sort_key sort_key"
 by(simp add: stable_sort_key_def sort_key_stable)
 
 lemma sort_key_const: "sort_key (\<lambda>x. c) xs = xs"
 by (metis (mono_tags) filter_True sort_key_stable)
 
 
 subsubsection \<open>\<^const>\<open>transpose\<close> on sorted lists\<close>
 
 lemma sorted_transpose[simp]: "sorted (rev (map length (transpose xs)))"
 by (auto simp: sorted_iff_nth_mono rev_nth nth_transpose
     length_filter_conv_card intro: card_mono)
 
 lemma transpose_max_length:
   "foldr (\<lambda>xs. max (length xs)) (transpose xs) 0 = length (filter (\<lambda>x. x \<noteq> []) xs)"
   (is "?L = ?R")
 proof (cases "transpose xs = []")
   case False
   have "?L = foldr max (map length (transpose xs)) 0"
     by (simp add: foldr_map comp_def)
   also have "... = length (transpose xs ! 0)"
     using False sorted_transpose by (simp add: foldr_max_sorted)
   finally show ?thesis
     using False by (simp add: nth_transpose)
 next
   case True
   hence "filter (\<lambda>x. x \<noteq> []) xs = []"
     by (auto intro!: filter_False simp: transpose_empty)
   thus ?thesis by (simp add: transpose_empty True)
 qed
 
 lemma length_transpose_sorted:
   fixes xs :: "'a list list"
   assumes sorted: "sorted (rev (map length xs))"
   shows "length (transpose xs) = (if xs = [] then 0 else length (xs ! 0))"
 proof (cases "xs = []")
   case False
   thus ?thesis
     using foldr_max_sorted[OF sorted] False
     unfolding length_transpose foldr_map comp_def
     by simp
 qed simp
 
 lemma nth_nth_transpose_sorted[simp]:
   fixes xs :: "'a list list"
   assumes sorted: "sorted (rev (map length xs))"
   and i: "i < length (transpose xs)"
   and j: "j < length (filter (\<lambda>ys. i < length ys) xs)"
   shows "transpose xs ! i ! j = xs ! j  ! i"
 using j filter_equals_takeWhile_sorted_rev[OF sorted, of i]
     nth_transpose[OF i] nth_map[OF j]
 by (simp add: takeWhile_nth)
 
 lemma transpose_column_length:
   fixes xs :: "'a list list"
   assumes sorted: "sorted (rev (map length xs))" and "i < length xs"
   shows "length (filter (\<lambda>ys. i < length ys) (transpose xs)) = length (xs ! i)"
 proof -
   have "xs \<noteq> []" using \<open>i < length xs\<close> by auto
   note filter_equals_takeWhile_sorted_rev[OF sorted, simp]
   { fix j assume "j \<le> i"
     note sorted_rev_nth_mono[OF sorted, of j i, simplified, OF this \<open>i < length xs\<close>]
   } note sortedE = this[consumes 1]
 
   have "{j. j < length (transpose xs) \<and> i < length (transpose xs ! j)}
     = {..< length (xs ! i)}"
   proof safe
     fix j
     assume "j < length (transpose xs)" and "i < length (transpose xs ! j)"
     with this(2) nth_transpose[OF this(1)]
     have "i < length (takeWhile (\<lambda>ys. j < length ys) xs)" by simp
     from nth_mem[OF this] takeWhile_nth[OF this]
     show "j < length (xs ! i)" by (auto dest: set_takeWhileD)
   next
     fix j assume "j < length (xs ! i)"
     thus "j < length (transpose xs)"
       using foldr_max_sorted[OF sorted] \<open>xs \<noteq> []\<close> sortedE[OF le0]
       by (auto simp: length_transpose comp_def foldr_map)
 
     have "Suc i \<le> length (takeWhile (\<lambda>ys. j < length ys) xs)"
       using \<open>i < length xs\<close> \<open>j < length (xs ! i)\<close> less_Suc_eq_le
       by (auto intro!: length_takeWhile_less_P_nth dest!: sortedE)
     with nth_transpose[OF \<open>j < length (transpose xs)\<close>]
     show "i < length (transpose xs ! j)" by simp
   qed
   thus ?thesis by (simp add: length_filter_conv_card)
 qed
 
 lemma transpose_column:
   fixes xs :: "'a list list"
   assumes sorted: "sorted (rev (map length xs))" and "i < length xs"
   shows "map (\<lambda>ys. ys ! i) (filter (\<lambda>ys. i < length ys) (transpose xs))
     = xs ! i" (is "?R = _")
 proof (rule nth_equalityI)
   show length: "length ?R = length (xs ! i)"
     using transpose_column_length[OF assms] by simp
 
   fix j assume j: "j < length ?R"
   note * = less_le_trans[OF this, unfolded length_map, OF length_filter_le]
   from j have j_less: "j < length (xs ! i)" using length by simp
   have i_less_tW: "Suc i \<le> length (takeWhile (\<lambda>ys. Suc j \<le> length ys) xs)"
   proof (rule length_takeWhile_less_P_nth)
     show "Suc i \<le> length xs" using \<open>i < length xs\<close> by simp
     fix k assume "k < Suc i"
     hence "k \<le> i" by auto
     with sorted_rev_nth_mono[OF sorted this] \<open>i < length xs\<close>
     have "length (xs ! i) \<le> length (xs ! k)" by simp
     thus "Suc j \<le> length (xs ! k)" using j_less by simp
   qed
   have i_less_filter: "i < length (filter (\<lambda>ys. j < length ys) xs) "
     unfolding filter_equals_takeWhile_sorted_rev[OF sorted, of j]
     using i_less_tW by (simp_all add: Suc_le_eq)
   from j show "?R ! j = xs ! i ! j"
     unfolding filter_equals_takeWhile_sorted_rev[OF sorted_transpose, of i]
     by (simp add: takeWhile_nth nth_nth_transpose_sorted[OF sorted * i_less_filter])
 qed
 
 lemma transpose_transpose:
   fixes xs :: "'a list list"
   assumes sorted: "sorted (rev (map length xs))"
   shows "transpose (transpose xs) = takeWhile (\<lambda>x. x \<noteq> []) xs" (is "?L = ?R")
 proof -
   have len: "length ?L = length ?R"
     unfolding length_transpose transpose_max_length
     using filter_equals_takeWhile_sorted_rev[OF sorted, of 0]
     by simp
 
   { fix i assume "i < length ?R"
     with less_le_trans[OF _ length_takeWhile_le[of _ xs]]
     have "i < length xs" by simp
   } note * = this
   show ?thesis
     by (rule nth_equalityI)
        (simp_all add: len nth_transpose transpose_column[OF sorted] * takeWhile_nth)
 qed
 
 theorem transpose_rectangle:
   assumes "xs = [] \<Longrightarrow> n = 0"
   assumes rect: "\<And> i. i < length xs \<Longrightarrow> length (xs ! i) = n"
   shows "transpose xs = map (\<lambda> i. map (\<lambda> j. xs ! j ! i) [0..<length xs]) [0..<n]"
     (is "?trans = ?map")
 proof (rule nth_equalityI)
   have "sorted (rev (map length xs))"
     by (auto simp: rev_nth rect sorted_iff_nth_mono)
   from foldr_max_sorted[OF this] assms
   show len: "length ?trans = length ?map"
     by (simp_all add: length_transpose foldr_map comp_def)
   moreover
   { fix i assume "i < n" hence "filter (\<lambda>ys. i < length ys) xs = xs"
       using rect by (auto simp: in_set_conv_nth intro!: filter_True) }
   ultimately show "\<And>i. i < length (transpose xs) \<Longrightarrow> ?trans ! i = ?map ! i"
     by (auto simp: nth_transpose intro: nth_equalityI)
 qed
 
 
 subsubsection \<open>\<open>sorted_key_list_of_set\<close>\<close>
 
 text\<open>
   This function maps (finite) linearly ordered sets to sorted lists.
   The linear order is obtained by a key function that maps the elements of the set to a type
   that is linearly ordered.
   Warning: in most cases it is not a good idea to convert from
   sets to lists but one should convert in the other direction (via \<^const>\<open>set\<close>).
 
   Note: this is a generalisation of the older \<open>sorted_list_of_set\<close> that is obtained by setting
   the key function to the identity. Consequently, new theorems should be added to the locale
   below. They should also be aliased to more convenient names for use with \<open>sorted_list_of_set\<close>
   as seen further below.
 \<close>
 
 definition (in linorder) sorted_key_list_of_set :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b set \<Rightarrow> 'b list"
   where "sorted_key_list_of_set f \<equiv> folding_on.F (insort_key f) []"
 
 locale folding_insort_key = lo?: linorder "less_eq :: 'a \<Rightarrow> 'a \<Rightarrow> bool" less
   for less_eq (infix "\<preceq>" 50) and less (infix "\<prec>" 50) +
   fixes S
   fixes f :: "'b \<Rightarrow> 'a"
   assumes inj_on: "inj_on f S"
 begin
 
 lemma insort_key_commute:
   "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> insort_key f y o insort_key f x = insort_key f x o insort_key f y"
 proof(rule ext, goal_cases)
   case (1 xs)
   with inj_on show ?case by (induction xs) (auto simp: inj_onD)
 qed
 
 sublocale fold_insort_key: folding_on S "insort_key f" "[]"
   rewrites "folding_on.F (insort_key f) [] = sorted_key_list_of_set f"
 proof -
   show "folding_on S (insort_key f)"
     by standard (simp add: insort_key_commute)
 qed (simp add: sorted_key_list_of_set_def)
 
 lemma idem_if_sorted_distinct:
   assumes "set xs \<subseteq> S" and "sorted (map f xs)" "distinct xs"
   shows "sorted_key_list_of_set f (set xs) = xs"
 proof(cases "S = {}")
   case True
   then show ?thesis using \<open>set xs \<subseteq> S\<close> by auto
 next
   case False
   with assms show ?thesis
   proof(induction xs)
     case (Cons a xs)
     with Cons show ?case by (cases xs) auto
   qed simp
 qed
 
 lemma sorted_key_list_of_set_empty:
   "sorted_key_list_of_set f {} = []"
   by (fact fold_insort_key.empty)
 
 lemma sorted_key_list_of_set_insert:
   assumes "insert x A \<subseteq> S" and "finite A" "x \<notin> A"
   shows "sorted_key_list_of_set f (insert x A)
         = insort_key f x (sorted_key_list_of_set f A)"
   using assms by (fact fold_insort_key.insert)
 
 lemma sorted_key_list_of_set_insert_remove [simp]:
   assumes "insert x A \<subseteq> S" and "finite A"
   shows "sorted_key_list_of_set f (insert x A)
         = insort_key f x (sorted_key_list_of_set f (A - {x}))"
   using assms by (fact fold_insort_key.insert_remove)
 
 lemma sorted_key_list_of_set_eq_Nil_iff [simp]:
   assumes "A \<subseteq> S" and "finite A"
   shows "sorted_key_list_of_set f A = [] \<longleftrightarrow> A = {}"
   using assms by (auto simp: fold_insort_key.remove)
 
 lemma set_sorted_key_list_of_set [simp]:
   assumes "A \<subseteq> S" and "finite A"
   shows "set (sorted_key_list_of_set f A) = A"
   using assms(2,1)
   by (induct A rule: finite_induct) (simp_all add: set_insort_key)
 
 lemma sorted_sorted_key_list_of_set [simp]:
   assumes "A \<subseteq> S"
   shows "sorted (map f (sorted_key_list_of_set f A))"
 proof (cases "finite A")
   case True thus ?thesis using \<open>A \<subseteq> S\<close>
     by (induction A) (simp_all add: sorted_insort_key)
 next
   case False thus ?thesis by simp
 qed
 
 lemma distinct_if_distinct_map: "distinct (map f xs) \<Longrightarrow> distinct xs"
   using inj_on by (simp add: distinct_map)
 
 lemma distinct_sorted_key_list_of_set [simp]:
   assumes "A \<subseteq> S"
   shows "distinct (map f (sorted_key_list_of_set f A))"
 proof (cases "finite A")
   case True thus ?thesis using \<open>A \<subseteq> S\<close> inj_on
     by (induction A) (force simp: distinct_insort_key dest: inj_onD)+
   next
   case False thus ?thesis by simp
 qed
 
 lemma length_sorted_key_list_of_set [simp]:
   assumes "A \<subseteq> S"
   shows "length (sorted_key_list_of_set f A) = card A"
 proof (cases "finite A")
   case True
   with assms inj_on show ?thesis
     using distinct_card[symmetric, OF distinct_sorted_key_list_of_set]
     by (auto simp: subset_inj_on intro!: card_image)
 qed auto
 
 lemmas sorted_key_list_of_set =
   set_sorted_key_list_of_set sorted_sorted_key_list_of_set distinct_sorted_key_list_of_set
 
 lemma sorted_key_list_of_set_remove:
   assumes "insert x A \<subseteq> S" and "finite A"
   shows "sorted_key_list_of_set f (A - {x}) = remove1 x (sorted_key_list_of_set f A)"
 proof (cases "x \<in> A")
   case False with assms have "x \<notin> set (sorted_key_list_of_set f A)" by simp
   with False show ?thesis by (simp add: remove1_idem)
 next
   case True then obtain B where A: "A = insert x B" by (rule Set.set_insert)
   with assms show ?thesis by simp
 qed
 
 lemma strict_sorted_key_list_of_set [simp]:
   "A \<subseteq> S \<Longrightarrow> sorted_wrt (\<prec>) (map f (sorted_key_list_of_set f A))"
   by (cases "finite A") (auto simp: strict_sorted_iff subset_inj_on[OF inj_on])
 
 lemma finite_set_strict_sorted:
   assumes "A \<subseteq> S" and "finite A"
   obtains l where "sorted_wrt (\<prec>) (map f l)" "set l = A" "length l = card A"
   using assms
   by (meson length_sorted_key_list_of_set set_sorted_key_list_of_set strict_sorted_key_list_of_set)
 
 lemma (in linorder) strict_sorted_equal:
   assumes "sorted_wrt (<) xs"
     and "sorted_wrt (<) ys"
     and "set ys = set xs"
   shows "ys = xs"
   using assms
 proof (induction xs arbitrary: ys)
   case (Cons x xs)
   show ?case
   proof (cases ys)
     case Nil
     then show ?thesis
       using Cons.prems by auto
   next
     case (Cons y ys')
     then have "xs = ys'"
       by (metis Cons.prems list.inject sorted_distinct_set_unique strict_sorted_iff)
     moreover have "x = y"
       using Cons.prems \<open>xs = ys'\<close> local.Cons by fastforce
     ultimately show ?thesis
       using local.Cons by blast
   qed
 qed auto
 
 lemma (in linorder) strict_sorted_equal_Uniq: "\<exists>\<^sub>\<le>\<^sub>1xs. sorted_wrt (<) xs \<and> set xs = A"
   by (simp add: Uniq_def strict_sorted_equal)
 
 lemma sorted_key_list_of_set_inject:
   assumes "A \<subseteq> S" "B \<subseteq> S"
   assumes "sorted_key_list_of_set f A = sorted_key_list_of_set f B" "finite A" "finite B"
   shows "A = B"
   using assms set_sorted_key_list_of_set by metis
 
 lemma sorted_key_list_of_set_unique:
   assumes "A \<subseteq> S" and "finite A"
   shows "sorted_wrt (\<prec>) (map f l) \<and> set l = A \<and> length l = card A
         \<longleftrightarrow> sorted_key_list_of_set f A = l"
   using assms
   by (auto simp: strict_sorted_iff card_distinct idem_if_sorted_distinct)
 
 end
 
 context linorder
 begin
 
 definition "sorted_list_of_set \<equiv> sorted_key_list_of_set (\<lambda>x::'a. x)"
 
 text \<open>
   We abuse the \<open>rewrites\<close> functionality of locales to remove trivial assumptions that result
   from instantiating the key function to the identity.
 \<close>
 sublocale sorted_list_of_set: folding_insort_key "(\<le>)" "(<)" UNIV "(\<lambda>x. x)"
   rewrites "sorted_key_list_of_set (\<lambda>x. x) = sorted_list_of_set"
        and "\<And>xs. map (\<lambda>x. x) xs \<equiv> xs"
        and "\<And>X. (X \<subseteq> UNIV) \<equiv> True"
        and "\<And>x. x \<in> UNIV \<equiv> True"
        and "\<And>P. (True \<Longrightarrow> P) \<equiv> Trueprop P"
        and "\<And>P Q. (True \<Longrightarrow> PROP P \<Longrightarrow> PROP Q) \<equiv> (PROP P \<Longrightarrow> True \<Longrightarrow> PROP Q)"
 proof -
   show "folding_insort_key (\<le>) (<) UNIV (\<lambda>x. x)"
     by standard simp
 qed (simp_all add: sorted_list_of_set_def)
 
 text \<open>Alias theorems for backwards compatibility and ease of use.\<close>
 lemmas sorted_list_of_set = sorted_list_of_set.sorted_key_list_of_set and
        sorted_list_of_set_empty = sorted_list_of_set.sorted_key_list_of_set_empty and
        sorted_list_of_set_insert = sorted_list_of_set.sorted_key_list_of_set_insert and
        sorted_list_of_set_insert_remove = sorted_list_of_set.sorted_key_list_of_set_insert_remove and
        sorted_list_of_set_eq_Nil_iff = sorted_list_of_set.sorted_key_list_of_set_eq_Nil_iff and
        set_sorted_list_of_set = sorted_list_of_set.set_sorted_key_list_of_set and
        sorted_sorted_list_of_set = sorted_list_of_set.sorted_sorted_key_list_of_set and
        distinct_sorted_list_of_set = sorted_list_of_set.distinct_sorted_key_list_of_set and
        length_sorted_list_of_set = sorted_list_of_set.length_sorted_key_list_of_set and
        sorted_list_of_set_remove = sorted_list_of_set.sorted_key_list_of_set_remove and
        strict_sorted_list_of_set = sorted_list_of_set.strict_sorted_key_list_of_set and
        sorted_list_of_set_inject = sorted_list_of_set.sorted_key_list_of_set_inject and
        sorted_list_of_set_unique = sorted_list_of_set.sorted_key_list_of_set_unique and
        finite_set_strict_sorted = sorted_list_of_set.finite_set_strict_sorted
 
 lemma sorted_list_of_set_sort_remdups [code]:
   "sorted_list_of_set (set xs) = sort (remdups xs)"
 proof -
   interpret comp_fun_commute insort by (fact comp_fun_commute_insort)
   show ?thesis
     by (simp add: sorted_list_of_set.fold_insort_key.eq_fold sort_conv_fold fold_set_fold_remdups)
 qed
 
 end
 
 
 lemma sorted_list_of_set_range [simp]:
   "sorted_list_of_set {m..<n} = [m..<n]"
 by (rule sorted_distinct_set_unique) simp_all
 
 lemma sorted_list_of_set_lessThan_Suc [simp]:
   "sorted_list_of_set {..<Suc k} = sorted_list_of_set {..<k} @ [k]"
   using le0 lessThan_atLeast0 sorted_list_of_set_range upt_Suc_append by presburger
 
 lemma sorted_list_of_set_atMost_Suc [simp]:
   "sorted_list_of_set {..Suc k} = sorted_list_of_set {..k} @ [Suc k]"
   using lessThan_Suc_atMost sorted_list_of_set_lessThan_Suc by fastforce
 
 lemma sorted_list_of_set_nonempty:
   assumes "finite A" "A \<noteq> {}"
   shows "sorted_list_of_set A = Min A # sorted_list_of_set (A - {Min A})"
   using assms
   by (auto simp: less_le simp flip: sorted_list_of_set.sorted_key_list_of_set_unique intro: Min_in)
 
 lemma sorted_list_of_set_greaterThanLessThan:
   assumes "Suc i < j"
     shows "sorted_list_of_set {i<..<j} = Suc i # sorted_list_of_set {Suc i<..<j}"
 proof -
   have "{i<..<j} = insert (Suc i) {Suc i<..<j}"
     using assms by auto
   then show ?thesis
     by (metis assms atLeastSucLessThan_greaterThanLessThan sorted_list_of_set_range upt_conv_Cons)
 qed
 
 lemma sorted_list_of_set_greaterThanAtMost:
   assumes "Suc i \<le> j"
     shows "sorted_list_of_set {i<..j} = Suc i # sorted_list_of_set {Suc i<..j}"
   using sorted_list_of_set_greaterThanLessThan [of i "Suc j"]
   by (metis assms greaterThanAtMost_def greaterThanLessThan_eq le_imp_less_Suc lessThan_Suc_atMost)
 
 lemma nth_sorted_list_of_set_greaterThanLessThan:
   "n < j - Suc i \<Longrightarrow> sorted_list_of_set {i<..<j} ! n = Suc (i+n)"
   by (induction n arbitrary: i) (auto simp: sorted_list_of_set_greaterThanLessThan)
 
 lemma nth_sorted_list_of_set_greaterThanAtMost:
   "n < j - i \<Longrightarrow> sorted_list_of_set {i<..j} ! n = Suc (i+n)"
   using nth_sorted_list_of_set_greaterThanLessThan [of n "Suc j" i]
   by (simp add: greaterThanAtMost_def greaterThanLessThan_eq lessThan_Suc_atMost)
 
 
 subsubsection \<open>\<open>lists\<close>: the list-forming operator over sets\<close>
 
 inductive_set
   lists :: "'a set => 'a list set"
   for A :: "'a set"
 where
     Nil [intro!, simp]: "[] \<in> lists A"
   | Cons [intro!, simp]: "\<lbrakk>a \<in> A; l \<in> lists A\<rbrakk> \<Longrightarrow> a#l \<in> lists A"
 
 inductive_cases listsE [elim!]: "x#l \<in> lists A"
 inductive_cases listspE [elim!]: "listsp A (x # l)"
 
 inductive_simps listsp_simps[code]:
   "listsp A []"
   "listsp A (x # xs)"
 
 lemma listsp_mono [mono]: "A \<le> B \<Longrightarrow> listsp A \<le> listsp B"
 by (rule predicate1I, erule listsp.induct, blast+)
 
 lemmas lists_mono = listsp_mono [to_set]
 
 lemma listsp_infI:
   assumes l: "listsp A l" shows "listsp B l \<Longrightarrow> listsp (inf A B) l" using l
 by induct blast+
 
 lemmas lists_IntI = listsp_infI [to_set]
 
 lemma listsp_inf_eq [simp]: "listsp (inf A B) = inf (listsp A) (listsp B)"
 proof (rule mono_inf [where f=listsp, THEN order_antisym])
   show "mono listsp" by (simp add: mono_def listsp_mono)
   show "inf (listsp A) (listsp B) \<le> listsp (inf A B)" by (blast intro!: listsp_infI)
 qed
 
 lemmas listsp_conj_eq [simp] = listsp_inf_eq [simplified inf_fun_def inf_bool_def]
 
 lemmas lists_Int_eq [simp] = listsp_inf_eq [to_set]
 
 lemma Cons_in_lists_iff[simp]: "x#xs \<in> lists A \<longleftrightarrow> x \<in> A \<and> xs \<in> lists A"
 by auto
 
 lemma append_in_listsp_conv [iff]:
      "(listsp A (xs @ ys)) = (listsp A xs \<and> listsp A ys)"
 by (induct xs) auto
 
 lemmas append_in_lists_conv [iff] = append_in_listsp_conv [to_set]
 
 lemma in_listsp_conv_set: "(listsp A xs) = (\<forall>x \<in> set xs. A x)"
 \<comment> \<open>eliminate \<open>listsp\<close> in favour of \<open>set\<close>\<close>
 by (induct xs) auto
 
 lemmas in_lists_conv_set [code_unfold] = in_listsp_conv_set [to_set]
 
 lemma in_listspD [dest!]: "listsp A xs \<Longrightarrow> \<forall>x\<in>set xs. A x"
 by (rule in_listsp_conv_set [THEN iffD1])
 
 lemmas in_listsD [dest!] = in_listspD [to_set]
 
 lemma in_listspI [intro!]: "\<forall>x\<in>set xs. A x \<Longrightarrow> listsp A xs"
 by (rule in_listsp_conv_set [THEN iffD2])
 
 lemmas in_listsI [intro!] = in_listspI [to_set]
 
 lemma lists_eq_set: "lists A = {xs. set xs \<le> A}"
 by auto
 
 lemma lists_empty [simp]: "lists {} = {[]}"
 by auto
 
 lemma lists_UNIV [simp]: "lists UNIV = UNIV"
 by auto
 
 lemma lists_image: "lists (f`A) = map f ` lists A"
 proof -
   { fix xs have "\<forall>x\<in>set xs. x \<in> f ` A \<Longrightarrow> xs \<in> map f ` lists A"
       by (induct xs) (auto simp del: list.map simp add: list.map[symmetric] intro!: imageI) }
   then show ?thesis by auto
 qed
 
 subsubsection \<open>Inductive definition for membership\<close>
 
 inductive ListMem :: "'a \<Rightarrow> 'a list \<Rightarrow> bool"
 where
     elem:  "ListMem x (x # xs)"
   | insert:  "ListMem x xs \<Longrightarrow> ListMem x (y # xs)"
 
 lemma ListMem_iff: "(ListMem x xs) = (x \<in> set xs)"
 proof
   show "ListMem x xs \<Longrightarrow> x \<in> set xs"
     by (induct set: ListMem) auto
   show "x \<in> set xs \<Longrightarrow> ListMem x xs"
     by (induct xs) (auto intro: ListMem.intros)
 qed
 
 
 subsubsection \<open>Lists as Cartesian products\<close>
 
 text\<open>\<open>set_Cons A Xs\<close>: the set of lists with head drawn from
 \<^term>\<open>A\<close> and tail drawn from \<^term>\<open>Xs\<close>.\<close>
 
 definition set_Cons :: "'a set \<Rightarrow> 'a list set \<Rightarrow> 'a list set" where
 "set_Cons A XS = {z. \<exists>x xs. z = x # xs \<and> x \<in> A \<and> xs \<in> XS}"
 
 lemma set_Cons_sing_Nil [simp]: "set_Cons A {[]} = (%x. [x])`A"
 by (auto simp add: set_Cons_def)
 
 text\<open>Yields the set of lists, all of the same length as the argument and
 with elements drawn from the corresponding element of the argument.\<close>
 
 primrec listset :: "'a set list \<Rightarrow> 'a list set" where
 "listset [] = {[]}" |
 "listset (A # As) = set_Cons A (listset As)"
 
 
 subsection \<open>Relations on Lists\<close>
 
 subsubsection \<open>Length Lexicographic Ordering\<close>
 
 text\<open>These orderings preserve well-foundedness: shorter lists
   precede longer lists. These ordering are not used in dictionaries.\<close>
 
 primrec \<comment> \<open>The lexicographic ordering for lists of the specified length\<close>
   lexn :: "('a \<times> 'a) set \<Rightarrow> nat \<Rightarrow> ('a list \<times> 'a list) set" where
 "lexn r 0 = {}" |
 "lexn r (Suc n) =
   (map_prod (%(x, xs). x#xs) (%(x, xs). x#xs) ` (r <*lex*> lexn r n)) Int
   {(xs, ys). length xs = Suc n \<and> length ys = Suc n}"
 
 definition lex :: "('a \<times> 'a) set \<Rightarrow> ('a list \<times> 'a list) set" where
 "lex r = (\<Union>n. lexn r n)" \<comment> \<open>Holds only between lists of the same length\<close>
 
 definition lenlex :: "('a \<times> 'a) set => ('a list \<times> 'a list) set" where
 "lenlex r = inv_image (less_than <*lex*> lex r) (\<lambda>xs. (length xs, xs))"
         \<comment> \<open>Compares lists by their length and then lexicographically\<close>
 
 lemma wf_lexn: assumes "wf r" shows "wf (lexn r n)"
 proof (induct n)
   case (Suc n)
   have inj: "inj (\<lambda>(x, xs). x # xs)"
     using assms by (auto simp: inj_on_def)
   have wf: "wf (map_prod (\<lambda>(x, xs). x # xs) (\<lambda>(x, xs). x # xs) ` (r <*lex*> lexn r n))"
     by (simp add: Suc.hyps assms wf_lex_prod wf_map_prod_image [OF _ inj])
   then show ?case
     by (rule wf_subset) auto
 qed auto
 
 lemma lexn_length:
   "(xs, ys) \<in> lexn r n \<Longrightarrow> length xs = n \<and> length ys = n"
   by (induct n arbitrary: xs ys) auto
 
 lemma wf_lex [intro!]:
   assumes "wf r" shows "wf (lex r)"
   unfolding lex_def
 proof (rule wf_UN)
   show "wf (lexn r i)" for i
     by (simp add: assms wf_lexn)
   show "\<And>i j. lexn r i \<noteq> lexn r j \<Longrightarrow> Domain (lexn r i) \<inter> Range (lexn r j) = {}"
     by (metis DomainE Int_emptyI RangeE lexn_length)
 qed
 
 lemma lexn_conv:
   "lexn r n =
     {(xs,ys). length xs = n \<and> length ys = n \<and>
     (\<exists>xys x y xs' ys'. xs= xys @ x#xs' \<and> ys= xys @ y # ys' \<and> (x, y) \<in> r)}"
 proof (induction n)
   case (Suc n)
   then show ?case
     apply (simp add: image_Collect lex_prod_def, safe, blast)
      apply (rule_tac x = "ab # xys" in exI, simp)
     apply (case_tac xys; force)
     done
 qed auto
 
 text\<open>By Mathias Fleury:\<close>
 proposition lexn_transI:
   assumes "trans r" shows "trans (lexn r n)"
 unfolding trans_def
 proof (intro allI impI)
   fix as bs cs
   assume asbs: "(as, bs) \<in> lexn r n" and bscs: "(bs, cs) \<in> lexn r n"
   obtain abs a b as' bs' where
     n: "length as = n" and "length bs = n" and
     as: "as = abs @ a # as'" and
     bs: "bs = abs @ b # bs'" and
     abr: "(a, b) \<in> r"
     using asbs unfolding lexn_conv by blast
   obtain bcs b' c' cs' bs' where
     n': "length cs = n" and "length bs = n" and
     bs': "bs = bcs @ b' # bs'" and
     cs: "cs = bcs @ c' # cs'" and
     b'c'r: "(b', c') \<in> r"
     using bscs unfolding lexn_conv by blast
   consider (le) "length bcs < length abs"
     | (eq) "length bcs = length abs"
     | (ge) "length bcs > length abs" by linarith
   thus "(as, cs) \<in> lexn r n"
   proof cases
     let ?k = "length bcs"
     case le
     hence "as ! ?k = bs ! ?k" unfolding as bs by (simp add: nth_append)
     hence "(as ! ?k, cs ! ?k) \<in> r" using b'c'r unfolding bs' cs by auto
     moreover
     have "length bcs < length as" using le unfolding as by simp
     from id_take_nth_drop[OF this]
     have "as = take ?k as @ as ! ?k # drop (Suc ?k) as" .
     moreover
     have "length bcs < length cs" unfolding cs by simp
     from id_take_nth_drop[OF this]
     have "cs = take ?k cs @ cs ! ?k # drop (Suc ?k) cs" .
     moreover have "take ?k as = take ?k cs"
       using le arg_cong[OF bs, of "take (length bcs)"]
       unfolding cs as bs' by auto
     ultimately show ?thesis using n n' unfolding lexn_conv by auto
   next
     let ?k = "length abs"
     case ge
     hence "bs ! ?k = cs ! ?k" unfolding bs' cs by (simp add: nth_append)
     hence "(as ! ?k, cs ! ?k) \<in> r" using abr unfolding as bs by auto
     moreover
     have "length abs < length as" using ge unfolding as by simp
     from id_take_nth_drop[OF this]
     have "as = take ?k as @ as ! ?k # drop (Suc ?k) as" .
     moreover have "length abs < length cs" using n n' unfolding as by simp
     from id_take_nth_drop[OF this]
     have "cs = take ?k cs @ cs ! ?k # drop (Suc ?k) cs" .
     moreover have "take ?k as = take ?k cs"
       using ge arg_cong[OF bs', of "take (length abs)"]
       unfolding cs as bs by auto
     ultimately show ?thesis using n n' unfolding lexn_conv by auto
   next
     let ?k = "length abs"
     case eq
     hence *: "abs = bcs" "b = b'" using bs bs' by auto
     hence "(a, c') \<in> r"
       using abr b'c'r assms unfolding trans_def by blast
     with * show ?thesis using n n' unfolding lexn_conv as bs cs by auto
   qed
 qed
 
 corollary lex_transI:
     assumes "trans r" shows "trans (lex r)"
   using lexn_transI [OF assms]
   by (clarsimp simp add: lex_def trans_def) (metis lexn_length)
 
 lemma lex_conv:
   "lex r =
     {(xs,ys). length xs = length ys \<and>
     (\<exists>xys x y xs' ys'. xs = xys @ x # xs' \<and> ys = xys @ y # ys' \<and> (x, y) \<in> r)}"
 by (force simp add: lex_def lexn_conv)
 
 lemma wf_lenlex [intro!]: "wf r \<Longrightarrow> wf (lenlex r)"
 by (unfold lenlex_def) blast
 
 lemma lenlex_conv:
     "lenlex r = {(xs,ys). length xs < length ys \<or>
                  length xs = length ys \<and> (xs, ys) \<in> lex r}"
   by (auto simp add: lenlex_def Id_on_def lex_prod_def inv_image_def)
 
 lemma total_lenlex:
   assumes "total r"
   shows "total (lenlex r)"
 proof -
   have "(xs,ys) \<in> lexn r (length xs) \<or> (ys,xs) \<in> lexn r (length xs)"
     if "xs \<noteq> ys" and len: "length xs = length ys" for xs ys
   proof -
     obtain pre x xs' y ys' where "x\<noteq>y" and xs: "xs = pre @ [x] @ xs'" and ys: "ys = pre @ [y] @ys'"
       by (meson len \<open>xs \<noteq> ys\<close> same_length_different)
     then consider "(x,y) \<in> r" | "(y,x) \<in> r"
       by (meson UNIV_I assms total_on_def)
     then show ?thesis
     by cases (use len in \<open>(force simp add: lexn_conv xs ys)+\<close>)
 qed
   then show ?thesis
     by (fastforce simp: lenlex_def total_on_def lex_def)
 qed
 
 lemma lenlex_transI [intro]: "trans r \<Longrightarrow> trans (lenlex r)"
   unfolding lenlex_def
   by (meson lex_transI trans_inv_image trans_less_than trans_lex_prod)
 
 lemma Nil_notin_lex [iff]: "([], ys) \<notin> lex r"
   by (simp add: lex_conv)
 
 lemma Nil2_notin_lex [iff]: "(xs, []) \<notin> lex r"
   by (simp add:lex_conv)
 
 lemma Cons_in_lex [simp]:
   "(x # xs, y # ys) \<in> lex r \<longleftrightarrow> (x, y) \<in> r \<and> length xs = length ys \<or> x = y \<and> (xs, ys) \<in> lex r"
  (is "?lhs = ?rhs")
 proof
   assume ?lhs then show ?rhs
     by (simp add: lex_conv) (metis hd_append list.sel(1) list.sel(3) tl_append2)
 next
   assume ?rhs then show ?lhs
     by (simp add: lex_conv) (blast intro: Cons_eq_appendI)
 qed
 
 lemma Nil_lenlex_iff1 [simp]: "([], ns) \<in> lenlex r \<longleftrightarrow> ns \<noteq> []"
   and Nil_lenlex_iff2 [simp]: "(ns,[]) \<notin> lenlex r"
   by (auto simp: lenlex_def)
 
 lemma Cons_lenlex_iff:
   "((m # ms, n # ns) \<in> lenlex r) \<longleftrightarrow>
     length ms < length ns
   \<or> length ms = length ns \<and> (m,n) \<in> r
   \<or> (m = n \<and> (ms,ns) \<in> lenlex r)"
   by (auto simp: lenlex_def)
 
 lemma lenlex_irreflexive: "(\<And>x. (x,x) \<notin> r) \<Longrightarrow> (xs,xs) \<notin> lenlex r"
   by (induction xs) (auto simp add: Cons_lenlex_iff)
 
 lemma lenlex_trans:
     "\<lbrakk>(x,y) \<in> lenlex r; (y,z) \<in> lenlex r; trans r\<rbrakk> \<Longrightarrow> (x,z) \<in> lenlex r"
   by (meson lenlex_transI transD)
 
 lemma lenlex_length: "(ms, ns) \<in> lenlex r \<Longrightarrow> length ms \<le> length ns"
   by (auto simp: lenlex_def)
 
 lemma lex_append_rightI:
   "(xs, ys) \<in> lex r \<Longrightarrow> length vs = length us \<Longrightarrow> (xs @ us, ys @ vs) \<in> lex r"
   by (fastforce simp: lex_def lexn_conv)
 
 lemma lex_append_leftI:
   "(ys, zs) \<in> lex r \<Longrightarrow> (xs @ ys, xs @ zs) \<in> lex r"
   by (induct xs) auto
 
 lemma lex_append_leftD:
   "\<forall>x. (x,x) \<notin> r \<Longrightarrow> (xs @ ys, xs @ zs) \<in> lex r \<Longrightarrow> (ys, zs) \<in> lex r"
   by (induct xs) auto
 
 lemma lex_append_left_iff:
   "\<forall>x. (x,x) \<notin> r \<Longrightarrow> (xs @ ys, xs @ zs) \<in> lex r \<longleftrightarrow> (ys, zs) \<in> lex r"
   by(metis lex_append_leftD lex_append_leftI)
 
 lemma lex_take_index:
   assumes "(xs, ys) \<in> lex r"
   obtains i where "i < length xs" and "i < length ys" and "take i xs = take i ys"
     and "(xs ! i, ys ! i) \<in> r"
 proof -
   obtain n us x xs' y ys' where "(xs, ys) \<in> lexn r n" and "length xs = n" and "length ys = n"
     and "xs = us @ x # xs'" and "ys = us @ y # ys'" and "(x, y) \<in> r"
     using assms by (fastforce simp: lex_def lexn_conv)
   then show ?thesis by (intro that [of "length us"]) auto
 qed
 
 lemma irrefl_lex: "irrefl r \<Longrightarrow> irrefl (lex r)"
   by (meson irrefl_def lex_take_index)
 
 lemma lexl_not_refl [simp]: "irrefl r \<Longrightarrow> (x,x) \<notin> lex r"
   by (meson irrefl_def lex_take_index)
 
 
 subsubsection \<open>Lexicographic Ordering\<close>
 
 text \<open>Classical lexicographic ordering on lists, ie. "a" < "ab" < "b".
     This ordering does \emph{not} preserve well-foundedness.
      Author: N. Voelker, March 2005.\<close>
 
 definition lexord :: "('a \<times> 'a) set \<Rightarrow> ('a list \<times> 'a list) set" where
 "lexord r = {(x,y). \<exists> a v. y = x @ a # v \<or>
             (\<exists> u a b v w. (a,b) \<in> r \<and> x = u @ (a # v) \<and> y = u @ (b # w))}"
 
 lemma lexord_Nil_left[simp]:  "([],y) \<in> lexord r = (\<exists> a x. y = a # x)"
 by (unfold lexord_def, induct_tac y, auto)
 
 lemma lexord_Nil_right[simp]: "(x,[]) \<notin> lexord r"
 by (unfold lexord_def, induct_tac x, auto)
 
 lemma lexord_cons_cons[simp]:
   "(a # x, b # y) \<in> lexord r \<longleftrightarrow> (a,b)\<in> r \<or> (a = b \<and> (x,y)\<in> lexord r)"  (is "?lhs = ?rhs")
 proof
   assume ?lhs
   then show ?rhs
     apply (simp add: lexord_def)
     apply (metis hd_append list.sel(1) list.sel(3) tl_append2)
     done
 qed (auto simp add: lexord_def; (blast | meson Cons_eq_appendI))
 
 lemmas lexord_simps = lexord_Nil_left lexord_Nil_right lexord_cons_cons
 
 lemma lexord_same_pref_iff:
   "(xs @ ys, xs @ zs) \<in> lexord r \<longleftrightarrow> (\<exists>x \<in> set xs. (x,x) \<in> r) \<or> (ys, zs) \<in> lexord r"
 by(induction xs) auto
 
 lemma lexord_same_pref_if_irrefl[simp]:
   "irrefl r \<Longrightarrow> (xs @ ys, xs @ zs) \<in> lexord r \<longleftrightarrow> (ys, zs) \<in> lexord r"
 by (simp add: irrefl_def lexord_same_pref_iff)
 
 lemma lexord_append_rightI: "\<exists> b z. y = b # z \<Longrightarrow> (x, x @ y) \<in> lexord r"
 by (metis append_Nil2 lexord_Nil_left lexord_same_pref_iff)
 
 lemma lexord_append_left_rightI:
   "(a,b) \<in> r \<Longrightarrow> (u @ a # x, u @ b # y) \<in> lexord r"
 by (simp add: lexord_same_pref_iff)
 
 lemma lexord_append_leftI: "(u,v) \<in> lexord r \<Longrightarrow> (x @ u, x @ v) \<in> lexord r"
 by (simp add: lexord_same_pref_iff)
 
 lemma lexord_append_leftD:
   "\<lbrakk>(x @ u, x @ v) \<in> lexord r; (\<forall>a. (a,a) \<notin> r) \<rbrakk> \<Longrightarrow> (u,v) \<in> lexord r"
 by (simp add: lexord_same_pref_iff)
 
 lemma lexord_take_index_conv:
    "((x,y) \<in> lexord r) =
     ((length x < length y \<and> take (length x) y = x) \<or>
      (\<exists>i. i < min(length x)(length y) \<and> take i x = take i y \<and> (x!i,y!i) \<in> r))"
 proof -
   have "(\<exists>a v. y = x @ a # v) = (length x < length y \<and> take (length x) y = x)"
     by (metis Cons_nth_drop_Suc append_eq_conv_conj drop_all list.simps(3) not_le)
   moreover
   have "(\<exists>u a b. (a, b) \<in> r \<and> (\<exists>v. x = u @ a # v) \<and> (\<exists>w. y = u @ b # w)) =
         (\<exists>i<length x. i < length y \<and> take i x = take i y \<and> (x ! i, y ! i) \<in> r)"
     apply safe
     using less_iff_Suc_add apply auto[1]
     by (metis id_take_nth_drop)
   ultimately show ?thesis
     by (auto simp: lexord_def Let_def)
 qed
 
 \<comment> \<open>lexord is extension of partial ordering List.lex\<close>
 lemma lexord_lex: "(x,y) \<in> lex r = ((x,y) \<in> lexord r \<and> length x = length y)"
 proof (induction x arbitrary: y)
   case (Cons a x y) then show ?case
     by (cases y) (force+)
 qed auto
 
 lemma lexord_sufI:
   assumes "(u,w) \<in> lexord r" "length w \<le> length u"
   shows "(u@v,w@z) \<in> lexord r"
 proof-
   from leD[OF assms(2)] assms(1)[unfolded lexord_take_index_conv[of u w r] min_absorb2[OF assms(2)]]
   obtain i where "take i u = take i w" and "(u!i,w!i) \<in> r" and "i < length w"
     by blast
   hence "((u@v)!i, (w@z)!i) \<in> r"
     unfolding nth_append using less_le_trans[OF \<open>i < length w\<close> assms(2)] \<open>(u!i,w!i) \<in> r\<close>
     by presburger
   moreover have "i < min (length (u@v)) (length (w@z))"
     using assms(2) \<open>i < length w\<close> by simp
   moreover have "take i (u@v) = take i (w@z)"
     using assms(2) \<open>i < length w\<close> \<open>take i u = take i w\<close> by simp
   ultimately show ?thesis
     using lexord_take_index_conv by blast
 qed
 
 lemma lexord_sufE:
   assumes "(xs@zs,ys@qs) \<in> lexord r" "xs \<noteq> ys" "length xs = length ys" "length zs = length qs"
   shows "(xs,ys) \<in> lexord r"
 proof-
   obtain i where "i < length (xs@zs)" and "i < length (ys@qs)" and "take i (xs@zs) = take i (ys@qs)"
   and "((xs@zs) ! i, (ys@qs) ! i) \<in> r"
     using assms(1) lex_take_index[unfolded lexord_lex,of "xs @ zs" "ys @ qs" r]
       length_append[of xs zs, unfolded assms(3,4), folded length_append[of ys qs]]
     by blast
   have "length (take i xs) = length (take i ys)"
     by (simp add: assms(3))
   have "i < length xs"
     using assms(2,3) le_less_linear take_all[of xs i] take_all[of ys i]
       \<open>take i (xs @ zs) = take i (ys @ qs)\<close> append_eq_append_conv take_append
     by metis
   hence "(xs ! i, ys ! i) \<in> r"
     using \<open>((xs @ zs) ! i, (ys @ qs) ! i) \<in> r\<close> assms(3) by (simp add: nth_append)
   moreover have "take i xs = take i ys"
     using assms(3) \<open>take i (xs @ zs) = take i (ys @ qs)\<close> by auto
   ultimately show ?thesis
     unfolding lexord_take_index_conv using \<open>i < length xs\<close> assms(3) by fastforce
 qed
 
 lemma lexord_irreflexive: "\<forall>x. (x,x) \<notin> r \<Longrightarrow> (xs,xs) \<notin> lexord r"
 by (induct xs) auto
 
 text\<open>By Ren\'e Thiemann:\<close>
 lemma lexord_partial_trans:
   "(\<And>x y z. x \<in> set xs \<Longrightarrow> (x,y) \<in> r \<Longrightarrow> (y,z) \<in> r \<Longrightarrow> (x,z) \<in> r)
    \<Longrightarrow>  (xs,ys) \<in> lexord r  \<Longrightarrow>  (ys,zs) \<in> lexord r \<Longrightarrow>  (xs,zs) \<in> lexord r"
 proof (induct xs arbitrary: ys zs)
   case Nil
   from Nil(3) show ?case unfolding lexord_def by (cases zs, auto)
 next
   case (Cons x xs yys zzs)
   from Cons(3) obtain y ys where yys: "yys = y # ys" unfolding lexord_def
     by (cases yys, auto)
   note Cons = Cons[unfolded yys]
   from Cons(3) have one: "(x,y) \<in> r \<or> x = y \<and> (xs,ys) \<in> lexord r" by auto
   from Cons(4) obtain z zs where zzs: "zzs = z # zs" unfolding lexord_def
     by (cases zzs, auto)
   note Cons = Cons[unfolded zzs]
   from Cons(4) have two: "(y,z) \<in> r \<or> y = z \<and> (ys,zs) \<in> lexord r" by auto
   {
     assume "(xs,ys) \<in> lexord r" and "(ys,zs) \<in> lexord r"
     from Cons(1)[OF _ this] Cons(2)
     have "(xs,zs) \<in> lexord r" by auto
   } note ind1 = this
   {
     assume "(x,y) \<in> r" and "(y,z) \<in> r"
     from Cons(2)[OF _ this] have "(x,z) \<in> r" by auto
   } note ind2 = this
   from one two ind1 ind2
   have "(x,z) \<in> r \<or> x = z \<and> (xs,zs) \<in> lexord r" by blast
   thus ?case unfolding zzs by auto
 qed
 
 lemma lexord_trans:
   "\<lbrakk> (x, y) \<in> lexord r; (y, z) \<in> lexord r; trans r \<rbrakk> \<Longrightarrow> (x, z) \<in> lexord r"
   by(auto simp: trans_def intro:lexord_partial_trans)
 
 lemma lexord_transI:  "trans r \<Longrightarrow> trans (lexord r)"
   by (meson lexord_trans transI)
 
 lemma total_lexord: "total r \<Longrightarrow> total (lexord r)"
   unfolding total_on_def
 proof clarsimp
   fix x y
   assume "\<forall>x y. x \<noteq> y \<longrightarrow> (x, y) \<in> r \<or> (y, x) \<in> r"
     and "(x::'a list) \<noteq> y"
     and "(y, x) \<notin> lexord r"
   then
   show "(x, y) \<in> lexord r"
   proof (induction x arbitrary: y)
     case Nil
     then show ?case
       by (metis lexord_Nil_left list.exhaust)
   next
     case (Cons a x y) then show ?case
       by (cases y) (force+)
   qed
 qed
 
 corollary lexord_linear: "(\<forall>a b. (a,b) \<in> r \<or> a = b \<or> (b,a) \<in> r) \<Longrightarrow> (x,y) \<in> lexord r \<or> x = y \<or> (y,x) \<in> lexord r"
   using total_lexord by (metis UNIV_I total_on_def)
 
 lemma lexord_irrefl:
   "irrefl R \<Longrightarrow> irrefl (lexord R)"
 by (simp add: irrefl_def lexord_irreflexive)
 
 lemma lexord_asym:
   assumes "asym R"
   shows "asym (lexord R)"
 proof
   fix xs ys
   assume "(xs, ys) \<in> lexord R"
   then show "(ys, xs) \<notin> lexord R"
   proof (induct xs arbitrary: ys)
     case Nil
     then show ?case by simp
   next
     case (Cons x xs)
     then obtain z zs where ys: "ys = z # zs" by (cases ys) auto
     with assms Cons show ?case by (auto dest: asymD)
   qed
 qed
 
 lemma lexord_asymmetric:
   assumes "asym R"
   assumes hyp: "(a, b) \<in> lexord R"
   shows "(b, a) \<notin> lexord R"
 proof -
   from \<open>asym R\<close> have "asym (lexord R)" by (rule lexord_asym)
   then show ?thesis by (auto simp: hyp dest: asymD)
 qed
 
 lemma asym_lex: "asym R \<Longrightarrow> asym (lex R)"
   by (meson asymI asymD irrefl_lex lexord_asym lexord_lex)
 
 lemma asym_lenlex: "asym R \<Longrightarrow> asym (lenlex R)"
   by (simp add: lenlex_def asym_inv_image asym_less_than asym_lex asym_lex_prod)
 
 lemma lenlex_append1:
   assumes len: "(us,xs) \<in> lenlex R" and eq: "length vs = length ys"
   shows "(us @ vs, xs @ ys) \<in> lenlex R"
   using len
 proof (induction us)
   case Nil
   then show ?case
     by (simp add: lenlex_def eq)
 next
   case (Cons u us)
   with lex_append_rightI show ?case
     by (fastforce simp add: lenlex_def eq)
 qed
 
 lemma lenlex_append2 [simp]:
   assumes "irrefl R"
   shows "(us @ xs, us @ ys) \<in> lenlex R \<longleftrightarrow> (xs, ys) \<in> lenlex R"
 proof (induction us)
   case Nil
   then show ?case
     by (simp add: lenlex_def)
 next
   case (Cons u us)
   with assms show ?case
     by (auto simp: lenlex_def irrefl_def)
 qed
 
 text \<open>
   Predicate version of lexicographic order integrated with Isabelle's order type classes.
   Author: Andreas Lochbihler
 \<close>
 
 context ord
 begin
 
 context
   notes [[inductive_internals]]
 begin
 
 inductive lexordp :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
 where
   Nil: "lexordp [] (y # ys)"
 | Cons: "x < y \<Longrightarrow> lexordp (x # xs) (y # ys)"
 | Cons_eq:
   "\<lbrakk> \<not> x < y; \<not> y < x; lexordp xs ys \<rbrakk> \<Longrightarrow> lexordp (x # xs) (y # ys)"
 
 end
 
 lemma lexordp_simps [simp, code]:
   "lexordp [] ys = (ys \<noteq> [])"
   "lexordp xs [] = False"
   "lexordp (x # xs) (y # ys) \<longleftrightarrow> x < y \<or> \<not> y < x \<and> lexordp xs ys"
 by(subst lexordp.simps, fastforce simp add: neq_Nil_conv)+
 
 inductive lexordp_eq :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
   Nil: "lexordp_eq [] ys"
 | Cons: "x < y \<Longrightarrow> lexordp_eq (x # xs) (y # ys)"
 | Cons_eq: "\<lbrakk> \<not> x < y; \<not> y < x; lexordp_eq xs ys \<rbrakk> \<Longrightarrow> lexordp_eq (x # xs) (y # ys)"
 
 lemma lexordp_eq_simps [simp, code]:
   "lexordp_eq [] ys = True"
   "lexordp_eq xs [] \<longleftrightarrow> xs = []"
   "lexordp_eq (x # xs) [] = False"
   "lexordp_eq (x # xs) (y # ys) \<longleftrightarrow> x < y \<or> \<not> y < x \<and> lexordp_eq xs ys"
 by(subst lexordp_eq.simps, fastforce)+
 
 lemma lexordp_append_rightI: "ys \<noteq> Nil \<Longrightarrow> lexordp xs (xs @ ys)"
 by(induct xs)(auto simp add: neq_Nil_conv)
 
 lemma lexordp_append_left_rightI: "x < y \<Longrightarrow> lexordp (us @ x # xs) (us @ y # ys)"
 by(induct us) auto
 
 lemma lexordp_eq_refl: "lexordp_eq xs xs"
 by(induct xs) simp_all
 
 lemma lexordp_append_leftI: "lexordp us vs \<Longrightarrow> lexordp (xs @ us) (xs @ vs)"
 by(induct xs) auto
 
 lemma lexordp_append_leftD: "\<lbrakk> lexordp (xs @ us) (xs @ vs); \<forall>a. \<not> a < a \<rbrakk> \<Longrightarrow> lexordp us vs"
 by(induct xs) auto
 
 lemma lexordp_irreflexive:
   assumes irrefl: "\<forall>x. \<not> x < x"
   shows "\<not> lexordp xs xs"
 proof
   assume "lexordp xs xs"
   thus False by(induct xs ys\<equiv>xs)(simp_all add: irrefl)
 qed
 
 lemma lexordp_into_lexordp_eq:
   "lexordp xs ys \<Longrightarrow> lexordp_eq xs ys"
 by (induction rule: lexordp.induct) simp_all
 
 lemma lexordp_eq_pref: "lexordp_eq u (u @ v)"
 by (metis append_Nil2 lexordp_append_rightI lexordp_eq_refl lexordp_into_lexordp_eq)
 
 end
 
 declare ord.lexordp_simps [simp, code]
 declare ord.lexordp_eq_simps [simp, code]
 
 context order
 begin
 
 lemma lexordp_antisym:
   assumes "lexordp xs ys" "lexordp ys xs"
   shows False
   using assms by induct auto
 
 lemma lexordp_irreflexive': "\<not> lexordp xs xs"
 by(rule lexordp_irreflexive) simp
 
 end
 
 context linorder begin
 
 lemma lexordp_cases [consumes 1, case_names Nil Cons Cons_eq, cases pred: lexordp]:
   assumes "lexordp xs ys"
   obtains (Nil) y ys' where "xs = []" "ys = y # ys'"
   | (Cons) x xs' y ys' where "xs = x # xs'" "ys = y # ys'" "x < y"
   | (Cons_eq) x xs' ys' where "xs = x # xs'" "ys = x # ys'" "lexordp xs' ys'"
 using assms by cases (fastforce simp add: not_less_iff_gr_or_eq)+
 
 lemma lexordp_induct [consumes 1, case_names Nil Cons Cons_eq, induct pred: lexordp]:
   assumes major: "lexordp xs ys"
   and Nil: "\<And>y ys. P [] (y # ys)"
   and Cons: "\<And>x xs y ys. x < y \<Longrightarrow> P (x # xs) (y # ys)"
   and Cons_eq: "\<And>x xs ys. \<lbrakk> lexordp xs ys; P xs ys \<rbrakk> \<Longrightarrow> P (x # xs) (x # ys)"
   shows "P xs ys"
 using major by induct (simp_all add: Nil Cons not_less_iff_gr_or_eq Cons_eq)
 
 lemma lexordp_iff:
   "lexordp xs ys \<longleftrightarrow> (\<exists>x vs. ys = xs @ x # vs) \<or> (\<exists>us a b vs ws. a < b \<and> xs = us @ a # vs \<and> ys = us @ b # ws)"
   (is "?lhs = ?rhs")
 proof
   assume ?lhs thus ?rhs
   proof induct
     case Cons_eq thus ?case by simp (metis append.simps(2))
   qed(fastforce intro: disjI2 del: disjCI intro: exI[where x="[]"])+
 next
   assume ?rhs thus ?lhs
     by(auto intro: lexordp_append_leftI[where us="[]", simplified] lexordp_append_leftI)
 qed
 
 lemma lexordp_conv_lexord:
   "lexordp xs ys \<longleftrightarrow> (xs, ys) \<in> lexord {(x, y). x < y}"
 by(simp add: lexordp_iff lexord_def)
 
 lemma lexordp_eq_antisym:
   assumes "lexordp_eq xs ys" "lexordp_eq ys xs"
   shows "xs = ys"
 using assms by induct simp_all
 
 lemma lexordp_eq_trans:
   assumes "lexordp_eq xs ys" and "lexordp_eq ys zs"
   shows "lexordp_eq xs zs"
   using assms
   by (induct arbitrary: zs) (case_tac zs; auto)+
 
 lemma lexordp_trans:
   assumes "lexordp xs ys" "lexordp ys zs"
   shows "lexordp xs zs"
   using assms
   by (induct arbitrary: zs) (case_tac zs; auto)+
 
 lemma lexordp_linear: "lexordp xs ys \<or> xs = ys \<or> lexordp ys xs"
   by(induct xs arbitrary: ys; case_tac ys; fastforce)
 
 lemma lexordp_conv_lexordp_eq: "lexordp xs ys \<longleftrightarrow> lexordp_eq xs ys \<and> \<not> lexordp_eq ys xs"
   (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume ?lhs
   hence "\<not> lexordp_eq ys xs" by induct simp_all
   with \<open>?lhs\<close> show ?rhs by (simp add: lexordp_into_lexordp_eq)
 next
   assume ?rhs
   hence "lexordp_eq xs ys" "\<not> lexordp_eq ys xs" by simp_all
   thus ?lhs by induct simp_all
 qed
 
 lemma lexordp_eq_conv_lexord: "lexordp_eq xs ys \<longleftrightarrow> xs = ys \<or> lexordp xs ys"
 by(auto simp add: lexordp_conv_lexordp_eq lexordp_eq_refl dest: lexordp_eq_antisym)
 
 lemma lexordp_eq_linear: "lexordp_eq xs ys \<or> lexordp_eq ys xs"
   by (induct xs arbitrary: ys) (case_tac ys; auto)+
 
 lemma lexordp_linorder: "class.linorder lexordp_eq lexordp"
   by unfold_locales
      (auto simp add: lexordp_conv_lexordp_eq lexordp_eq_refl lexordp_eq_antisym intro: lexordp_eq_trans del: disjCI intro: lexordp_eq_linear)
 
 end
 
 
 subsubsection \<open>Lexicographic combination of measure functions\<close>
 
 text \<open>These are useful for termination proofs\<close>
 
 definition "measures fs = inv_image (lex less_than) (%a. map (%f. f a) fs)"
 
 lemma wf_measures[simp]: "wf (measures fs)"
 unfolding measures_def
 by blast
 
 lemma in_measures[simp]:
   "(x, y) \<in> measures [] = False"
   "(x, y) \<in> measures (f # fs)
          = (f x < f y \<or> (f x = f y \<and> (x, y) \<in> measures fs))"
 unfolding measures_def
 by auto
 
 lemma measures_less: "f x < f y \<Longrightarrow> (x, y) \<in> measures (f#fs)"
 by simp
 
 lemma measures_lesseq: "f x \<le> f y \<Longrightarrow> (x, y) \<in> measures fs \<Longrightarrow> (x, y) \<in> measures (f#fs)"
 by auto
 
 
 subsubsection \<open>Lifting Relations to Lists: one element\<close>
 
 definition listrel1 :: "('a \<times> 'a) set \<Rightarrow> ('a list \<times> 'a list) set" where
 "listrel1 r = {(xs,ys).
    \<exists>us z z' vs. xs = us @ z # vs \<and> (z,z') \<in> r \<and> ys = us @ z' # vs}"
 
 lemma listrel1I:
   "\<lbrakk> (x, y) \<in> r;  xs = us @ x # vs;  ys = us @ y # vs \<rbrakk> \<Longrightarrow>
   (xs, ys) \<in> listrel1 r"
 unfolding listrel1_def by auto
 
 lemma listrel1E:
   "\<lbrakk> (xs, ys) \<in> listrel1 r;
      !!x y us vs. \<lbrakk> (x, y) \<in> r;  xs = us @ x # vs;  ys = us @ y # vs \<rbrakk> \<Longrightarrow> P
    \<rbrakk> \<Longrightarrow> P"
 unfolding listrel1_def by auto
 
 lemma not_Nil_listrel1 [iff]: "([], xs) \<notin> listrel1 r"
 unfolding listrel1_def by blast
 
 lemma not_listrel1_Nil [iff]: "(xs, []) \<notin> listrel1 r"
 unfolding listrel1_def by blast
 
 lemma Cons_listrel1_Cons [iff]:
   "(x # xs, y # ys) \<in> listrel1 r \<longleftrightarrow>
    (x,y) \<in> r \<and> xs = ys \<or> x = y \<and> (xs, ys) \<in> listrel1 r"
 by (simp add: listrel1_def Cons_eq_append_conv) (blast)
 
 lemma listrel1I1: "(x,y) \<in> r \<Longrightarrow> (x # xs, y # xs) \<in> listrel1 r"
 by fast
 
 lemma listrel1I2: "(xs, ys) \<in> listrel1 r \<Longrightarrow> (x # xs, x # ys) \<in> listrel1 r"
 by fast
 
 lemma append_listrel1I:
   "(xs, ys) \<in> listrel1 r \<and> us = vs \<or> xs = ys \<and> (us, vs) \<in> listrel1 r
     \<Longrightarrow> (xs @ us, ys @ vs) \<in> listrel1 r"
 unfolding listrel1_def
 by auto (blast intro: append_eq_appendI)+
 
 lemma Cons_listrel1E1[elim!]:
   assumes "(x # xs, ys) \<in> listrel1 r"
     and "\<And>y. ys = y # xs \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> R"
     and "\<And>zs. ys = x # zs \<Longrightarrow> (xs, zs) \<in> listrel1 r \<Longrightarrow> R"
   shows R
 using assms by (cases ys) blast+
 
 lemma Cons_listrel1E2[elim!]:
   assumes "(xs, y # ys) \<in> listrel1 r"
     and "\<And>x. xs = x # ys \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> R"
     and "\<And>zs. xs = y # zs \<Longrightarrow> (zs, ys) \<in> listrel1 r \<Longrightarrow> R"
   shows R
 using assms by (cases xs) blast+
 
 lemma snoc_listrel1_snoc_iff:
   "(xs @ [x], ys @ [y]) \<in> listrel1 r
     \<longleftrightarrow> (xs, ys) \<in> listrel1 r \<and> x = y \<or> xs = ys \<and> (x,y) \<in> r" (is "?L \<longleftrightarrow> ?R")
 proof
   assume ?L thus ?R
     by (fastforce simp: listrel1_def snoc_eq_iff_butlast butlast_append)
 next
   assume ?R then show ?L unfolding listrel1_def by force
 qed
 
 lemma listrel1_eq_len: "(xs,ys) \<in> listrel1 r \<Longrightarrow> length xs = length ys"
 unfolding listrel1_def by auto
 
 lemma listrel1_mono:
   "r \<subseteq> s \<Longrightarrow> listrel1 r \<subseteq> listrel1 s"
 unfolding listrel1_def by blast
 
 
 lemma listrel1_converse: "listrel1 (r\<inverse>) = (listrel1 r)\<inverse>"
 unfolding listrel1_def by blast
 
 lemma in_listrel1_converse:
   "(x,y) \<in> listrel1 (r\<inverse>) \<longleftrightarrow> (x,y) \<in> (listrel1 r)\<inverse>"
 unfolding listrel1_def by blast
 
 lemma listrel1_iff_update:
   "(xs,ys) \<in> (listrel1 r)
    \<longleftrightarrow> (\<exists>y n. (xs ! n, y) \<in> r \<and> n < length xs \<and> ys = xs[n:=y])" (is "?L \<longleftrightarrow> ?R")
 proof
   assume "?L"
   then obtain x y u v where "xs = u @ x # v"  "ys = u @ y # v"  "(x,y) \<in> r"
     unfolding listrel1_def by auto
   then have "ys = xs[length u := y]" and "length u < length xs"
     and "(xs ! length u, y) \<in> r" by auto
   then show "?R" by auto
 next
   assume "?R"
   then obtain x y n where "(xs!n, y) \<in> r" "n < size xs" "ys = xs[n:=y]" "x = xs!n"
     by auto
   then obtain u v where "xs = u @ x # v" and "ys = u @ y # v" and "(x, y) \<in> r"
     by (auto intro: upd_conv_take_nth_drop id_take_nth_drop)
   then show "?L" by (auto simp: listrel1_def)
 qed
 
 
 text\<open>Accessible part and wellfoundedness:\<close>
 
 lemma Cons_acc_listrel1I [intro!]:
   "x \<in> Wellfounded.acc r \<Longrightarrow> xs \<in> Wellfounded.acc (listrel1 r) \<Longrightarrow> (x # xs) \<in> Wellfounded.acc (listrel1 r)"
 proof (induction arbitrary: xs set: Wellfounded.acc)
   case outer: (1 u)
   show ?case
   proof (induct xs rule: acc_induct)
     case 1
     show "xs \<in> Wellfounded.acc (listrel1 r)"
       by (simp add: outer.prems)
   qed (metis (no_types, lifting) Cons_listrel1E2 acc.simps outer.IH)
 qed
 
 lemma lists_accD: "xs \<in> lists (Wellfounded.acc r) \<Longrightarrow> xs \<in> Wellfounded.acc (listrel1 r)"
 proof (induct set: lists)
   case Nil
   then show ?case
     by (meson acc.intros not_listrel1_Nil)
 next
   case (Cons a l)
   then show ?case
     by blast
 qed
 
 lemma lists_accI: "xs \<in> Wellfounded.acc (listrel1 r) \<Longrightarrow> xs \<in> lists (Wellfounded.acc r)"
 proof (induction set: Wellfounded.acc)
   case (1 x)
   then have "\<And>u v. \<lbrakk>u \<in> set x; (v, u) \<in> r\<rbrakk> \<Longrightarrow> v \<in> Wellfounded.acc r"
     by (metis in_lists_conv_set in_set_conv_decomp listrel1I)
   then show ?case
     by (meson acc.intros in_listsI)
 qed
 
 lemma wf_listrel1_iff[simp]: "wf(listrel1 r) = wf r"
 by (auto simp: wf_acc_iff
       intro: lists_accD lists_accI[THEN Cons_in_lists_iff[THEN iffD1, THEN conjunct1]])
 
 subsubsection \<open>Lifting Relations to Lists: all elements\<close>
 
 inductive_set
   listrel :: "('a \<times> 'b) set \<Rightarrow> ('a list \<times> 'b list) set"
   for r :: "('a \<times> 'b) set"
 where
     Nil:  "([],[]) \<in> listrel r"
   | Cons: "\<lbrakk>(x,y) \<in> r; (xs,ys) \<in> listrel r\<rbrakk> \<Longrightarrow> (x#xs, y#ys) \<in> listrel r"
 
 inductive_cases listrel_Nil1 [elim!]: "([],xs) \<in> listrel r"
 inductive_cases listrel_Nil2 [elim!]: "(xs,[]) \<in> listrel r"
 inductive_cases listrel_Cons1 [elim!]: "(y#ys,xs) \<in> listrel r"
 inductive_cases listrel_Cons2 [elim!]: "(xs,y#ys) \<in> listrel r"
 
 
 lemma listrel_eq_len:  "(xs, ys) \<in> listrel r \<Longrightarrow> length xs = length ys"
   by(induct rule: listrel.induct) auto
 
 lemma listrel_iff_zip [code_unfold]: "(xs,ys) \<in> listrel r \<longleftrightarrow>
   length xs = length ys \<and> (\<forall>(x,y) \<in> set(zip xs ys). (x,y) \<in> r)" (is "?L \<longleftrightarrow> ?R")
 proof
   assume ?L thus ?R by induct (auto intro: listrel_eq_len)
 next
   assume ?R thus ?L
     apply (clarify)
     by (induct rule: list_induct2) (auto intro: listrel.intros)
 qed
 
 lemma listrel_iff_nth: "(xs,ys) \<in> listrel r \<longleftrightarrow>
   length xs = length ys \<and> (\<forall>n < length xs. (xs!n, ys!n) \<in> r)" (is "?L \<longleftrightarrow> ?R")
   by (auto simp add: all_set_conv_all_nth listrel_iff_zip)
 
 lemma listrel_mono: "r \<subseteq> s \<Longrightarrow> listrel r \<subseteq> listrel s"
   by (meson listrel_iff_nth subrelI subset_eq)
 
 lemma listrel_subset:
   assumes "r \<subseteq> A \<times> A" shows "listrel r \<subseteq> lists A \<times> lists A"
 proof clarify
   show "a \<in> lists A \<and> b \<in> lists A" if "(a, b) \<in> listrel r" for a b
     using that assms by (induction rule: listrel.induct, auto)
 qed
 
 lemma listrel_refl_on:
   assumes "refl_on A r" shows "refl_on (lists A) (listrel r)"
 proof -
   have "l \<in> lists A \<Longrightarrow> (l, l) \<in> listrel r" for l
     using assms unfolding refl_on_def
     by (induction l, auto intro: listrel.intros)
   then show ?thesis
     by (meson assms listrel_subset refl_on_def)
 qed
 
 lemma listrel_sym: "sym r \<Longrightarrow> sym (listrel r)"
   by (simp add: listrel_iff_nth sym_def)
 
 lemma listrel_trans:
   assumes "trans r" shows "trans (listrel r)"
 proof -
   have "(x, z) \<in> listrel r" if "(x, y) \<in> listrel r" "(y, z) \<in> listrel r" for x y z
     using that
   proof induction
     case (Cons x y xs ys)
     then show ?case
       by clarsimp (metis assms listrel.Cons listrel_iff_nth transD)
   qed auto
   then show ?thesis
     using transI by blast
 qed
 
 theorem equiv_listrel: "equiv A r \<Longrightarrow> equiv (lists A) (listrel r)"
   by (simp add: equiv_def listrel_refl_on listrel_sym listrel_trans)
 
 lemma listrel_rtrancl_refl[iff]: "(xs,xs) \<in> listrel(r\<^sup>*)"
   using listrel_refl_on[of UNIV, OF refl_rtrancl]
   by(auto simp: refl_on_def)
 
 lemma listrel_rtrancl_trans:
   "\<lbrakk>(xs,ys) \<in> listrel(r\<^sup>*);  (ys,zs) \<in> listrel(r\<^sup>*)\<rbrakk> \<Longrightarrow> (xs,zs) \<in> listrel(r\<^sup>*)"
   by (metis listrel_trans trans_def trans_rtrancl)
 
 lemma listrel_Nil [simp]: "listrel r `` {[]} = {[]}"
   by (blast intro: listrel.intros)
 
 lemma listrel_Cons:
   "listrel r `` {x#xs} = set_Cons (r``{x}) (listrel r `` {xs})"
   by (auto simp add: set_Cons_def intro: listrel.intros)
 
 text \<open>Relating \<^term>\<open>listrel1\<close>, \<^term>\<open>listrel\<close> and closures:\<close>
 
 lemma listrel1_rtrancl_subset_rtrancl_listrel1: "listrel1 (r\<^sup>*) \<subseteq> (listrel1 r)\<^sup>*"
 proof (rule subrelI)
   fix xs ys assume 1: "(xs,ys) \<in> listrel1 (r\<^sup>*)"
   { fix x y us vs
     have "(x,y) \<in> r\<^sup>* \<Longrightarrow> (us @ x # vs, us @ y # vs) \<in> (listrel1 r)\<^sup>*"
     proof(induct rule: rtrancl.induct)
       case rtrancl_refl show ?case by simp
     next
       case rtrancl_into_rtrancl thus ?case
         by (metis listrel1I rtrancl.rtrancl_into_rtrancl)
     qed }
   thus "(xs,ys) \<in> (listrel1 r)\<^sup>*" using 1 by(blast elim: listrel1E)
 qed
 
 lemma rtrancl_listrel1_eq_len: "(x,y) \<in> (listrel1 r)\<^sup>* \<Longrightarrow> length x = length y"
   by (induct rule: rtrancl.induct) (auto intro: listrel1_eq_len)
 
 lemma rtrancl_listrel1_ConsI1:
   "(xs,ys) \<in> (listrel1 r)\<^sup>* \<Longrightarrow> (x#xs,x#ys) \<in> (listrel1 r)\<^sup>*"
 proof (induction rule: rtrancl.induct)
   case (rtrancl_into_rtrancl a b c)
   then show ?case
     by (metis listrel1I2 rtrancl.rtrancl_into_rtrancl)
 qed auto
 
 lemma rtrancl_listrel1_ConsI2:
   "(x,y) \<in> r\<^sup>* \<Longrightarrow> (xs, ys) \<in> (listrel1 r)\<^sup>* \<Longrightarrow> (x # xs, y # ys) \<in> (listrel1 r)\<^sup>*"
   by (meson in_mono listrel1I1 listrel1_rtrancl_subset_rtrancl_listrel1 rtrancl_listrel1_ConsI1 rtrancl_trans)
 
 lemma listrel1_subset_listrel:
   "r \<subseteq> r' \<Longrightarrow> refl r' \<Longrightarrow> listrel1 r \<subseteq> listrel(r')"
   by(auto elim!: listrel1E simp add: listrel_iff_zip set_zip refl_on_def)
 
 lemma listrel_reflcl_if_listrel1:
   "(xs,ys) \<in> listrel1 r \<Longrightarrow> (xs,ys) \<in> listrel(r\<^sup>*)"
   by(erule listrel1E)(auto simp add: listrel_iff_zip set_zip)
 
 lemma listrel_rtrancl_eq_rtrancl_listrel1: "listrel (r\<^sup>*) = (listrel1 r)\<^sup>*"
 proof
   { fix x y assume "(x,y) \<in> listrel (r\<^sup>*)"
     then have "(x,y) \<in> (listrel1 r)\<^sup>*"
     by induct (auto intro: rtrancl_listrel1_ConsI2) }
   then show "listrel (r\<^sup>*) \<subseteq> (listrel1 r)\<^sup>*"
     by (rule subrelI)
 next
   show "listrel (r\<^sup>*) \<supseteq> (listrel1 r)\<^sup>*"
   proof(rule subrelI)
     fix xs ys assume "(xs,ys) \<in> (listrel1 r)\<^sup>*"
     then show "(xs,ys) \<in> listrel (r\<^sup>*)"
     proof induct
       case base show ?case by(auto simp add: listrel_iff_zip set_zip)
     next
       case (step ys zs)
       thus ?case by (metis listrel_reflcl_if_listrel1 listrel_rtrancl_trans)
     qed
   qed
 qed
 
 lemma rtrancl_listrel1_if_listrel:
   "(xs,ys) \<in> listrel r \<Longrightarrow> (xs,ys) \<in> (listrel1 r)\<^sup>*"
   by(metis listrel_rtrancl_eq_rtrancl_listrel1 subsetD[OF listrel_mono] r_into_rtrancl subsetI)
 
 lemma listrel_subset_rtrancl_listrel1: "listrel r \<subseteq> (listrel1 r)\<^sup>*"
   by(fast intro:rtrancl_listrel1_if_listrel)
 
 
 subsection \<open>Size function\<close>
 
 lemma [measure_function]: "is_measure f \<Longrightarrow> is_measure (size_list f)"
   by (rule is_measure_trivial)
 
 lemma [measure_function]: "is_measure f \<Longrightarrow> is_measure (size_option f)"
   by (rule is_measure_trivial)
 
 lemma size_list_estimation[termination_simp]:
   "x \<in> set xs \<Longrightarrow> y < f x \<Longrightarrow> y < size_list f xs"
   by (induct xs) auto
 
 lemma size_list_estimation'[termination_simp]:
   "x \<in> set xs \<Longrightarrow> y \<le> f x \<Longrightarrow> y \<le> size_list f xs"
   by (induct xs) auto
 
 lemma size_list_map[simp]: "size_list f (map g xs) = size_list (f \<circ> g) xs"
   by (induct xs) auto
 
 lemma size_list_append[simp]: "size_list f (xs @ ys) = size_list f xs + size_list f ys"
   by (induct xs, auto)
 
 lemma size_list_pointwise[termination_simp]:
   "(\<And>x. x \<in> set xs \<Longrightarrow> f x \<le> g x) \<Longrightarrow> size_list f xs \<le> size_list g xs"
   by (induct xs) force+
 
 
 subsection \<open>Monad operation\<close>
 
 definition bind :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b list) \<Rightarrow> 'b list" where
 "bind xs f = concat (map f xs)"
 
 hide_const (open) bind
 
 lemma bind_simps [simp]:
   "List.bind [] f = []"
   "List.bind (x # xs) f = f x @ List.bind xs f"
   by (simp_all add: bind_def)
 
 lemma list_bind_cong [fundef_cong]:
   assumes "xs = ys" "(\<And>x. x \<in> set xs \<Longrightarrow> f x = g x)"
   shows   "List.bind xs f = List.bind ys g"
 proof -
   from assms(2) have "List.bind xs f = List.bind xs g"
     by (induction xs) simp_all
   with assms(1) show ?thesis by simp
 qed
 
 lemma set_list_bind: "set (List.bind xs f) = (\<Union>x\<in>set xs. set (f x))"
   by (induction xs) simp_all
 
 
 subsection \<open>Code generation\<close>
 
 text\<open>Optional tail recursive version of \<^const>\<open>map\<close>. Can avoid
 stack overflow in some target languages.\<close>
 
 fun map_tailrec_rev ::  "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'b list" where
 "map_tailrec_rev f [] bs = bs" |
 "map_tailrec_rev f (a#as) bs = map_tailrec_rev f as (f a # bs)"
 
 lemma map_tailrec_rev:
   "map_tailrec_rev f as bs = rev(map f as) @ bs"
 by(induction as arbitrary: bs) simp_all
 
 definition map_tailrec :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list" where
 "map_tailrec f as = rev (map_tailrec_rev f as [])"
 
 text\<open>Code equation:\<close>
 lemma map_eq_map_tailrec: "map = map_tailrec"
 by(simp add: fun_eq_iff map_tailrec_def map_tailrec_rev)
 
 
 subsubsection \<open>Counterparts for set-related operations\<close>
 
 definition member :: "'a list \<Rightarrow> 'a \<Rightarrow> bool" where
 [code_abbrev]: "member xs x \<longleftrightarrow> x \<in> set xs"
 
 text \<open>
   Use \<open>member\<close> only for generating executable code.  Otherwise use
   \<^prop>\<open>x \<in> set xs\<close> instead --- it is much easier to reason about.
 \<close>
 
 lemma member_rec [code]:
   "member (x # xs) y \<longleftrightarrow> x = y \<or> member xs y"
   "member [] y \<longleftrightarrow> False"
   by (auto simp add: member_def)
 
 lemma in_set_member (* FIXME delete candidate *):
   "x \<in> set xs \<longleftrightarrow> member xs x"
   by (simp add: member_def)
 
 lemmas list_all_iff [code_abbrev] = fun_cong[OF list.pred_set]
 
 definition list_ex :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
 list_ex_iff [code_abbrev]: "list_ex P xs \<longleftrightarrow> Bex (set xs) P"
 
 definition list_ex1 :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
 list_ex1_iff [code_abbrev]: "list_ex1 P xs \<longleftrightarrow> (\<exists>! x. x \<in> set xs \<and> P x)"
 
 text \<open>
   Usually you should prefer \<open>\<forall>x\<in>set xs\<close>, \<open>\<exists>x\<in>set xs\<close>
   and \<open>\<exists>!x. x\<in>set xs \<and> _\<close> over \<^const>\<open>list_all\<close>, \<^const>\<open>list_ex\<close>
   and \<^const>\<open>list_ex1\<close> in specifications.
 \<close>
 
 lemma list_all_simps [code]:
   "list_all P (x # xs) \<longleftrightarrow> P x \<and> list_all P xs"
   "list_all P [] \<longleftrightarrow> True"
   by (simp_all add: list_all_iff)
 
 lemma list_ex_simps [simp, code]:
   "list_ex P (x # xs) \<longleftrightarrow> P x \<or> list_ex P xs"
   "list_ex P [] \<longleftrightarrow> False"
   by (simp_all add: list_ex_iff)
 
 lemma list_ex1_simps [simp, code]:
   "list_ex1 P [] = False"
   "list_ex1 P (x # xs) = (if P x then list_all (\<lambda>y. \<not> P y \<or> x = y) xs else list_ex1 P xs)"
   by (auto simp add: list_ex1_iff list_all_iff)
 
 lemma Ball_set_list_all: (* FIXME delete candidate *)
   "Ball (set xs) P \<longleftrightarrow> list_all P xs"
   by (simp add: list_all_iff)
 
 lemma Bex_set_list_ex: (* FIXME delete candidate *)
   "Bex (set xs) P \<longleftrightarrow> list_ex P xs"
   by (simp add: list_ex_iff)
 
 lemma list_all_append [simp]:
   "list_all P (xs @ ys) \<longleftrightarrow> list_all P xs \<and> list_all P ys"
   by (auto simp add: list_all_iff)
 
 lemma list_ex_append [simp]:
   "list_ex P (xs @ ys) \<longleftrightarrow> list_ex P xs \<or> list_ex P ys"
   by (auto simp add: list_ex_iff)
 
 lemma list_all_rev [simp]:
   "list_all P (rev xs) \<longleftrightarrow> list_all P xs"
   by (simp add: list_all_iff)
 
 lemma list_ex_rev [simp]:
   "list_ex P (rev xs) \<longleftrightarrow> list_ex P xs"
   by (simp add: list_ex_iff)
 
 lemma list_all_length:
   "list_all P xs \<longleftrightarrow> (\<forall>n < length xs. P (xs ! n))"
   by (auto simp add: list_all_iff set_conv_nth)
 
 lemma list_ex_length:
   "list_ex P xs \<longleftrightarrow> (\<exists>n < length xs. P (xs ! n))"
   by (auto simp add: list_ex_iff set_conv_nth)
 
 lemmas list_all_cong [fundef_cong] = list.pred_cong
 
 lemma list_ex_cong [fundef_cong]:
   "xs = ys \<Longrightarrow> (\<And>x. x \<in> set ys \<Longrightarrow> f x = g x) \<Longrightarrow> list_ex f xs = list_ex g ys"
 by (simp add: list_ex_iff)
 
 definition can_select :: "('a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
 [code_abbrev]: "can_select P A = (\<exists>!x\<in>A. P x)"
 
 lemma can_select_set_list_ex1 [code]:
   "can_select P (set A) = list_ex1 P A"
   by (simp add: list_ex1_iff can_select_def)
 
 
 text \<open>Executable checks for relations on sets\<close>
 
 definition listrel1p :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
 "listrel1p r xs ys = ((xs, ys) \<in> listrel1 {(x, y). r x y})"
 
 lemma [code_unfold]:
   "(xs, ys) \<in> listrel1 r = listrel1p (\<lambda>x y. (x, y) \<in> r) xs ys"
 unfolding listrel1p_def by auto
 
 lemma [code]:
   "listrel1p r [] xs = False"
   "listrel1p r xs [] =  False"
   "listrel1p r (x # xs) (y # ys) \<longleftrightarrow>
      r x y \<and> xs = ys \<or> x = y \<and> listrel1p r xs ys"
 by (simp add: listrel1p_def)+
 
 definition
   lexordp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
   "lexordp r xs ys = ((xs, ys) \<in> lexord {(x, y). r x y})"
 
 lemma [code_unfold]:
   "(xs, ys) \<in> lexord r = lexordp (\<lambda>x y. (x, y) \<in> r) xs ys"
 unfolding lexordp_def by auto
 
 lemma [code]:
   "lexordp r xs [] = False"
   "lexordp r [] (y#ys) = True"
   "lexordp r (x # xs) (y # ys) = (r x y \<or> (x = y \<and> lexordp r xs ys))"
 unfolding lexordp_def by auto
 
 text \<open>Bounded quantification and summation over nats.\<close>
 
 lemma atMost_upto [code_unfold]:
   "{..n} = set [0..<Suc n]"
   by auto
 
 lemma atLeast_upt [code_unfold]:
   "{..<n} = set [0..<n]"
   by auto
 
 lemma greaterThanLessThan_upt [code_unfold]:
   "{n<..<m} = set [Suc n..<m]"
   by auto
 
 lemmas atLeastLessThan_upt [code_unfold] = set_upt [symmetric]
 
 lemma greaterThanAtMost_upt [code_unfold]:
   "{n<..m} = set [Suc n..<Suc m]"
   by auto
 
 lemma atLeastAtMost_upt [code_unfold]:
   "{n..m} = set [n..<Suc m]"
   by auto
 
 lemma all_nat_less_eq [code_unfold]:
   "(\<forall>m<n::nat. P m) \<longleftrightarrow> (\<forall>m \<in> {0..<n}. P m)"
   by auto
 
 lemma ex_nat_less_eq [code_unfold]:
   "(\<exists>m<n::nat. P m) \<longleftrightarrow> (\<exists>m \<in> {0..<n}. P m)"
   by auto
 
 lemma all_nat_less [code_unfold]:
   "(\<forall>m\<le>n::nat. P m) \<longleftrightarrow> (\<forall>m \<in> {0..n}. P m)"
   by auto
 
 lemma ex_nat_less [code_unfold]:
   "(\<exists>m\<le>n::nat. P m) \<longleftrightarrow> (\<exists>m \<in> {0..n}. P m)"
   by auto
 
 text\<open>Bounded \<open>LEAST\<close> operator:\<close>
 
 definition "Bleast S P = (LEAST x. x \<in> S \<and> P x)"
 
 definition "abort_Bleast S P = (LEAST x. x \<in> S \<and> P x)"
 
 declare [[code abort: abort_Bleast]]
 
 lemma Bleast_code [code]:
  "Bleast (set xs) P = (case filter P (sort xs) of
     x#xs \<Rightarrow> x |
     [] \<Rightarrow> abort_Bleast (set xs) P)"
 proof (cases "filter P (sort xs)")
   case Nil thus ?thesis by (simp add: Bleast_def abort_Bleast_def)
 next
   case (Cons x ys)
   have "(LEAST x. x \<in> set xs \<and> P x) = x"
   proof (rule Least_equality)
     show "x \<in> set xs \<and> P x"
       by (metis Cons Cons_eq_filter_iff in_set_conv_decomp set_sort)
     next
       fix y assume "y \<in> set xs \<and> P y"
       hence "y \<in> set (filter P xs)" by auto
       thus "x \<le> y"
         by (metis Cons eq_iff filter_sort set_ConsD set_sort sorted_wrt.simps(2) sorted_sort)
   qed
   thus ?thesis using Cons by (simp add: Bleast_def)
 qed
 
 declare Bleast_def[symmetric, code_unfold]
 
 text \<open>Summation over ints.\<close>
 
 lemma greaterThanLessThan_upto [code_unfold]:
   "{i<..<j::int} = set [i+1..j - 1]"
 by auto
 
 lemma atLeastLessThan_upto [code_unfold]:
   "{i..<j::int} = set [i..j - 1]"
 by auto
 
 lemma greaterThanAtMost_upto [code_unfold]:
   "{i<..j::int} = set [i+1..j]"
 by auto
 
 lemmas atLeastAtMost_upto [code_unfold] = set_upto [symmetric]
 
 
 subsubsection \<open>Optimizing by rewriting\<close>
 
 definition null :: "'a list \<Rightarrow> bool" where
   [code_abbrev]: "null xs \<longleftrightarrow> xs = []"
 
 text \<open>
   Efficient emptyness check is implemented by \<^const>\<open>null\<close>.
 \<close>
 
 lemma null_rec [code]:
   "null (x # xs) \<longleftrightarrow> False"
   "null [] \<longleftrightarrow> True"
   by (simp_all add: null_def)
 
 lemma eq_Nil_null: (* FIXME delete candidate *)
   "xs = [] \<longleftrightarrow> null xs"
   by (simp add: null_def)
 
 lemma equal_Nil_null [code_unfold]:
   "HOL.equal xs [] \<longleftrightarrow> null xs"
   "HOL.equal [] = null"
   by (auto simp add: equal null_def)
 
 definition maps :: "('a \<Rightarrow> 'b list) \<Rightarrow> 'a list \<Rightarrow> 'b list" where
   [code_abbrev]: "maps f xs = concat (map f xs)"
 
 definition map_filter :: "('a \<Rightarrow> 'b option) \<Rightarrow> 'a list \<Rightarrow> 'b list" where
   [code_post]: "map_filter f xs = map (the \<circ> f) (filter (\<lambda>x. f x \<noteq> None) xs)"
 
 text \<open>
   Operations \<^const>\<open>maps\<close> and \<^const>\<open>map_filter\<close> avoid
   intermediate lists on execution -- do not use for proving.
 \<close>
 
 lemma maps_simps [code]:
   "maps f (x # xs) = f x @ maps f xs"
   "maps f [] = []"
   by (simp_all add: maps_def)
 
 lemma map_filter_simps [code]:
   "map_filter f (x # xs) = (case f x of None \<Rightarrow> map_filter f xs | Some y \<Rightarrow> y # map_filter f xs)"
   "map_filter f [] = []"
   by (simp_all add: map_filter_def split: option.split)
 
 lemma concat_map_maps: (* FIXME delete candidate *)
   "concat (map f xs) = maps f xs"
   by (simp add: maps_def)
 
 lemma map_filter_map_filter [code_unfold]:
   "map f (filter P xs) = map_filter (\<lambda>x. if P x then Some (f x) else None) xs"
   by (simp add: map_filter_def)
 
 text \<open>Optimized code for \<open>\<forall>i\<in>{a..b::int}\<close> and \<open>\<forall>n:{a..<b::nat}\<close>
 and similiarly for \<open>\<exists>\<close>.\<close>
 
 definition all_interval_nat :: "(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
   "all_interval_nat P i j \<longleftrightarrow> (\<forall>n \<in> {i..<j}. P n)"
 
 lemma [code]:
   "all_interval_nat P i j \<longleftrightarrow> i \<ge> j \<or> P i \<and> all_interval_nat P (Suc i) j"
 proof -
   have *: "\<And>n. P i \<Longrightarrow> \<forall>n\<in>{Suc i..<j}. P n \<Longrightarrow> i \<le> n \<Longrightarrow> n < j \<Longrightarrow> P n"
     using le_less_Suc_eq by fastforce
   show ?thesis by (auto simp add: all_interval_nat_def intro: *)
 qed
 
 lemma list_all_iff_all_interval_nat [code_unfold]:
   "list_all P [i..<j] \<longleftrightarrow> all_interval_nat P i j"
   by (simp add: list_all_iff all_interval_nat_def)
 
 lemma list_ex_iff_not_all_inverval_nat [code_unfold]:
   "list_ex P [i..<j] \<longleftrightarrow> \<not> (all_interval_nat (Not \<circ> P) i j)"
   by (simp add: list_ex_iff all_interval_nat_def)
 
 definition all_interval_int :: "(int \<Rightarrow> bool) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
   "all_interval_int P i j \<longleftrightarrow> (\<forall>k \<in> {i..j}. P k)"
 
 lemma [code]:
   "all_interval_int P i j \<longleftrightarrow> i > j \<or> P i \<and> all_interval_int P (i + 1) j"
 proof -
   have *: "\<And>k. P i \<Longrightarrow> \<forall>k\<in>{i+1..j}. P k \<Longrightarrow> i \<le> k \<Longrightarrow> k \<le> j \<Longrightarrow> P k"
     by (smt (verit, best) atLeastAtMost_iff)
   show ?thesis by (auto simp add: all_interval_int_def intro: *)
 qed
 
 lemma list_all_iff_all_interval_int [code_unfold]:
   "list_all P [i..j] \<longleftrightarrow> all_interval_int P i j"
   by (simp add: list_all_iff all_interval_int_def)
 
 lemma list_ex_iff_not_all_inverval_int [code_unfold]:
   "list_ex P [i..j] \<longleftrightarrow> \<not> (all_interval_int (Not \<circ> P) i j)"
   by (simp add: list_ex_iff all_interval_int_def)
 
 text \<open>optimized code (tail-recursive) for \<^term>\<open>length\<close>\<close>
 
 definition gen_length :: "nat \<Rightarrow> 'a list \<Rightarrow> nat"
 where "gen_length n xs = n + length xs"
 
 lemma gen_length_code [code]:
   "gen_length n [] = n"
   "gen_length n (x # xs) = gen_length (Suc n) xs"
 by(simp_all add: gen_length_def)
 
 declare list.size(3-4)[code del]
 
 lemma length_code [code]: "length = gen_length 0"
 by(simp add: gen_length_def fun_eq_iff)
 
 hide_const (open) member null maps map_filter all_interval_nat all_interval_int gen_length
 
 
 subsubsection \<open>Pretty lists\<close>
 
 ML \<open>
 (* Code generation for list literals. *)
 
 signature LIST_CODE =
 sig
   val add_literal_list: string -> theory -> theory
 end;
 
 structure List_Code : LIST_CODE =
 struct
 
 open Basic_Code_Thingol;
 
 fun implode_list t =
   let
     fun dest_cons (IConst { sym = Code_Symbol.Constant \<^const_name>\<open>Cons\<close>, ... } `$ t1 `$ t2) = SOME (t1, t2)
       | dest_cons _ = NONE;
     val (ts, t') = Code_Thingol.unfoldr dest_cons t;
   in case t'
    of IConst { sym = Code_Symbol.Constant \<^const_name>\<open>Nil\<close>, ... } => SOME ts
     | _ => NONE
   end;
 
 fun print_list (target_fxy, target_cons) pr fxy t1 t2 =
   Code_Printer.brackify_infix (target_fxy, Code_Printer.R) fxy (
     pr (Code_Printer.INFX (target_fxy, Code_Printer.X)) t1,
     Code_Printer.str target_cons,
     pr (Code_Printer.INFX (target_fxy, Code_Printer.R)) t2
   );
 
 fun add_literal_list target =
   let
     fun pretty literals pr _ vars fxy [(t1, _), (t2, _)] =
       case Option.map (cons t1) (implode_list t2)
        of SOME ts =>
             Code_Printer.literal_list literals (map (pr vars Code_Printer.NOBR) ts)
         | NONE =>
             print_list (Code_Printer.infix_cons literals) (pr vars) fxy t1 t2;
   in
     Code_Target.set_printings (Code_Symbol.Constant (\<^const_name>\<open>Cons\<close>,
       [(target, SOME (Code_Printer.complex_const_syntax (2, pretty)))]))
   end
 
 end;
 \<close>
 
 code_printing
   type_constructor list \<rightharpoonup>
     (SML) "_ list"
     and (OCaml) "_ list"
     and (Haskell) "![(_)]"
     and (Scala) "List[(_)]"
 | constant Nil \<rightharpoonup>
     (SML) "[]"
     and (OCaml) "[]"
     and (Haskell) "[]"
     and (Scala) "!Nil"
 | class_instance list :: equal \<rightharpoonup>
     (Haskell) -
 | constant "HOL.equal :: 'a list \<Rightarrow> 'a list \<Rightarrow> bool" \<rightharpoonup>
     (Haskell) infix 4 "=="
 
 setup \<open>fold (List_Code.add_literal_list) ["SML", "OCaml", "Haskell", "Scala"]\<close>
 
 code_reserved SML
   list
 
 code_reserved OCaml
   list
 
 
 subsubsection \<open>Use convenient predefined operations\<close>
 
 code_printing
   constant "(@)" \<rightharpoonup>
     (SML) infixr 7 "@"
     and (OCaml) infixr 6 "@"
     and (Haskell) infixr 5 "++"
     and (Scala) infixl 7 "++"
 | constant map \<rightharpoonup>
     (Haskell) "map"
 | constant filter \<rightharpoonup>
     (Haskell) "filter"
 | constant concat \<rightharpoonup>
     (Haskell) "concat"
 | constant List.maps \<rightharpoonup>
     (Haskell) "concatMap"
 | constant rev \<rightharpoonup>
     (Haskell) "reverse"
 | constant zip \<rightharpoonup>
     (Haskell) "zip"
 | constant List.null \<rightharpoonup>
     (Haskell) "null"
 | constant takeWhile \<rightharpoonup>
     (Haskell) "takeWhile"
 | constant dropWhile \<rightharpoonup>
     (Haskell) "dropWhile"
 | constant list_all \<rightharpoonup>
     (Haskell) "all"
 | constant list_ex \<rightharpoonup>
     (Haskell) "any"
 
 
 subsubsection \<open>Implementation of sets by lists\<close>
 
 lemma is_empty_set [code]:
   "Set.is_empty (set xs) \<longleftrightarrow> List.null xs"
   by (simp add: Set.is_empty_def null_def)
 
 lemma empty_set [code]:
   "{} = set []"
   by simp
 
 lemma UNIV_coset [code]:
   "UNIV = List.coset []"
   by simp
 
 lemma compl_set [code]:
   "- set xs = List.coset xs"
   by simp
 
 lemma compl_coset [code]:
   "- List.coset xs = set xs"
   by simp
 
 lemma [code]:
   "x \<in> set xs \<longleftrightarrow> List.member xs x"
   "x \<in> List.coset xs \<longleftrightarrow> \<not> List.member xs x"
   by (simp_all add: member_def)
 
 lemma insert_code [code]:
   "insert x (set xs) = set (List.insert x xs)"
   "insert x (List.coset xs) = List.coset (removeAll x xs)"
   by simp_all
 
 lemma remove_code [code]:
   "Set.remove x (set xs) = set (removeAll x xs)"
   "Set.remove x (List.coset xs) = List.coset (List.insert x xs)"
   by (simp_all add: remove_def Compl_insert)
 
 lemma filter_set [code]:
   "Set.filter P (set xs) = set (filter P xs)"
   by auto
 
 lemma image_set [code]:
   "image f (set xs) = set (map f xs)"
   by simp
 
 lemma subset_code [code]:
   "set xs \<le> B \<longleftrightarrow> (\<forall>x\<in>set xs. x \<in> B)"
   "A \<le> List.coset ys \<longleftrightarrow> (\<forall>y\<in>set ys. y \<notin> A)"
   "List.coset [] \<subseteq> set [] \<longleftrightarrow> False"
   by auto
 
 text \<open>A frequent case -- avoid intermediate sets\<close>
 lemma [code_unfold]:
   "set xs \<subseteq> set ys \<longleftrightarrow> list_all (\<lambda>x. x \<in> set ys) xs"
   by (auto simp: list_all_iff)
 
 lemma Ball_set [code]:
   "Ball (set xs) P \<longleftrightarrow> list_all P xs"
   by (simp add: list_all_iff)
 
 lemma Bex_set [code]:
   "Bex (set xs) P \<longleftrightarrow> list_ex P xs"
   by (simp add: list_ex_iff)
 
 lemma card_set [code]:
   "card (set xs) = length (remdups xs)"
   by (simp add: length_remdups_card_conv)
 
 lemma the_elem_set [code]:
   "the_elem (set [x]) = x"
   by simp
 
 lemma Pow_set [code]:
   "Pow (set []) = {{}}"
   "Pow (set (x # xs)) = (let A = Pow (set xs) in A \<union> insert x ` A)"
   by (simp_all add: Pow_insert Let_def)
 
 definition map_project :: "('a \<Rightarrow> 'b option) \<Rightarrow> 'a set \<Rightarrow> 'b set" where
   "map_project f A = {b. \<exists> a \<in> A. f a = Some b}"
 
 lemma [code]:
   "map_project f (set xs) = set (List.map_filter f xs)"
   by (auto simp add: map_project_def map_filter_def image_def)
 
 hide_const (open) map_project
 
 
 text \<open>Operations on relations\<close>
 
 lemma product_code [code]:
   "Product_Type.product (set xs) (set ys) = set [(x, y). x \<leftarrow> xs, y \<leftarrow> ys]"
   by (auto simp add: Product_Type.product_def)
 
 lemma Id_on_set [code]:
   "Id_on (set xs) = set [(x, x). x \<leftarrow> xs]"
   by (auto simp add: Id_on_def)
 
 lemma [code]:
   "R `` S = List.map_project (\<lambda>(x, y). if x \<in> S then Some y else None) R"
 unfolding map_project_def by (auto split: prod.split if_split_asm)
 
 lemma trancl_set_ntrancl [code]:
   "trancl (set xs) = ntrancl (card (set xs) - 1) (set xs)"
   by (simp add: finite_trancl_ntranl)
 
 lemma set_relcomp [code]:
   "set xys O set yzs = set ([(fst xy, snd yz). xy \<leftarrow> xys, yz \<leftarrow> yzs, snd xy = fst yz])"
   by auto (auto simp add: Bex_def image_def)
 
 lemma wf_set [code]:
   "wf (set xs) = acyclic (set xs)"
   by (simp add: wf_iff_acyclic_if_finite)
 
 
 subsection \<open>Setup for Lifting/Transfer\<close>
 
 subsubsection \<open>Transfer rules for the Transfer package\<close>
 
 context includes lifting_syntax
 begin
 
 lemma tl_transfer [transfer_rule]:
   "(list_all2 A ===> list_all2 A) tl tl"
   unfolding tl_def[abs_def] by transfer_prover
 
 lemma butlast_transfer [transfer_rule]:
   "(list_all2 A ===> list_all2 A) butlast butlast"
   by (rule rel_funI, erule list_all2_induct, auto)
 
 lemma map_rec: "map f xs = rec_list Nil (%x _ y. Cons (f x) y) xs"
   by (induct xs) auto
 
 lemma append_transfer [transfer_rule]:
   "(list_all2 A ===> list_all2 A ===> list_all2 A) append append"
   unfolding List.append_def by transfer_prover
 
 lemma rev_transfer [transfer_rule]:
   "(list_all2 A ===> list_all2 A) rev rev"
   unfolding List.rev_def by transfer_prover
 
 lemma filter_transfer [transfer_rule]:
   "((A ===> (=)) ===> list_all2 A ===> list_all2 A) filter filter"
   unfolding List.filter_def by transfer_prover
 
 lemma fold_transfer [transfer_rule]:
   "((A ===> B ===> B) ===> list_all2 A ===> B ===> B) fold fold"
   unfolding List.fold_def by transfer_prover
 
 lemma foldr_transfer [transfer_rule]:
   "((A ===> B ===> B) ===> list_all2 A ===> B ===> B) foldr foldr"
   unfolding List.foldr_def by transfer_prover
 
 lemma foldl_transfer [transfer_rule]:
   "((B ===> A ===> B) ===> B ===> list_all2 A ===> B) foldl foldl"
   unfolding List.foldl_def by transfer_prover
 
 lemma concat_transfer [transfer_rule]:
   "(list_all2 (list_all2 A) ===> list_all2 A) concat concat"
   unfolding List.concat_def by transfer_prover
 
 lemma drop_transfer [transfer_rule]:
   "((=) ===> list_all2 A ===> list_all2 A) drop drop"
   unfolding List.drop_def by transfer_prover
 
 lemma take_transfer [transfer_rule]:
   "((=) ===> list_all2 A ===> list_all2 A) take take"
   unfolding List.take_def by transfer_prover
 
 lemma list_update_transfer [transfer_rule]:
   "(list_all2 A ===> (=) ===> A ===> list_all2 A) list_update list_update"
   unfolding list_update_def by transfer_prover
 
 lemma takeWhile_transfer [transfer_rule]:
   "((A ===> (=)) ===> list_all2 A ===> list_all2 A) takeWhile takeWhile"
   unfolding takeWhile_def by transfer_prover
 
 lemma dropWhile_transfer [transfer_rule]:
   "((A ===> (=)) ===> list_all2 A ===> list_all2 A) dropWhile dropWhile"
   unfolding dropWhile_def by transfer_prover
 
 lemma zip_transfer [transfer_rule]:
   "(list_all2 A ===> list_all2 B ===> list_all2 (rel_prod A B)) zip zip"
   unfolding zip_def by transfer_prover
 
 lemma product_transfer [transfer_rule]:
   "(list_all2 A ===> list_all2 B ===> list_all2 (rel_prod A B)) List.product List.product"
   unfolding List.product_def by transfer_prover
 
 lemma product_lists_transfer [transfer_rule]:
   "(list_all2 (list_all2 A) ===> list_all2 (list_all2 A)) product_lists product_lists"
   unfolding product_lists_def by transfer_prover
 
 lemma insert_transfer [transfer_rule]:
   assumes [transfer_rule]: "bi_unique A"
   shows "(A ===> list_all2 A ===> list_all2 A) List.insert List.insert"
   unfolding List.insert_def [abs_def] by transfer_prover
 
 lemma find_transfer [transfer_rule]:
   "((A ===> (=)) ===> list_all2 A ===> rel_option A) List.find List.find"
   unfolding List.find_def by transfer_prover
 
 lemma those_transfer [transfer_rule]:
   "(list_all2 (rel_option P) ===> rel_option (list_all2 P)) those those"
   unfolding List.those_def by transfer_prover
 
 lemma remove1_transfer [transfer_rule]:
   assumes [transfer_rule]: "bi_unique A"
   shows "(A ===> list_all2 A ===> list_all2 A) remove1 remove1"
   unfolding remove1_def by transfer_prover
 
 lemma removeAll_transfer [transfer_rule]:
   assumes [transfer_rule]: "bi_unique A"
   shows "(A ===> list_all2 A ===> list_all2 A) removeAll removeAll"
   unfolding removeAll_def by transfer_prover
 
 lemma successively_transfer [transfer_rule]:
   "((A ===> A ===> (=)) ===> list_all2 A ===> (=)) successively successively"
   unfolding successively_altdef by transfer_prover
 
 lemma distinct_transfer [transfer_rule]:
   assumes [transfer_rule]: "bi_unique A"
   shows "(list_all2 A ===> (=)) distinct distinct"
   unfolding distinct_def by transfer_prover
 
 lemma distinct_adj_transfer [transfer_rule]:
   assumes "bi_unique A"
   shows "(list_all2 A ===> (=)) distinct_adj distinct_adj"
   unfolding rel_fun_def
 proof (intro allI impI)
   fix xs ys assume "list_all2 A xs ys"
   thus "distinct_adj xs \<longleftrightarrow> distinct_adj ys"
   proof (induction rule: list_all2_induct)
     case (Cons x xs y ys)
     show ?case
       by (metis Cons assms bi_unique_def distinct_adj_Cons list.rel_sel)
   qed auto
 qed
 
 lemma remdups_transfer [transfer_rule]:
   assumes [transfer_rule]: "bi_unique A"
   shows "(list_all2 A ===> list_all2 A) remdups remdups"
   unfolding remdups_def by transfer_prover
 
 lemma remdups_adj_transfer [transfer_rule]:
   assumes [transfer_rule]: "bi_unique A"
   shows "(list_all2 A ===> list_all2 A) remdups_adj remdups_adj"
   proof (rule rel_funI, erule list_all2_induct)
   qed (auto simp: remdups_adj_Cons assms[unfolded bi_unique_def] split: list.splits)
 
 lemma replicate_transfer [transfer_rule]:
   "((=) ===> A ===> list_all2 A) replicate replicate"
   unfolding replicate_def by transfer_prover
 
 lemma length_transfer [transfer_rule]:
   "(list_all2 A ===> (=)) length length"
   unfolding size_list_overloaded_def size_list_def by transfer_prover
 
 lemma rotate1_transfer [transfer_rule]:
   "(list_all2 A ===> list_all2 A) rotate1 rotate1"
   unfolding rotate1_def by transfer_prover
 
 lemma rotate_transfer [transfer_rule]:
   "((=) ===> list_all2 A ===> list_all2 A) rotate rotate"
   unfolding rotate_def [abs_def] by transfer_prover
 
 lemma nths_transfer [transfer_rule]:
   "(list_all2 A ===> rel_set (=) ===> list_all2 A) nths nths"
   unfolding nths_def [abs_def] by transfer_prover
 
 lemma subseqs_transfer [transfer_rule]:
   "(list_all2 A ===> list_all2 (list_all2 A)) subseqs subseqs"
   unfolding subseqs_def [abs_def] by transfer_prover
 
 lemma partition_transfer [transfer_rule]:
   "((A ===> (=)) ===> list_all2 A ===> rel_prod (list_all2 A) (list_all2 A))
     partition partition"
   unfolding partition_def by transfer_prover
 
 lemma lists_transfer [transfer_rule]:
   "(rel_set A ===> rel_set (list_all2 A)) lists lists"
 proof (rule rel_funI, rule rel_setI)
   show "\<lbrakk>l \<in> lists X; rel_set A X Y\<rbrakk> \<Longrightarrow> \<exists>y\<in>lists Y. list_all2 A l y" for X Y l
   proof (induction l rule: lists.induct)
     case (Cons a l)
     then show ?case
       by (simp only: rel_set_def list_all2_Cons1, metis lists.Cons)
   qed auto
   show "\<lbrakk>l \<in> lists Y; rel_set A X Y\<rbrakk> \<Longrightarrow> \<exists>x\<in>lists X. list_all2 A x l" for X Y l
   proof (induction l rule: lists.induct)
     case (Cons a l)
     then show ?case
       by (simp only: rel_set_def list_all2_Cons2, metis lists.Cons)
   qed auto
 qed
 
 lemma set_Cons_transfer [transfer_rule]:
   "(rel_set A ===> rel_set (list_all2 A) ===> rel_set (list_all2 A))
     set_Cons set_Cons"
   unfolding rel_fun_def rel_set_def set_Cons_def
   by (fastforce simp add: list_all2_Cons1 list_all2_Cons2)
 
 lemma listset_transfer [transfer_rule]:
   "(list_all2 (rel_set A) ===> rel_set (list_all2 A)) listset listset"
   unfolding listset_def by transfer_prover
 
 lemma null_transfer [transfer_rule]:
   "(list_all2 A ===> (=)) List.null List.null"
   unfolding rel_fun_def List.null_def by auto
 
 lemma list_all_transfer [transfer_rule]:
   "((A ===> (=)) ===> list_all2 A ===> (=)) list_all list_all"
   unfolding list_all_iff [abs_def] by transfer_prover
 
 lemma list_ex_transfer [transfer_rule]:
   "((A ===> (=)) ===> list_all2 A ===> (=)) list_ex list_ex"
   unfolding list_ex_iff [abs_def] by transfer_prover
 
 lemma splice_transfer [transfer_rule]:
   "(list_all2 A ===> list_all2 A ===> list_all2 A) splice splice"
   apply (rule rel_funI, erule list_all2_induct, simp add: rel_fun_def, simp)
   apply (rule rel_funI)
   apply (erule_tac xs=x in list_all2_induct, simp, simp add: rel_fun_def)
   done
 
 lemma shuffles_transfer [transfer_rule]:
   "(list_all2 A ===> list_all2 A ===> rel_set (list_all2 A)) shuffles shuffles"
 proof (intro rel_funI, goal_cases)
   case (1 xs xs' ys ys')
   thus ?case
   proof (induction xs ys arbitrary: xs' ys' rule: shuffles.induct)
     case (3 x xs y ys xs' ys')
     from "3.prems" obtain x' xs'' where xs': "xs' = x' # xs''" by (cases xs') auto
     from "3.prems" obtain y' ys'' where ys': "ys' = y' # ys''" by (cases ys') auto
     have [transfer_rule]: "A x x'" "A y y'" "list_all2 A xs xs''" "list_all2 A ys ys''"
       using "3.prems" by (simp_all add: xs' ys')
     have [transfer_rule]: "rel_set (list_all2 A) (shuffles xs (y # ys)) (shuffles xs'' ys')" and
          [transfer_rule]: "rel_set (list_all2 A) (shuffles (x # xs) ys) (shuffles xs' ys'')"
       using "3.prems" by (auto intro!: "3.IH" simp: xs' ys')
     have "rel_set (list_all2 A) ((#) x ` shuffles xs (y # ys) \<union> (#) y ` shuffles (x # xs) ys)
                ((#) x' ` shuffles xs'' ys' \<union> (#) y' ` shuffles xs' ys'')" by transfer_prover
     thus ?case by (simp add: xs' ys')
   qed (auto simp: rel_set_def)
 qed
 
 lemma rtrancl_parametric [transfer_rule]:
   assumes [transfer_rule]: "bi_unique A" "bi_total A"
   shows "(rel_set (rel_prod A A) ===> rel_set (rel_prod A A)) rtrancl rtrancl"
 unfolding rtrancl_def by transfer_prover
 
 lemma monotone_parametric [transfer_rule]:
   assumes [transfer_rule]: "bi_total A"
   shows "((A ===> A ===> (=)) ===> (B ===> B ===> (=)) ===> (A ===> B) ===> (=)) monotone monotone"
 unfolding monotone_def[abs_def] by transfer_prover
 
 lemma fun_ord_parametric [transfer_rule]:
   assumes [transfer_rule]: "bi_total C"
   shows "((A ===> B ===> (=)) ===> (C ===> A) ===> (C ===> B) ===> (=)) fun_ord fun_ord"
 unfolding fun_ord_def[abs_def] by transfer_prover
 
 lemma fun_lub_parametric [transfer_rule]:
   assumes [transfer_rule]: "bi_total A"  "bi_unique A"
   shows "((rel_set A ===> B) ===> rel_set (C ===> A) ===> C ===> B) fun_lub fun_lub"
 unfolding fun_lub_def[abs_def] by transfer_prover
 
 end
 
 end
diff --git a/src/HOL/Nat.thy b/src/HOL/Nat.thy
--- a/src/HOL/Nat.thy
+++ b/src/HOL/Nat.thy
@@ -1,2572 +1,2572 @@
 (*  Title:      HOL/Nat.thy
     Author:     Tobias Nipkow
     Author:     Lawrence C Paulson
     Author:     Markus Wenzel
 *)
 
 section \<open>Natural numbers\<close>
 
 theory Nat
 imports Inductive Typedef Fun Rings
 begin
 
 subsection \<open>Type \<open>ind\<close>\<close>
 
 typedecl ind
 
 axiomatization Zero_Rep :: ind and Suc_Rep :: "ind \<Rightarrow> ind"
   \<comment> \<open>The axiom of infinity in 2 parts:\<close>
   where Suc_Rep_inject: "Suc_Rep x = Suc_Rep y \<Longrightarrow> x = y"
     and Suc_Rep_not_Zero_Rep: "Suc_Rep x \<noteq> Zero_Rep"
 
 
 subsection \<open>Type nat\<close>
 
 text \<open>Type definition\<close>
 
 inductive Nat :: "ind \<Rightarrow> bool"
   where
     Zero_RepI: "Nat Zero_Rep"
   | Suc_RepI: "Nat i \<Longrightarrow> Nat (Suc_Rep i)"
 
 typedef nat = "{n. Nat n}"
   morphisms Rep_Nat Abs_Nat
   using Nat.Zero_RepI by auto
 
 lemma Nat_Rep_Nat: "Nat (Rep_Nat n)"
   using Rep_Nat by simp
 
 lemma Nat_Abs_Nat_inverse: "Nat n \<Longrightarrow> Rep_Nat (Abs_Nat n) = n"
   using Abs_Nat_inverse by simp
 
 lemma Nat_Abs_Nat_inject: "Nat n \<Longrightarrow> Nat m \<Longrightarrow> Abs_Nat n = Abs_Nat m \<longleftrightarrow> n = m"
   using Abs_Nat_inject by simp
 
 instantiation nat :: zero
 begin
 
 definition Zero_nat_def: "0 = Abs_Nat Zero_Rep"
 
 instance ..
 
 end
 
 definition Suc :: "nat \<Rightarrow> nat"
   where "Suc n = Abs_Nat (Suc_Rep (Rep_Nat n))"
 
 lemma Suc_not_Zero: "Suc m \<noteq> 0"
   by (simp add: Zero_nat_def Suc_def Suc_RepI Zero_RepI
       Nat_Abs_Nat_inject Suc_Rep_not_Zero_Rep Nat_Rep_Nat)
 
 lemma Zero_not_Suc: "0 \<noteq> Suc m"
   by (rule not_sym) (rule Suc_not_Zero)
 
 lemma Suc_Rep_inject': "Suc_Rep x = Suc_Rep y \<longleftrightarrow> x = y"
   by (rule iffI, rule Suc_Rep_inject) simp_all
 
 lemma nat_induct0:
   assumes "P 0" and "\<And>n. P n \<Longrightarrow> P (Suc n)"
   shows "P n"
 proof -
   have "P (Abs_Nat (Rep_Nat n))"
     using assms unfolding Zero_nat_def Suc_def
     by (iprover intro:  Nat_Rep_Nat [THEN Nat.induct] elim: Nat_Abs_Nat_inverse [THEN subst])
   then show ?thesis
     by (simp add: Rep_Nat_inverse)
 qed
 
 free_constructors case_nat for "0 :: nat" | Suc pred
   where "pred (0 :: nat) = (0 :: nat)"
 proof atomize_elim
   fix n
   show "n = 0 \<or> (\<exists>m. n = Suc m)"
     by (induction n rule: nat_induct0) auto
 next
   fix n m
   show "(Suc n = Suc m) = (n = m)"
     by (simp add: Suc_def Nat_Abs_Nat_inject Nat_Rep_Nat Suc_RepI Suc_Rep_inject' Rep_Nat_inject)
 next
   fix n
   show "0 \<noteq> Suc n"
     by (simp add: Suc_not_Zero)
 qed
 
 
 \<comment> \<open>Avoid name clashes by prefixing the output of \<open>old_rep_datatype\<close> with \<open>old\<close>.\<close>
 setup \<open>Sign.mandatory_path "old"\<close>
 
 old_rep_datatype "0 :: nat" Suc
   by (erule nat_induct0) auto
 
 setup \<open>Sign.parent_path\<close>
 
 \<comment> \<open>But erase the prefix for properties that are not generated by \<open>free_constructors\<close>.\<close>
 setup \<open>Sign.mandatory_path "nat"\<close>
 
 declare old.nat.inject[iff del]
   and old.nat.distinct(1)[simp del, induct_simp del]
 
 lemmas induct = old.nat.induct
 lemmas inducts = old.nat.inducts
 lemmas rec = old.nat.rec
 lemmas simps = nat.inject nat.distinct nat.case nat.rec
 
 setup \<open>Sign.parent_path\<close>
 
 abbreviation rec_nat :: "'a \<Rightarrow> (nat \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a"
   where "rec_nat \<equiv> old.rec_nat"
 
 declare nat.sel[code del]
 
 hide_const (open) Nat.pred \<comment> \<open>hide everything related to the selector\<close>
 hide_fact
   nat.case_eq_if
   nat.collapse
   nat.expand
   nat.sel
   nat.exhaust_sel
   nat.split_sel
   nat.split_sel_asm
 
 lemma nat_exhaust [case_names 0 Suc, cases type: nat]:
   "(y = 0 \<Longrightarrow> P) \<Longrightarrow> (\<And>nat. y = Suc nat \<Longrightarrow> P) \<Longrightarrow> P"
   \<comment> \<open>for backward compatibility -- names of variables differ\<close>
   by (rule old.nat.exhaust)
 
 lemma nat_induct [case_names 0 Suc, induct type: nat]:
   fixes n
   assumes "P 0" and "\<And>n. P n \<Longrightarrow> P (Suc n)"
   shows "P n"
   \<comment> \<open>for backward compatibility -- names of variables differ\<close>
   using assms by (rule nat.induct)
 
 hide_fact
   nat_exhaust
   nat_induct0
 
 ML \<open>
 val nat_basic_lfp_sugar =
   let
     val ctr_sugar = the (Ctr_Sugar.ctr_sugar_of_global \<^theory> \<^type_name>\<open>nat\<close>);
     val recx = Logic.varify_types_global \<^term>\<open>rec_nat\<close>;
     val C = body_type (fastype_of recx);
   in
     {T = HOLogic.natT, fp_res_index = 0, C = C, fun_arg_Tsss = [[], [[HOLogic.natT, C]]],
      ctr_sugar = ctr_sugar, recx = recx, rec_thms = @{thms nat.rec}}
   end;
 \<close>
 
 setup \<open>
 let
   fun basic_lfp_sugars_of _ [\<^typ>\<open>nat\<close>] _ _ ctxt =
       ([], [0], [nat_basic_lfp_sugar], [], [], [], TrueI (*dummy*), [], false, ctxt)
     | basic_lfp_sugars_of bs arg_Ts callers callssss ctxt =
       BNF_LFP_Rec_Sugar.default_basic_lfp_sugars_of bs arg_Ts callers callssss ctxt;
 in
   BNF_LFP_Rec_Sugar.register_lfp_rec_extension
     {nested_simps = [], special_endgame_tac = K (K (K (K no_tac))), is_new_datatype = K (K true),
      basic_lfp_sugars_of = basic_lfp_sugars_of, rewrite_nested_rec_call = NONE}
 end
 \<close>
 
 text \<open>Injectiveness and distinctness lemmas\<close>
 
 lemma inj_Suc [simp]:
   "inj_on Suc N"
   by (simp add: inj_on_def)
 
 lemma bij_betw_Suc [simp]:
   "bij_betw Suc M N \<longleftrightarrow> Suc ` M = N"
   by (simp add: bij_betw_def)
 
 lemma Suc_neq_Zero: "Suc m = 0 \<Longrightarrow> R"
   by (rule notE) (rule Suc_not_Zero)
 
 lemma Zero_neq_Suc: "0 = Suc m \<Longrightarrow> R"
   by (rule Suc_neq_Zero) (erule sym)
 
 lemma Suc_inject: "Suc x = Suc y \<Longrightarrow> x = y"
   by (rule inj_Suc [THEN injD])
 
 lemma n_not_Suc_n: "n \<noteq> Suc n"
   by (induct n) simp_all
 
 lemma Suc_n_not_n: "Suc n \<noteq> n"
   by (rule not_sym) (rule n_not_Suc_n)
 
 text \<open>A special form of induction for reasoning about \<^term>\<open>m < n\<close> and \<^term>\<open>m - n\<close>.\<close>
 lemma diff_induct:
   assumes "\<And>x. P x 0"
     and "\<And>y. P 0 (Suc y)"
     and "\<And>x y. P x y \<Longrightarrow> P (Suc x) (Suc y)"
   shows "P m n"
 proof (induct n arbitrary: m)
   case 0
   show ?case by (rule assms(1))
 next
   case (Suc n)
   show ?case
   proof (induct m)
     case 0
     show ?case by (rule assms(2))
   next
     case (Suc m)
     from \<open>P m n\<close> show ?case by (rule assms(3))
   qed
 qed
 
 
 subsection \<open>Arithmetic operators\<close>
 
 instantiation nat :: comm_monoid_diff
 begin
 
 primrec plus_nat
   where
     add_0: "0 + n = (n::nat)"
   | add_Suc: "Suc m + n = Suc (m + n)"
 
 lemma add_0_right [simp]: "m + 0 = m"
   for m :: nat
   by (induct m) simp_all
 
 lemma add_Suc_right [simp]: "m + Suc n = Suc (m + n)"
   by (induct m) simp_all
 
 declare add_0 [code]
 
 lemma add_Suc_shift [code]: "Suc m + n = m + Suc n"
   by simp
 
 primrec minus_nat
   where
     diff_0 [code]: "m - 0 = (m::nat)"
   | diff_Suc: "m - Suc n = (case m - n of 0 \<Rightarrow> 0 | Suc k \<Rightarrow> k)"
 
 declare diff_Suc [simp del]
 
 lemma diff_0_eq_0 [simp, code]: "0 - n = 0"
   for n :: nat
   by (induct n) (simp_all add: diff_Suc)
 
 lemma diff_Suc_Suc [simp, code]: "Suc m - Suc n = m - n"
   by (induct n) (simp_all add: diff_Suc)
 
 instance
 proof
   fix n m q :: nat
   show "(n + m) + q = n + (m + q)" by (induct n) simp_all
   show "n + m = m + n" by (induct n) simp_all
   show "m + n - m = n" by (induct m) simp_all
   show "n - m - q = n - (m + q)" by (induct q) (simp_all add: diff_Suc)
   show "0 + n = n" by simp
   show "0 - n = 0" by simp
 qed
 
 end
 
 hide_fact (open) add_0 add_0_right diff_0
 
 instantiation nat :: comm_semiring_1_cancel
 begin
 
 definition One_nat_def [simp]: "1 = Suc 0"
 
 primrec times_nat
   where
     mult_0: "0 * n = (0::nat)"
   | mult_Suc: "Suc m * n = n + (m * n)"
 
 lemma mult_0_right [simp]: "m * 0 = 0"
   for m :: nat
   by (induct m) simp_all
 
 lemma mult_Suc_right [simp]: "m * Suc n = m + (m * n)"
   by (induct m) (simp_all add: add.left_commute)
 
 lemma add_mult_distrib: "(m + n) * k = (m * k) + (n * k)"
   for m n k :: nat
   by (induct m) (simp_all add: add.assoc)
 
 instance
 proof
   fix k n m q :: nat
   show "0 \<noteq> (1::nat)"
     by simp
   show "1 * n = n"
     by simp
   show "n * m = m * n"
     by (induct n) simp_all
   show "(n * m) * q = n * (m * q)"
     by (induct n) (simp_all add: add_mult_distrib)
   show "(n + m) * q = n * q + m * q"
     by (rule add_mult_distrib)
   show "k * (m - n) = (k * m) - (k * n)"
     by (induct m n rule: diff_induct) simp_all
 qed
 
 end
 
 
 subsubsection \<open>Addition\<close>
 
 text \<open>Reasoning about \<open>m + 0 = 0\<close>, etc.\<close>
 
 lemma add_is_0 [iff]: "m + n = 0 \<longleftrightarrow> m = 0 \<and> n = 0"
   for m n :: nat
   by (cases m) simp_all
 
 lemma add_is_1: "m + n = Suc 0 \<longleftrightarrow> m = Suc 0 \<and> n = 0 \<or> m = 0 \<and> n = Suc 0"
   by (cases m) simp_all
 
 lemma one_is_add: "Suc 0 = m + n \<longleftrightarrow> m = Suc 0 \<and> n = 0 \<or> m = 0 \<and> n = Suc 0"
   by (rule trans, rule eq_commute, rule add_is_1)
 
 lemma add_eq_self_zero: "m + n = m \<Longrightarrow> n = 0"
   for m n :: nat
   by (induct m) simp_all
 
 lemma plus_1_eq_Suc:
   "plus 1 = Suc"
   by (simp add: fun_eq_iff)
 
 lemma Suc_eq_plus1: "Suc n = n + 1"
   by simp
 
 lemma Suc_eq_plus1_left: "Suc n = 1 + n"
   by simp
 
 
 subsubsection \<open>Difference\<close>
 
 lemma Suc_diff_diff [simp]: "(Suc m - n) - Suc k = m - n - k"
   by (simp add: diff_diff_add)
 
 lemma diff_Suc_1 [simp]: "Suc n - 1 = n"
   by simp
 
 
 subsubsection \<open>Multiplication\<close>
 
 lemma mult_is_0 [simp]: "m * n = 0 \<longleftrightarrow> m = 0 \<or> n = 0" for m n :: nat
   by (induct m) auto
 
 lemma mult_eq_1_iff [simp]: "m * n = Suc 0 \<longleftrightarrow> m = Suc 0 \<and> n = Suc 0"
 proof (induct m)
   case 0
   then show ?case by simp
 next
   case (Suc m)
   then show ?case by (induct n) auto
 qed
 
 lemma one_eq_mult_iff [simp]: "Suc 0 = m * n \<longleftrightarrow> m = Suc 0 \<and> n = Suc 0"
   by (simp add: eq_commute flip: mult_eq_1_iff)
 
 lemma nat_mult_eq_1_iff [simp]: "m * n = 1 \<longleftrightarrow> m = 1 \<and> n = 1" 
   and nat_1_eq_mult_iff [simp]: "1 = m * n \<longleftrightarrow> m = 1 \<and> n = 1" for m n :: nat
   by auto
 
 lemma mult_cancel1 [simp]: "k * m = k * n \<longleftrightarrow> m = n \<or> k = 0"
   for k m n :: nat
 proof -
   have "k \<noteq> 0 \<Longrightarrow> k * m = k * n \<Longrightarrow> m = n"
   proof (induct n arbitrary: m)
     case 0
     then show "m = 0" by simp
   next
     case (Suc n)
     then show "m = Suc n"
       by (cases m) (simp_all add: eq_commute [of 0])
   qed
   then show ?thesis by auto
 qed
 
 lemma mult_cancel2 [simp]: "m * k = n * k \<longleftrightarrow> m = n \<or> k = 0"
   for k m n :: nat
   by (simp add: mult.commute)
 
 lemma Suc_mult_cancel1: "Suc k * m = Suc k * n \<longleftrightarrow> m = n"
   by (subst mult_cancel1) simp
 
 
 subsection \<open>Orders on \<^typ>\<open>nat\<close>\<close>
 
 subsubsection \<open>Operation definition\<close>
 
 instantiation nat :: linorder
 begin
 
 primrec less_eq_nat
   where
     "(0::nat) \<le> n \<longleftrightarrow> True"
   | "Suc m \<le> n \<longleftrightarrow> (case n of 0 \<Rightarrow> False | Suc n \<Rightarrow> m \<le> n)"
 
 declare less_eq_nat.simps [simp del]
 
 lemma le0 [iff]: "0 \<le> n" for
   n :: nat
   by (simp add: less_eq_nat.simps)
 
 lemma [code]: "0 \<le> n \<longleftrightarrow> True"
   for n :: nat
   by simp
 
 definition less_nat
   where less_eq_Suc_le: "n < m \<longleftrightarrow> Suc n \<le> m"
 
 lemma Suc_le_mono [iff]: "Suc n \<le> Suc m \<longleftrightarrow> n \<le> m"
   by (simp add: less_eq_nat.simps(2))
 
 lemma Suc_le_eq [code]: "Suc m \<le> n \<longleftrightarrow> m < n"
   unfolding less_eq_Suc_le ..
 
 lemma le_0_eq [iff]: "n \<le> 0 \<longleftrightarrow> n = 0"
   for n :: nat
   by (induct n) (simp_all add: less_eq_nat.simps(2))
 
 lemma not_less0 [iff]: "\<not> n < 0"
   for n :: nat
   by (simp add: less_eq_Suc_le)
 
 lemma less_nat_zero_code [code]: "n < 0 \<longleftrightarrow> False"
   for n :: nat
   by simp
 
 lemma Suc_less_eq [iff]: "Suc m < Suc n \<longleftrightarrow> m < n"
   by (simp add: less_eq_Suc_le)
 
 lemma less_Suc_eq_le [code]: "m < Suc n \<longleftrightarrow> m \<le> n"
   by (simp add: less_eq_Suc_le)
 
 lemma Suc_less_eq2: "Suc n < m \<longleftrightarrow> (\<exists>m'. m = Suc m' \<and> n < m')"
   by (cases m) auto
 
 lemma le_SucI: "m \<le> n \<Longrightarrow> m \<le> Suc n"
   by (induct m arbitrary: n) (simp_all add: less_eq_nat.simps(2) split: nat.splits)
 
 lemma Suc_leD: "Suc m \<le> n \<Longrightarrow> m \<le> n"
   by (cases n) (auto intro: le_SucI)
 
 lemma less_SucI: "m < n \<Longrightarrow> m < Suc n"
   by (simp add: less_eq_Suc_le) (erule Suc_leD)
 
 lemma Suc_lessD: "Suc m < n \<Longrightarrow> m < n"
   by (simp add: less_eq_Suc_le) (erule Suc_leD)
 
 instance
 proof
   fix n m q :: nat
   show "n < m \<longleftrightarrow> n \<le> m \<and> \<not> m \<le> n"
   proof (induct n arbitrary: m)
     case 0
     then show ?case
       by (cases m) (simp_all add: less_eq_Suc_le)
   next
     case (Suc n)
     then show ?case
       by (cases m) (simp_all add: less_eq_Suc_le)
   qed
   show "n \<le> n"
     by (induct n) simp_all
   then show "n = m" if "n \<le> m" and "m \<le> n"
     using that by (induct n arbitrary: m)
       (simp_all add: less_eq_nat.simps(2) split: nat.splits)
   show "n \<le> q" if "n \<le> m" and "m \<le> q"
     using that
   proof (induct n arbitrary: m q)
     case 0
     show ?case by simp
   next
     case (Suc n)
     then show ?case
       by (simp_all (no_asm_use) add: less_eq_nat.simps(2) split: nat.splits, clarify,
         simp_all (no_asm_use) add: less_eq_nat.simps(2) split: nat.splits, clarify,
         simp_all (no_asm_use) add: less_eq_nat.simps(2) split: nat.splits)
   qed
   show "n \<le> m \<or> m \<le> n"
     by (induct n arbitrary: m)
       (simp_all add: less_eq_nat.simps(2) split: nat.splits)
 qed
 
 end
 
 instantiation nat :: order_bot
 begin
 
 definition bot_nat :: nat
   where "bot_nat = 0"
 
 instance
   by standard (simp add: bot_nat_def)
 
 end
 
 instance nat :: no_top
   by standard (auto intro: less_Suc_eq_le [THEN iffD2])
 
 
 subsubsection \<open>Introduction properties\<close>
 
 lemma lessI [iff]: "n < Suc n"
   by (simp add: less_Suc_eq_le)
 
 lemma zero_less_Suc [iff]: "0 < Suc n"
   by (simp add: less_Suc_eq_le)
 
 
 subsubsection \<open>Elimination properties\<close>
 
 lemma less_not_refl: "\<not> n < n"
   for n :: nat
   by (rule order_less_irrefl)
 
 lemma less_not_refl2: "n < m \<Longrightarrow> m \<noteq> n"
   for m n :: nat
   by (rule not_sym) (rule less_imp_neq)
 
 lemma less_not_refl3: "s < t \<Longrightarrow> s \<noteq> t"
   for s t :: nat
   by (rule less_imp_neq)
 
 lemma less_irrefl_nat: "n < n \<Longrightarrow> R"
   for n :: nat
   by (rule notE, rule less_not_refl)
 
 lemma less_zeroE: "n < 0 \<Longrightarrow> R"
   for n :: nat
   by (rule notE) (rule not_less0)
 
 lemma less_Suc_eq: "m < Suc n \<longleftrightarrow> m < n \<or> m = n"
   unfolding less_Suc_eq_le le_less ..
 
 lemma less_Suc0 [iff]: "(n < Suc 0) = (n = 0)"
   by (simp add: less_Suc_eq)
 
 lemma less_one [iff]: "n < 1 \<longleftrightarrow> n = 0"
   for n :: nat
   unfolding One_nat_def by (rule less_Suc0)
 
 lemma Suc_mono: "m < n \<Longrightarrow> Suc m < Suc n"
   by simp
 
 text \<open>"Less than" is antisymmetric, sort of.\<close>
 lemma less_antisym: "\<not> n < m \<Longrightarrow> n < Suc m \<Longrightarrow> m = n"
   unfolding not_less less_Suc_eq_le by (rule antisym)
 
 lemma nat_neq_iff: "m \<noteq> n \<longleftrightarrow> m < n \<or> n < m"
   for m n :: nat
   by (rule linorder_neq_iff)
 
 
 subsubsection \<open>Inductive (?) properties\<close>
 
 lemma Suc_lessI: "m < n \<Longrightarrow> Suc m \<noteq> n \<Longrightarrow> Suc m < n"
   unfolding less_eq_Suc_le [of m] le_less by simp
 
 lemma lessE:
   assumes major: "i < k"
     and 1: "k = Suc i \<Longrightarrow> P"
     and 2: "\<And>j. i < j \<Longrightarrow> k = Suc j \<Longrightarrow> P"
   shows P
 proof -
   from major have "\<exists>j. i \<le> j \<and> k = Suc j"
     unfolding less_eq_Suc_le by (induct k) simp_all
   then have "(\<exists>j. i < j \<and> k = Suc j) \<or> k = Suc i"
     by (auto simp add: less_le)
   with 1 2 show P by auto
 qed
 
 lemma less_SucE:
   assumes major: "m < Suc n"
     and less: "m < n \<Longrightarrow> P"
     and eq: "m = n \<Longrightarrow> P"
   shows P
 proof (rule major [THEN lessE])
   show "Suc n = Suc m \<Longrightarrow> P"
     using eq by blast
   show "\<And>j. \<lbrakk>m < j; Suc n = Suc j\<rbrakk> \<Longrightarrow> P"
     by (blast intro: less)
 qed
 
 lemma Suc_lessE:
   assumes major: "Suc i < k"
     and minor: "\<And>j. i < j \<Longrightarrow> k = Suc j \<Longrightarrow> P"
   shows P
 proof (rule major [THEN lessE])
   show "k = Suc (Suc i) \<Longrightarrow> P"
     using lessI minor by iprover
   show "\<And>j. \<lbrakk>Suc i < j; k = Suc j\<rbrakk> \<Longrightarrow> P"
     using Suc_lessD minor by iprover
 qed
 
 lemma Suc_less_SucD: "Suc m < Suc n \<Longrightarrow> m < n"
   by simp
 
 lemma less_trans_Suc:
   assumes le: "i < j"
   shows "j < k \<Longrightarrow> Suc i < k"
 proof (induct k)
   case 0
   then show ?case by simp
 next
   case (Suc k)
   with le show ?case
     by simp (auto simp add: less_Suc_eq dest: Suc_lessD)
 qed
 
 text \<open>Can be used with \<open>less_Suc_eq\<close> to get \<^prop>\<open>n = m \<or> n < m\<close>.\<close>
 lemma not_less_eq: "\<not> m < n \<longleftrightarrow> n < Suc m"
   by (simp only: not_less less_Suc_eq_le)
 
 lemma not_less_eq_eq: "\<not> m \<le> n \<longleftrightarrow> Suc n \<le> m"
   by (simp only: not_le Suc_le_eq)
 
 text \<open>Properties of "less than or equal".\<close>
 
 lemma le_imp_less_Suc: "m \<le> n \<Longrightarrow> m < Suc n"
   by (simp only: less_Suc_eq_le)
 
 lemma Suc_n_not_le_n: "\<not> Suc n \<le> n"
   by (simp add: not_le less_Suc_eq_le)
 
 lemma le_Suc_eq: "m \<le> Suc n \<longleftrightarrow> m \<le> n \<or> m = Suc n"
   by (simp add: less_Suc_eq_le [symmetric] less_Suc_eq)
 
 lemma le_SucE: "m \<le> Suc n \<Longrightarrow> (m \<le> n \<Longrightarrow> R) \<Longrightarrow> (m = Suc n \<Longrightarrow> R) \<Longrightarrow> R"
   by (drule le_Suc_eq [THEN iffD1], iprover+)
 
 lemma Suc_leI: "m < n \<Longrightarrow> Suc m \<le> n"
   by (simp only: Suc_le_eq)
 
 text \<open>Stronger version of \<open>Suc_leD\<close>.\<close>
 lemma Suc_le_lessD: "Suc m \<le> n \<Longrightarrow> m < n"
   by (simp only: Suc_le_eq)
 
 lemma less_imp_le_nat: "m < n \<Longrightarrow> m \<le> n" for m n :: nat
   unfolding less_eq_Suc_le by (rule Suc_leD)
 
 text \<open>For instance, \<open>(Suc m < Suc n) = (Suc m \<le> n) = (m < n)\<close>\<close>
 lemmas le_simps = less_imp_le_nat less_Suc_eq_le Suc_le_eq
 
 
 text \<open>Equivalence of \<open>m \<le> n\<close> and \<open>m < n \<or> m = n\<close>\<close>
 
 lemma less_or_eq_imp_le: "m < n \<or> m = n \<Longrightarrow> m \<le> n"
   for m n :: nat
   unfolding le_less .
 
 lemma le_eq_less_or_eq: "m \<le> n \<longleftrightarrow> m < n \<or> m = n"
   for m n :: nat
   by (rule le_less)
 
 text \<open>Useful with \<open>blast\<close>.\<close>
 lemma eq_imp_le: "m = n \<Longrightarrow> m \<le> n"
   for m n :: nat
   by auto
 
 lemma le_refl: "n \<le> n"
   for n :: nat
   by simp
 
 lemma le_trans: "i \<le> j \<Longrightarrow> j \<le> k \<Longrightarrow> i \<le> k"
   for i j k :: nat
   by (rule order_trans)
 
 lemma le_antisym: "m \<le> n \<Longrightarrow> n \<le> m \<Longrightarrow> m = n"
   for m n :: nat
   by (rule antisym)
 
 lemma nat_less_le: "m < n \<longleftrightarrow> m \<le> n \<and> m \<noteq> n"
   for m n :: nat
   by (rule less_le)
 
 lemma le_neq_implies_less: "m \<le> n \<Longrightarrow> m \<noteq> n \<Longrightarrow> m < n"
   for m n :: nat
   unfolding less_le ..
 
 lemma nat_le_linear: "m \<le> n \<or> n \<le> m"
   for m n :: nat
   by (rule linear)
 
 lemmas linorder_neqE_nat = linorder_neqE [where 'a = nat]
 
 lemma le_less_Suc_eq: "m \<le> n \<Longrightarrow> n < Suc m \<longleftrightarrow> n = m"
   unfolding less_Suc_eq_le by auto
 
 lemma not_less_less_Suc_eq: "\<not> n < m \<Longrightarrow> n < Suc m \<longleftrightarrow> n = m"
   unfolding not_less by (rule le_less_Suc_eq)
 
 lemmas not_less_simps = not_less_less_Suc_eq le_less_Suc_eq
 
 lemma not0_implies_Suc: "n \<noteq> 0 \<Longrightarrow> \<exists>m. n = Suc m"
   by (cases n) simp_all
 
 lemma gr0_implies_Suc: "n > 0 \<Longrightarrow> \<exists>m. n = Suc m"
   by (cases n) simp_all
 
 lemma gr_implies_not0: "m < n \<Longrightarrow> n \<noteq> 0"
   for m n :: nat
   by (cases n) simp_all
 
 lemma neq0_conv[iff]: "n \<noteq> 0 \<longleftrightarrow> 0 < n"
   for n :: nat
   by (cases n) simp_all
 
 text \<open>This theorem is useful with \<open>blast\<close>\<close>
 lemma gr0I: "(n = 0 \<Longrightarrow> False) \<Longrightarrow> 0 < n"
   for n :: nat
   by (rule neq0_conv[THEN iffD1]) iprover
 
 lemma gr0_conv_Suc: "0 < n \<longleftrightarrow> (\<exists>m. n = Suc m)"
   by (fast intro: not0_implies_Suc)
 
 lemma not_gr0 [iff]: "\<not> 0 < n \<longleftrightarrow> n = 0"
   for n :: nat
   using neq0_conv by blast
 
 lemma Suc_le_D: "Suc n \<le> m' \<Longrightarrow> \<exists>m. m' = Suc m"
   by (induct m') simp_all
 
 text \<open>Useful in certain inductive arguments\<close>
 lemma less_Suc_eq_0_disj: "m < Suc n \<longleftrightarrow> m = 0 \<or> (\<exists>j. m = Suc j \<and> j < n)"
   by (cases m) simp_all
 
 lemma All_less_Suc: "(\<forall>i < Suc n. P i) = (P n \<and> (\<forall>i < n. P i))"
   by (auto simp: less_Suc_eq)
 
 lemma All_less_Suc2: "(\<forall>i < Suc n. P i) = (P 0 \<and> (\<forall>i < n. P(Suc i)))"
   by (auto simp: less_Suc_eq_0_disj)
 
 lemma Ex_less_Suc: "(\<exists>i < Suc n. P i) = (P n \<or> (\<exists>i < n. P i))"
   by (auto simp: less_Suc_eq)
 
 lemma Ex_less_Suc2: "(\<exists>i < Suc n. P i) = (P 0 \<or> (\<exists>i < n. P(Suc i)))"
   by (auto simp: less_Suc_eq_0_disj)
 
 text \<open>@{term mono} (non-strict) doesn't imply increasing, as the function could be constant\<close>
 lemma strict_mono_imp_increasing:
   fixes n::nat
   assumes "strict_mono f" shows "f n \<ge> n"
 proof (induction n)
   case 0
   then show ?case
     by auto
 next
   case (Suc n)
   then show ?case
     unfolding not_less_eq_eq [symmetric]
     using Suc_n_not_le_n assms order_trans strict_mono_less_eq by blast
 qed
 
 subsubsection \<open>Monotonicity of Addition\<close>
 
 lemma Suc_pred [simp]: "n > 0 \<Longrightarrow> Suc (n - Suc 0) = n"
   by (simp add: diff_Suc split: nat.split)
 
 lemma Suc_diff_1 [simp]: "0 < n \<Longrightarrow> Suc (n - 1) = n"
   unfolding One_nat_def by (rule Suc_pred)
 
 lemma nat_add_left_cancel_le [simp]: "k + m \<le> k + n \<longleftrightarrow> m \<le> n"
   for k m n :: nat
   by (induct k) simp_all
 
 lemma nat_add_left_cancel_less [simp]: "k + m < k + n \<longleftrightarrow> m < n"
   for k m n :: nat
   by (induct k) simp_all
 
 lemma add_gr_0 [iff]: "m + n > 0 \<longleftrightarrow> m > 0 \<or> n > 0"
   for m n :: nat
   by (auto dest: gr0_implies_Suc)
 
 text \<open>strict, in 1st argument\<close>
 lemma add_less_mono1: "i < j \<Longrightarrow> i + k < j + k"
   for i j k :: nat
   by (induct k) simp_all
 
 text \<open>strict, in both arguments\<close>
 lemma add_less_mono: 
   fixes i j k l :: nat
   assumes "i < j" "k < l" shows "i + k < j + l"
 proof -
   have "i + k < j + k"
     by (simp add: add_less_mono1 assms)
   also have "...  < j + l"
     using \<open>i < j\<close> by (induction j) (auto simp: assms)
   finally show ?thesis .
 qed
 
 lemma less_imp_Suc_add: "m < n \<Longrightarrow> \<exists>k. n = Suc (m + k)"
 proof (induct n)
   case 0
   then show ?case by simp
 next
   case Suc
   then show ?case
     by (simp add: order_le_less)
       (blast elim!: less_SucE intro!: Nat.add_0_right [symmetric] add_Suc_right [symmetric])
 qed
 
 lemma le_Suc_ex: "k \<le> l \<Longrightarrow> (\<exists>n. l = k + n)"
   for k l :: nat
   by (auto simp: less_Suc_eq_le[symmetric] dest: less_imp_Suc_add)
 
 lemma less_natE:
   assumes \<open>m < n\<close>
   obtains q where \<open>n = Suc (m + q)\<close>
   using assms by (auto dest: less_imp_Suc_add intro: that)
 
 text \<open>strict, in 1st argument; proof is by induction on \<open>k > 0\<close>\<close>
 lemma mult_less_mono2:
   fixes i j :: nat
   assumes "i < j" and "0 < k"
   shows "k * i < k * j"
   using \<open>0 < k\<close>
 proof (induct k)
   case 0
   then show ?case by simp
 next
   case (Suc k)
   with \<open>i < j\<close> show ?case
     by (cases k) (simp_all add: add_less_mono)
 qed
 
 text \<open>Addition is the inverse of subtraction:
   if \<^term>\<open>n \<le> m\<close> then \<^term>\<open>n + (m - n) = m\<close>.\<close>
 lemma add_diff_inverse_nat: "\<not> m < n \<Longrightarrow> n + (m - n) = m"
   for m n :: nat
   by (induct m n rule: diff_induct) simp_all
 
 lemma nat_le_iff_add: "m \<le> n \<longleftrightarrow> (\<exists>k. n = m + k)"
   for m n :: nat
   using nat_add_left_cancel_le[of m 0] by (auto dest: le_Suc_ex)
 
 text \<open>The naturals form an ordered \<open>semidom\<close> and a \<open>dioid\<close>.\<close>
 
 instance nat :: linordered_semidom
 proof
   fix m n q :: nat
   show "0 < (1::nat)"
     by simp
   show "m \<le> n \<Longrightarrow> q + m \<le> q + n"
     by simp
   show "m < n \<Longrightarrow> 0 < q \<Longrightarrow> q * m < q * n"
     by (simp add: mult_less_mono2)
   show "m \<noteq> 0 \<Longrightarrow> n \<noteq> 0 \<Longrightarrow> m * n \<noteq> 0"
     by simp
   show "n \<le> m \<Longrightarrow> (m - n) + n = m"
     by (simp add: add_diff_inverse_nat add.commute linorder_not_less)
 qed
 
 instance nat :: dioid
   by standard (rule nat_le_iff_add)
 
 declare le0[simp del] \<comment> \<open>This is now @{thm zero_le}\<close>
 declare le_0_eq[simp del] \<comment> \<open>This is now @{thm le_zero_eq}\<close>
 declare not_less0[simp del] \<comment> \<open>This is now @{thm not_less_zero}\<close>
 declare not_gr0[simp del] \<comment> \<open>This is now @{thm not_gr_zero}\<close>
 
 instance nat :: ordered_cancel_comm_monoid_add ..
 instance nat :: ordered_cancel_comm_monoid_diff ..
 
 
 subsubsection \<open>\<^term>\<open>min\<close> and \<^term>\<open>max\<close>\<close>
 
 global_interpretation bot_nat_0: ordering_top \<open>(\<ge>)\<close> \<open>(>)\<close> \<open>0::nat\<close>
   by standard simp
 
 global_interpretation max_nat: semilattice_neutr_order max \<open>0::nat\<close> \<open>(\<ge>)\<close> \<open>(>)\<close>
   by standard (simp add: max_def)
 
 lemma mono_Suc: "mono Suc"
   by (rule monoI) simp
 
 lemma min_0L [simp]: "min 0 n = 0"
   for n :: nat
   by (rule min_absorb1) simp
 
 lemma min_0R [simp]: "min n 0 = 0"
   for n :: nat
   by (rule min_absorb2) simp
 
 lemma min_Suc_Suc [simp]: "min (Suc m) (Suc n) = Suc (min m n)"
   by (simp add: mono_Suc min_of_mono)
 
 lemma min_Suc1: "min (Suc n) m = (case m of 0 \<Rightarrow> 0 | Suc m' \<Rightarrow> Suc(min n m'))"
   by (simp split: nat.split)
 
 lemma min_Suc2: "min m (Suc n) = (case m of 0 \<Rightarrow> 0 | Suc m' \<Rightarrow> Suc(min m' n))"
   by (simp split: nat.split)
 
 lemma max_0L [simp]: "max 0 n = n"
   for n :: nat
   by (fact max_nat.left_neutral)
 
 lemma max_0R [simp]: "max n 0 = n"
   for n :: nat
   by (fact max_nat.right_neutral)
 
 lemma max_Suc_Suc [simp]: "max (Suc m) (Suc n) = Suc (max m n)"
   by (simp add: mono_Suc max_of_mono)
 
 lemma max_Suc1: "max (Suc n) m = (case m of 0 \<Rightarrow> Suc n | Suc m' \<Rightarrow> Suc (max n m'))"
   by (simp split: nat.split)
 
 lemma max_Suc2: "max m (Suc n) = (case m of 0 \<Rightarrow> Suc n | Suc m' \<Rightarrow> Suc (max m' n))"
   by (simp split: nat.split)
 
 lemma nat_mult_min_left: "min m n * q = min (m * q) (n * q)"
   for m n q :: nat
   by (simp add: min_def not_le)
     (auto dest: mult_right_le_imp_le mult_right_less_imp_less le_less_trans)
 
 lemma nat_mult_min_right: "m * min n q = min (m * n) (m * q)"
   for m n q :: nat
   by (simp add: min_def not_le)
     (auto dest: mult_left_le_imp_le mult_left_less_imp_less le_less_trans)
 
 lemma nat_add_max_left: "max m n + q = max (m + q) (n + q)"
   for m n q :: nat
   by (simp add: max_def)
 
 lemma nat_add_max_right: "m + max n q = max (m + n) (m + q)"
   for m n q :: nat
   by (simp add: max_def)
 
 lemma nat_mult_max_left: "max m n * q = max (m * q) (n * q)"
   for m n q :: nat
   by (simp add: max_def not_le)
     (auto dest: mult_right_le_imp_le mult_right_less_imp_less le_less_trans)
 
 lemma nat_mult_max_right: "m * max n q = max (m * n) (m * q)"
   for m n q :: nat
   by (simp add: max_def not_le)
     (auto dest: mult_left_le_imp_le mult_left_less_imp_less le_less_trans)
 
 
 subsubsection \<open>Additional theorems about \<^term>\<open>(\<le>)\<close>\<close>
 
 text \<open>Complete induction, aka course-of-values induction\<close>
 
 instance nat :: wellorder
 proof
   fix P and n :: nat
   assume step: "(\<And>m. m < n \<Longrightarrow> P m) \<Longrightarrow> P n" for n :: nat
   have "\<And>q. q \<le> n \<Longrightarrow> P q"
   proof (induct n)
     case (0 n)
     have "P 0" by (rule step) auto
     with 0 show ?case by auto
   next
     case (Suc m n)
     then have "n \<le> m \<or> n = Suc m"
       by (simp add: le_Suc_eq)
     then show ?case
     proof
       assume "n \<le> m"
       then show "P n" by (rule Suc(1))
     next
       assume n: "n = Suc m"
       show "P n" by (rule step) (rule Suc(1), simp add: n le_simps)
     qed
   qed
   then show "P n" by auto
 qed
 
 
 lemma Least_eq_0[simp]: "P 0 \<Longrightarrow> Least P = 0"
   for P :: "nat \<Rightarrow> bool"
   by (rule Least_equality[OF _ le0])
 
 lemma Least_Suc:
   assumes "P n" "\<not> P 0" 
   shows "(LEAST n. P n) = Suc (LEAST m. P (Suc m))"
 proof (cases n)
   case (Suc m)
   show ?thesis
   proof (rule antisym)
     show "(LEAST x. P x) \<le> Suc (LEAST x. P (Suc x))"
       using assms Suc by (force intro: LeastI Least_le)
     have \<section>: "P (LEAST x. P x)"
       by (blast intro: LeastI assms)
     show "Suc (LEAST m. P (Suc m)) \<le> (LEAST n. P n)"
     proof (cases "(LEAST n. P n)")
       case 0
       then show ?thesis
         using \<section> by (simp add: assms)
     next
       case Suc
       with \<section> show ?thesis
         by (auto simp: Least_le)
     qed
   qed
 qed (use assms in auto)
 
 lemma Least_Suc2: "P n \<Longrightarrow> Q m \<Longrightarrow> \<not> P 0 \<Longrightarrow> \<forall>k. P (Suc k) = Q k \<Longrightarrow> Least P = Suc (Least Q)"
   by (erule (1) Least_Suc [THEN ssubst]) simp
 
 lemma ex_least_nat_le:
   fixes P :: "nat \<Rightarrow> bool"
   assumes "P n" "\<not> P 0" 
   shows "\<exists>k\<le>n. (\<forall>i<k. \<not> P i) \<and> P k"
 proof (cases n)
   case (Suc m)
   with assms show ?thesis
     by (blast intro: Least_le LeastI_ex dest: not_less_Least)
 qed (use assms in auto)
 
 lemma ex_least_nat_less:
   fixes P :: "nat \<Rightarrow> bool"
   assumes "P n" "\<not> P 0" 
   shows "\<exists>k<n. (\<forall>i\<le>k. \<not> P i) \<and> P (Suc k)"
 proof (cases n)
   case (Suc m)
   then obtain k where k: "k \<le> n" "\<forall>i<k. \<not> P i" "P k"
     using ex_least_nat_le [OF assms] by blast
   show ?thesis 
     by (cases k) (use assms k less_eq_Suc_le in auto)
 qed (use assms in auto)
 
 
 lemma nat_less_induct:
   fixes P :: "nat \<Rightarrow> bool"
   assumes "\<And>n. \<forall>m. m < n \<longrightarrow> P m \<Longrightarrow> P n"
   shows "P n"
   using assms less_induct by blast
 
 lemma measure_induct_rule [case_names less]:
   fixes f :: "'a \<Rightarrow> 'b::wellorder"
   assumes step: "\<And>x. (\<And>y. f y < f x \<Longrightarrow> P y) \<Longrightarrow> P x"
   shows "P a"
   by (induct m \<equiv> "f a" arbitrary: a rule: less_induct) (auto intro: step)
 
 text \<open>old style induction rules:\<close>
 lemma measure_induct:
   fixes f :: "'a \<Rightarrow> 'b::wellorder"
   shows "(\<And>x. \<forall>y. f y < f x \<longrightarrow> P y \<Longrightarrow> P x) \<Longrightarrow> P a"
   by (rule measure_induct_rule [of f P a]) iprover
 
 lemma full_nat_induct:
   assumes step: "\<And>n. (\<forall>m. Suc m \<le> n \<longrightarrow> P m) \<Longrightarrow> P n"
   shows "P n"
   by (rule less_induct) (auto intro: step simp:le_simps)
 
 text\<open>An induction rule for establishing binary relations\<close>
 lemma less_Suc_induct [consumes 1]:
   assumes less: "i < j"
     and step: "\<And>i. P i (Suc i)"
     and trans: "\<And>i j k. i < j \<Longrightarrow> j < k \<Longrightarrow> P i j \<Longrightarrow> P j k \<Longrightarrow> P i k"
   shows "P i j"
 proof -
   from less obtain k where j: "j = Suc (i + k)"
     by (auto dest: less_imp_Suc_add)
   have "P i (Suc (i + k))"
   proof (induct k)
     case 0
     show ?case by (simp add: step)
   next
     case (Suc k)
     have "0 + i < Suc k + i" by (rule add_less_mono1) simp
     then have "i < Suc (i + k)" by (simp add: add.commute)
     from trans[OF this lessI Suc step]
     show ?case by simp
   qed
   then show "P i j" by (simp add: j)
 qed
 
 text \<open>
   The method of infinite descent, frequently used in number theory.
   Provided by Roelof Oosterhuis.
   \<open>P n\<close> is true for all natural numbers if
   \<^item> case ``0'': given \<open>n = 0\<close> prove \<open>P n\<close>
   \<^item> case ``smaller'': given \<open>n > 0\<close> and \<open>\<not> P n\<close> prove there exists
     a smaller natural number \<open>m\<close> such that \<open>\<not> P m\<close>.
 \<close>
 
 lemma infinite_descent: "(\<And>n. \<not> P n \<Longrightarrow> \<exists>m<n. \<not> P m) \<Longrightarrow> P n" for P :: "nat \<Rightarrow> bool"
   \<comment> \<open>compact version without explicit base case\<close>
   by (induct n rule: less_induct) auto
 
 lemma infinite_descent0 [case_names 0 smaller]:
   fixes P :: "nat \<Rightarrow> bool"
   assumes "P 0"
     and "\<And>n. n > 0 \<Longrightarrow> \<not> P n \<Longrightarrow> \<exists>m. m < n \<and> \<not> P m"
   shows "P n"
 proof (rule infinite_descent)
   fix n
   show "\<not> P n \<Longrightarrow> \<exists>m<n. \<not> P m"
     using assms by (cases "n > 0") auto
 qed
 
 text \<open>
   Infinite descent using a mapping to \<open>nat\<close>:
   \<open>P x\<close> is true for all \<open>x \<in> D\<close> if there exists a \<open>V \<in> D \<Rightarrow> nat\<close> and
   \<^item> case ``0'': given \<open>V x = 0\<close> prove \<open>P x\<close>
   \<^item> ``smaller'': given \<open>V x > 0\<close> and \<open>\<not> P x\<close> prove
   there exists a \<open>y \<in> D\<close> such that \<open>V y < V x\<close> and \<open>\<not> P y\<close>.
 \<close>
 corollary infinite_descent0_measure [case_names 0 smaller]:
   fixes V :: "'a \<Rightarrow> nat"
   assumes 1: "\<And>x. V x = 0 \<Longrightarrow> P x"
     and 2: "\<And>x. V x > 0 \<Longrightarrow> \<not> P x \<Longrightarrow> \<exists>y. V y < V x \<and> \<not> P y"
   shows "P x"
 proof -
   obtain n where "n = V x" by auto
   moreover have "\<And>x. V x = n \<Longrightarrow> P x"
   proof (induct n rule: infinite_descent0)
     case 0
     with 1 show "P x" by auto
   next
     case (smaller n)
     then obtain x where *: "V x = n " and "V x > 0 \<and> \<not> P x" by auto
     with 2 obtain y where "V y < V x \<and> \<not> P y" by auto
     with * obtain m where "m = V y \<and> m < n \<and> \<not> P y" by auto
     then show ?case by auto
   qed
   ultimately show "P x" by auto
 qed
 
 text \<open>Again, without explicit base case:\<close>
 lemma infinite_descent_measure:
   fixes V :: "'a \<Rightarrow> nat"
   assumes "\<And>x. \<not> P x \<Longrightarrow> \<exists>y. V y < V x \<and> \<not> P y"
   shows "P x"
 proof -
   from assms obtain n where "n = V x" by auto
   moreover have "\<And>x. V x = n \<Longrightarrow> P x"
   proof -
     have "\<exists>m < V x. \<exists>y. V y = m \<and> \<not> P y" if "\<not> P x" for x
       using assms and that by auto
     then show "\<And>x. V x = n \<Longrightarrow> P x"
       by (induct n rule: infinite_descent, auto)
   qed
   ultimately show "P x" by auto
 qed
 
 text \<open>A (clumsy) way of lifting \<open><\<close> monotonicity to \<open>\<le>\<close> monotonicity\<close>
 lemma less_mono_imp_le_mono:
   fixes f :: "nat \<Rightarrow> nat"
     and i j :: nat
   assumes "\<And>i j::nat. i < j \<Longrightarrow> f i < f j"
     and "i \<le> j"
   shows "f i \<le> f j"
   using assms by (auto simp add: order_le_less)
 
 
 text \<open>non-strict, in 1st argument\<close>
 lemma add_le_mono1: "i \<le> j \<Longrightarrow> i + k \<le> j + k"
   for i j k :: nat
   by (rule add_right_mono)
 
 text \<open>non-strict, in both arguments\<close>
 lemma add_le_mono: "i \<le> j \<Longrightarrow> k \<le> l \<Longrightarrow> i + k \<le> j + l"
   for i j k l :: nat
   by (rule add_mono)
 
 lemma le_add2: "n \<le> m + n"
   for m n :: nat
   by simp
 
 lemma le_add1: "n \<le> n + m"
   for m n :: nat
   by simp
 
 lemma less_add_Suc1: "i < Suc (i + m)"
   by (rule le_less_trans, rule le_add1, rule lessI)
 
 lemma less_add_Suc2: "i < Suc (m + i)"
   by (rule le_less_trans, rule le_add2, rule lessI)
 
 lemma less_iff_Suc_add: "m < n \<longleftrightarrow> (\<exists>k. n = Suc (m + k))"
   by (iprover intro!: less_add_Suc1 less_imp_Suc_add)
 
 lemma trans_le_add1: "i \<le> j \<Longrightarrow> i \<le> j + m"
   for i j m :: nat
   by (rule le_trans, assumption, rule le_add1)
 
 lemma trans_le_add2: "i \<le> j \<Longrightarrow> i \<le> m + j"
   for i j m :: nat
   by (rule le_trans, assumption, rule le_add2)
 
 lemma trans_less_add1: "i < j \<Longrightarrow> i < j + m"
   for i j m :: nat
   by (rule less_le_trans, assumption, rule le_add1)
 
 lemma trans_less_add2: "i < j \<Longrightarrow> i < m + j"
   for i j m :: nat
   by (rule less_le_trans, assumption, rule le_add2)
 
 lemma add_lessD1: "i + j < k \<Longrightarrow> i < k"
   for i j k :: nat
   by (rule le_less_trans [of _ "i+j"]) (simp_all add: le_add1)
 
 lemma not_add_less1 [iff]: "\<not> i + j < i"
   for i j :: nat
   by simp
 
 lemma not_add_less2 [iff]: "\<not> j + i < i"
   for i j :: nat
   by simp
 
 lemma add_leD1: "m + k \<le> n \<Longrightarrow> m \<le> n"
   for k m n :: nat
   by (rule order_trans [of _ "m + k"]) (simp_all add: le_add1)
 
 lemma add_leD2: "m + k \<le> n \<Longrightarrow> k \<le> n"
   for k m n :: nat
   by (force simp add: add.commute dest: add_leD1)
 
 lemma add_leE: "m + k \<le> n \<Longrightarrow> (m \<le> n \<Longrightarrow> k \<le> n \<Longrightarrow> R) \<Longrightarrow> R"
   for k m n :: nat
   by (blast dest: add_leD1 add_leD2)
 
 text \<open>needs \<open>\<And>k\<close> for \<open>ac_simps\<close> to work\<close>
 lemma less_add_eq_less: "\<And>k. k < l \<Longrightarrow> m + l = k + n \<Longrightarrow> m < n"
   for l m n :: nat
   by (force simp del: add_Suc_right simp add: less_iff_Suc_add add_Suc_right [symmetric] ac_simps)
 
 
 subsubsection \<open>More results about difference\<close>
 
 lemma Suc_diff_le: "n \<le> m \<Longrightarrow> Suc m - n = Suc (m - n)"
   by (induct m n rule: diff_induct) simp_all
 
 lemma diff_less_Suc: "m - n < Suc m"
   by (induct m n rule: diff_induct) (auto simp: less_Suc_eq)
 
 lemma diff_le_self [simp]: "m - n \<le> m"
   for m n :: nat
   by (induct m n rule: diff_induct) (simp_all add: le_SucI)
 
 lemma less_imp_diff_less: "j < k \<Longrightarrow> j - n < k"
   for j k n :: nat
   by (rule le_less_trans, rule diff_le_self)
 
 lemma diff_Suc_less [simp]: "0 < n \<Longrightarrow> n - Suc i < n"
   by (cases n) (auto simp add: le_simps)
 
 lemma diff_add_assoc: "k \<le> j \<Longrightarrow> (i + j) - k = i + (j - k)"
   for i j k :: nat
   by (fact ordered_cancel_comm_monoid_diff_class.diff_add_assoc) 
 
 lemma add_diff_assoc [simp]: "k \<le> j \<Longrightarrow> i + (j - k) = i + j - k"
   for i j k :: nat
   by (fact ordered_cancel_comm_monoid_diff_class.add_diff_assoc)
 
 lemma diff_add_assoc2: "k \<le> j \<Longrightarrow> (j + i) - k = (j - k) + i"
   for i j k :: nat
   by (fact ordered_cancel_comm_monoid_diff_class.diff_add_assoc2)
 
 lemma add_diff_assoc2 [simp]: "k \<le> j \<Longrightarrow> j - k + i = j + i - k"
   for i j k :: nat
   by (fact ordered_cancel_comm_monoid_diff_class.add_diff_assoc2)
 
 lemma le_imp_diff_is_add: "i \<le> j \<Longrightarrow> (j - i = k) = (j = k + i)"
   for i j k :: nat
   by auto
 
 lemma diff_is_0_eq [simp]: "m - n = 0 \<longleftrightarrow> m \<le> n"
   for m n :: nat
   by (induct m n rule: diff_induct) simp_all
 
 lemma diff_is_0_eq' [simp]: "m \<le> n \<Longrightarrow> m - n = 0"
   for m n :: nat
   by (rule iffD2, rule diff_is_0_eq)
 
 lemma zero_less_diff [simp]: "0 < n - m \<longleftrightarrow> m < n"
   for m n :: nat
   by (induct m n rule: diff_induct) simp_all
 
 lemma less_imp_add_positive:
   assumes "i < j"
   shows "\<exists>k::nat. 0 < k \<and> i + k = j"
 proof
   from assms show "0 < j - i \<and> i + (j - i) = j"
     by (simp add: order_less_imp_le)
 qed
 
 text \<open>a nice rewrite for bounded subtraction\<close>
 lemma nat_minus_add_max: "n - m + m = max n m"
   for m n :: nat
   by (simp add: max_def not_le order_less_imp_le)
 
 lemma nat_diff_split: "P (a - b) \<longleftrightarrow> (a < b \<longrightarrow> P 0) \<and> (\<forall>d. a = b + d \<longrightarrow> P d)"
   for a b :: nat
   \<comment> \<open>elimination of \<open>-\<close> on \<open>nat\<close>\<close>
   by (cases "a < b") (auto simp add: not_less le_less dest!: add_eq_self_zero [OF sym])
 
 lemma nat_diff_split_asm: "P (a - b) \<longleftrightarrow> \<not> (a < b \<and> \<not> P 0 \<or> (\<exists>d. a = b + d \<and> \<not> P d))"
   for a b :: nat
   \<comment> \<open>elimination of \<open>-\<close> on \<open>nat\<close> in assumptions\<close>
   by (auto split: nat_diff_split)
 
 lemma Suc_pred': "0 < n \<Longrightarrow> n = Suc(n - 1)"
   by simp
 
 lemma add_eq_if: "m + n = (if m = 0 then n else Suc ((m - 1) + n))"
   unfolding One_nat_def by (cases m) simp_all
 
 lemma mult_eq_if: "m * n = (if m = 0 then 0 else n + ((m - 1) * n))"
   for m n :: nat
   by (cases m) simp_all
 
 lemma Suc_diff_eq_diff_pred: "0 < n \<Longrightarrow> Suc m - n = m - (n - 1)"
   by (cases n) simp_all
 
 lemma diff_Suc_eq_diff_pred: "m - Suc n = (m - 1) - n"
   by (cases m) simp_all
 
 lemma Let_Suc [simp]: "Let (Suc n) f \<equiv> f (Suc n)"
   by (fact Let_def)
 
 
 subsubsection \<open>Monotonicity of multiplication\<close>
 
 lemma mult_le_mono1: "i \<le> j \<Longrightarrow> i * k \<le> j * k"
   for i j k :: nat
   by (simp add: mult_right_mono)
 
 lemma mult_le_mono2: "i \<le> j \<Longrightarrow> k * i \<le> k * j"
   for i j k :: nat
   by (simp add: mult_left_mono)
 
 text \<open>\<open>\<le>\<close> monotonicity, BOTH arguments\<close>
 lemma mult_le_mono: "i \<le> j \<Longrightarrow> k \<le> l \<Longrightarrow> i * k \<le> j * l"
   for i j k l :: nat
   by (simp add: mult_mono)
 
 lemma mult_less_mono1: "i < j \<Longrightarrow> 0 < k \<Longrightarrow> i * k < j * k"
   for i j k :: nat
   by (simp add: mult_strict_right_mono)
 
 text \<open>Differs from the standard \<open>zero_less_mult_iff\<close> in that there are no negative numbers.\<close>
 lemma nat_0_less_mult_iff [simp]: "0 < m * n \<longleftrightarrow> 0 < m \<and> 0 < n"
   for m n :: nat
 proof (induct m)
   case 0
   then show ?case by simp
 next
   case (Suc m)
   then show ?case by (cases n) simp_all
 qed
 
 lemma one_le_mult_iff [simp]: "Suc 0 \<le> m * n \<longleftrightarrow> Suc 0 \<le> m \<and> Suc 0 \<le> n"
 proof (induct m)
   case 0
   then show ?case by simp
 next
   case (Suc m)
   then show ?case by (cases n) simp_all
 qed
 
 lemma mult_less_cancel2 [simp]: "m * k < n * k \<longleftrightarrow> 0 < k \<and> m < n"
   for k m n :: nat
 proof (intro iffI conjI)
   assume m: "m * k < n * k"
   then show "0 < k"
     by (cases k) auto
   show "m < n"
   proof (cases k)
     case 0
     then show ?thesis
       using m by auto
   next
     case (Suc k')
     then show ?thesis
       using m
       by (simp flip: linorder_not_le) (blast intro: add_mono mult_le_mono1)
   qed
 next
   assume "0 < k \<and> m < n"
   then show "m * k < n * k"
     by (blast intro: mult_less_mono1)
 qed
 
 lemma mult_less_cancel1 [simp]: "k * m < k * n \<longleftrightarrow> 0 < k \<and> m < n"
   for k m n :: nat
   by (simp add: mult.commute [of k])
 
 lemma mult_le_cancel1 [simp]: "k * m \<le> k * n \<longleftrightarrow> (0 < k \<longrightarrow> m \<le> n)"
   for k m n :: nat
   by (simp add: linorder_not_less [symmetric], auto)
 
 lemma mult_le_cancel2 [simp]: "m * k \<le> n * k \<longleftrightarrow> (0 < k \<longrightarrow> m \<le> n)"
   for k m n :: nat
   by (simp add: linorder_not_less [symmetric], auto)
 
 lemma Suc_mult_less_cancel1: "Suc k * m < Suc k * n \<longleftrightarrow> m < n"
   by (subst mult_less_cancel1) simp
 
 lemma Suc_mult_le_cancel1: "Suc k * m \<le> Suc k * n \<longleftrightarrow> m \<le> n"
   by (subst mult_le_cancel1) simp
 
 lemma le_square: "m \<le> m * m"
   for m :: nat
   by (cases m) (auto intro: le_add1)
 
 lemma le_cube: "m \<le> m * (m * m)"
   for m :: nat
   by (cases m) (auto intro: le_add1)
 
 text \<open>Lemma for \<open>gcd\<close>\<close>
 lemma mult_eq_self_implies_10: 
   fixes m n :: nat
   assumes "m = m * n" shows "n = 1 \<or> m = 0"
 proof (rule disjCI)
   assume "m \<noteq> 0"
   show "n = 1"
   proof (cases n "1::nat" rule: linorder_cases)
     case greater
     show ?thesis
       using assms mult_less_mono2 [OF greater, of m] \<open>m \<noteq> 0\<close> by auto
   qed (use assms \<open>m \<noteq> 0\<close> in auto)
 qed
 
 lemma mono_times_nat:
   fixes n :: nat
   assumes "n > 0"
   shows "mono (times n)"
 proof
   fix m q :: nat
   assume "m \<le> q"
   with assms show "n * m \<le> n * q" by simp
 qed
 
 text \<open>The lattice order on \<^typ>\<open>nat\<close>.\<close>
 
 instantiation nat :: distrib_lattice
 begin
 
 definition "(inf :: nat \<Rightarrow> nat \<Rightarrow> nat) = min"
 
 definition "(sup :: nat \<Rightarrow> nat \<Rightarrow> nat) = max"
 
 instance
   by intro_classes
     (auto simp add: inf_nat_def sup_nat_def max_def not_le min_def
       intro: order_less_imp_le antisym elim!: order_trans order_less_trans)
 
 end
 
 
 subsection \<open>Natural operation of natural numbers on functions\<close>
 
 text \<open>
   We use the same logical constant for the power operations on
   functions and relations, in order to share the same syntax.
 \<close>
 
 consts compow :: "nat \<Rightarrow> 'a \<Rightarrow> 'a"
 
 abbreviation compower :: "'a \<Rightarrow> nat \<Rightarrow> 'a" (infixr "^^" 80)
   where "f ^^ n \<equiv> compow n f"
 
 notation (latex output)
   compower ("(_\<^bsup>_\<^esup>)" [1000] 1000)
 
 text \<open>\<open>f ^^ n = f \<circ> \<dots> \<circ> f\<close>, the \<open>n\<close>-fold composition of \<open>f\<close>\<close>
 
 overloading
   funpow \<equiv> "compow :: nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)"
 begin
 
 primrec funpow :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a"
   where
     "funpow 0 f = id"
   | "funpow (Suc n) f = f \<circ> funpow n f"
 
 end
 
 lemma funpow_0 [simp]: "(f ^^ 0) x = x"
   by simp
 
 lemma funpow_Suc_right: "f ^^ Suc n = f ^^ n \<circ> f"
 proof (induct n)
   case 0
   then show ?case by simp
 next
   fix n
   assume "f ^^ Suc n = f ^^ n \<circ> f"
   then show "f ^^ Suc (Suc n) = f ^^ Suc n \<circ> f"
     by (simp add: o_assoc)
 qed
 
 lemmas funpow_simps_right = funpow.simps(1) funpow_Suc_right
 
 text \<open>For code generation.\<close>
 
 context
 begin
 
 qualified definition funpow :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a"
   where funpow_code_def [code_abbrev]: "funpow = compow"
 
 lemma [code]:
   "funpow (Suc n) f = f \<circ> funpow n f"
   "funpow 0 f = id"
   by (simp_all add: funpow_code_def)
 
 end
 
 lemma funpow_add: "f ^^ (m + n) = f ^^ m \<circ> f ^^ n"
   by (induct m) simp_all
 
 lemma funpow_mult: "(f ^^ m) ^^ n = f ^^ (m * n)"
   for f :: "'a \<Rightarrow> 'a"
   by (induct n) (simp_all add: funpow_add)
 
 lemma funpow_swap1: "f ((f ^^ n) x) = (f ^^ n) (f x)"
 proof -
   have "f ((f ^^ n) x) = (f ^^ (n + 1)) x" by simp
   also have "\<dots>  = (f ^^ n \<circ> f ^^ 1) x" by (simp only: funpow_add)
   also have "\<dots> = (f ^^ n) (f x)" by simp
   finally show ?thesis .
 qed
 
 lemma comp_funpow: "comp f ^^ n = comp (f ^^ n)"
   for f :: "'a \<Rightarrow> 'a"
   by (induct n) simp_all
 
 lemma Suc_funpow[simp]: "Suc ^^ n = ((+) n)"
   by (induct n) simp_all
 
 lemma id_funpow[simp]: "id ^^ n = id"
   by (induct n) simp_all
 
 lemma funpow_mono: "mono f \<Longrightarrow> A \<le> B \<Longrightarrow> (f ^^ n) A \<le> (f ^^ n) B"
   for f :: "'a \<Rightarrow> ('a::order)"
   by (induct n arbitrary: A B)
      (auto simp del: funpow.simps(2) simp add: funpow_Suc_right mono_def)
 
 lemma funpow_mono2:
   assumes "mono f"
     and "i \<le> j"
     and "x \<le> y"
     and "x \<le> f x"
   shows "(f ^^ i) x \<le> (f ^^ j) y"
   using assms(2,3)
 proof (induct j arbitrary: y)
   case 0
   then show ?case by simp
 next
   case (Suc j)
   show ?case
   proof(cases "i = Suc j")
     case True
     with assms(1) Suc show ?thesis
       by (simp del: funpow.simps add: funpow_simps_right monoD funpow_mono)
   next
     case False
     with assms(1,4) Suc show ?thesis
       by (simp del: funpow.simps add: funpow_simps_right le_eq_less_or_eq less_Suc_eq_le)
         (simp add: Suc.hyps monoD order_subst1)
   qed
 qed
 
 lemma inj_fn[simp]:
   fixes f::"'a \<Rightarrow> 'a"
   assumes "inj f"
   shows "inj (f^^n)"
 proof (induction n)
   case Suc thus ?case using inj_compose[OF assms Suc.IH] by (simp del: comp_apply)
 qed simp
 
 lemma surj_fn[simp]:
   fixes f::"'a \<Rightarrow> 'a"
   assumes "surj f"
   shows "surj (f^^n)"
 proof (induction n)
   case Suc thus ?case by (simp add: comp_surj[OF Suc.IH assms] del: comp_apply)
 qed simp
 
 lemma bij_fn[simp]:
   fixes f::"'a \<Rightarrow> 'a"
   assumes "bij f"
   shows "bij (f^^n)"
 by (rule bijI[OF inj_fn[OF bij_is_inj[OF assms]] surj_fn[OF bij_is_surj[OF assms]]])
 
 lemma bij_betw_funpow: \<^marker>\<open>contributor \<open>Lars Noschinski\<close>\<close>
   assumes "bij_betw f S S" shows "bij_betw (f ^^ n) S S"
 proof (induct n)
   case 0 then show ?case by (auto simp: id_def[symmetric])
 next
   case (Suc n)
   then show ?case unfolding funpow.simps using assms by (rule bij_betw_trans)
 qed
 
 
 subsection \<open>Kleene iteration\<close>
 
 lemma Kleene_iter_lpfp:
   fixes f :: "'a::order_bot \<Rightarrow> 'a"
   assumes "mono f"
     and "f p \<le> p"
   shows "(f ^^ k) bot \<le> p"
 proof (induct k)
   case 0
   show ?case by simp
 next
   case Suc
   show ?case
     using monoD[OF assms(1) Suc] assms(2) by simp
 qed
 
 lemma lfp_Kleene_iter:
   assumes "mono f"
     and "(f ^^ Suc k) bot = (f ^^ k) bot"
   shows "lfp f = (f ^^ k) bot"
 proof (rule antisym)
   show "lfp f \<le> (f ^^ k) bot"
   proof (rule lfp_lowerbound)
     show "f ((f ^^ k) bot) \<le> (f ^^ k) bot"
       using assms(2) by simp
   qed
   show "(f ^^ k) bot \<le> lfp f"
     using Kleene_iter_lpfp[OF assms(1)] lfp_unfold[OF assms(1)] by simp
 qed
 
 lemma mono_pow: "mono f \<Longrightarrow> mono (f ^^ n)"
   for f :: "'a \<Rightarrow> 'a::complete_lattice"
   by (induct n) (auto simp: mono_def)
 
 lemma lfp_funpow:
   assumes f: "mono f"
   shows "lfp (f ^^ Suc n) = lfp f"
 proof (rule antisym)
   show "lfp f \<le> lfp (f ^^ Suc n)"
   proof (rule lfp_lowerbound)
     have "f (lfp (f ^^ Suc n)) = lfp (\<lambda>x. f ((f ^^ n) x))"
       unfolding funpow_Suc_right by (simp add: lfp_rolling f mono_pow comp_def)
     then show "f (lfp (f ^^ Suc n)) \<le> lfp (f ^^ Suc n)"
       by (simp add: comp_def)
   qed
   have "(f ^^ n) (lfp f) = lfp f" for n
     by (induct n) (auto intro: f lfp_fixpoint)
   then show "lfp (f ^^ Suc n) \<le> lfp f"
     by (intro lfp_lowerbound) (simp del: funpow.simps)
 qed
 
 lemma gfp_funpow:
   assumes f: "mono f"
   shows "gfp (f ^^ Suc n) = gfp f"
 proof (rule antisym)
   show "gfp f \<ge> gfp (f ^^ Suc n)"
   proof (rule gfp_upperbound)
     have "f (gfp (f ^^ Suc n)) = gfp (\<lambda>x. f ((f ^^ n) x))"
       unfolding funpow_Suc_right by (simp add: gfp_rolling f mono_pow comp_def)
     then show "f (gfp (f ^^ Suc n)) \<ge> gfp (f ^^ Suc n)"
       by (simp add: comp_def)
   qed
   have "(f ^^ n) (gfp f) = gfp f" for n
     by (induct n) (auto intro: f gfp_fixpoint)
   then show "gfp (f ^^ Suc n) \<ge> gfp f"
     by (intro gfp_upperbound) (simp del: funpow.simps)
 qed
 
 lemma Kleene_iter_gpfp:
   fixes f :: "'a::order_top \<Rightarrow> 'a"
   assumes "mono f"
     and "p \<le> f p"
   shows "p \<le> (f ^^ k) top"
 proof (induct k)
   case 0
   show ?case by simp
 next
   case Suc
   show ?case
     using monoD[OF assms(1) Suc] assms(2) by simp
 qed
 
 lemma gfp_Kleene_iter:
   assumes "mono f"
     and "(f ^^ Suc k) top = (f ^^ k) top"
   shows "gfp f = (f ^^ k) top"
     (is "?lhs = ?rhs")
 proof (rule antisym)
   have "?rhs \<le> f ?rhs"
     using assms(2) by simp
   then show "?rhs \<le> ?lhs"
     by (rule gfp_upperbound)
   show "?lhs \<le> ?rhs"
     using Kleene_iter_gpfp[OF assms(1)] gfp_unfold[OF assms(1)] by simp
 qed
 
 
 subsection \<open>Embedding of the naturals into any \<open>semiring_1\<close>: \<^term>\<open>of_nat\<close>\<close>
 
 context semiring_1
 begin
 
 definition of_nat :: "nat \<Rightarrow> 'a"
   where "of_nat n = (plus 1 ^^ n) 0"
 
 lemma of_nat_simps [simp]:
   shows of_nat_0: "of_nat 0 = 0"
     and of_nat_Suc: "of_nat (Suc m) = 1 + of_nat m"
   by (simp_all add: of_nat_def)
 
 lemma of_nat_1 [simp]: "of_nat 1 = 1"
   by (simp add: of_nat_def)
 
 lemma of_nat_add [simp]: "of_nat (m + n) = of_nat m + of_nat n"
   by (induct m) (simp_all add: ac_simps)
 
 lemma of_nat_mult [simp]: "of_nat (m * n) = of_nat m * of_nat n"
   by (induct m) (simp_all add: ac_simps distrib_right)
 
 lemma mult_of_nat_commute: "of_nat x * y = y * of_nat x"
   by (induct x) (simp_all add: algebra_simps)
 
 primrec of_nat_aux :: "('a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a"
   where
     "of_nat_aux inc 0 i = i"
   | "of_nat_aux inc (Suc n) i = of_nat_aux inc n (inc i)" \<comment> \<open>tail recursive\<close>
 
 lemma of_nat_code: "of_nat n = of_nat_aux (\<lambda>i. i + 1) n 0"
 proof (induct n)
   case 0
   then show ?case by simp
 next
   case (Suc n)
   have "\<And>i. of_nat_aux (\<lambda>i. i + 1) n (i + 1) = of_nat_aux (\<lambda>i. i + 1) n i + 1"
     by (induct n) simp_all
   from this [of 0] have "of_nat_aux (\<lambda>i. i + 1) n 1 = of_nat_aux (\<lambda>i. i + 1) n 0 + 1"
     by simp
   with Suc show ?case
     by (simp add: add.commute)
 qed
 
 lemma of_nat_of_bool [simp]:
   "of_nat (of_bool P) = of_bool P"
   by auto
 
 end
 
 declare of_nat_code [code]
 
 context semiring_1_cancel
 begin
 
 lemma of_nat_diff:
   \<open>of_nat (m - n) = of_nat m - of_nat n\<close> if \<open>n \<le> m\<close>
 proof -
   from that obtain q where \<open>m = n + q\<close>
     by (blast dest: le_Suc_ex)
   then show ?thesis
     by simp
 qed
 
 end
 
 text \<open>Class for unital semirings with characteristic zero.
  Includes non-ordered rings like the complex numbers.\<close>
 
 class semiring_char_0 = semiring_1 +
   assumes inj_of_nat: "inj of_nat"
 begin
 
 lemma of_nat_eq_iff [simp]: "of_nat m = of_nat n \<longleftrightarrow> m = n"
   by (auto intro: inj_of_nat injD)
 
 text \<open>Special cases where either operand is zero\<close>
 
 lemma of_nat_0_eq_iff [simp]: "0 = of_nat n \<longleftrightarrow> 0 = n"
   by (fact of_nat_eq_iff [of 0 n, unfolded of_nat_0])
 
 lemma of_nat_eq_0_iff [simp]: "of_nat m = 0 \<longleftrightarrow> m = 0"
   by (fact of_nat_eq_iff [of m 0, unfolded of_nat_0])
 
 lemma of_nat_1_eq_iff [simp]: "1 = of_nat n \<longleftrightarrow> n=1"
   using of_nat_eq_iff by fastforce
 
 lemma of_nat_eq_1_iff [simp]: "of_nat n = 1 \<longleftrightarrow> n=1"
   using of_nat_eq_iff by fastforce
 
 lemma of_nat_neq_0 [simp]: "of_nat (Suc n) \<noteq> 0"
   unfolding of_nat_eq_0_iff by simp
 
 lemma of_nat_0_neq [simp]: "0 \<noteq> of_nat (Suc n)"
   unfolding of_nat_0_eq_iff by simp
 
 end
 
 class ring_char_0 = ring_1 + semiring_char_0
 
 context linordered_nonzero_semiring
 begin
 
 lemma of_nat_0_le_iff [simp]: "0 \<le> of_nat n"
   by (induct n) simp_all
 
 lemma of_nat_less_0_iff [simp]: "\<not> of_nat m < 0"
   by (simp add: not_less)
 
 lemma of_nat_mono[simp]: "i \<le> j \<Longrightarrow> of_nat i \<le> of_nat j"
   by (auto simp: le_iff_add intro!: add_increasing2)
 
 lemma of_nat_less_iff [simp]: "of_nat m < of_nat n \<longleftrightarrow> m < n"
 proof(induct m n rule: diff_induct)
   case (1 m) then show ?case
     by auto
 next
   case (2 n) then show ?case
     by (simp add: add_pos_nonneg)
 next
   case (3 m n)
   then show ?case
     by (auto simp: add_commute [of 1] add_mono1 not_less add_right_mono leD)
 qed
 
 lemma of_nat_le_iff [simp]: "of_nat m \<le> of_nat n \<longleftrightarrow> m \<le> n"
   by (simp add: not_less [symmetric] linorder_not_less [symmetric])
 
 lemma less_imp_of_nat_less: "m < n \<Longrightarrow> of_nat m < of_nat n"
   by simp
 
 lemma of_nat_less_imp_less: "of_nat m < of_nat n \<Longrightarrow> m < n"
   by simp
 
 text \<open>Every \<open>linordered_nonzero_semiring\<close> has characteristic zero.\<close>
 
 subclass semiring_char_0
   by standard (auto intro!: injI simp add: order.eq_iff)
 
 text \<open>Special cases where either operand is zero\<close>
 
 lemma of_nat_le_0_iff [simp]: "of_nat m \<le> 0 \<longleftrightarrow> m = 0"
   by (rule of_nat_le_iff [of _ 0, simplified])
 
 lemma of_nat_0_less_iff [simp]: "0 < of_nat n \<longleftrightarrow> 0 < n"
   by (rule of_nat_less_iff [of 0, simplified])
 
 end
 
 context linordered_nonzero_semiring
 begin
 
 lemma of_nat_max: "of_nat (max x y) = max (of_nat x) (of_nat y)"
   by (auto simp: max_def ord_class.max_def)
 
 lemma of_nat_min: "of_nat (min x y) = min (of_nat x) (of_nat y)"
   by (auto simp: min_def ord_class.min_def)
 
 end
 
 context linordered_semidom
 begin
 
 subclass linordered_nonzero_semiring ..
 
 subclass semiring_char_0 ..
 
 end
 
 context linordered_idom
 begin
 
 lemma abs_of_nat [simp]:
   "\<bar>of_nat n\<bar> = of_nat n"
   by (simp add: abs_if)
 
 lemma sgn_of_nat [simp]:
   "sgn (of_nat n) = of_bool (n > 0)"
   by simp
 
 end
 
 lemma of_nat_id [simp]: "of_nat n = n"
   by (induct n) simp_all
 
 lemma of_nat_eq_id [simp]: "of_nat = id"
   by (auto simp add: fun_eq_iff)
 
 
 subsection \<open>The set of natural numbers\<close>
 
 context semiring_1
 begin
 
 definition Nats :: "'a set"  ("\<nat>")
   where "\<nat> = range of_nat"
 
 lemma of_nat_in_Nats [simp]: "of_nat n \<in> \<nat>"
   by (simp add: Nats_def)
 
 lemma Nats_0 [simp]: "0 \<in> \<nat>"
   using of_nat_0 [symmetric] unfolding Nats_def
   by (rule range_eqI)
 
 lemma Nats_1 [simp]: "1 \<in> \<nat>"
   using of_nat_1 [symmetric] unfolding Nats_def
   by (rule range_eqI)
 
 lemma Nats_add [simp]: "a \<in> \<nat> \<Longrightarrow> b \<in> \<nat> \<Longrightarrow> a + b \<in> \<nat>"
   unfolding Nats_def using of_nat_add [symmetric]
   by (blast intro: range_eqI)
 
 lemma Nats_mult [simp]: "a \<in> \<nat> \<Longrightarrow> b \<in> \<nat> \<Longrightarrow> a * b \<in> \<nat>"
   unfolding Nats_def using of_nat_mult [symmetric]
   by (blast intro: range_eqI)
 
 lemma Nats_cases [cases set: Nats]:
   assumes "x \<in> \<nat>"
   obtains (of_nat) n where "x = of_nat n"
   unfolding Nats_def
 proof -
   from \<open>x \<in> \<nat>\<close> have "x \<in> range of_nat" unfolding Nats_def .
   then obtain n where "x = of_nat n" ..
   then show thesis ..
 qed
 
 lemma Nats_induct [case_names of_nat, induct set: Nats]: "x \<in> \<nat> \<Longrightarrow> (\<And>n. P (of_nat n)) \<Longrightarrow> P x"
   by (rule Nats_cases) auto
 
 end
 
 lemma Nats_diff [simp]:
   fixes a:: "'a::linordered_idom"
   assumes "a \<in> \<nat>" "b \<in> \<nat>" "b \<le> a" shows "a - b \<in> \<nat>"
 proof -
   obtain i where i: "a = of_nat i"
     using Nats_cases assms by blast
   obtain j where j: "b = of_nat j"
     using Nats_cases assms by blast
   have "j \<le> i"
     using \<open>b \<le> a\<close> i j of_nat_le_iff by blast
   then have *: "of_nat i - of_nat j = (of_nat (i-j) :: 'a)"
     by (simp add: of_nat_diff)
   then show ?thesis
     by (simp add: * i j)
 qed
 
 
 subsection \<open>Further arithmetic facts concerning the natural numbers\<close>
 
 lemma subst_equals:
   assumes "t = s" and "u = t"
   shows "u = s"
   using assms(2,1) by (rule trans)
 
 locale nat_arith
 begin
 
 lemma add1: "(A::'a::comm_monoid_add) \<equiv> k + a \<Longrightarrow> A + b \<equiv> k + (a + b)"
   by (simp only: ac_simps)
 
 lemma add2: "(B::'a::comm_monoid_add) \<equiv> k + b \<Longrightarrow> a + B \<equiv> k + (a + b)"
   by (simp only: ac_simps)
 
 lemma suc1: "A == k + a \<Longrightarrow> Suc A \<equiv> k + Suc a"
   by (simp only: add_Suc_right)
 
 lemma rule0: "(a::'a::comm_monoid_add) \<equiv> a + 0"
   by (simp only: add_0_right)
 
 end
 
 ML_file \<open>Tools/nat_arith.ML\<close>
 
 simproc_setup nateq_cancel_sums
   ("(l::nat) + m = n" | "(l::nat) = m + n" | "Suc m = n" | "m = Suc n") =
-  \<open>fn phi => try o Nat_Arith.cancel_eq_conv\<close>
+  \<open>K (try o Nat_Arith.cancel_eq_conv)\<close>
 
 simproc_setup natless_cancel_sums
   ("(l::nat) + m < n" | "(l::nat) < m + n" | "Suc m < n" | "m < Suc n") =
-  \<open>fn phi => try o Nat_Arith.cancel_less_conv\<close>
+  \<open>K (try o Nat_Arith.cancel_less_conv)\<close>
 
 simproc_setup natle_cancel_sums
   ("(l::nat) + m \<le> n" | "(l::nat) \<le> m + n" | "Suc m \<le> n" | "m \<le> Suc n") =
-  \<open>fn phi => try o Nat_Arith.cancel_le_conv\<close>
+  \<open>K (try o Nat_Arith.cancel_le_conv)\<close>
 
 simproc_setup natdiff_cancel_sums
   ("(l::nat) + m - n" | "(l::nat) - (m + n)" | "Suc m - n" | "m - Suc n") =
-  \<open>fn phi => try o Nat_Arith.cancel_diff_conv\<close>
+  \<open>K (try o Nat_Arith.cancel_diff_conv)\<close>
 
 context order
 begin
 
 lemma lift_Suc_mono_le:
   assumes mono: "\<And>n. f n \<le> f (Suc n)"
     and "n \<le> n'"
   shows "f n \<le> f n'"
 proof (cases "n < n'")
   case True
   then show ?thesis
     by (induct n n' rule: less_Suc_induct) (auto intro: mono)
 next
   case False
   with \<open>n \<le> n'\<close> show ?thesis by auto
 qed
 
 lemma lift_Suc_antimono_le:
   assumes mono: "\<And>n. f n \<ge> f (Suc n)"
     and "n \<le> n'"
   shows "f n \<ge> f n'"
 proof (cases "n < n'")
   case True
   then show ?thesis
     by (induct n n' rule: less_Suc_induct) (auto intro: mono)
 next
   case False
   with \<open>n \<le> n'\<close> show ?thesis by auto
 qed
 
 lemma lift_Suc_mono_less:
   assumes mono: "\<And>n. f n < f (Suc n)"
     and "n < n'"
   shows "f n < f n'"
   using \<open>n < n'\<close> by (induct n n' rule: less_Suc_induct) (auto intro: mono)
 
 lemma lift_Suc_mono_less_iff: "(\<And>n. f n < f (Suc n)) \<Longrightarrow> f n < f m \<longleftrightarrow> n < m"
   by (blast intro: less_asym' lift_Suc_mono_less [of f]
     dest: linorder_not_less[THEN iffD1] le_eq_less_or_eq [THEN iffD1])
 
 end
 
 lemma mono_iff_le_Suc: "mono f \<longleftrightarrow> (\<forall>n. f n \<le> f (Suc n))"
   unfolding mono_def by (auto intro: lift_Suc_mono_le [of f])
 
 lemma antimono_iff_le_Suc: "antimono f \<longleftrightarrow> (\<forall>n. f (Suc n) \<le> f n)"
   unfolding antimono_def by (auto intro: lift_Suc_antimono_le [of f])
 
 lemma mono_nat_linear_lb:
   fixes f :: "nat \<Rightarrow> nat"
   assumes "\<And>m n. m < n \<Longrightarrow> f m < f n"
   shows "f m + k \<le> f (m + k)"
 proof (induct k)
   case 0
   then show ?case by simp
 next
   case (Suc k)
   then have "Suc (f m + k) \<le> Suc (f (m + k))" by simp
   also from assms [of "m + k" "Suc (m + k)"] have "Suc (f (m + k)) \<le> f (Suc (m + k))"
     by (simp add: Suc_le_eq)
   finally show ?case by simp
 qed
 
 
 text \<open>Subtraction laws, mostly by Clemens Ballarin\<close>
 
 lemma diff_less_mono:
   fixes a b c :: nat
   assumes "a < b" and "c \<le> a"
   shows "a - c < b - c"
 proof -
   from assms obtain d e where "b = c + (d + e)" and "a = c + e" and "d > 0"
     by (auto dest!: le_Suc_ex less_imp_Suc_add simp add: ac_simps)
   then show ?thesis by simp
 qed
 
 lemma less_diff_conv: "i < j - k \<longleftrightarrow> i + k < j"
   for i j k :: nat
   by (cases "k \<le> j") (auto simp add: not_le dest: less_imp_Suc_add le_Suc_ex)
 
 lemma less_diff_conv2: "k \<le> j \<Longrightarrow> j - k < i \<longleftrightarrow> j < i + k"
   for j k i :: nat
   by (auto dest: le_Suc_ex)
 
 lemma le_diff_conv: "j - k \<le> i \<longleftrightarrow> j \<le> i + k"
   for j k i :: nat
   by (cases "k \<le> j") (auto simp add: not_le dest!: less_imp_Suc_add le_Suc_ex)
 
 lemma diff_diff_cancel [simp]: "i \<le> n \<Longrightarrow> n - (n - i) = i"
   for i n :: nat
   by (auto dest: le_Suc_ex)
 
 lemma diff_less [simp]: "0 < n \<Longrightarrow> 0 < m \<Longrightarrow> m - n < m"
   for i n :: nat
   by (auto dest: less_imp_Suc_add)
 
 text \<open>Simplification of relational expressions involving subtraction\<close>
 
 lemma diff_diff_eq: "k \<le> m \<Longrightarrow> k \<le> n \<Longrightarrow> m - k - (n - k) = m - n"
   for m n k :: nat
   by (auto dest!: le_Suc_ex)
 
 hide_fact (open) diff_diff_eq
 
 lemma eq_diff_iff: "k \<le> m \<Longrightarrow> k \<le> n \<Longrightarrow> m - k = n - k \<longleftrightarrow> m = n"
   for m n k :: nat
   by (auto dest: le_Suc_ex)
 
 lemma less_diff_iff: "k \<le> m \<Longrightarrow> k \<le> n \<Longrightarrow> m - k < n - k \<longleftrightarrow> m < n"
   for m n k :: nat
   by (auto dest!: le_Suc_ex)
 
 lemma le_diff_iff: "k \<le> m \<Longrightarrow> k \<le> n \<Longrightarrow> m - k \<le> n - k \<longleftrightarrow> m \<le> n"
   for m n k :: nat
   by (auto dest!: le_Suc_ex)
 
 lemma le_diff_iff': "a \<le> c \<Longrightarrow> b \<le> c \<Longrightarrow> c - a \<le> c - b \<longleftrightarrow> b \<le> a"
   for a b c :: nat
   by (force dest: le_Suc_ex)
 
 
 text \<open>(Anti)Monotonicity of subtraction -- by Stephan Merz\<close>
 
 lemma diff_le_mono: "m \<le> n \<Longrightarrow> m - l \<le> n - l"
   for m n l :: nat
   by (auto dest: less_imp_le less_imp_Suc_add split: nat_diff_split)
 
 lemma diff_le_mono2: "m \<le> n \<Longrightarrow> l - n \<le> l - m"
   for m n l :: nat
   by (auto dest: less_imp_le le_Suc_ex less_imp_Suc_add less_le_trans split: nat_diff_split)
 
 lemma diff_less_mono2: "m < n \<Longrightarrow> m < l \<Longrightarrow> l - n < l - m"
   for m n l :: nat
   by (auto dest: less_imp_Suc_add split: nat_diff_split)
 
 lemma diffs0_imp_equal: "m - n = 0 \<Longrightarrow> n - m = 0 \<Longrightarrow> m = n"
   for m n :: nat
   by (simp split: nat_diff_split)
 
 lemma min_diff: "min (m - i) (n - i) = min m n - i"
   for m n i :: nat
   by (cases m n rule: le_cases)
     (auto simp add: not_le min.absorb1 min.absorb2 min.absorb_iff1 [symmetric] diff_le_mono)
 
 lemma inj_on_diff_nat:
   fixes k :: nat
   assumes "\<And>n. n \<in> N \<Longrightarrow> k \<le> n"
   shows "inj_on (\<lambda>n. n - k) N"
 proof (rule inj_onI)
   fix x y
   assume a: "x \<in> N" "y \<in> N" "x - k = y - k"
   with assms have "x - k + k = y - k + k" by auto
   with a assms show "x = y" by (auto simp add: eq_diff_iff)
 qed
 
 text \<open>Rewriting to pull differences out\<close>
 
 lemma diff_diff_right [simp]: "k \<le> j \<Longrightarrow> i - (j - k) = i + k - j"
   for i j k :: nat
   by (fact diff_diff_right)
 
 lemma diff_Suc_diff_eq1 [simp]:
   assumes "k \<le> j"
   shows "i - Suc (j - k) = i + k - Suc j"
 proof -
   from assms have *: "Suc (j - k) = Suc j - k"
     by (simp add: Suc_diff_le)
   from assms have "k \<le> Suc j"
     by (rule order_trans) simp
   with diff_diff_right [of k "Suc j" i] * show ?thesis
     by simp
 qed
 
 lemma diff_Suc_diff_eq2 [simp]:
   assumes "k \<le> j"
   shows "Suc (j - k) - i = Suc j - (k + i)"
 proof -
   from assms obtain n where "j = k + n"
     by (auto dest: le_Suc_ex)
   moreover have "Suc n - i = (k + Suc n) - (k + i)"
     using add_diff_cancel_left [of k "Suc n" i] by simp
   ultimately show ?thesis by simp
 qed
 
 lemma Suc_diff_Suc:
   assumes "n < m"
   shows "Suc (m - Suc n) = m - n"
 proof -
   from assms obtain q where "m = n + Suc q"
     by (auto dest: less_imp_Suc_add)
   moreover define r where "r = Suc q"
   ultimately have "Suc (m - Suc n) = r" and "m = n + r"
     by simp_all
   then show ?thesis by simp
 qed
 
 lemma one_less_mult: "Suc 0 < n \<Longrightarrow> Suc 0 < m \<Longrightarrow> Suc 0 < m * n"
   using less_1_mult [of n m] by (simp add: ac_simps)
 
 lemma n_less_m_mult_n: "0 < n \<Longrightarrow> Suc 0 < m \<Longrightarrow> n < m * n"
   using mult_strict_right_mono [of 1 m n] by simp
 
 lemma n_less_n_mult_m: "0 < n \<Longrightarrow> Suc 0 < m \<Longrightarrow> n < n * m"
   using mult_strict_left_mono [of 1 m n] by simp
 
 
 text \<open>Induction starting beyond zero\<close>
 
 lemma nat_induct_at_least [consumes 1, case_names base Suc]:
   "P n" if "n \<ge> m" "P m" "\<And>n. n \<ge> m \<Longrightarrow> P n \<Longrightarrow> P (Suc n)"
 proof -
   define q where "q = n - m"
   with \<open>n \<ge> m\<close> have "n = m + q"
     by simp
   moreover have "P (m + q)"
     by (induction q) (use that in simp_all)
   ultimately show "P n"
     by simp
 qed
 
 lemma nat_induct_non_zero [consumes 1, case_names 1 Suc]:
   "P n" if "n > 0" "P 1" "\<And>n. n > 0 \<Longrightarrow> P n \<Longrightarrow> P (Suc n)"
 proof -
   from \<open>n > 0\<close> have "n \<ge> 1"
     by (cases n) simp_all
   moreover note \<open>P 1\<close>
   moreover have "\<And>n. n \<ge> 1 \<Longrightarrow> P n \<Longrightarrow> P (Suc n)"
     using \<open>\<And>n. n > 0 \<Longrightarrow> P n \<Longrightarrow> P (Suc n)\<close>
     by (simp add: Suc_le_eq)
   ultimately show "P n"
     by (rule nat_induct_at_least)
 qed
 
 
 text \<open>Specialized induction principles that work "backwards":\<close>
 
 lemma inc_induct [consumes 1, case_names base step]:
   assumes less: "i \<le> j"
     and base: "P j"
     and step: "\<And>n. i \<le> n \<Longrightarrow> n < j \<Longrightarrow> P (Suc n) \<Longrightarrow> P n"
   shows "P i"
   using less step
 proof (induct "j - i" arbitrary: i)
   case (0 i)
   then have "i = j" by simp
   with base show ?case by simp
 next
   case (Suc d n)
   from Suc.hyps have "n \<noteq> j" by auto
   with Suc have "n < j" by (simp add: less_le)
   from \<open>Suc d = j - n\<close> have "d + 1 = j - n" by simp
   then have "d + 1 - 1 = j - n - 1" by simp
   then have "d = j - n - 1" by simp
   then have "d = j - (n + 1)" by (simp add: diff_diff_eq)
   then have "d = j - Suc n" by simp
   moreover from \<open>n < j\<close> have "Suc n \<le> j" by (simp add: Suc_le_eq)
   ultimately have "P (Suc n)"
   proof (rule Suc.hyps)
     fix q
     assume "Suc n \<le> q"
     then have "n \<le> q" by (simp add: Suc_le_eq less_imp_le)
     moreover assume "q < j"
     moreover assume "P (Suc q)"
     ultimately show "P q" by (rule Suc.prems)
   qed
   with order_refl \<open>n < j\<close> show "P n" by (rule Suc.prems)
 qed
 
 lemma strict_inc_induct [consumes 1, case_names base step]:
   assumes less: "i < j"
     and base: "\<And>i. j = Suc i \<Longrightarrow> P i"
     and step: "\<And>i. i < j \<Longrightarrow> P (Suc i) \<Longrightarrow> P i"
   shows "P i"
 using less proof (induct "j - i - 1" arbitrary: i)
   case (0 i)
   from \<open>i < j\<close> obtain n where "j = i + n" and "n > 0"
     by (auto dest!: less_imp_Suc_add)
   with 0 have "j = Suc i"
     by (auto intro: order_antisym simp add: Suc_le_eq)
   with base show ?case by simp
 next
   case (Suc d i)
   from \<open>Suc d = j - i - 1\<close> have *: "Suc d = j - Suc i"
     by (simp add: diff_diff_add)
   then have "Suc d - 1 = j - Suc i - 1" by simp
   then have "d = j - Suc i - 1" by simp
   moreover from * have "j - Suc i \<noteq> 0" by auto
   then have "Suc i < j" by (simp add: not_le)
   ultimately have "P (Suc i)" by (rule Suc.hyps)
   with \<open>i < j\<close> show "P i" by (rule step)
 qed
 
 lemma zero_induct_lemma: "P k \<Longrightarrow> (\<And>n. P (Suc n) \<Longrightarrow> P n) \<Longrightarrow> P (k - i)"
   using inc_induct[of "k - i" k P, simplified] by blast
 
 lemma zero_induct: "P k \<Longrightarrow> (\<And>n. P (Suc n) \<Longrightarrow> P n) \<Longrightarrow> P 0"
   using inc_induct[of 0 k P] by blast
 
 text \<open>Further induction rule similar to @{thm inc_induct}.\<close>
 
 lemma dec_induct [consumes 1, case_names base step]:
   "i \<le> j \<Longrightarrow> P i \<Longrightarrow> (\<And>n. i \<le> n \<Longrightarrow> n < j \<Longrightarrow> P n \<Longrightarrow> P (Suc n)) \<Longrightarrow> P j"
 proof (induct j arbitrary: i)
   case 0
   then show ?case by simp
 next
   case (Suc j)
   from Suc.prems consider "i \<le> j" | "i = Suc j"
     by (auto simp add: le_Suc_eq)
   then show ?case
   proof cases
     case 1
     moreover have "j < Suc j" by simp
     moreover have "P j" using \<open>i \<le> j\<close> \<open>P i\<close>
     proof (rule Suc.hyps)
       fix q
       assume "i \<le> q"
       moreover assume "q < j" then have "q < Suc j"
         by (simp add: less_Suc_eq)
       moreover assume "P q"
       ultimately show "P (Suc q)" by (rule Suc.prems)
     qed
     ultimately show "P (Suc j)" by (rule Suc.prems)
   next
     case 2
     with \<open>P i\<close> show "P (Suc j)" by simp
   qed
 qed
 
 lemma transitive_stepwise_le:
   assumes "m \<le> n" "\<And>x. R x x" "\<And>x y z. R x y \<Longrightarrow> R y z \<Longrightarrow> R x z" and "\<And>n. R n (Suc n)"
   shows "R m n"
 using \<open>m \<le> n\<close>  
   by (induction rule: dec_induct) (use assms in blast)+
 
 
 subsubsection \<open>Greatest operator\<close>
 
 lemma ex_has_greatest_nat:
   "P (k::nat) \<Longrightarrow> \<forall>y. P y \<longrightarrow> y \<le> b \<Longrightarrow> \<exists>x. P x \<and> (\<forall>y. P y \<longrightarrow> y \<le> x)"
 proof (induction "b-k" arbitrary: b k rule: less_induct)
   case less
   show ?case
   proof cases
     assume "\<exists>n>k. P n"
     then obtain n where "n>k" "P n" by blast
     have "n \<le> b" using \<open>P n\<close> less.prems(2) by auto
     hence "b-n < b-k"
       by(rule diff_less_mono2[OF \<open>k<n\<close> less_le_trans[OF \<open>k<n\<close>]])
     from less.hyps[OF this \<open>P n\<close> less.prems(2)]
     show ?thesis .
   next
     assume "\<not> (\<exists>n>k. P n)"
     hence "\<forall>y. P y \<longrightarrow> y \<le> k" by (auto simp: not_less)
     thus ?thesis using less.prems(1) by auto
   qed
 qed
 
 lemma
   fixes k::nat
   assumes "P k" and minor: "\<And>y. P y \<Longrightarrow> y \<le> b"
   shows GreatestI_nat: "P (Greatest P)" 
     and Greatest_le_nat: "k \<le> Greatest P"
 proof -
   obtain x where "P x" "\<And>y. P y \<Longrightarrow> y \<le> x"
     using assms ex_has_greatest_nat by blast
   with \<open>P k\<close> show "P (Greatest P)" "k \<le> Greatest P"
     using GreatestI2_order by blast+
 qed
 
 lemma GreatestI_ex_nat:
   "\<lbrakk> \<exists>k::nat. P k;  \<And>y. P y \<Longrightarrow> y \<le> b \<rbrakk> \<Longrightarrow> P (Greatest P)"
   by (blast intro: GreatestI_nat)
 
 
 subsection \<open>Monotonicity of \<open>funpow\<close>\<close>
 
 lemma funpow_increasing: "m \<le> n \<Longrightarrow> mono f \<Longrightarrow> (f ^^ n) \<top> \<le> (f ^^ m) \<top>"
   for f :: "'a::{lattice,order_top} \<Rightarrow> 'a"
   by (induct rule: inc_induct)
     (auto simp del: funpow.simps(2) simp add: funpow_Suc_right
       intro: order_trans[OF _ funpow_mono])
 
 lemma funpow_decreasing: "m \<le> n \<Longrightarrow> mono f \<Longrightarrow> (f ^^ m) \<bottom> \<le> (f ^^ n) \<bottom>"
   for f :: "'a::{lattice,order_bot} \<Rightarrow> 'a"
   by (induct rule: dec_induct)
     (auto simp del: funpow.simps(2) simp add: funpow_Suc_right
       intro: order_trans[OF _ funpow_mono])
 
 lemma mono_funpow: "mono Q \<Longrightarrow> mono (\<lambda>i. (Q ^^ i) \<bottom>)"
   for Q :: "'a::{lattice,order_bot} \<Rightarrow> 'a"
   by (auto intro!: funpow_decreasing simp: mono_def)
 
 lemma antimono_funpow: "mono Q \<Longrightarrow> antimono (\<lambda>i. (Q ^^ i) \<top>)"
   for Q :: "'a::{lattice,order_top} \<Rightarrow> 'a"
   by (auto intro!: funpow_increasing simp: antimono_def)
 
 
 subsection \<open>The divides relation on \<^typ>\<open>nat\<close>\<close>
 
 lemma dvd_1_left [iff]: "Suc 0 dvd k"
   by (simp add: dvd_def)
 
 lemma dvd_1_iff_1 [simp]: "m dvd Suc 0 \<longleftrightarrow> m = Suc 0"
   by (simp add: dvd_def)
 
 lemma nat_dvd_1_iff_1 [simp]: "m dvd 1 \<longleftrightarrow> m = 1"
   for m :: nat
   by (simp add: dvd_def)
 
 lemma dvd_antisym: "m dvd n \<Longrightarrow> n dvd m \<Longrightarrow> m = n"
   for m n :: nat
   unfolding dvd_def by (force dest: mult_eq_self_implies_10 simp add: mult.assoc)
 
 lemma dvd_diff_nat [simp]: "k dvd m \<Longrightarrow> k dvd n \<Longrightarrow> k dvd (m - n)"
   for k m n :: nat
   unfolding dvd_def by (blast intro: right_diff_distrib' [symmetric])
 
 lemma dvd_diffD: 
   fixes k m n :: nat
   assumes "k dvd m - n" "k dvd n" "n \<le> m"
   shows "k dvd m"
 proof -
   have "k dvd n + (m - n)"
     using assms by (blast intro: dvd_add)
   with assms show ?thesis
     by simp
 qed
 
 lemma dvd_diffD1: "k dvd m - n \<Longrightarrow> k dvd m \<Longrightarrow> n \<le> m \<Longrightarrow> k dvd n"
   for k m n :: nat
   by (drule_tac m = m in dvd_diff_nat) auto
 
 lemma dvd_mult_cancel:
   fixes m n k :: nat
   assumes "k * m dvd k * n" and "0 < k"
   shows "m dvd n"
 proof -
   from assms(1) obtain q where "k * n = (k * m) * q" ..
   then have "k * n = k * (m * q)" by (simp add: ac_simps)
   with \<open>0 < k\<close> have "n = m * q" by (auto simp add: mult_left_cancel)
   then show ?thesis ..
 qed
 
 lemma dvd_mult_cancel1:
   fixes m n :: nat
   assumes "0 < m"
   shows "m * n dvd m \<longleftrightarrow> n = 1"
 proof 
   assume "m * n dvd m"
   then have "m * n dvd m * 1"
     by simp
   then have "n dvd 1"
     by (iprover intro: assms dvd_mult_cancel)
   then show "n = 1"
     by auto
 qed auto
 
 lemma dvd_mult_cancel2: "0 < m \<Longrightarrow> n * m dvd m \<longleftrightarrow> n = 1"
   for m n :: nat
   using dvd_mult_cancel1 [of m n] by (simp add: ac_simps)
 
 lemma dvd_imp_le: "k dvd n \<Longrightarrow> 0 < n \<Longrightarrow> k \<le> n"
   for k n :: nat
   by (auto elim!: dvdE) (auto simp add: gr0_conv_Suc)
 
 lemma nat_dvd_not_less: "0 < m \<Longrightarrow> m < n \<Longrightarrow> \<not> n dvd m"
   for m n :: nat
   by (auto elim!: dvdE) (auto simp add: gr0_conv_Suc)
 
 lemma less_eq_dvd_minus:
   fixes m n :: nat
   assumes "m \<le> n"
   shows "m dvd n \<longleftrightarrow> m dvd n - m"
 proof -
   from assms have "n = m + (n - m)" by simp
   then obtain q where "n = m + q" ..
   then show ?thesis by (simp add: add.commute [of m])
 qed
 
 lemma dvd_minus_self: "m dvd n - m \<longleftrightarrow> n < m \<or> m dvd n"
   for m n :: nat
   by (cases "n < m") (auto elim!: dvdE simp add: not_less le_imp_diff_is_add dest: less_imp_le)
 
 lemma dvd_minus_add:
   fixes m n q r :: nat
   assumes "q \<le> n" "q \<le> r * m"
   shows "m dvd n - q \<longleftrightarrow> m dvd n + (r * m - q)"
 proof -
   have "m dvd n - q \<longleftrightarrow> m dvd r * m + (n - q)"
     using dvd_add_times_triv_left_iff [of m r] by simp
   also from assms have "\<dots> \<longleftrightarrow> m dvd r * m + n - q" by simp
   also from assms have "\<dots> \<longleftrightarrow> m dvd (r * m - q) + n" by simp
   also have "\<dots> \<longleftrightarrow> m dvd n + (r * m - q)" by (simp add: add.commute)
   finally show ?thesis .
 qed
 
 
 subsection \<open>Aliasses\<close>
 
 lemma nat_mult_1: "1 * n = n"
   for n :: nat
   by (fact mult_1_left)
 
 lemma nat_mult_1_right: "n * 1 = n"
   for n :: nat
   by (fact mult_1_right)
 
 lemma diff_mult_distrib: "(m - n) * k = (m * k) - (n * k)"
   for k m n :: nat
   by (fact left_diff_distrib')
 
 lemma diff_mult_distrib2: "k * (m - n) = (k * m) - (k * n)"
   for k m n :: nat
   by (fact right_diff_distrib')
 
 (*Used in AUTO2 and Groups.le_diff_conv2 (with variables renamed) doesn't work for some reason*)
 lemma le_diff_conv2: "k \<le> j \<Longrightarrow> (i \<le> j - k) = (i + k \<le> j)"
   for i j k :: nat
   by (fact le_diff_conv2) 
 
 lemma diff_self_eq_0 [simp]: "m - m = 0"
   for m :: nat
   by (fact diff_cancel)
 
 lemma diff_diff_left [simp]: "i - j - k = i - (j + k)"
   for i j k :: nat
   by (fact diff_diff_add)
 
 lemma diff_commute: "i - j - k = i - k - j"
   for i j k :: nat
   by (fact diff_right_commute)
 
 lemma diff_add_inverse: "(n + m) - n = m"
   for m n :: nat
   by (fact add_diff_cancel_left')
 
 lemma diff_add_inverse2: "(m + n) - n = m"
   for m n :: nat
   by (fact add_diff_cancel_right')
 
 lemma diff_cancel: "(k + m) - (k + n) = m - n"
   for k m n :: nat
   by (fact add_diff_cancel_left)
 
 lemma diff_cancel2: "(m + k) - (n + k) = m - n"
   for k m n :: nat
   by (fact add_diff_cancel_right)
 
 lemma diff_add_0: "n - (n + m) = 0"
   for m n :: nat
   by (fact diff_add_zero)
 
 lemma add_mult_distrib2: "k * (m + n) = (k * m) + (k * n)"
   for k m n :: nat
   by (fact distrib_left)
 
 lemmas nat_distrib =
   add_mult_distrib distrib_left diff_mult_distrib diff_mult_distrib2
 
 
 subsection \<open>Size of a datatype value\<close>
 
 class size =
   fixes size :: "'a \<Rightarrow> nat" \<comment> \<open>see further theory \<open>Wellfounded\<close>\<close>
 
 instantiation nat :: size
 begin
 
 definition size_nat where [simp, code]: "size (n::nat) = n"
 
 instance ..
 
 end
 
 lemmas size_nat = size_nat_def
 
 lemma size_neq_size_imp_neq: "size x \<noteq> size y \<Longrightarrow> x \<noteq> y"
   by (erule contrapos_nn) (rule arg_cong)
 
 
 subsection \<open>Code module namespace\<close>
 
 code_identifier
   code_module Nat \<rightharpoonup> (SML) Arith and (OCaml) Arith and (Haskell) Arith
 
 hide_const (open) of_nat_aux
 
 end
diff --git a/src/HOL/Nonstandard_Analysis/NSA.thy b/src/HOL/Nonstandard_Analysis/NSA.thy
--- a/src/HOL/Nonstandard_Analysis/NSA.thy
+++ b/src/HOL/Nonstandard_Analysis/NSA.thy
@@ -1,1672 +1,1672 @@
 (*  Title:      HOL/Nonstandard_Analysis/NSA.thy
     Author:     Jacques D. Fleuriot, University of Cambridge
     Author:     Lawrence C Paulson, University of Cambridge
 *)
 
 section \<open>Infinite Numbers, Infinitesimals, Infinitely Close Relation\<close>
 
 theory NSA
   imports HyperDef "HOL-Library.Lub_Glb" 
 begin
 
 definition hnorm :: "'a::real_normed_vector star \<Rightarrow> real star"
   where [transfer_unfold]: "hnorm = *f* norm"
 
 definition Infinitesimal  :: "('a::real_normed_vector) star set"
   where "Infinitesimal = {x. \<forall>r \<in> Reals. 0 < r \<longrightarrow> hnorm x < r}"
 
 definition HFinite :: "('a::real_normed_vector) star set"
   where "HFinite = {x. \<exists>r \<in> Reals. hnorm x < r}"
 
 definition HInfinite :: "('a::real_normed_vector) star set"
   where "HInfinite = {x. \<forall>r \<in> Reals. r < hnorm x}"
 
 definition approx :: "'a::real_normed_vector star \<Rightarrow> 'a star \<Rightarrow> bool"  (infixl "\<approx>" 50)
   where "x \<approx> y \<longleftrightarrow> x - y \<in> Infinitesimal"
     \<comment> \<open>the ``infinitely close'' relation\<close>
 
 definition st :: "hypreal \<Rightarrow> hypreal"
   where "st = (\<lambda>x. SOME r. x \<in> HFinite \<and> r \<in> \<real> \<and> r \<approx> x)"
     \<comment> \<open>the standard part of a hyperreal\<close>
 
 definition monad :: "'a::real_normed_vector star \<Rightarrow> 'a star set"
   where "monad x = {y. x \<approx> y}"
 
 definition galaxy :: "'a::real_normed_vector star \<Rightarrow> 'a star set"
   where "galaxy x = {y. (x + -y) \<in> HFinite}"
 
 lemma SReal_def: "\<real> \<equiv> {x. \<exists>r. x = hypreal_of_real r}"
   by (simp add: Reals_def image_def)
 
 
 subsection \<open>Nonstandard Extension of the Norm Function\<close>
 
 definition scaleHR :: "real star \<Rightarrow> 'a star \<Rightarrow> 'a::real_normed_vector star"
   where [transfer_unfold]: "scaleHR = starfun2 scaleR"
 
 lemma Standard_hnorm [simp]: "x \<in> Standard \<Longrightarrow> hnorm x \<in> Standard"
   by (simp add: hnorm_def)
 
 lemma star_of_norm [simp]: "star_of (norm x) = hnorm (star_of x)"
   by transfer (rule refl)
 
 lemma hnorm_ge_zero [simp]: "\<And>x::'a::real_normed_vector star. 0 \<le> hnorm x"
   by transfer (rule norm_ge_zero)
 
 lemma hnorm_eq_zero [simp]: "\<And>x::'a::real_normed_vector star. hnorm x = 0 \<longleftrightarrow> x = 0"
   by transfer (rule norm_eq_zero)
 
 lemma hnorm_triangle_ineq: "\<And>x y::'a::real_normed_vector star. hnorm (x + y) \<le> hnorm x + hnorm y"
   by transfer (rule norm_triangle_ineq)
 
 lemma hnorm_triangle_ineq3: "\<And>x y::'a::real_normed_vector star. \<bar>hnorm x - hnorm y\<bar> \<le> hnorm (x - y)"
   by transfer (rule norm_triangle_ineq3)
 
 lemma hnorm_scaleR: "\<And>x::'a::real_normed_vector star. hnorm (a *\<^sub>R x) = \<bar>star_of a\<bar> * hnorm x"
   by transfer (rule norm_scaleR)
 
 lemma hnorm_scaleHR: "\<And>a (x::'a::real_normed_vector star). hnorm (scaleHR a x) = \<bar>a\<bar> * hnorm x"
   by transfer (rule norm_scaleR)
 
 lemma hnorm_mult_ineq: "\<And>x y::'a::real_normed_algebra star. hnorm (x * y) \<le> hnorm x * hnorm y"
   by transfer (rule norm_mult_ineq)
 
 lemma hnorm_mult: "\<And>x y::'a::real_normed_div_algebra star. hnorm (x * y) = hnorm x * hnorm y"
   by transfer (rule norm_mult)
 
 lemma hnorm_hyperpow: "\<And>(x::'a::{real_normed_div_algebra} star) n. hnorm (x pow n) = hnorm x pow n"
   by transfer (rule norm_power)
 
 lemma hnorm_one [simp]: "hnorm (1::'a::real_normed_div_algebra star) = 1"
   by transfer (rule norm_one)
 
 lemma hnorm_zero [simp]: "hnorm (0::'a::real_normed_vector star) = 0"
   by transfer (rule norm_zero)
 
 lemma zero_less_hnorm_iff [simp]: "\<And>x::'a::real_normed_vector star. 0 < hnorm x \<longleftrightarrow> x \<noteq> 0"
   by transfer (rule zero_less_norm_iff)
 
 lemma hnorm_minus_cancel [simp]: "\<And>x::'a::real_normed_vector star. hnorm (- x) = hnorm x"
   by transfer (rule norm_minus_cancel)
 
 lemma hnorm_minus_commute: "\<And>a b::'a::real_normed_vector star. hnorm (a - b) = hnorm (b - a)"
   by transfer (rule norm_minus_commute)
 
 lemma hnorm_triangle_ineq2: "\<And>a b::'a::real_normed_vector star. hnorm a - hnorm b \<le> hnorm (a - b)"
   by transfer (rule norm_triangle_ineq2)
 
 lemma hnorm_triangle_ineq4: "\<And>a b::'a::real_normed_vector star. hnorm (a - b) \<le> hnorm a + hnorm b"
   by transfer (rule norm_triangle_ineq4)
 
 lemma abs_hnorm_cancel [simp]: "\<And>a::'a::real_normed_vector star. \<bar>hnorm a\<bar> = hnorm a"
   by transfer (rule abs_norm_cancel)
 
 lemma hnorm_of_hypreal [simp]: "\<And>r. hnorm (of_hypreal r::'a::real_normed_algebra_1 star) = \<bar>r\<bar>"
   by transfer (rule norm_of_real)
 
 lemma nonzero_hnorm_inverse:
   "\<And>a::'a::real_normed_div_algebra star. a \<noteq> 0 \<Longrightarrow> hnorm (inverse a) = inverse (hnorm a)"
   by transfer (rule nonzero_norm_inverse)
 
 lemma hnorm_inverse:
   "\<And>a::'a::{real_normed_div_algebra, division_ring} star. hnorm (inverse a) = inverse (hnorm a)"
   by transfer (rule norm_inverse)
 
 lemma hnorm_divide: "\<And>a b::'a::{real_normed_field, field} star. hnorm (a / b) = hnorm a / hnorm b"
   by transfer (rule norm_divide)
 
 lemma hypreal_hnorm_def [simp]: "\<And>r::hypreal. hnorm r = \<bar>r\<bar>"
   by transfer (rule real_norm_def)
 
 lemma hnorm_add_less:
   "\<And>(x::'a::real_normed_vector star) y r s. hnorm x < r \<Longrightarrow> hnorm y < s \<Longrightarrow> hnorm (x + y) < r + s"
   by transfer (rule norm_add_less)
 
 lemma hnorm_mult_less:
   "\<And>(x::'a::real_normed_algebra star) y r s. hnorm x < r \<Longrightarrow> hnorm y < s \<Longrightarrow> hnorm (x * y) < r * s"
   by transfer (rule norm_mult_less)
 
 lemma hnorm_scaleHR_less: "\<bar>x\<bar> < r \<Longrightarrow> hnorm y < s \<Longrightarrow> hnorm (scaleHR x y) < r * s"
  by (simp only: hnorm_scaleHR) (simp add: mult_strict_mono')
 
 
 subsection \<open>Closure Laws for the Standard Reals\<close>
 
 lemma Reals_add_cancel: "x + y \<in> \<real> \<Longrightarrow> y \<in> \<real> \<Longrightarrow> x \<in> \<real>"
   by (drule (1) Reals_diff) simp
 
 lemma SReal_hrabs: "x \<in> \<real> \<Longrightarrow> \<bar>x\<bar> \<in> \<real>"
   for x :: hypreal
   by (simp add: Reals_eq_Standard)
 
 lemma SReal_hypreal_of_real [simp]: "hypreal_of_real x \<in> \<real>"
   by (simp add: Reals_eq_Standard)
 
 lemma SReal_divide_numeral: "r \<in> \<real> \<Longrightarrow> r / (numeral w::hypreal) \<in> \<real>"
   by simp
 
 text \<open>\<open>\<epsilon>\<close> is not in Reals because it is an infinitesimal\<close>
 lemma SReal_epsilon_not_mem: "\<epsilon> \<notin> \<real>"
   by (auto simp: SReal_def hypreal_of_real_not_eq_epsilon [symmetric])
 
 lemma SReal_omega_not_mem: "\<omega> \<notin> \<real>"
   by (auto simp: SReal_def hypreal_of_real_not_eq_omega [symmetric])
 
 lemma SReal_UNIV_real: "{x. hypreal_of_real x \<in> \<real>} = (UNIV::real set)"
   by simp
 
 lemma SReal_iff: "x \<in> \<real> \<longleftrightarrow> (\<exists>y. x = hypreal_of_real y)"
   by (simp add: SReal_def)
 
 lemma hypreal_of_real_image: "hypreal_of_real `(UNIV::real set) = \<real>"
   by (simp add: Reals_eq_Standard Standard_def)
 
 lemma inv_hypreal_of_real_image: "inv hypreal_of_real ` \<real> = UNIV"
   by (simp add: Reals_eq_Standard Standard_def inj_star_of)
 
 lemma SReal_dense: "x \<in> \<real> \<Longrightarrow> y \<in> \<real> \<Longrightarrow> x < y \<Longrightarrow> \<exists>r \<in> Reals. x < r \<and> r < y"
   for x y :: hypreal
   using dense by (fastforce simp add: SReal_def)
 
 
 subsection \<open>Set of Finite Elements is a Subring of the Extended Reals\<close>
 
 lemma HFinite_add: "x \<in> HFinite \<Longrightarrow> y \<in> HFinite \<Longrightarrow> x + y \<in> HFinite"
   unfolding HFinite_def by (blast intro!: Reals_add hnorm_add_less)
 
 lemma HFinite_mult: "x \<in> HFinite \<Longrightarrow> y \<in> HFinite \<Longrightarrow> x * y \<in> HFinite"
   for x y :: "'a::real_normed_algebra star"
   unfolding HFinite_def by (blast intro!: Reals_mult hnorm_mult_less)
 
 lemma HFinite_scaleHR: "x \<in> HFinite \<Longrightarrow> y \<in> HFinite \<Longrightarrow> scaleHR x y \<in> HFinite"
   by (auto simp: HFinite_def intro!: Reals_mult hnorm_scaleHR_less)
 
 lemma HFinite_minus_iff: "- x \<in> HFinite \<longleftrightarrow> x \<in> HFinite"
   by (simp add: HFinite_def)
 
 lemma HFinite_star_of [simp]: "star_of x \<in> HFinite"
   by (simp add: HFinite_def) (metis SReal_hypreal_of_real gt_ex star_of_less star_of_norm)
 
 lemma SReal_subset_HFinite: "(\<real>::hypreal set) \<subseteq> HFinite"
   by (auto simp add: SReal_def)
 
 lemma HFiniteD: "x \<in> HFinite \<Longrightarrow> \<exists>t \<in> Reals. hnorm x < t"
   by (simp add: HFinite_def)
 
 lemma HFinite_hrabs_iff [iff]: "\<bar>x\<bar> \<in> HFinite \<longleftrightarrow> x \<in> HFinite"
   for x :: hypreal
   by (simp add: HFinite_def)
 
 lemma HFinite_hnorm_iff [iff]: "hnorm x \<in> HFinite \<longleftrightarrow> x \<in> HFinite"
   for x :: hypreal
   by (simp add: HFinite_def)
 
 lemma HFinite_numeral [simp]: "numeral w \<in> HFinite"
   unfolding star_numeral_def by (rule HFinite_star_of)
 
 text \<open>As always with numerals, \<open>0\<close> and \<open>1\<close> are special cases.\<close>
 
 lemma HFinite_0 [simp]: "0 \<in> HFinite"
   unfolding star_zero_def by (rule HFinite_star_of)
 
 lemma HFinite_1 [simp]: "1 \<in> HFinite"
   unfolding star_one_def by (rule HFinite_star_of)
 
 lemma hrealpow_HFinite: "x \<in> HFinite \<Longrightarrow> x ^ n \<in> HFinite"
   for x :: "'a::{real_normed_algebra,monoid_mult} star"
   by (induct n) (auto intro: HFinite_mult)
 
 lemma HFinite_bounded: 
   fixes x y :: hypreal
   assumes "x \<in> HFinite" and y: "y \<le> x" "0 \<le> y" shows "y \<in> HFinite"
 proof (cases "x \<le> 0")
   case True
   then have "y = 0"
     using y by auto
   then show ?thesis
     by simp
 next
   case False
   then show ?thesis
     using assms le_less_trans by (auto simp: HFinite_def)
 qed
 
 
 subsection \<open>Set of Infinitesimals is a Subring of the Hyperreals\<close>
 
 lemma InfinitesimalI: "(\<And>r. r \<in> \<real> \<Longrightarrow> 0 < r \<Longrightarrow> hnorm x < r) \<Longrightarrow> x \<in> Infinitesimal"
   by (simp add: Infinitesimal_def)
 
 lemma InfinitesimalD: "x \<in> Infinitesimal \<Longrightarrow> \<forall>r \<in> Reals. 0 < r \<longrightarrow> hnorm x < r"
   by (simp add: Infinitesimal_def)
 
 lemma InfinitesimalI2: "(\<And>r. 0 < r \<Longrightarrow> hnorm x < star_of r) \<Longrightarrow> x \<in> Infinitesimal"
   by (auto simp add: Infinitesimal_def SReal_def)
 
 lemma InfinitesimalD2: "x \<in> Infinitesimal \<Longrightarrow> 0 < r \<Longrightarrow> hnorm x < star_of r"
   by (auto simp add: Infinitesimal_def SReal_def)
 
 lemma Infinitesimal_zero [iff]: "0 \<in> Infinitesimal"
   by (simp add: Infinitesimal_def)
 
 lemma Infinitesimal_add:
   assumes "x \<in> Infinitesimal" "y \<in> Infinitesimal"
   shows "x + y \<in> Infinitesimal"
 proof (rule InfinitesimalI)
   show "hnorm (x + y) < r"
     if "r \<in> \<real>" and "0 < r" for r :: "real star"
   proof -
     have "hnorm x < r/2" "hnorm y < r/2"
       using InfinitesimalD SReal_divide_numeral assms half_gt_zero that by blast+
     then show ?thesis
       using hnorm_add_less by fastforce
   qed
 qed
 
 lemma Infinitesimal_minus_iff [simp]: "- x \<in> Infinitesimal \<longleftrightarrow> x \<in> Infinitesimal"
   by (simp add: Infinitesimal_def)
 
 lemma Infinitesimal_hnorm_iff: "hnorm x \<in> Infinitesimal \<longleftrightarrow> x \<in> Infinitesimal"
   by (simp add: Infinitesimal_def)
 
 lemma Infinitesimal_hrabs_iff [iff]: "\<bar>x\<bar> \<in> Infinitesimal \<longleftrightarrow> x \<in> Infinitesimal"
   for x :: hypreal
   by (simp add: abs_if)
 
 lemma Infinitesimal_of_hypreal_iff [simp]:
   "(of_hypreal x::'a::real_normed_algebra_1 star) \<in> Infinitesimal \<longleftrightarrow> x \<in> Infinitesimal"
   by (subst Infinitesimal_hnorm_iff [symmetric]) simp
 
 lemma Infinitesimal_diff: "x \<in> Infinitesimal \<Longrightarrow> y \<in> Infinitesimal \<Longrightarrow> x - y \<in> Infinitesimal"
   using Infinitesimal_add [of x "- y"] by simp
 
 lemma Infinitesimal_mult: 
   fixes x y :: "'a::real_normed_algebra star"
   assumes "x \<in> Infinitesimal" "y \<in> Infinitesimal"
   shows "x * y \<in> Infinitesimal"
   proof (rule InfinitesimalI)
   show "hnorm (x * y) < r"
     if "r \<in> \<real>" and "0 < r" for r :: "real star"
   proof -
     have "hnorm x < 1" "hnorm y < r"
       using assms that  by (auto simp add: InfinitesimalD)
     then show ?thesis
       using hnorm_mult_less by fastforce
   qed
 qed
 
 lemma Infinitesimal_HFinite_mult:
   fixes x y :: "'a::real_normed_algebra star"
   assumes "x \<in> Infinitesimal" "y \<in> HFinite"
   shows "x * y \<in> Infinitesimal"
 proof (rule InfinitesimalI)
   obtain t where "hnorm y < t" "t \<in> Reals"
     using HFiniteD \<open>y \<in> HFinite\<close> by blast
   then have "t > 0"
     using hnorm_ge_zero le_less_trans by blast
   show "hnorm (x * y) < r"
     if "r \<in> \<real>" and "0 < r" for r :: "real star"
   proof -
     have "hnorm x < r/t"
       by (meson InfinitesimalD Reals_divide \<open>hnorm y < t\<close> \<open>t \<in> \<real>\<close> assms(1) divide_pos_pos hnorm_ge_zero le_less_trans that) 
     then have "hnorm (x * y) < (r / t) * t"
       using \<open>hnorm y < t\<close> hnorm_mult_less by blast
     then show ?thesis
       using \<open>0 < t\<close> by auto
   qed
 qed
 
 lemma Infinitesimal_HFinite_scaleHR:
   assumes "x \<in> Infinitesimal" "y \<in> HFinite"
   shows "scaleHR x y \<in> Infinitesimal"
 proof (rule InfinitesimalI)
   obtain t where "hnorm y < t" "t \<in> Reals"
     using HFiniteD \<open>y \<in> HFinite\<close> by blast
   then have "t > 0"
     using hnorm_ge_zero le_less_trans by blast
   show "hnorm (scaleHR x y) < r"
     if "r \<in> \<real>" and "0 < r" for r :: "real star"
   proof -
     have "\<bar>x\<bar> * hnorm y < (r / t) * t"
       by (metis InfinitesimalD Reals_divide \<open>0 < t\<close> \<open>hnorm y < t\<close> \<open>t \<in> \<real>\<close> assms(1) divide_pos_pos hnorm_ge_zero hypreal_hnorm_def mult_strict_mono' that)
     then show ?thesis
       by (simp add: \<open>0 < t\<close> hnorm_scaleHR less_imp_not_eq2)
   qed
 qed
 
 lemma Infinitesimal_HFinite_mult2:
   fixes x y :: "'a::real_normed_algebra star"
   assumes "x \<in> Infinitesimal" "y \<in> HFinite"
   shows  "y * x \<in> Infinitesimal"
 proof (rule InfinitesimalI)
   obtain t where "hnorm y < t" "t \<in> Reals"
     using HFiniteD \<open>y \<in> HFinite\<close> by blast
   then have "t > 0"
     using hnorm_ge_zero le_less_trans by blast
   show "hnorm (y * x) < r"
     if "r \<in> \<real>" and "0 < r" for r :: "real star"
   proof -
     have "hnorm x < r/t"
       by (meson InfinitesimalD Reals_divide \<open>hnorm y < t\<close> \<open>t \<in> \<real>\<close> assms(1) divide_pos_pos hnorm_ge_zero le_less_trans that) 
     then have "hnorm (y * x) < t * (r / t)"
       using \<open>hnorm y < t\<close> hnorm_mult_less by blast
     then show ?thesis
       using \<open>0 < t\<close> by auto
   qed
 qed
 
 lemma Infinitesimal_scaleR2: 
   assumes "x \<in> Infinitesimal" shows "a *\<^sub>R x \<in> Infinitesimal"
     by (metis HFinite_star_of Infinitesimal_HFinite_mult2 Infinitesimal_hnorm_iff assms hnorm_scaleR hypreal_hnorm_def star_of_norm)
 
 lemma Compl_HFinite: "- HFinite = HInfinite"
   proof -
   have "r < hnorm x" if *: "\<And>s. s \<in> \<real> \<Longrightarrow> s \<le> hnorm x" and "r \<in> \<real>"
     for x :: "'a star" and r :: hypreal
     using * [of "r+1"] \<open>r \<in> \<real>\<close> by auto
   then show ?thesis
     by (auto simp add: HInfinite_def HFinite_def linorder_not_less)
 qed
 
 lemma HInfinite_inverse_Infinitesimal:
   "x \<in> HInfinite \<Longrightarrow> inverse x \<in> Infinitesimal"
   for x :: "'a::real_normed_div_algebra star"
   by (simp add: HInfinite_def InfinitesimalI hnorm_inverse inverse_less_imp_less)
 
 lemma inverse_Infinitesimal_iff_HInfinite:
   "x \<noteq> 0 \<Longrightarrow> inverse x \<in> Infinitesimal \<longleftrightarrow> x \<in> HInfinite"
   for x :: "'a::real_normed_div_algebra star"
   by (metis Compl_HFinite Compl_iff HInfinite_inverse_Infinitesimal InfinitesimalD Infinitesimal_HFinite_mult Reals_1 hnorm_one left_inverse less_irrefl zero_less_one)
 
 lemma HInfiniteI: "(\<And>r. r \<in> \<real> \<Longrightarrow> r < hnorm x) \<Longrightarrow> x \<in> HInfinite"
   by (simp add: HInfinite_def)
 
 lemma HInfiniteD: "x \<in> HInfinite \<Longrightarrow> r \<in> \<real> \<Longrightarrow> r < hnorm x"
   by (simp add: HInfinite_def)
 
 lemma HInfinite_mult: 
   fixes x y :: "'a::real_normed_div_algebra star"
   assumes "x \<in> HInfinite" "y \<in> HInfinite" shows "x * y \<in> HInfinite"
 proof (rule HInfiniteI, simp only: hnorm_mult)
   have "x \<noteq> 0"
     using Compl_HFinite HFinite_0 assms by blast
   show "r < hnorm x * hnorm y"
     if "r \<in> \<real>" for r :: "real star"
   proof -
     have "r = r * 1"
       by simp
     also have "\<dots> < hnorm x * hnorm y"
       by (meson HInfiniteD Reals_1 \<open>x \<noteq> 0\<close> assms le_numeral_extra(1) mult_strict_mono that zero_less_hnorm_iff)
     finally show ?thesis .
   qed
 qed
 
 lemma hypreal_add_zero_less_le_mono: "r < x \<Longrightarrow> 0 \<le> y \<Longrightarrow> r < x + y"
   for r x y :: hypreal
   by simp
 
 lemma HInfinite_add_ge_zero: "x \<in> HInfinite \<Longrightarrow> 0 \<le> y \<Longrightarrow> 0 \<le> x \<Longrightarrow> x + y \<in> HInfinite"
   for x y :: hypreal
   by (auto simp: abs_if add.commute HInfinite_def)
 
 lemma HInfinite_add_ge_zero2: "x \<in> HInfinite \<Longrightarrow> 0 \<le> y \<Longrightarrow> 0 \<le> x \<Longrightarrow> y + x \<in> HInfinite"
   for x y :: hypreal
   by (auto intro!: HInfinite_add_ge_zero simp add: add.commute)
 
 lemma HInfinite_add_gt_zero: "x \<in> HInfinite \<Longrightarrow> 0 < y \<Longrightarrow> 0 < x \<Longrightarrow> x + y \<in> HInfinite"
   for x y :: hypreal
   by (blast intro: HInfinite_add_ge_zero order_less_imp_le)
 
 lemma HInfinite_minus_iff: "- x \<in> HInfinite \<longleftrightarrow> x \<in> HInfinite"
   by (simp add: HInfinite_def)
 
 lemma HInfinite_add_le_zero: "x \<in> HInfinite \<Longrightarrow> y \<le> 0 \<Longrightarrow> x \<le> 0 \<Longrightarrow> x + y \<in> HInfinite"
   for x y :: hypreal
   by (metis (no_types, lifting) HInfinite_add_ge_zero2 HInfinite_minus_iff add.inverse_distrib_swap neg_0_le_iff_le)
 
 lemma HInfinite_add_lt_zero: "x \<in> HInfinite \<Longrightarrow> y < 0 \<Longrightarrow> x < 0 \<Longrightarrow> x + y \<in> HInfinite"
   for x y :: hypreal
   by (blast intro: HInfinite_add_le_zero order_less_imp_le)
 
 lemma not_Infinitesimal_not_zero: "x \<notin> Infinitesimal \<Longrightarrow> x \<noteq> 0"
   by auto
 
 lemma HFinite_diff_Infinitesimal_hrabs:
   "x \<in> HFinite - Infinitesimal \<Longrightarrow> \<bar>x\<bar> \<in> HFinite - Infinitesimal"
   for x :: hypreal
   by blast
 
 lemma hnorm_le_Infinitesimal: "e \<in> Infinitesimal \<Longrightarrow> hnorm x \<le> e \<Longrightarrow> x \<in> Infinitesimal"
   by (auto simp: Infinitesimal_def abs_less_iff)
 
 lemma hnorm_less_Infinitesimal: "e \<in> Infinitesimal \<Longrightarrow> hnorm x < e \<Longrightarrow> x \<in> Infinitesimal"
   by (erule hnorm_le_Infinitesimal, erule order_less_imp_le)
 
 lemma hrabs_le_Infinitesimal: "e \<in> Infinitesimal \<Longrightarrow> \<bar>x\<bar> \<le> e \<Longrightarrow> x \<in> Infinitesimal"
   for x :: hypreal
   by (erule hnorm_le_Infinitesimal) simp
 
 lemma hrabs_less_Infinitesimal: "e \<in> Infinitesimal \<Longrightarrow> \<bar>x\<bar> < e \<Longrightarrow> x \<in> Infinitesimal"
   for x :: hypreal
   by (erule hnorm_less_Infinitesimal) simp
 
 lemma Infinitesimal_interval:
   "e \<in> Infinitesimal \<Longrightarrow> e' \<in> Infinitesimal \<Longrightarrow> e' < x \<Longrightarrow> x < e \<Longrightarrow> x \<in> Infinitesimal"
   for x :: hypreal
   by (auto simp add: Infinitesimal_def abs_less_iff)
 
 lemma Infinitesimal_interval2:
   "e \<in> Infinitesimal \<Longrightarrow> e' \<in> Infinitesimal \<Longrightarrow> e' \<le> x \<Longrightarrow> x \<le> e \<Longrightarrow> x \<in> Infinitesimal"
   for x :: hypreal
   by (auto intro: Infinitesimal_interval simp add: order_le_less)
 
 lemma lemma_Infinitesimal_hyperpow: "x \<in> Infinitesimal \<Longrightarrow> 0 < N \<Longrightarrow> \<bar>x pow N\<bar> \<le> \<bar>x\<bar>"
   for x :: hypreal
   apply (clarsimp simp: Infinitesimal_def)
   by (metis Reals_1 abs_ge_zero hyperpow_Suc_le_self2 hyperpow_hrabs hypnat_gt_zero_iff2 zero_less_one)
 
 lemma Infinitesimal_hyperpow: "x \<in> Infinitesimal \<Longrightarrow> 0 < N \<Longrightarrow> x pow N \<in> Infinitesimal"
   for x :: hypreal
   using hrabs_le_Infinitesimal lemma_Infinitesimal_hyperpow by blast
 
 lemma hrealpow_hyperpow_Infinitesimal_iff:
   "(x ^ n \<in> Infinitesimal) \<longleftrightarrow> x pow (hypnat_of_nat n) \<in> Infinitesimal"
   by (simp only: hyperpow_hypnat_of_nat)
 
 lemma Infinitesimal_hrealpow: "x \<in> Infinitesimal \<Longrightarrow> 0 < n \<Longrightarrow> x ^ n \<in> Infinitesimal"
   for x :: hypreal
   by (simp add: hrealpow_hyperpow_Infinitesimal_iff Infinitesimal_hyperpow)
 
 lemma not_Infinitesimal_mult:
   "x \<notin> Infinitesimal \<Longrightarrow> y \<notin> Infinitesimal \<Longrightarrow> x * y \<notin> Infinitesimal"
   for x y :: "'a::real_normed_div_algebra star"
   by (metis (no_types, lifting) inverse_Infinitesimal_iff_HInfinite ComplI Compl_HFinite Infinitesimal_HFinite_mult divide_inverse eq_divide_imp inverse_inverse_eq mult_zero_right)
 
 lemma Infinitesimal_mult_disj: "x * y \<in> Infinitesimal \<Longrightarrow> x \<in> Infinitesimal \<or> y \<in> Infinitesimal"
   for x y :: "'a::real_normed_div_algebra star"
   using not_Infinitesimal_mult by blast
 
 lemma HFinite_Infinitesimal_not_zero: "x \<in> HFinite-Infinitesimal \<Longrightarrow> x \<noteq> 0"
   by blast
 
 lemma HFinite_Infinitesimal_diff_mult:
   "x \<in> HFinite - Infinitesimal \<Longrightarrow> y \<in> HFinite - Infinitesimal \<Longrightarrow> x * y \<in> HFinite - Infinitesimal"
   for x y :: "'a::real_normed_div_algebra star"
   by (simp add: HFinite_mult not_Infinitesimal_mult)
 
 lemma Infinitesimal_subset_HFinite: "Infinitesimal \<subseteq> HFinite"
   using HFinite_def InfinitesimalD Reals_1 zero_less_one by blast
 
 lemma Infinitesimal_star_of_mult: "x \<in> Infinitesimal \<Longrightarrow> x * star_of r \<in> Infinitesimal"
   for x :: "'a::real_normed_algebra star"
   by (erule HFinite_star_of [THEN [2] Infinitesimal_HFinite_mult])
 
 lemma Infinitesimal_star_of_mult2: "x \<in> Infinitesimal \<Longrightarrow> star_of r * x \<in> Infinitesimal"
   for x :: "'a::real_normed_algebra star"
   by (erule HFinite_star_of [THEN [2] Infinitesimal_HFinite_mult2])
 
 
 subsection \<open>The Infinitely Close Relation\<close>
 
 lemma mem_infmal_iff: "x \<in> Infinitesimal \<longleftrightarrow> x \<approx> 0"
   by (simp add: Infinitesimal_def approx_def)
 
 lemma approx_minus_iff: "x \<approx> y \<longleftrightarrow> x - y \<approx> 0"
   by (simp add: approx_def)
 
 lemma approx_minus_iff2: "x \<approx> y \<longleftrightarrow> - y + x \<approx> 0"
   by (simp add: approx_def add.commute)
 
 lemma approx_refl [iff]: "x \<approx> x"
   by (simp add: approx_def Infinitesimal_def)
 
 lemma approx_sym: "x \<approx> y \<Longrightarrow> y \<approx> x"
   by (metis Infinitesimal_minus_iff approx_def minus_diff_eq)
 
 lemma approx_trans:
   assumes "x \<approx> y" "y \<approx> z" shows "x \<approx> z"
 proof -
   have "x - y \<in> Infinitesimal" "z - y \<in> Infinitesimal"
     using assms approx_def approx_sym by auto
   then have "x - z \<in> Infinitesimal"
     using Infinitesimal_diff by force
   then show ?thesis
     by (simp add: approx_def)
 qed
 
 lemma approx_trans2: "r \<approx> x \<Longrightarrow> s \<approx> x \<Longrightarrow> r \<approx> s"
   by (blast intro: approx_sym approx_trans)
 
 lemma approx_trans3: "x \<approx> r \<Longrightarrow> x \<approx> s \<Longrightarrow> r \<approx> s"
   by (blast intro: approx_sym approx_trans)
 
 lemma approx_reorient: "x \<approx> y \<longleftrightarrow> y \<approx> x"
   by (blast intro: approx_sym)
 
 text \<open>Reorientation simplification procedure: reorients (polymorphic)
   \<open>0 = x\<close>, \<open>1 = x\<close>, \<open>nnn = x\<close> provided \<open>x\<close> isn't \<open>0\<close>, \<open>1\<close> or a numeral.\<close>
 simproc_setup approx_reorient_simproc
   ("0 \<approx> x" | "1 \<approx> y" | "numeral w \<approx> z" | "- 1 \<approx> y" | "- numeral w \<approx> r") =
 \<open>
   let val rule = @{thm approx_reorient} RS eq_reflection
-      fun proc phi ss ct =
+      fun proc ct =
         case Thm.term_of ct of
           _ $ t $ u => if can HOLogic.dest_number u then NONE
             else if can HOLogic.dest_number t then SOME rule else NONE
         | _ => NONE
-  in proc end
+  in K (K proc) end
 \<close>
 
 lemma Infinitesimal_approx_minus: "x - y \<in> Infinitesimal \<longleftrightarrow> x \<approx> y"
   by (simp add: approx_minus_iff [symmetric] mem_infmal_iff)
 
 lemma approx_monad_iff: "x \<approx> y \<longleftrightarrow> monad x = monad y"
   apply (simp add: monad_def set_eq_iff)
   using approx_reorient approx_trans by blast
 
 lemma Infinitesimal_approx: "x \<in> Infinitesimal \<Longrightarrow> y \<in> Infinitesimal \<Longrightarrow> x \<approx> y"
   by (simp add: Infinitesimal_diff approx_def)
 
 lemma approx_add: "a \<approx> b \<Longrightarrow> c \<approx> d \<Longrightarrow> a + c \<approx> b + d"
 proof (unfold approx_def)
   assume inf: "a - b \<in> Infinitesimal" "c - d \<in> Infinitesimal"
   have "a + c - (b + d) = (a - b) + (c - d)" by simp
   also have "... \<in> Infinitesimal"
     using inf by (rule Infinitesimal_add)
   finally show "a + c - (b + d) \<in> Infinitesimal" .
 qed
 
 lemma approx_minus: "a \<approx> b \<Longrightarrow> - a \<approx> - b"
   by (metis approx_def approx_sym minus_diff_eq minus_diff_minus)
 
 lemma approx_minus2: "- a \<approx> - b \<Longrightarrow> a \<approx> b"
   by (auto dest: approx_minus)
 
 lemma approx_minus_cancel [simp]: "- a \<approx> - b \<longleftrightarrow> a \<approx> b"
   by (blast intro: approx_minus approx_minus2)
 
 lemma approx_add_minus: "a \<approx> b \<Longrightarrow> c \<approx> d \<Longrightarrow> a + - c \<approx> b + - d"
   by (blast intro!: approx_add approx_minus)
 
 lemma approx_diff: "a \<approx> b \<Longrightarrow> c \<approx> d \<Longrightarrow> a - c \<approx> b - d"
   using approx_add [of a b "- c" "- d"] by simp
 
 lemma approx_mult1: "a \<approx> b \<Longrightarrow> c \<in> HFinite \<Longrightarrow> a * c \<approx> b * c"
   for a b c :: "'a::real_normed_algebra star"
   by (simp add: approx_def Infinitesimal_HFinite_mult left_diff_distrib [symmetric])
 
 lemma approx_mult2: "a \<approx> b \<Longrightarrow> c \<in> HFinite \<Longrightarrow> c * a \<approx> c * b"
   for a b c :: "'a::real_normed_algebra star"
   by (simp add: approx_def Infinitesimal_HFinite_mult2 right_diff_distrib [symmetric])
 
 lemma approx_mult_subst: "u \<approx> v * x \<Longrightarrow> x \<approx> y \<Longrightarrow> v \<in> HFinite \<Longrightarrow> u \<approx> v * y"
   for u v x y :: "'a::real_normed_algebra star"
   by (blast intro: approx_mult2 approx_trans)
 
 lemma approx_mult_subst2: "u \<approx> x * v \<Longrightarrow> x \<approx> y \<Longrightarrow> v \<in> HFinite \<Longrightarrow> u \<approx> y * v"
   for u v x y :: "'a::real_normed_algebra star"
   by (blast intro: approx_mult1 approx_trans)
 
 lemma approx_mult_subst_star_of: "u \<approx> x * star_of v \<Longrightarrow> x \<approx> y \<Longrightarrow> u \<approx> y * star_of v"
   for u x y :: "'a::real_normed_algebra star"
   by (auto intro: approx_mult_subst2)
 
 lemma approx_eq_imp: "a = b \<Longrightarrow> a \<approx> b"
   by (simp add: approx_def)
 
 lemma Infinitesimal_minus_approx: "x \<in> Infinitesimal \<Longrightarrow> - x \<approx> x"
   by (blast intro: Infinitesimal_minus_iff [THEN iffD2] mem_infmal_iff [THEN iffD1] approx_trans2)
 
 lemma bex_Infinitesimal_iff: "(\<exists>y \<in> Infinitesimal. x - z = y) \<longleftrightarrow> x \<approx> z"
   by (simp add: approx_def)
 
 lemma bex_Infinitesimal_iff2: "(\<exists>y \<in> Infinitesimal. x = z + y) \<longleftrightarrow> x \<approx> z"
   by (force simp add: bex_Infinitesimal_iff [symmetric])
 
 lemma Infinitesimal_add_approx: "y \<in> Infinitesimal \<Longrightarrow> x + y = z \<Longrightarrow> x \<approx> z"
   using approx_sym bex_Infinitesimal_iff2 by blast
 
 lemma Infinitesimal_add_approx_self: "y \<in> Infinitesimal \<Longrightarrow> x \<approx> x + y"
   by (simp add: Infinitesimal_add_approx)
 
 lemma Infinitesimal_add_approx_self2: "y \<in> Infinitesimal \<Longrightarrow> x \<approx> y + x"
   by (auto dest: Infinitesimal_add_approx_self simp add: add.commute)
 
 lemma Infinitesimal_add_minus_approx_self: "y \<in> Infinitesimal \<Longrightarrow> x \<approx> x + - y"
   by (blast intro!: Infinitesimal_add_approx_self Infinitesimal_minus_iff [THEN iffD2])
 
 lemma Infinitesimal_add_cancel: "y \<in> Infinitesimal \<Longrightarrow> x + y \<approx> z \<Longrightarrow> x \<approx> z"
   using Infinitesimal_add_approx approx_trans by blast
 
 lemma Infinitesimal_add_right_cancel: "y \<in> Infinitesimal \<Longrightarrow> x \<approx> z + y \<Longrightarrow> x \<approx> z"
   by (metis Infinitesimal_add_approx_self approx_monad_iff)
 
 lemma approx_add_left_cancel: "d + b \<approx> d + c \<Longrightarrow> b \<approx> c"
   by (metis add_diff_cancel_left bex_Infinitesimal_iff)
 
 lemma approx_add_right_cancel: "b + d \<approx> c + d \<Longrightarrow> b \<approx> c"
   by (simp add: approx_def)
 
 lemma approx_add_mono1: "b \<approx> c \<Longrightarrow> d + b \<approx> d + c"
   by (simp add: approx_add)
 
 lemma approx_add_mono2: "b \<approx> c \<Longrightarrow> b + a \<approx> c + a"
   by (simp add: add.commute approx_add_mono1)
 
 lemma approx_add_left_iff [simp]: "a + b \<approx> a + c \<longleftrightarrow> b \<approx> c"
   by (fast elim: approx_add_left_cancel approx_add_mono1)
 
 lemma approx_add_right_iff [simp]: "b + a \<approx> c + a \<longleftrightarrow> b \<approx> c"
   by (simp add: add.commute)
 
 lemma approx_HFinite: "x \<in> HFinite \<Longrightarrow> x \<approx> y \<Longrightarrow> y \<in> HFinite"
   by (metis HFinite_add Infinitesimal_subset_HFinite approx_sym subsetD bex_Infinitesimal_iff2)
 
 lemma approx_star_of_HFinite: "x \<approx> star_of D \<Longrightarrow> x \<in> HFinite"
   by (rule approx_sym [THEN [2] approx_HFinite], auto)
 
 lemma approx_mult_HFinite: "a \<approx> b \<Longrightarrow> c \<approx> d \<Longrightarrow> b \<in> HFinite \<Longrightarrow> d \<in> HFinite \<Longrightarrow> a * c \<approx> b * d"
   for a b c d :: "'a::real_normed_algebra star"
   by (meson approx_HFinite approx_mult2 approx_mult_subst2 approx_sym)
 
 lemma scaleHR_left_diff_distrib: "\<And>a b x. scaleHR (a - b) x = scaleHR a x - scaleHR b x"
   by transfer (rule scaleR_left_diff_distrib)
 
 lemma approx_scaleR1: "a \<approx> star_of b \<Longrightarrow> c \<in> HFinite \<Longrightarrow> scaleHR a c \<approx> b *\<^sub>R c"
   unfolding approx_def
   by (metis Infinitesimal_HFinite_scaleHR scaleHR_def scaleHR_left_diff_distrib star_scaleR_def starfun2_star_of)
 
 lemma approx_scaleR2: "a \<approx> b \<Longrightarrow> c *\<^sub>R a \<approx> c *\<^sub>R b"
   by (simp add: approx_def Infinitesimal_scaleR2 scaleR_right_diff_distrib [symmetric])
 
 lemma approx_scaleR_HFinite: "a \<approx> star_of b \<Longrightarrow> c \<approx> d \<Longrightarrow> d \<in> HFinite \<Longrightarrow> scaleHR a c \<approx> b *\<^sub>R d"
   by (meson approx_HFinite approx_scaleR1 approx_scaleR2 approx_sym approx_trans)
 
 lemma approx_mult_star_of: "a \<approx> star_of b \<Longrightarrow> c \<approx> star_of d \<Longrightarrow> a * c \<approx> star_of b * star_of d"
   for a c :: "'a::real_normed_algebra star"
   by (blast intro!: approx_mult_HFinite approx_star_of_HFinite HFinite_star_of)
 
 lemma approx_SReal_mult_cancel_zero:
   fixes a x :: hypreal
   assumes "a \<in> \<real>" "a \<noteq> 0" "a * x \<approx> 0" shows "x \<approx> 0"
 proof -
   have "inverse a \<in> HFinite"
     using Reals_inverse SReal_subset_HFinite assms(1) by blast
   then show ?thesis
     using assms by (auto dest: approx_mult2 simp add: mult.assoc [symmetric])
 qed
 
 lemma approx_mult_SReal1: "a \<in> \<real> \<Longrightarrow> x \<approx> 0 \<Longrightarrow> x * a \<approx> 0"
   for a x :: hypreal
   by (auto dest: SReal_subset_HFinite [THEN subsetD] approx_mult1)
 
 lemma approx_mult_SReal2: "a \<in> \<real> \<Longrightarrow> x \<approx> 0 \<Longrightarrow> a * x \<approx> 0"
   for a x :: hypreal
   by (auto dest: SReal_subset_HFinite [THEN subsetD] approx_mult2)
 
 lemma approx_mult_SReal_zero_cancel_iff [simp]: "a \<in> \<real> \<Longrightarrow> a \<noteq> 0 \<Longrightarrow> a * x \<approx> 0 \<longleftrightarrow> x \<approx> 0"
   for a x :: hypreal
   by (blast intro: approx_SReal_mult_cancel_zero approx_mult_SReal2)
 
 lemma approx_SReal_mult_cancel:
   fixes a w z :: hypreal
   assumes "a \<in> \<real>" "a \<noteq> 0" "a * w \<approx> a * z" shows "w \<approx> z"
 proof -
   have "inverse a \<in> HFinite"
     using Reals_inverse SReal_subset_HFinite assms(1) by blast
   then show ?thesis
     using assms by (auto dest: approx_mult2 simp add: mult.assoc [symmetric])
 qed
 
 lemma approx_SReal_mult_cancel_iff1 [simp]: "a \<in> \<real> \<Longrightarrow> a \<noteq> 0 \<Longrightarrow> a * w \<approx> a * z \<longleftrightarrow> w \<approx> z"
   for a w z :: hypreal
   by (meson SReal_subset_HFinite approx_SReal_mult_cancel approx_mult2 subsetD)
 
 lemma approx_le_bound:
   fixes z :: hypreal
   assumes "z \<le> f" " f \<approx> g" "g \<le> z" shows "f \<approx> z"
 proof -
   obtain y where "z \<le> g + y" and "y \<in> Infinitesimal" "f = g + y"
     using assms bex_Infinitesimal_iff2 by auto
   then have "z - g \<in> Infinitesimal"
     using assms(3) hrabs_le_Infinitesimal by auto 
   then show ?thesis
     by (metis approx_def approx_trans2 assms(2))
 qed
 
 lemma approx_hnorm: "x \<approx> y \<Longrightarrow> hnorm x \<approx> hnorm y"
   for x y :: "'a::real_normed_vector star"
 proof (unfold approx_def)
   assume "x - y \<in> Infinitesimal"
   then have "hnorm (x - y) \<in> Infinitesimal"
     by (simp only: Infinitesimal_hnorm_iff)
   moreover have "(0::real star) \<in> Infinitesimal"
     by (rule Infinitesimal_zero)
   moreover have "0 \<le> \<bar>hnorm x - hnorm y\<bar>"
     by (rule abs_ge_zero)
   moreover have "\<bar>hnorm x - hnorm y\<bar> \<le> hnorm (x - y)"
     by (rule hnorm_triangle_ineq3)
   ultimately have "\<bar>hnorm x - hnorm y\<bar> \<in> Infinitesimal"
     by (rule Infinitesimal_interval2)
   then show "hnorm x - hnorm y \<in> Infinitesimal"
     by (simp only: Infinitesimal_hrabs_iff)
 qed
 
 
 subsection \<open>Zero is the Only Infinitesimal that is also a Real\<close>
 
 lemma Infinitesimal_less_SReal: "x \<in> \<real> \<Longrightarrow> y \<in> Infinitesimal \<Longrightarrow> 0 < x \<Longrightarrow> y < x"
   for x y :: hypreal
   using InfinitesimalD by fastforce
 
 lemma Infinitesimal_less_SReal2: "y \<in> Infinitesimal \<Longrightarrow> \<forall>r \<in> Reals. 0 < r \<longrightarrow> y < r"
   for y :: hypreal
   by (blast intro: Infinitesimal_less_SReal)
 
 lemma SReal_not_Infinitesimal: "0 < y \<Longrightarrow> y \<in> \<real> ==> y \<notin> Infinitesimal"
   for y :: hypreal
   by (auto simp add: Infinitesimal_def abs_if)
 
 lemma SReal_minus_not_Infinitesimal: "y < 0 \<Longrightarrow> y \<in> \<real> \<Longrightarrow> y \<notin> Infinitesimal"
   for y :: hypreal
   using Infinitesimal_minus_iff Reals_minus SReal_not_Infinitesimal neg_0_less_iff_less by blast
 
 lemma SReal_Int_Infinitesimal_zero: "\<real> Int Infinitesimal = {0::hypreal}"
   proof -
   have "x = 0" if "x \<in> \<real>" "x \<in> Infinitesimal" for x :: "real star"
     using that SReal_minus_not_Infinitesimal SReal_not_Infinitesimal not_less_iff_gr_or_eq by blast
   then show ?thesis
     by auto
 qed
 
 lemma SReal_Infinitesimal_zero: "x \<in> \<real> \<Longrightarrow> x \<in> Infinitesimal \<Longrightarrow> x = 0"
   for x :: hypreal
   using SReal_Int_Infinitesimal_zero by blast
 
 lemma SReal_HFinite_diff_Infinitesimal: "x \<in> \<real> \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> x \<in> HFinite - Infinitesimal"
   for x :: hypreal
   by (auto dest: SReal_Infinitesimal_zero SReal_subset_HFinite [THEN subsetD])
 
 lemma hypreal_of_real_HFinite_diff_Infinitesimal:
   "hypreal_of_real x \<noteq> 0 \<Longrightarrow> hypreal_of_real x \<in> HFinite - Infinitesimal"
   by (rule SReal_HFinite_diff_Infinitesimal) auto
 
 lemma star_of_Infinitesimal_iff_0 [iff]: "star_of x \<in> Infinitesimal \<longleftrightarrow> x = 0"
 proof
   show "x = 0" if "star_of x \<in> Infinitesimal"
   proof -
     have "hnorm (star_n (\<lambda>n. x)) \<in> Standard"
       by (metis Reals_eq_Standard SReal_iff star_of_def star_of_norm)
     then show ?thesis
       by (metis InfinitesimalD2 less_irrefl star_of_norm that zero_less_norm_iff)
   qed
 qed auto
 
 lemma star_of_HFinite_diff_Infinitesimal: "x \<noteq> 0 \<Longrightarrow> star_of x \<in> HFinite - Infinitesimal"
   by simp
 
 lemma numeral_not_Infinitesimal [simp]:
   "numeral w \<noteq> (0::hypreal) \<Longrightarrow> (numeral w :: hypreal) \<notin> Infinitesimal"
   by (fast dest: Reals_numeral [THEN SReal_Infinitesimal_zero])
 
 text \<open>Again: \<open>1\<close> is a special case, but not \<open>0\<close> this time.\<close>
 lemma one_not_Infinitesimal [simp]:
   "(1::'a::{real_normed_vector,zero_neq_one} star) \<notin> Infinitesimal"
   by (metis star_of_Infinitesimal_iff_0 star_one_def zero_neq_one)
 
 lemma approx_SReal_not_zero: "y \<in> \<real> \<Longrightarrow> x \<approx> y \<Longrightarrow> y \<noteq> 0 \<Longrightarrow> x \<noteq> 0"
   for x y :: hypreal
   using SReal_Infinitesimal_zero approx_sym mem_infmal_iff by auto
 
 lemma HFinite_diff_Infinitesimal_approx:
   "x \<approx> y \<Longrightarrow> y \<in> HFinite - Infinitesimal \<Longrightarrow> x \<in> HFinite - Infinitesimal"
   by (meson Diff_iff approx_HFinite approx_sym approx_trans3 mem_infmal_iff)
 
 text \<open>The premise \<open>y \<noteq> 0\<close> is essential; otherwise \<open>x / y = 0\<close> and we lose the
   \<open>HFinite\<close> premise.\<close>
 lemma Infinitesimal_ratio:
   "y \<noteq> 0 \<Longrightarrow> y \<in> Infinitesimal \<Longrightarrow> x / y \<in> HFinite \<Longrightarrow> x \<in> Infinitesimal"
   for x y :: "'a::{real_normed_div_algebra,field} star"
   using Infinitesimal_HFinite_mult by fastforce
 
 lemma Infinitesimal_SReal_divide: "x \<in> Infinitesimal \<Longrightarrow> y \<in> \<real> \<Longrightarrow> x / y \<in> Infinitesimal"
   for x y :: hypreal
   by (metis HFinite_star_of Infinitesimal_HFinite_mult Reals_inverse SReal_iff divide_inverse)
 
 
 section \<open>Standard Part Theorem\<close>
 
 text \<open>
   Every finite \<open>x \<in> R*\<close> is infinitely close to a unique real number
   (i.e. a member of \<open>Reals\<close>).
 \<close>
 
 
 subsection \<open>Uniqueness: Two Infinitely Close Reals are Equal\<close>
 
 lemma star_of_approx_iff [simp]: "star_of x \<approx> star_of y \<longleftrightarrow> x = y"
   by (metis approx_def right_minus_eq star_of_Infinitesimal_iff_0 star_of_simps(2))
 
 lemma SReal_approx_iff: "x \<in> \<real> \<Longrightarrow> y \<in> \<real> \<Longrightarrow> x \<approx> y \<longleftrightarrow> x = y"
   for x y :: hypreal
   by (meson Reals_diff SReal_Infinitesimal_zero approx_def approx_refl right_minus_eq)
 
 lemma numeral_approx_iff [simp]:
   "(numeral v \<approx> (numeral w :: 'a::{numeral,real_normed_vector} star)) = (numeral v = (numeral w :: 'a))"
   by (metis star_of_approx_iff star_of_numeral)
 
 text \<open>And also for \<open>0 \<approx> #nn\<close> and \<open>1 \<approx> #nn\<close>, \<open>#nn \<approx> 0\<close> and \<open>#nn \<approx> 1\<close>.\<close>
 lemma [simp]:
   "(numeral w \<approx> (0::'a::{numeral,real_normed_vector} star)) = (numeral w = (0::'a))"
   "((0::'a::{numeral,real_normed_vector} star) \<approx> numeral w) = (numeral w = (0::'a))"
   "(numeral w \<approx> (1::'b::{numeral,one,real_normed_vector} star)) = (numeral w = (1::'b))"
   "((1::'b::{numeral,one,real_normed_vector} star) \<approx> numeral w) = (numeral w = (1::'b))"
   "\<not> (0 \<approx> (1::'c::{zero_neq_one,real_normed_vector} star))"
   "\<not> (1 \<approx> (0::'c::{zero_neq_one,real_normed_vector} star))"
   unfolding star_numeral_def star_zero_def star_one_def star_of_approx_iff
   by (auto intro: sym)
 
 lemma star_of_approx_numeral_iff [simp]: "star_of k \<approx> numeral w \<longleftrightarrow> k = numeral w"
   by (subst star_of_approx_iff [symmetric]) auto
 
 lemma star_of_approx_zero_iff [simp]: "star_of k \<approx> 0 \<longleftrightarrow> k = 0"
   by (simp_all add: star_of_approx_iff [symmetric])
 
 lemma star_of_approx_one_iff [simp]: "star_of k \<approx> 1 \<longleftrightarrow> k = 1"
   by (simp_all add: star_of_approx_iff [symmetric])
 
 lemma approx_unique_real: "r \<in> \<real> \<Longrightarrow> s \<in> \<real> \<Longrightarrow> r \<approx> x \<Longrightarrow> s \<approx> x \<Longrightarrow> r = s"
   for r s :: hypreal
   by (blast intro: SReal_approx_iff [THEN iffD1] approx_trans2)
 
 
 subsection \<open>Existence of Unique Real Infinitely Close\<close>
 
 subsubsection \<open>Lifting of the Ub and Lub Properties\<close>
 
 lemma hypreal_of_real_isUb_iff: "isUb \<real> (hypreal_of_real ` Q) (hypreal_of_real Y) = isUb UNIV Q Y"
   for Q :: "real set" and Y :: real
   by (simp add: isUb_def setle_def)
 
 lemma hypreal_of_real_isLub_iff:
   "isLub \<real> (hypreal_of_real ` Q) (hypreal_of_real Y) = isLub (UNIV :: real set) Q Y"  (is "?lhs = ?rhs")
   for Q :: "real set" and Y :: real
 proof 
   assume ?lhs
   then show ?rhs
     by (simp add: isLub_def leastP_def) (metis hypreal_of_real_isUb_iff mem_Collect_eq setge_def star_of_le)
 next
   assume ?rhs
   then show ?lhs
   apply (simp add: isLub_def leastP_def hypreal_of_real_isUb_iff setge_def)
     by (metis SReal_iff hypreal_of_real_isUb_iff isUb_def star_of_le)
 qed
 
 lemma lemma_isUb_hypreal_of_real: "isUb \<real> P Y \<Longrightarrow> \<exists>Yo. isUb \<real> P (hypreal_of_real Yo)"
   by (auto simp add: SReal_iff isUb_def)
 
 lemma lemma_isLub_hypreal_of_real: "isLub \<real> P Y \<Longrightarrow> \<exists>Yo. isLub \<real> P (hypreal_of_real Yo)"
   by (auto simp add: isLub_def leastP_def isUb_def SReal_iff)
 
 lemma SReal_complete:
   fixes P :: "hypreal set"
   assumes "isUb \<real> P Y" "P \<subseteq> \<real>" "P \<noteq> {}"
     shows "\<exists>t. isLub \<real> P t"
 proof -
   obtain Q where "P = hypreal_of_real ` Q"
     by (metis \<open>P \<subseteq> \<real>\<close> hypreal_of_real_image subset_imageE)
   then show ?thesis
     by (metis assms(1) \<open>P \<noteq> {}\<close> equals0I hypreal_of_real_isLub_iff hypreal_of_real_isUb_iff image_empty lemma_isUb_hypreal_of_real reals_complete)
 qed
 
 
 text \<open>Lemmas about lubs.\<close>
 
 lemma lemma_st_part_lub:
   fixes x :: hypreal
   assumes "x \<in> HFinite"
   shows "\<exists>t. isLub \<real> {s. s \<in> \<real> \<and> s < x} t"
 proof -
   obtain t where t: "t \<in> \<real>" "hnorm x < t"
     using HFiniteD assms by blast
   then have "isUb \<real> {s. s \<in> \<real> \<and> s < x} t"
     by (simp add: abs_less_iff isUbI le_less_linear less_imp_not_less setleI)
   moreover have "\<exists>y. y \<in> \<real> \<and> y < x"
     using t by (rule_tac x = "-t" in exI) (auto simp add: abs_less_iff)
   ultimately show ?thesis
     using SReal_complete by fastforce
 qed
 
 lemma hypreal_setle_less_trans: "S *<= x \<Longrightarrow> x < y \<Longrightarrow> S *<= y"
   for x y :: hypreal
   by (meson le_less_trans less_imp_le setle_def)
 
 lemma hypreal_gt_isUb: "isUb R S x \<Longrightarrow> x < y \<Longrightarrow> y \<in> R \<Longrightarrow> isUb R S y"
   for x y :: hypreal
   using hypreal_setle_less_trans isUb_def by blast
 
 lemma lemma_SReal_ub: "x \<in> \<real> \<Longrightarrow> isUb \<real> {s. s \<in> \<real> \<and> s < x} x"
   for x :: hypreal
   by (auto intro: isUbI setleI order_less_imp_le)
 
 lemma lemma_SReal_lub: 
   fixes x :: hypreal
   assumes "x \<in> \<real>" shows "isLub \<real> {s. s \<in> \<real> \<and> s < x} x"
 proof -
   have "x \<le> y" if "isUb \<real> {s \<in> \<real>. s < x} y" for y
   proof -
     have "y \<in> \<real>"
       using isUbD2a that by blast
     show ?thesis
     proof (cases x y rule: linorder_cases)
       case greater
       then obtain r where "y < r" "r < x"
         using dense by blast
       then show ?thesis
         using isUbD [OF that]
         by simp (meson SReal_dense \<open>y \<in> \<real>\<close> assms greater not_le)
     qed auto
   qed
   with assms show ?thesis
     by (simp add: isLubI2 isUbI setgeI setleI)
 qed
 
 lemma lemma_st_part_major:
   fixes x r t :: hypreal
   assumes x: "x \<in> HFinite" and r: "r \<in> \<real>" "0 < r" and t: "isLub \<real> {s. s \<in> \<real> \<and> s < x} t"
   shows "\<bar>x - t\<bar> < r"
 proof -
   have "t \<in> \<real>"
     using isLubD1a t by blast
   have lemma_st_part_gt_ub: "x < r \<Longrightarrow> r \<in> \<real> \<Longrightarrow> isUb \<real> {s. s \<in> \<real> \<and> s < x} r"
     for  r :: hypreal
     by (auto dest: order_less_trans intro: order_less_imp_le intro!: isUbI setleI)
 
   have "isUb \<real> {s \<in> \<real>. s < x} t"
     by (simp add: t isLub_isUb)
   then have "\<not> r + t < x"
     by (metis (mono_tags, lifting) Reals_add \<open>t \<in> \<real>\<close> add_le_same_cancel2 isUbD leD mem_Collect_eq r)
   then have "x - t \<le> r"
     by simp
   moreover have "\<not> x < t - r"
     using lemma_st_part_gt_ub isLub_le_isUb \<open>t \<in> \<real>\<close> r t x by fastforce
   then have "- (x - t) \<le> r"
     by linarith
   moreover have False if "x - t = r \<or> - (x - t) = r"
   proof -
     have "x \<in> \<real>"
       by (metis \<open>t \<in> \<real>\<close> \<open>r \<in> \<real>\<close> that Reals_add_cancel Reals_minus_iff add_uminus_conv_diff)
     then have "isLub \<real> {s \<in> \<real>. s < x} x"
       by (rule lemma_SReal_lub)
     then show False
       using r t that x isLub_unique by force
   qed
   ultimately show ?thesis
     using abs_less_iff dual_order.order_iff_strict by blast
 qed
 
 lemma lemma_st_part_major2:
   "x \<in> HFinite \<Longrightarrow> isLub \<real> {s. s \<in> \<real> \<and> s < x} t \<Longrightarrow> \<forall>r \<in> Reals. 0 < r \<longrightarrow> \<bar>x - t\<bar> < r"
   for x t :: hypreal
   by (blast dest!: lemma_st_part_major)
 
 
 text\<open>Existence of real and Standard Part Theorem.\<close>
 
 lemma lemma_st_part_Ex: "x \<in> HFinite \<Longrightarrow> \<exists>t\<in>Reals. \<forall>r \<in> Reals. 0 < r \<longrightarrow> \<bar>x - t\<bar> < r"
   for x :: hypreal
   by (meson isLubD1a lemma_st_part_lub lemma_st_part_major2)
 
 lemma st_part_Ex: "x \<in> HFinite \<Longrightarrow> \<exists>t\<in>Reals. x \<approx> t"
   for x :: hypreal
   by (metis InfinitesimalI approx_def hypreal_hnorm_def lemma_st_part_Ex)
 
 text \<open>There is a unique real infinitely close.\<close>
 lemma st_part_Ex1: "x \<in> HFinite \<Longrightarrow> \<exists>!t::hypreal. t \<in> \<real> \<and> x \<approx> t"
   by (meson SReal_approx_iff approx_trans2 st_part_Ex)
 
 
 subsection \<open>Finite, Infinite and Infinitesimal\<close>
 
 lemma HFinite_Int_HInfinite_empty [simp]: "HFinite Int HInfinite = {}"
   using Compl_HFinite by blast
 
 lemma HFinite_not_HInfinite:
   assumes x: "x \<in> HFinite" shows "x \<notin> HInfinite"
   using Compl_HFinite x by blast
 
 lemma not_HFinite_HInfinite: "x \<notin> HFinite \<Longrightarrow> x \<in> HInfinite"
   using Compl_HFinite by blast
 
 lemma HInfinite_HFinite_disj: "x \<in> HInfinite \<or> x \<in> HFinite"
   by (blast intro: not_HFinite_HInfinite)
 
 lemma HInfinite_HFinite_iff: "x \<in> HInfinite \<longleftrightarrow> x \<notin> HFinite"
   by (blast dest: HFinite_not_HInfinite not_HFinite_HInfinite)
 
 lemma HFinite_HInfinite_iff: "x \<in> HFinite \<longleftrightarrow> x \<notin> HInfinite"
   by (simp add: HInfinite_HFinite_iff)
 
 lemma HInfinite_diff_HFinite_Infinitesimal_disj:
   "x \<notin> Infinitesimal \<Longrightarrow> x \<in> HInfinite \<or> x \<in> HFinite - Infinitesimal"
   by (fast intro: not_HFinite_HInfinite)
 
 lemma HFinite_inverse: "x \<in> HFinite \<Longrightarrow> x \<notin> Infinitesimal \<Longrightarrow> inverse x \<in> HFinite"
   for x :: "'a::real_normed_div_algebra star"
   using HInfinite_inverse_Infinitesimal not_HFinite_HInfinite by force
 
 lemma HFinite_inverse2: "x \<in> HFinite - Infinitesimal \<Longrightarrow> inverse x \<in> HFinite"
   for x :: "'a::real_normed_div_algebra star"
   by (blast intro: HFinite_inverse)
 
 text \<open>Stronger statement possible in fact.\<close>
 lemma Infinitesimal_inverse_HFinite: "x \<notin> Infinitesimal \<Longrightarrow> inverse x \<in> HFinite"
   for x :: "'a::real_normed_div_algebra star"
   using HFinite_HInfinite_iff HInfinite_inverse_Infinitesimal by fastforce
 
 lemma HFinite_not_Infinitesimal_inverse:
   "x \<in> HFinite - Infinitesimal \<Longrightarrow> inverse x \<in> HFinite - Infinitesimal"
   for x :: "'a::real_normed_div_algebra star"
   using HFinite_Infinitesimal_not_zero HFinite_inverse2 Infinitesimal_HFinite_mult2 by fastforce
 
 lemma approx_inverse: 
   fixes x y :: "'a::real_normed_div_algebra star"
   assumes "x \<approx> y" and y: "y \<in> HFinite - Infinitesimal" shows "inverse x \<approx> inverse y"
 proof -
   have x: "x \<in> HFinite - Infinitesimal"
     using HFinite_diff_Infinitesimal_approx assms(1) y by blast
   with y HFinite_inverse2 have "inverse x \<in> HFinite" "inverse y \<in> HFinite"
     by blast+
   then have "inverse y * x \<approx> 1"
     by (metis Diff_iff approx_mult2 assms(1) left_inverse not_Infinitesimal_not_zero y)
   then show ?thesis
     by (metis (no_types, lifting) DiffD2 HFinite_Infinitesimal_not_zero Infinitesimal_mult_disj x approx_def approx_sym left_diff_distrib left_inverse)
 qed
 
 (*Used for NSLIM_inverse, NSLIMSEQ_inverse*)
 lemmas star_of_approx_inverse = star_of_HFinite_diff_Infinitesimal [THEN [2] approx_inverse]
 lemmas hypreal_of_real_approx_inverse =  hypreal_of_real_HFinite_diff_Infinitesimal [THEN [2] approx_inverse]
 
 lemma inverse_add_Infinitesimal_approx:
   "x \<in> HFinite - Infinitesimal \<Longrightarrow> h \<in> Infinitesimal \<Longrightarrow> inverse (x + h) \<approx> inverse x"
   for x h :: "'a::real_normed_div_algebra star"
   by (auto intro: approx_inverse approx_sym Infinitesimal_add_approx_self)
 
 lemma inverse_add_Infinitesimal_approx2:
   "x \<in> HFinite - Infinitesimal \<Longrightarrow> h \<in> Infinitesimal \<Longrightarrow> inverse (h + x) \<approx> inverse x"
   for x h :: "'a::real_normed_div_algebra star"
   by (metis add.commute inverse_add_Infinitesimal_approx)
 
 lemma inverse_add_Infinitesimal_approx_Infinitesimal:
   "x \<in> HFinite - Infinitesimal \<Longrightarrow> h \<in> Infinitesimal \<Longrightarrow> inverse (x + h) - inverse x \<approx> h"
   for x h :: "'a::real_normed_div_algebra star"
   by (meson Infinitesimal_approx bex_Infinitesimal_iff inverse_add_Infinitesimal_approx)
 
 lemma Infinitesimal_square_iff: "x \<in> Infinitesimal \<longleftrightarrow> x * x \<in> Infinitesimal"
   for x :: "'a::real_normed_div_algebra star"
   using Infinitesimal_mult Infinitesimal_mult_disj by auto
 declare Infinitesimal_square_iff [symmetric, simp]
 
 lemma HFinite_square_iff [simp]: "x * x \<in> HFinite \<longleftrightarrow> x \<in> HFinite"
   for x :: "'a::real_normed_div_algebra star"
   using HFinite_HInfinite_iff HFinite_mult HInfinite_mult by blast
 
 lemma HInfinite_square_iff [simp]: "x * x \<in> HInfinite \<longleftrightarrow> x \<in> HInfinite"
   for x :: "'a::real_normed_div_algebra star"
   by (auto simp add: HInfinite_HFinite_iff)
 
 lemma approx_HFinite_mult_cancel: "a \<in> HFinite - Infinitesimal \<Longrightarrow> a * w \<approx> a * z \<Longrightarrow> w \<approx> z"
   for a w z :: "'a::real_normed_div_algebra star"
   by (metis DiffD2 Infinitesimal_mult_disj bex_Infinitesimal_iff right_diff_distrib)
 
 lemma approx_HFinite_mult_cancel_iff1: "a \<in> HFinite - Infinitesimal \<Longrightarrow> a * w \<approx> a * z \<longleftrightarrow> w \<approx> z"
   for a w z :: "'a::real_normed_div_algebra star"
   by (auto intro: approx_mult2 approx_HFinite_mult_cancel)
 
 lemma HInfinite_HFinite_add_cancel: "x + y \<in> HInfinite \<Longrightarrow> y \<in> HFinite \<Longrightarrow> x \<in> HInfinite"
   using HFinite_add HInfinite_HFinite_iff by blast
 
 lemma HInfinite_HFinite_add: "x \<in> HInfinite \<Longrightarrow> y \<in> HFinite \<Longrightarrow> x + y \<in> HInfinite"
   by (metis (no_types, opaque_lifting) HFinite_HInfinite_iff HFinite_add HFinite_minus_iff add.commute add_minus_cancel)
 
 lemma HInfinite_ge_HInfinite: "x \<in> HInfinite \<Longrightarrow> x \<le> y \<Longrightarrow> 0 \<le> x \<Longrightarrow> y \<in> HInfinite"
   for x y :: hypreal
   by (auto intro: HFinite_bounded simp add: HInfinite_HFinite_iff)
 
 lemma Infinitesimal_inverse_HInfinite: "x \<in> Infinitesimal \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> inverse x \<in> HInfinite"
   for x :: "'a::real_normed_div_algebra star"
   by (metis Infinitesimal_HFinite_mult not_HFinite_HInfinite one_not_Infinitesimal right_inverse)
 
 lemma HInfinite_HFinite_not_Infinitesimal_mult:
   "x \<in> HInfinite \<Longrightarrow> y \<in> HFinite - Infinitesimal \<Longrightarrow> x * y \<in> HInfinite"
   for x y :: "'a::real_normed_div_algebra star"
   by (metis (no_types, opaque_lifting) HFinite_HInfinite_iff HFinite_Infinitesimal_not_zero HFinite_inverse2 HFinite_mult mult.assoc mult.right_neutral right_inverse)
 
 lemma HInfinite_HFinite_not_Infinitesimal_mult2:
   "x \<in> HInfinite \<Longrightarrow> y \<in> HFinite - Infinitesimal \<Longrightarrow> y * x \<in> HInfinite"
   for x y :: "'a::real_normed_div_algebra star"
   by (metis Diff_iff HInfinite_HFinite_iff HInfinite_inverse_Infinitesimal Infinitesimal_HFinite_mult2 divide_inverse mult_zero_right nonzero_eq_divide_eq)
 
 lemma HInfinite_gt_SReal: "x \<in> HInfinite \<Longrightarrow> 0 < x \<Longrightarrow> y \<in> \<real> \<Longrightarrow> y < x"
   for x y :: hypreal
   by (auto dest!: bspec simp add: HInfinite_def abs_if order_less_imp_le)
 
 lemma HInfinite_gt_zero_gt_one: "x \<in> HInfinite \<Longrightarrow> 0 < x \<Longrightarrow> 1 < x"
   for x :: hypreal
   by (auto intro: HInfinite_gt_SReal)
 
 lemma not_HInfinite_one [simp]: "1 \<notin> HInfinite"
   by (simp add: HInfinite_HFinite_iff)
 
 lemma approx_hrabs_disj: "\<bar>x\<bar> \<approx> x \<or> \<bar>x\<bar> \<approx> -x"
   for x :: hypreal
   by (simp add: abs_if)
 
 
 subsection \<open>Theorems about Monads\<close>
 
 lemma monad_hrabs_Un_subset: "monad \<bar>x\<bar> \<le> monad x \<union> monad (- x)"
   for x :: hypreal
   by (simp add: abs_if)
 
 lemma Infinitesimal_monad_eq: "e \<in> Infinitesimal \<Longrightarrow> monad (x + e) = monad x"
   by (fast intro!: Infinitesimal_add_approx_self [THEN approx_sym] approx_monad_iff [THEN iffD1])
 
 lemma mem_monad_iff: "u \<in> monad x \<longleftrightarrow> - u \<in> monad (- x)"
   by (simp add: monad_def)
 
 lemma Infinitesimal_monad_zero_iff: "x \<in> Infinitesimal \<longleftrightarrow> x \<in> monad 0"
   by (auto intro: approx_sym simp add: monad_def mem_infmal_iff)
 
 lemma monad_zero_minus_iff: "x \<in> monad 0 \<longleftrightarrow> - x \<in> monad 0"
   by (simp add: Infinitesimal_monad_zero_iff [symmetric])
 
 lemma monad_zero_hrabs_iff: "x \<in> monad 0 \<longleftrightarrow> \<bar>x\<bar> \<in> monad 0"
   for x :: hypreal
   using Infinitesimal_monad_zero_iff by blast
 
 lemma mem_monad_self [simp]: "x \<in> monad x"
   by (simp add: monad_def)
 
 
 subsection \<open>Proof that \<^term>\<open>x \<approx> y\<close> implies \<^term>\<open>\<bar>x\<bar> \<approx> \<bar>y\<bar>\<close>\<close>
 
 lemma approx_subset_monad: "x \<approx> y \<Longrightarrow> {x, y} \<le> monad x"
   by (simp (no_asm)) (simp add: approx_monad_iff)
 
 lemma approx_subset_monad2: "x \<approx> y \<Longrightarrow> {x, y} \<le> monad y"
   using approx_subset_monad approx_sym by auto
 
 lemma mem_monad_approx: "u \<in> monad x \<Longrightarrow> x \<approx> u"
   by (simp add: monad_def)
 
 lemma approx_mem_monad: "x \<approx> u \<Longrightarrow> u \<in> monad x"
   by (simp add: monad_def)
 
 lemma approx_mem_monad2: "x \<approx> u \<Longrightarrow> x \<in> monad u"
   using approx_mem_monad approx_sym by blast
 
 lemma approx_mem_monad_zero: "x \<approx> y \<Longrightarrow> x \<in> monad 0 \<Longrightarrow> y \<in> monad 0"
   using approx_trans monad_def by blast
 
 lemma Infinitesimal_approx_hrabs: "x \<approx> y \<Longrightarrow> x \<in> Infinitesimal \<Longrightarrow> \<bar>x\<bar> \<approx> \<bar>y\<bar>"
   for x y :: hypreal
   using approx_hnorm by fastforce
 
 lemma less_Infinitesimal_less: "0 < x \<Longrightarrow> x \<notin> Infinitesimal \<Longrightarrow> e \<in> Infinitesimal \<Longrightarrow> e < x"
   for x :: hypreal
   using Infinitesimal_interval less_linear by blast
 
 lemma Ball_mem_monad_gt_zero: "0 < x \<Longrightarrow> x \<notin> Infinitesimal \<Longrightarrow> u \<in> monad x \<Longrightarrow> 0 < u"
   for u x :: hypreal
   by (metis bex_Infinitesimal_iff2 less_Infinitesimal_less less_add_same_cancel2 mem_monad_approx)
 
 lemma Ball_mem_monad_less_zero: "x < 0 \<Longrightarrow> x \<notin> Infinitesimal \<Longrightarrow> u \<in> monad x \<Longrightarrow> u < 0"
   for u x :: hypreal
   by (metis Ball_mem_monad_gt_zero approx_monad_iff less_asym linorder_neqE_linordered_idom mem_infmal_iff mem_monad_approx mem_monad_self)
 
 lemma lemma_approx_gt_zero: "0 < x \<Longrightarrow> x \<notin> Infinitesimal \<Longrightarrow> x \<approx> y \<Longrightarrow> 0 < y"
   for x y :: hypreal
   by (blast dest: Ball_mem_monad_gt_zero approx_subset_monad)
 
 lemma lemma_approx_less_zero: "x < 0 \<Longrightarrow> x \<notin> Infinitesimal \<Longrightarrow> x \<approx> y \<Longrightarrow> y < 0"
   for x y :: hypreal
   by (blast dest: Ball_mem_monad_less_zero approx_subset_monad)
 
 lemma approx_hrabs: "x \<approx> y \<Longrightarrow> \<bar>x\<bar> \<approx> \<bar>y\<bar>"
   for x y :: hypreal
   by (drule approx_hnorm) simp
 
 lemma approx_hrabs_zero_cancel: "\<bar>x\<bar> \<approx> 0 \<Longrightarrow> x \<approx> 0"
   for x :: hypreal
   using mem_infmal_iff by blast
 
 lemma approx_hrabs_add_Infinitesimal: "e \<in> Infinitesimal \<Longrightarrow> \<bar>x\<bar> \<approx> \<bar>x + e\<bar>"
   for e x :: hypreal
   by (fast intro: approx_hrabs Infinitesimal_add_approx_self)
 
 lemma approx_hrabs_add_minus_Infinitesimal: "e \<in> Infinitesimal ==> \<bar>x\<bar> \<approx> \<bar>x + -e\<bar>"
   for e x :: hypreal
   by (fast intro: approx_hrabs Infinitesimal_add_minus_approx_self)
 
 lemma hrabs_add_Infinitesimal_cancel:
   "e \<in> Infinitesimal \<Longrightarrow> e' \<in> Infinitesimal \<Longrightarrow> \<bar>x + e\<bar> = \<bar>y + e'\<bar> \<Longrightarrow> \<bar>x\<bar> \<approx> \<bar>y\<bar>"
   for e e' x y :: hypreal
   by (metis approx_hrabs_add_Infinitesimal approx_trans2)
 
 lemma hrabs_add_minus_Infinitesimal_cancel:
   "e \<in> Infinitesimal \<Longrightarrow> e' \<in> Infinitesimal \<Longrightarrow> \<bar>x + -e\<bar> = \<bar>y + -e'\<bar> \<Longrightarrow> \<bar>x\<bar> \<approx> \<bar>y\<bar>"
   for e e' x y :: hypreal
   by (meson Infinitesimal_minus_iff hrabs_add_Infinitesimal_cancel)
 
 
 subsection \<open>More \<^term>\<open>HFinite\<close> and \<^term>\<open>Infinitesimal\<close> Theorems\<close>
 
 text \<open>
   Interesting slightly counterintuitive theorem: necessary
   for proving that an open interval is an NS open set.
 \<close>
 lemma Infinitesimal_add_hypreal_of_real_less:
   assumes "x < y" and u: "u \<in> Infinitesimal"
   shows "hypreal_of_real x + u < hypreal_of_real y"
 proof -
   have "\<bar>u\<bar> < hypreal_of_real y - hypreal_of_real x"
     using InfinitesimalD \<open>x < y\<close> u by fastforce
   then show ?thesis
     by (simp add: abs_less_iff)
 qed
 
 lemma Infinitesimal_add_hrabs_hypreal_of_real_less:
   "x \<in> Infinitesimal \<Longrightarrow> \<bar>hypreal_of_real r\<bar> < hypreal_of_real y \<Longrightarrow>
     \<bar>hypreal_of_real r + x\<bar> < hypreal_of_real y"
   by (metis Infinitesimal_add_hypreal_of_real_less approx_hrabs_add_Infinitesimal approx_sym bex_Infinitesimal_iff2 star_of_abs star_of_less)
 
 lemma Infinitesimal_add_hrabs_hypreal_of_real_less2:
   "x \<in> Infinitesimal \<Longrightarrow> \<bar>hypreal_of_real r\<bar> < hypreal_of_real y \<Longrightarrow>
     \<bar>x + hypreal_of_real r\<bar> < hypreal_of_real y"
   using Infinitesimal_add_hrabs_hypreal_of_real_less by fastforce
 
 lemma hypreal_of_real_le_add_Infininitesimal_cancel:
   assumes le: "hypreal_of_real x + u \<le> hypreal_of_real y + v" 
       and u: "u \<in> Infinitesimal" and v: "v \<in> Infinitesimal"
   shows "hypreal_of_real x \<le> hypreal_of_real y"
 proof (rule ccontr)
   assume "\<not> hypreal_of_real x \<le> hypreal_of_real y"
   then have "hypreal_of_real y + (v - u) < hypreal_of_real x"
     by (simp add: Infinitesimal_add_hypreal_of_real_less Infinitesimal_diff u v)
   then show False
     by (simp add: add_diff_eq add_le_imp_le_diff le leD)
 qed
 
 lemma hypreal_of_real_le_add_Infininitesimal_cancel2:
   "u \<in> Infinitesimal \<Longrightarrow> v \<in> Infinitesimal \<Longrightarrow>
     hypreal_of_real x + u \<le> hypreal_of_real y + v \<Longrightarrow> x \<le> y"
   by (blast intro: star_of_le [THEN iffD1] intro!: hypreal_of_real_le_add_Infininitesimal_cancel)
 
 lemma hypreal_of_real_less_Infinitesimal_le_zero:
   "hypreal_of_real x < e \<Longrightarrow> e \<in> Infinitesimal \<Longrightarrow> hypreal_of_real x \<le> 0"
   by (metis Infinitesimal_interval eq_iff le_less_linear star_of_Infinitesimal_iff_0 star_of_eq_0)
 
 lemma Infinitesimal_add_not_zero: "h \<in> Infinitesimal \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> star_of x + h \<noteq> 0"
   by (metis Infinitesimal_add_approx_self star_of_approx_zero_iff)
 
 lemma monad_hrabs_less: "y \<in> monad x \<Longrightarrow> 0 < hypreal_of_real e \<Longrightarrow> \<bar>y - x\<bar> < hypreal_of_real e"
   by (simp add: Infinitesimal_approx_minus approx_sym less_Infinitesimal_less mem_monad_approx)
 
 lemma mem_monad_SReal_HFinite: "x \<in> monad (hypreal_of_real  a) \<Longrightarrow> x \<in> HFinite"
   using HFinite_star_of approx_HFinite mem_monad_approx by blast
 
 
 subsection \<open>Theorems about Standard Part\<close>
 
 lemma st_approx_self: "x \<in> HFinite \<Longrightarrow> st x \<approx> x"
   by (metis (no_types, lifting) approx_refl approx_trans3 someI_ex st_def st_part_Ex st_part_Ex1)
 
 lemma st_SReal: "x \<in> HFinite \<Longrightarrow> st x \<in> \<real>"
   by (metis (mono_tags, lifting) approx_sym someI_ex st_def st_part_Ex)
 
 lemma st_HFinite: "x \<in> HFinite \<Longrightarrow> st x \<in> HFinite"
   by (erule st_SReal [THEN SReal_subset_HFinite [THEN subsetD]])
 
 lemma st_unique: "r \<in> \<real> \<Longrightarrow> r \<approx> x \<Longrightarrow> st x = r"
   by (meson SReal_subset_HFinite approx_HFinite approx_unique_real st_SReal st_approx_self subsetD)
 
 lemma st_SReal_eq: "x \<in> \<real> \<Longrightarrow> st x = x"
   by (metis approx_refl st_unique)
 
 lemma st_hypreal_of_real [simp]: "st (hypreal_of_real x) = hypreal_of_real x"
   by (rule SReal_hypreal_of_real [THEN st_SReal_eq])
 
 lemma st_eq_approx: "x \<in> HFinite \<Longrightarrow> y \<in> HFinite \<Longrightarrow> st x = st y \<Longrightarrow> x \<approx> y"
   by (auto dest!: st_approx_self elim!: approx_trans3)
 
 lemma approx_st_eq:
   assumes x: "x \<in> HFinite" and y: "y \<in> HFinite" and xy: "x \<approx> y"
   shows "st x = st y"
 proof -
   have "st x \<approx> x" "st y \<approx> y" "st x \<in> \<real>" "st y \<in> \<real>"
     by (simp_all add: st_approx_self st_SReal x y)
   with xy show ?thesis
     by (fast elim: approx_trans approx_trans2 SReal_approx_iff [THEN iffD1])
 qed
 
 lemma st_eq_approx_iff: "x \<in> HFinite \<Longrightarrow> y \<in> HFinite \<Longrightarrow> x \<approx> y \<longleftrightarrow> st x = st y"
   by (blast intro: approx_st_eq st_eq_approx)
 
 lemma st_Infinitesimal_add_SReal: "x \<in> \<real> \<Longrightarrow> e \<in> Infinitesimal \<Longrightarrow> st (x + e) = x"
   by (simp add: Infinitesimal_add_approx_self st_unique)
 
 lemma st_Infinitesimal_add_SReal2: "x \<in> \<real> \<Longrightarrow> e \<in> Infinitesimal \<Longrightarrow> st (e + x) = x"
   by (metis add.commute st_Infinitesimal_add_SReal)
 
 lemma HFinite_st_Infinitesimal_add: "x \<in> HFinite \<Longrightarrow> \<exists>e \<in> Infinitesimal. x = st(x) + e"
   by (blast dest!: st_approx_self [THEN approx_sym] bex_Infinitesimal_iff2 [THEN iffD2])
 
 lemma st_add: "x \<in> HFinite \<Longrightarrow> y \<in> HFinite \<Longrightarrow> st (x + y) = st x + st y"
   by (simp add: st_unique st_SReal st_approx_self approx_add)
 
 lemma st_numeral [simp]: "st (numeral w) = numeral w"
   by (rule Reals_numeral [THEN st_SReal_eq])
 
 lemma st_neg_numeral [simp]: "st (- numeral w) = - numeral w"
   using st_unique by auto
 
 lemma st_0 [simp]: "st 0 = 0"
   by (simp add: st_SReal_eq)
 
 lemma st_1 [simp]: "st 1 = 1"
   by (simp add: st_SReal_eq)
 
 lemma st_neg_1 [simp]: "st (- 1) = - 1"
   by (simp add: st_SReal_eq)
 
 lemma st_minus: "x \<in> HFinite \<Longrightarrow> st (- x) = - st x"
   by (simp add: st_unique st_SReal st_approx_self approx_minus)
 
 lemma st_diff: "\<lbrakk>x \<in> HFinite; y \<in> HFinite\<rbrakk> \<Longrightarrow> st (x - y) = st x - st y"
   by (simp add: st_unique st_SReal st_approx_self approx_diff)
 
 lemma st_mult: "\<lbrakk>x \<in> HFinite; y \<in> HFinite\<rbrakk> \<Longrightarrow> st (x * y) = st x * st y"
   by (simp add: st_unique st_SReal st_approx_self approx_mult_HFinite)
 
 lemma st_Infinitesimal: "x \<in> Infinitesimal \<Longrightarrow> st x = 0"
   by (simp add: st_unique mem_infmal_iff)
 
 lemma st_not_Infinitesimal: "st(x) \<noteq> 0 \<Longrightarrow> x \<notin> Infinitesimal"
 by (fast intro: st_Infinitesimal)
 
 lemma st_inverse: "x \<in> HFinite \<Longrightarrow> st x \<noteq> 0 \<Longrightarrow> st (inverse x) = inverse (st x)"
   by (simp add: approx_inverse st_SReal st_approx_self st_not_Infinitesimal st_unique)
 
 lemma st_divide [simp]: "x \<in> HFinite \<Longrightarrow> y \<in> HFinite \<Longrightarrow> st y \<noteq> 0 \<Longrightarrow> st (x / y) = st x / st y"
   by (simp add: divide_inverse st_mult st_not_Infinitesimal HFinite_inverse st_inverse)
 
 lemma st_idempotent [simp]: "x \<in> HFinite \<Longrightarrow> st (st x) = st x"
   by (blast intro: st_HFinite st_approx_self approx_st_eq)
 
 lemma Infinitesimal_add_st_less:
   "x \<in> HFinite \<Longrightarrow> y \<in> HFinite \<Longrightarrow> u \<in> Infinitesimal \<Longrightarrow> st x < st y \<Longrightarrow> st x + u < st y"
   by (metis Infinitesimal_add_hypreal_of_real_less SReal_iff st_SReal star_of_less)
 
 lemma Infinitesimal_add_st_le_cancel:
   "x \<in> HFinite \<Longrightarrow> y \<in> HFinite \<Longrightarrow> u \<in> Infinitesimal \<Longrightarrow>
     st x \<le> st y + u \<Longrightarrow> st x \<le> st y"
   by (meson Infinitesimal_add_st_less leD le_less_linear)
 
 lemma st_le: "x \<in> HFinite \<Longrightarrow> y \<in> HFinite \<Longrightarrow> x \<le> y \<Longrightarrow> st x \<le> st y"
   by (metis approx_le_bound approx_sym linear st_SReal st_approx_self st_part_Ex1)
 
 lemma st_zero_le: "0 \<le> x \<Longrightarrow> x \<in> HFinite \<Longrightarrow> 0 \<le> st x"
   by (metis HFinite_0 st_0 st_le)
 
 lemma st_zero_ge: "x \<le> 0 \<Longrightarrow> x \<in> HFinite \<Longrightarrow> st x \<le> 0"
   by (metis HFinite_0 st_0 st_le)
 
 lemma st_hrabs: "x \<in> HFinite \<Longrightarrow> \<bar>st x\<bar> = st \<bar>x\<bar>"
   by (simp add: order_class.order.antisym st_zero_ge linorder_not_le st_zero_le abs_if st_minus linorder_not_less)
 
 
 subsection \<open>Alternative Definitions using Free Ultrafilter\<close>
 
 subsubsection \<open>\<^term>\<open>HFinite\<close>\<close>
 
 lemma HFinite_FreeUltrafilterNat:
   assumes "star_n X \<in> HFinite"
   shows "\<exists>u. eventually (\<lambda>n. norm (X n) < u) \<U>"
 proof -
   obtain r where "hnorm (star_n X) < hypreal_of_real r"
     using HFiniteD SReal_iff assms by fastforce
   then have "\<forall>\<^sub>F n in \<U>. norm (X n) < r"
     by (simp add: hnorm_def star_n_less star_of_def starfun_star_n)
   then show ?thesis ..
 qed
 
 lemma FreeUltrafilterNat_HFinite:
   assumes "eventually (\<lambda>n. norm (X n) < u) \<U>"
   shows "star_n X \<in> HFinite"
 proof -
   have "hnorm (star_n X) < hypreal_of_real u"
     by (simp add: assms hnorm_def star_n_less star_of_def starfun_star_n)
   then show ?thesis
     by (meson HInfiniteD SReal_hypreal_of_real less_asym not_HFinite_HInfinite)
 qed
 
 lemma HFinite_FreeUltrafilterNat_iff:
   "star_n X \<in> HFinite \<longleftrightarrow> (\<exists>u. eventually (\<lambda>n. norm (X n) < u) \<U>)"
   using FreeUltrafilterNat_HFinite HFinite_FreeUltrafilterNat by blast
 
 
 subsubsection \<open>\<^term>\<open>HInfinite\<close>\<close>
 
 text \<open>Exclude this type of sets from free ultrafilter for Infinite numbers!\<close>
 lemma FreeUltrafilterNat_const_Finite:
   "eventually (\<lambda>n. norm (X n) = u) \<U> \<Longrightarrow> star_n X \<in> HFinite"
   by (simp add: FreeUltrafilterNat_HFinite [where u = "u+1"] eventually_mono)
 
 lemma HInfinite_FreeUltrafilterNat:
   assumes "star_n X \<in> HInfinite" shows "\<forall>\<^sub>F n in \<U>. u < norm (X n)"
 proof -
 have "\<not> (\<forall>\<^sub>F n in \<U>. norm (X n) < u + 1)"
   using FreeUltrafilterNat_HFinite HFinite_HInfinite_iff assms by auto
   then show ?thesis
     by (auto simp flip: FreeUltrafilterNat.eventually_not_iff elim: eventually_mono)
 qed
 
 lemma FreeUltrafilterNat_HInfinite:
   assumes "\<And>u. eventually (\<lambda>n. u < norm (X n)) \<U>"
   shows "star_n X \<in> HInfinite"
 proof -
   { fix u
     assume "\<forall>\<^sub>Fn in \<U>. norm (X n) < u" "\<forall>\<^sub>Fn in \<U>. u < norm (X n)"
     then have "\<forall>\<^sub>F x in \<U>. False"
       by eventually_elim auto
     then have False
       by (simp add: eventually_False FreeUltrafilterNat.proper) }
   then show ?thesis
     using HFinite_FreeUltrafilterNat HInfinite_HFinite_iff assms by blast
 qed
 
 lemma HInfinite_FreeUltrafilterNat_iff:
   "star_n X \<in> HInfinite \<longleftrightarrow> (\<forall>u. eventually (\<lambda>n. u < norm (X n)) \<U>)"
   using HInfinite_FreeUltrafilterNat FreeUltrafilterNat_HInfinite by blast
 
 
 subsubsection \<open>\<^term>\<open>Infinitesimal\<close>\<close>
 
 lemma ball_SReal_eq: "(\<forall>x::hypreal \<in> Reals. P x) \<longleftrightarrow> (\<forall>x::real. P (star_of x))"
   by (auto simp: SReal_def)
 
 
 lemma Infinitesimal_FreeUltrafilterNat_iff:
   "(star_n X \<in> Infinitesimal) = (\<forall>u>0. eventually (\<lambda>n. norm (X n) < u) \<U>)"  (is "?lhs = ?rhs")
 proof -
   have "?lhs \<longleftrightarrow> (\<forall>r>0. hnorm (star_n X) < hypreal_of_real r)"
     by (simp add: Infinitesimal_def ball_SReal_eq)
   also have "... \<longleftrightarrow> ?rhs"
     by (simp add: hnorm_def starfun_star_n star_of_def star_less_def starP2_star_n)
   finally show ?thesis .
 qed
 
 
 text \<open>Infinitesimals as smaller than \<open>1/n\<close> for all \<open>n::nat (> 0)\<close>.\<close>
 
 lemma lemma_Infinitesimal: "(\<forall>r. 0 < r \<longrightarrow> x < r) \<longleftrightarrow> (\<forall>n. x < inverse (real (Suc n)))"
   by (meson inverse_positive_iff_positive less_trans of_nat_0_less_iff reals_Archimedean zero_less_Suc)
 
 lemma lemma_Infinitesimal2:
   "(\<forall>r \<in> Reals. 0 < r \<longrightarrow> x < r) \<longleftrightarrow> (\<forall>n. x < inverse(hypreal_of_nat (Suc n)))" (is "_ = ?rhs")
 proof (intro iffI strip)
   assume R: ?rhs
   fix r::hypreal
   assume "r \<in> \<real>" "0 < r"
   then obtain n y where "inverse (real (Suc n)) < y" and r: "r = hypreal_of_real y"
     by (metis SReal_iff reals_Archimedean star_of_0_less)
   then have "inverse (1 + hypreal_of_nat n) < hypreal_of_real y"
     by (metis of_nat_Suc star_of_inverse star_of_less star_of_nat_def)
   then show "x < r"
     by (metis R r le_less_trans less_imp_le of_nat_Suc)
 qed (meson Reals_inverse Reals_of_nat of_nat_0_less_iff positive_imp_inverse_positive zero_less_Suc)
 
 
 lemma Infinitesimal_hypreal_of_nat_iff:
   "Infinitesimal = {x. \<forall>n. hnorm x < inverse (hypreal_of_nat (Suc n))}"
   using Infinitesimal_def lemma_Infinitesimal2 by auto
 
 
 subsection \<open>Proof that \<open>\<omega>\<close> is an infinite number\<close>
 
 text \<open>It will follow that \<open>\<epsilon>\<close> is an infinitesimal number.\<close>
 
 lemma Suc_Un_eq: "{n. n < Suc m} = {n. n < m} Un {n. n = m}"
   by (auto simp add: less_Suc_eq)
 
 
 text \<open>Prove that any segment is finite and hence cannot belong to \<open>\<U>\<close>.\<close>
 
 lemma finite_real_of_nat_segment: "finite {n::nat. real n < real (m::nat)}"
   by auto
 
 lemma finite_real_of_nat_less_real: "finite {n::nat. real n < u}"
 proof -
   obtain m where "u < real m"
     using reals_Archimedean2 by blast
   then have "{n. real n < u} \<subseteq> {..<m}"
     by force
   then show ?thesis
     using finite_nat_iff_bounded by force
 qed
 
 lemma finite_real_of_nat_le_real: "finite {n::nat. real n \<le> u}"
   by (metis infinite_nat_iff_unbounded leD le_nat_floor mem_Collect_eq)
 
 lemma finite_rabs_real_of_nat_le_real: "finite {n::nat. \<bar>real n\<bar> \<le> u}"
   by (simp add: finite_real_of_nat_le_real)
 
 lemma rabs_real_of_nat_le_real_FreeUltrafilterNat:
   "\<not> eventually (\<lambda>n. \<bar>real n\<bar> \<le> u) \<U>"
   by (blast intro!: FreeUltrafilterNat.finite finite_rabs_real_of_nat_le_real)
 
 lemma FreeUltrafilterNat_nat_gt_real: "eventually (\<lambda>n. u < real n) \<U>"
 proof -
   have "{n::nat. \<not> u < real n} = {n. real n \<le> u}"
     by auto
   then show ?thesis
     by (auto simp add: FreeUltrafilterNat.finite' finite_real_of_nat_le_real)
 qed
 
 text \<open>The complement of \<open>{n. \<bar>real n\<bar> \<le> u} = {n. u < \<bar>real n\<bar>}\<close> is in
   \<open>\<U>\<close> by property of (free) ultrafilters.\<close>
 
 text \<open>\<^term>\<open>\<omega>\<close> is a member of \<^term>\<open>HInfinite\<close>.\<close>
 theorem HInfinite_omega [simp]: "\<omega> \<in> HInfinite"
 proof -
   have "\<forall>\<^sub>F n in \<U>. u < norm (1 + real n)" for u
     using FreeUltrafilterNat_nat_gt_real [of "u-1"] eventually_mono by fastforce
   then show ?thesis
     by (simp add: omega_def FreeUltrafilterNat_HInfinite)
 qed
 
 
 text \<open>Epsilon is a member of Infinitesimal.\<close>
 
 lemma Infinitesimal_epsilon [simp]: "\<epsilon> \<in> Infinitesimal"
   by (auto intro!: HInfinite_inverse_Infinitesimal HInfinite_omega
       simp add: epsilon_inverse_omega)
 
 lemma HFinite_epsilon [simp]: "\<epsilon> \<in> HFinite"
   by (auto intro: Infinitesimal_subset_HFinite [THEN subsetD])
 
 lemma epsilon_approx_zero [simp]: "\<epsilon> \<approx> 0"
   by (simp add: mem_infmal_iff [symmetric])
 
 text \<open>Needed for proof that we define a hyperreal \<open>[<X(n)] \<approx> hypreal_of_real a\<close> given
   that \<open>\<forall>n. |X n - a| < 1/n\<close>. Used in proof of \<open>NSLIM \<Rightarrow> LIM\<close>.\<close>
 lemma real_of_nat_less_inverse_iff: "0 < u \<Longrightarrow> u < inverse (real(Suc n)) \<longleftrightarrow> real(Suc n) < inverse u"
   using less_imp_inverse_less by force
 
 lemma finite_inverse_real_of_posnat_gt_real: "0 < u \<Longrightarrow> finite {n. u < inverse (real (Suc n))}"
 proof (simp only: real_of_nat_less_inverse_iff)
   have "{n. 1 + real n < inverse u} = {n. real n < inverse u - 1}"
     by fastforce
   then show "finite {n. real (Suc n) < inverse u}"
     using finite_real_of_nat_less_real [of "inverse u - 1"]
     by auto
 qed
 
 lemma finite_inverse_real_of_posnat_ge_real:
   assumes "0 < u"
   shows "finite {n. u \<le> inverse (real (Suc n))}"
 proof -
   have "\<forall>na. u \<le> inverse (1 + real na) \<longrightarrow> na \<le> ceiling (inverse u)"
     by (smt (verit, best) assms ceiling_less_cancel ceiling_of_nat inverse_inverse_eq inverse_le_iff_le)
   then show ?thesis
     apply (auto simp add: finite_nat_set_iff_bounded_le)
     by (meson assms inverse_positive_iff_positive le_nat_iff less_imp_le zero_less_ceiling)
 qed
 
 lemma inverse_real_of_posnat_ge_real_FreeUltrafilterNat:
   "0 < u \<Longrightarrow> \<not> eventually (\<lambda>n. u \<le> inverse(real(Suc n))) \<U>"
   by (blast intro!: FreeUltrafilterNat.finite finite_inverse_real_of_posnat_ge_real)
 
 lemma FreeUltrafilterNat_inverse_real_of_posnat:
   "0 < u \<Longrightarrow> eventually (\<lambda>n. inverse(real(Suc n)) < u) \<U>"
   by (drule inverse_real_of_posnat_ge_real_FreeUltrafilterNat)
     (simp add: FreeUltrafilterNat.eventually_not_iff not_le[symmetric])
 
 text \<open>Example of an hypersequence (i.e. an extended standard sequence)
   whose term with an hypernatural suffix is an infinitesimal i.e.
   the whn'nth term of the hypersequence is a member of Infinitesimal\<close>
 
 lemma SEQ_Infinitesimal: "( *f* (\<lambda>n::nat. inverse(real(Suc n)))) whn \<in> Infinitesimal"
   by (simp add: hypnat_omega_def starfun_star_n star_n_inverse Infinitesimal_FreeUltrafilterNat_iff
       FreeUltrafilterNat_inverse_real_of_posnat del: of_nat_Suc)
 
 text \<open>Example where we get a hyperreal from a real sequence
   for which a particular property holds. The theorem is
   used in proofs about equivalence of nonstandard and
   standard neighbourhoods. Also used for equivalence of
   nonstandard ans standard definitions of pointwise
   limit.\<close>
 
 text \<open>\<open>|X(n) - x| < 1/n \<Longrightarrow> [<X n>] - hypreal_of_real x| \<in> Infinitesimal\<close>\<close>
 lemma real_seq_to_hypreal_Infinitesimal:
   "\<forall>n. norm (X n - x) < inverse (real (Suc n)) \<Longrightarrow> star_n X - star_of x \<in> Infinitesimal"
   unfolding star_n_diff star_of_def Infinitesimal_FreeUltrafilterNat_iff star_n_inverse
   by (auto dest!: FreeUltrafilterNat_inverse_real_of_posnat
       intro: order_less_trans elim!: eventually_mono)
 
 lemma real_seq_to_hypreal_approx:
   "\<forall>n. norm (X n - x) < inverse (real (Suc n)) \<Longrightarrow> star_n X \<approx> star_of x"
   by (metis bex_Infinitesimal_iff real_seq_to_hypreal_Infinitesimal)
 
 lemma real_seq_to_hypreal_approx2:
   "\<forall>n. norm (x - X n) < inverse(real(Suc n)) \<Longrightarrow> star_n X \<approx> star_of x"
   by (metis norm_minus_commute real_seq_to_hypreal_approx)
 
 lemma real_seq_to_hypreal_Infinitesimal2:
   "\<forall>n. norm(X n - Y n) < inverse(real(Suc n)) \<Longrightarrow> star_n X - star_n Y \<in> Infinitesimal"
   unfolding Infinitesimal_FreeUltrafilterNat_iff star_n_diff
   by (auto dest!: FreeUltrafilterNat_inverse_real_of_posnat
       intro: order_less_trans elim!: eventually_mono)
 
 end
diff --git a/src/HOL/Num.thy b/src/HOL/Num.thy
--- a/src/HOL/Num.thy
+++ b/src/HOL/Num.thy
@@ -1,1553 +1,1553 @@
 (*  Title:      HOL/Num.thy
     Author:     Florian Haftmann
     Author:     Brian Huffman
 *)
 
 section \<open>Binary Numerals\<close>
 
 theory Num
   imports BNF_Least_Fixpoint Transfer
 begin
 
 subsection \<open>The \<open>num\<close> type\<close>
 
 datatype num = One | Bit0 num | Bit1 num
 
 text \<open>Increment function for type \<^typ>\<open>num\<close>\<close>
 
 primrec inc :: "num \<Rightarrow> num"
   where
     "inc One = Bit0 One"
   | "inc (Bit0 x) = Bit1 x"
   | "inc (Bit1 x) = Bit0 (inc x)"
 
 text \<open>Converting between type \<^typ>\<open>num\<close> and type \<^typ>\<open>nat\<close>\<close>
 
 primrec nat_of_num :: "num \<Rightarrow> nat"
   where
     "nat_of_num One = Suc 0"
   | "nat_of_num (Bit0 x) = nat_of_num x + nat_of_num x"
   | "nat_of_num (Bit1 x) = Suc (nat_of_num x + nat_of_num x)"
 
 primrec num_of_nat :: "nat \<Rightarrow> num"
   where
     "num_of_nat 0 = One"
   | "num_of_nat (Suc n) = (if 0 < n then inc (num_of_nat n) else One)"
 
 lemma nat_of_num_pos: "0 < nat_of_num x"
   by (induct x) simp_all
 
 lemma nat_of_num_neq_0: " nat_of_num x \<noteq> 0"
   by (induct x) simp_all
 
 lemma nat_of_num_inc: "nat_of_num (inc x) = Suc (nat_of_num x)"
   by (induct x) simp_all
 
 lemma num_of_nat_double: "0 < n \<Longrightarrow> num_of_nat (n + n) = Bit0 (num_of_nat n)"
   by (induct n) simp_all
 
 text \<open>Type \<^typ>\<open>num\<close> is isomorphic to the strictly positive natural numbers.\<close>
 
 lemma nat_of_num_inverse: "num_of_nat (nat_of_num x) = x"
   by (induct x) (simp_all add: num_of_nat_double nat_of_num_pos)
 
 lemma num_of_nat_inverse: "0 < n \<Longrightarrow> nat_of_num (num_of_nat n) = n"
   by (induct n) (simp_all add: nat_of_num_inc)
 
 lemma num_eq_iff: "x = y \<longleftrightarrow> nat_of_num x = nat_of_num y"
   apply safe
   apply (drule arg_cong [where f=num_of_nat])
   apply (simp add: nat_of_num_inverse)
   done
 
 lemma num_induct [case_names One inc]:
   fixes P :: "num \<Rightarrow> bool"
   assumes One: "P One"
     and inc: "\<And>x. P x \<Longrightarrow> P (inc x)"
   shows "P x"
 proof -
   obtain n where n: "Suc n = nat_of_num x"
     by (cases "nat_of_num x") (simp_all add: nat_of_num_neq_0)
   have "P (num_of_nat (Suc n))"
   proof (induct n)
     case 0
     from One show ?case by simp
   next
     case (Suc n)
     then have "P (inc (num_of_nat (Suc n)))" by (rule inc)
     then show "P (num_of_nat (Suc (Suc n)))" by simp
   qed
   with n show "P x"
     by (simp add: nat_of_num_inverse)
 qed
 
 text \<open>
   From now on, there are two possible models for \<^typ>\<open>num\<close>: as positive
   naturals (rule \<open>num_induct\<close>) and as digit representation (rules
   \<open>num.induct\<close>, \<open>num.cases\<close>).
 \<close>
 
 
 subsection \<open>Numeral operations\<close>
 
 instantiation num :: "{plus,times,linorder}"
 begin
 
 definition [code del]: "m + n = num_of_nat (nat_of_num m + nat_of_num n)"
 
 definition [code del]: "m * n = num_of_nat (nat_of_num m * nat_of_num n)"
 
 definition [code del]: "m \<le> n \<longleftrightarrow> nat_of_num m \<le> nat_of_num n"
 
 definition [code del]: "m < n \<longleftrightarrow> nat_of_num m < nat_of_num n"
 
 instance
   by standard (auto simp add: less_num_def less_eq_num_def num_eq_iff)
 
 end
 
 lemma nat_of_num_add: "nat_of_num (x + y) = nat_of_num x + nat_of_num y"
   unfolding plus_num_def
   by (intro num_of_nat_inverse add_pos_pos nat_of_num_pos)
 
 lemma nat_of_num_mult: "nat_of_num (x * y) = nat_of_num x * nat_of_num y"
   unfolding times_num_def
   by (intro num_of_nat_inverse mult_pos_pos nat_of_num_pos)
 
 lemma add_num_simps [simp, code]:
   "One + One = Bit0 One"
   "One + Bit0 n = Bit1 n"
   "One + Bit1 n = Bit0 (n + One)"
   "Bit0 m + One = Bit1 m"
   "Bit0 m + Bit0 n = Bit0 (m + n)"
   "Bit0 m + Bit1 n = Bit1 (m + n)"
   "Bit1 m + One = Bit0 (m + One)"
   "Bit1 m + Bit0 n = Bit1 (m + n)"
   "Bit1 m + Bit1 n = Bit0 (m + n + One)"
   by (simp_all add: num_eq_iff nat_of_num_add)
 
 lemma mult_num_simps [simp, code]:
   "m * One = m"
   "One * n = n"
   "Bit0 m * Bit0 n = Bit0 (Bit0 (m * n))"
   "Bit0 m * Bit1 n = Bit0 (m * Bit1 n)"
   "Bit1 m * Bit0 n = Bit0 (Bit1 m * n)"
   "Bit1 m * Bit1 n = Bit1 (m + n + Bit0 (m * n))"
   by (simp_all add: num_eq_iff nat_of_num_add nat_of_num_mult distrib_right distrib_left)
 
 lemma eq_num_simps:
   "One = One \<longleftrightarrow> True"
   "One = Bit0 n \<longleftrightarrow> False"
   "One = Bit1 n \<longleftrightarrow> False"
   "Bit0 m = One \<longleftrightarrow> False"
   "Bit1 m = One \<longleftrightarrow> False"
   "Bit0 m = Bit0 n \<longleftrightarrow> m = n"
   "Bit0 m = Bit1 n \<longleftrightarrow> False"
   "Bit1 m = Bit0 n \<longleftrightarrow> False"
   "Bit1 m = Bit1 n \<longleftrightarrow> m = n"
   by simp_all
 
 lemma le_num_simps [simp, code]:
   "One \<le> n \<longleftrightarrow> True"
   "Bit0 m \<le> One \<longleftrightarrow> False"
   "Bit1 m \<le> One \<longleftrightarrow> False"
   "Bit0 m \<le> Bit0 n \<longleftrightarrow> m \<le> n"
   "Bit0 m \<le> Bit1 n \<longleftrightarrow> m \<le> n"
   "Bit1 m \<le> Bit1 n \<longleftrightarrow> m \<le> n"
   "Bit1 m \<le> Bit0 n \<longleftrightarrow> m < n"
   using nat_of_num_pos [of n] nat_of_num_pos [of m]
   by (auto simp add: less_eq_num_def less_num_def)
 
 lemma less_num_simps [simp, code]:
   "m < One \<longleftrightarrow> False"
   "One < Bit0 n \<longleftrightarrow> True"
   "One < Bit1 n \<longleftrightarrow> True"
   "Bit0 m < Bit0 n \<longleftrightarrow> m < n"
   "Bit0 m < Bit1 n \<longleftrightarrow> m \<le> n"
   "Bit1 m < Bit1 n \<longleftrightarrow> m < n"
   "Bit1 m < Bit0 n \<longleftrightarrow> m < n"
   using nat_of_num_pos [of n] nat_of_num_pos [of m]
   by (auto simp add: less_eq_num_def less_num_def)
 
 lemma le_num_One_iff: "x \<le> num.One \<longleftrightarrow> x = num.One"
   by (simp add: antisym_conv)
 
 text \<open>Rules using \<open>One\<close> and \<open>inc\<close> as constructors.\<close>
 
 lemma add_One: "x + One = inc x"
   by (simp add: num_eq_iff nat_of_num_add nat_of_num_inc)
 
 lemma add_One_commute: "One + n = n + One"
   by (induct n) simp_all
 
 lemma add_inc: "x + inc y = inc (x + y)"
   by (simp add: num_eq_iff nat_of_num_add nat_of_num_inc)
 
 lemma mult_inc: "x * inc y = x * y + x"
   by (simp add: num_eq_iff nat_of_num_mult nat_of_num_add nat_of_num_inc)
 
 text \<open>The \<^const>\<open>num_of_nat\<close> conversion.\<close>
 
 lemma num_of_nat_One: "n \<le> 1 \<Longrightarrow> num_of_nat n = One"
   by (cases n) simp_all
 
 lemma num_of_nat_plus_distrib:
   "0 < m \<Longrightarrow> 0 < n \<Longrightarrow> num_of_nat (m + n) = num_of_nat m + num_of_nat n"
   by (induct n) (auto simp add: add_One add_One_commute add_inc)
 
 text \<open>A double-and-decrement function.\<close>
 
 primrec BitM :: "num \<Rightarrow> num"
   where
     "BitM One = One"
   | "BitM (Bit0 n) = Bit1 (BitM n)"
   | "BitM (Bit1 n) = Bit1 (Bit0 n)"
 
 lemma BitM_plus_one: "BitM n + One = Bit0 n"
   by (induct n) simp_all
 
 lemma one_plus_BitM: "One + BitM n = Bit0 n"
   unfolding add_One_commute BitM_plus_one ..
 
 lemma BitM_inc_eq:
   \<open>Num.BitM (Num.inc n) = Num.Bit1 n\<close>
   by (induction n) simp_all
 
 lemma inc_BitM_eq:
   \<open>Num.inc (Num.BitM n) = num.Bit0 n\<close>
   by (simp add: BitM_plus_one[symmetric] add_One)
 
 text \<open>Squaring and exponentiation.\<close>
 
 primrec sqr :: "num \<Rightarrow> num"
   where
     "sqr One = One"
   | "sqr (Bit0 n) = Bit0 (Bit0 (sqr n))"
   | "sqr (Bit1 n) = Bit1 (Bit0 (sqr n + n))"
 
 primrec pow :: "num \<Rightarrow> num \<Rightarrow> num"
   where
     "pow x One = x"
   | "pow x (Bit0 y) = sqr (pow x y)"
   | "pow x (Bit1 y) = sqr (pow x y) * x"
 
 lemma nat_of_num_sqr: "nat_of_num (sqr x) = nat_of_num x * nat_of_num x"
   by (induct x) (simp_all add: algebra_simps nat_of_num_add)
 
 lemma sqr_conv_mult: "sqr x = x * x"
   by (simp add: num_eq_iff nat_of_num_sqr nat_of_num_mult)
 
 lemma num_double [simp]:
   "num.Bit0 num.One * n = num.Bit0 n"
   by (simp add: num_eq_iff nat_of_num_mult)
 
 
 subsection \<open>Binary numerals\<close>
 
 text \<open>
   We embed binary representations into a generic algebraic
   structure using \<open>numeral\<close>.
 \<close>
 
 class numeral = one + semigroup_add
 begin
 
 primrec numeral :: "num \<Rightarrow> 'a"
   where
     numeral_One: "numeral One = 1"
   | numeral_Bit0: "numeral (Bit0 n) = numeral n + numeral n"
   | numeral_Bit1: "numeral (Bit1 n) = numeral n + numeral n + 1"
 
 lemma numeral_code [code]:
   "numeral One = 1"
   "numeral (Bit0 n) = (let m = numeral n in m + m)"
   "numeral (Bit1 n) = (let m = numeral n in m + m + 1)"
   by (simp_all add: Let_def)
 
 lemma one_plus_numeral_commute: "1 + numeral x = numeral x + 1"
 proof (induct x)
   case One
   then show ?case by simp
 next
   case Bit0
   then show ?case by (simp add: add.assoc [symmetric]) (simp add: add.assoc)
 next
   case Bit1
   then show ?case by (simp add: add.assoc [symmetric]) (simp add: add.assoc)
 qed
 
 lemma numeral_inc: "numeral (inc x) = numeral x + 1"
 proof (induct x)
   case One
   then show ?case by simp
 next
   case Bit0
   then show ?case by simp
 next
   case (Bit1 x)
   have "numeral x + (1 + numeral x) + 1 = numeral x + (numeral x + 1) + 1"
     by (simp only: one_plus_numeral_commute)
   with Bit1 show ?case
     by (simp add: add.assoc)
 qed
 
 declare numeral.simps [simp del]
 
 abbreviation "Numeral1 \<equiv> numeral One"
 
 declare numeral_One [code_post]
 
 end
 
 text \<open>Numeral syntax.\<close>
 
 syntax
   "_Numeral" :: "num_const \<Rightarrow> 'a"    ("_")
 
 ML_file \<open>Tools/numeral.ML\<close>
 
 parse_translation \<open>
   let
     fun numeral_tr [(c as Const (\<^syntax_const>\<open>_constrain\<close>, _)) $ t $ u] =
           c $ numeral_tr [t] $ u
       | numeral_tr [Const (num, _)] =
           (Numeral.mk_number_syntax o #value o Lexicon.read_num) num
       | numeral_tr ts = raise TERM ("numeral_tr", ts);
   in [(\<^syntax_const>\<open>_Numeral\<close>, K numeral_tr)] end
 \<close>
 
 typed_print_translation \<open>
   let
     fun num_tr' ctxt T [n] =
       let
         val k = Numeral.dest_num_syntax n;
         val t' =
           Syntax.const \<^syntax_const>\<open>_Numeral\<close> $
             Syntax.free (string_of_int k);
       in
         (case T of
           Type (\<^type_name>\<open>fun\<close>, [_, T']) =>
             if Printer.type_emphasis ctxt T' then
               Syntax.const \<^syntax_const>\<open>_constrain\<close> $ t' $
                 Syntax_Phases.term_of_typ ctxt T'
             else t'
         | _ => if T = dummyT then t' else raise Match)
       end;
   in
    [(\<^const_syntax>\<open>numeral\<close>, num_tr')]
   end
 \<close>
 
 
 subsection \<open>Class-specific numeral rules\<close>
 
 text \<open>\<^const>\<open>numeral\<close> is a morphism.\<close>
 
 
 subsubsection \<open>Structures with addition: class \<open>numeral\<close>\<close>
 
 context numeral
 begin
 
 lemma numeral_add: "numeral (m + n) = numeral m + numeral n"
   by (induct n rule: num_induct)
     (simp_all only: numeral_One add_One add_inc numeral_inc add.assoc)
 
 lemma numeral_plus_numeral: "numeral m + numeral n = numeral (m + n)"
   by (rule numeral_add [symmetric])
 
 lemma numeral_plus_one: "numeral n + 1 = numeral (n + One)"
   using numeral_add [of n One] by (simp add: numeral_One)
 
 lemma one_plus_numeral: "1 + numeral n = numeral (One + n)"
   using numeral_add [of One n] by (simp add: numeral_One)
 
 lemma one_add_one: "1 + 1 = 2"
   using numeral_add [of One One] by (simp add: numeral_One)
 
 lemmas add_numeral_special =
   numeral_plus_one one_plus_numeral one_add_one
 
 end
 
 
 subsubsection \<open>Structures with negation: class \<open>neg_numeral\<close>\<close>
 
 class neg_numeral = numeral + group_add
 begin
 
 lemma uminus_numeral_One: "- Numeral1 = - 1"
   by (simp add: numeral_One)
 
 text \<open>Numerals form an abelian subgroup.\<close>
 
 inductive is_num :: "'a \<Rightarrow> bool"
   where
     "is_num 1"
   | "is_num x \<Longrightarrow> is_num (- x)"
   | "is_num x \<Longrightarrow> is_num y \<Longrightarrow> is_num (x + y)"
 
 lemma is_num_numeral: "is_num (numeral k)"
   by (induct k) (simp_all add: numeral.simps is_num.intros)
 
 lemma is_num_add_commute: "is_num x \<Longrightarrow> is_num y \<Longrightarrow> x + y = y + x"
 proof(induction x rule: is_num.induct)
   case 1
   then show ?case
   proof (induction y rule: is_num.induct)
     case 1
     then show ?case by simp
   next
     case (2 y)
     then have "y + (1 + - y) + y = y + (- y + 1) + y"
       by (simp add: add.assoc)
     then have "y + (1 + - y) = y + (- y + 1)"
       by simp
     then show ?case
       by (rule add_left_imp_eq[of y])
   next
     case (3 x y)
     then have "1 + (x + y) = x + 1 + y"
       by (simp add: add.assoc [symmetric])
     then show ?case using 3
       by (simp add: add.assoc)
   qed
 next
   case (2 x)
   then have "x + (- x + y) + x = x + (y + - x) + x"
     by (simp add: add.assoc)
   then have "x + (- x + y) = x + (y + - x)"
     by simp
   then show ?case
     by (rule add_left_imp_eq[of x])
 next
   case (3 x z)
   moreover have "x + (y + z) = (x + y) + z"
     by (simp add: add.assoc[symmetric])
   ultimately show ?case 
     by (simp add: add.assoc)
 qed
 
 lemma is_num_add_left_commute: "is_num x \<Longrightarrow> is_num y \<Longrightarrow> x + (y + z) = y + (x + z)"
   by (simp only: add.assoc [symmetric] is_num_add_commute)
 
 lemmas is_num_normalize =
   add.assoc is_num_add_commute is_num_add_left_commute
   is_num.intros is_num_numeral
   minus_add
 
 definition dbl :: "'a \<Rightarrow> 'a"
   where "dbl x = x + x"
 
 definition dbl_inc :: "'a \<Rightarrow> 'a"
   where "dbl_inc x = x + x + 1"
 
 definition dbl_dec :: "'a \<Rightarrow> 'a"
   where "dbl_dec x = x + x - 1"
 
 definition sub :: "num \<Rightarrow> num \<Rightarrow> 'a"
   where "sub k l = numeral k - numeral l"
 
 lemma numeral_BitM: "numeral (BitM n) = numeral (Bit0 n) - 1"
   by (simp only: BitM_plus_one [symmetric] numeral_add numeral_One eq_diff_eq)
 
 lemma sub_inc_One_eq:
   \<open>Num.sub (Num.inc n) num.One = numeral n\<close>
   by (simp_all add: sub_def diff_eq_eq numeral_inc numeral.numeral_One)
 
 lemma dbl_simps [simp]:
   "dbl (- numeral k) = - dbl (numeral k)"
   "dbl 0 = 0"
   "dbl 1 = 2"
   "dbl (- 1) = - 2"
   "dbl (numeral k) = numeral (Bit0 k)"
   by (simp_all add: dbl_def numeral.simps minus_add)
 
 lemma dbl_inc_simps [simp]:
   "dbl_inc (- numeral k) = - dbl_dec (numeral k)"
   "dbl_inc 0 = 1"
   "dbl_inc 1 = 3"
   "dbl_inc (- 1) = - 1"
   "dbl_inc (numeral k) = numeral (Bit1 k)"
   by (simp_all add: dbl_inc_def dbl_dec_def numeral.simps numeral_BitM is_num_normalize algebra_simps
       del: add_uminus_conv_diff)
 
 lemma dbl_dec_simps [simp]:
   "dbl_dec (- numeral k) = - dbl_inc (numeral k)"
   "dbl_dec 0 = - 1"
   "dbl_dec 1 = 1"
   "dbl_dec (- 1) = - 3"
   "dbl_dec (numeral k) = numeral (BitM k)"
   by (simp_all add: dbl_dec_def dbl_inc_def numeral.simps numeral_BitM is_num_normalize)
 
 lemma sub_num_simps [simp]:
   "sub One One = 0"
   "sub One (Bit0 l) = - numeral (BitM l)"
   "sub One (Bit1 l) = - numeral (Bit0 l)"
   "sub (Bit0 k) One = numeral (BitM k)"
   "sub (Bit1 k) One = numeral (Bit0 k)"
   "sub (Bit0 k) (Bit0 l) = dbl (sub k l)"
   "sub (Bit0 k) (Bit1 l) = dbl_dec (sub k l)"
   "sub (Bit1 k) (Bit0 l) = dbl_inc (sub k l)"
   "sub (Bit1 k) (Bit1 l) = dbl (sub k l)"
   by (simp_all add: dbl_def dbl_dec_def dbl_inc_def sub_def numeral.simps
     numeral_BitM is_num_normalize del: add_uminus_conv_diff add: diff_conv_add_uminus)
 
 lemma add_neg_numeral_simps:
   "numeral m + - numeral n = sub m n"
   "- numeral m + numeral n = sub n m"
   "- numeral m + - numeral n = - (numeral m + numeral n)"
   by (simp_all add: sub_def numeral_add numeral.simps is_num_normalize
       del: add_uminus_conv_diff add: diff_conv_add_uminus)
 
 lemma add_neg_numeral_special:
   "1 + - numeral m = sub One m"
   "- numeral m + 1 = sub One m"
   "numeral m + - 1 = sub m One"
   "- 1 + numeral n = sub n One"
   "- 1 + - numeral n = - numeral (inc n)"
   "- numeral m + - 1 = - numeral (inc m)"
   "1 + - 1 = 0"
   "- 1 + 1 = 0"
   "- 1 + - 1 = - 2"
   by (simp_all add: sub_def numeral_add numeral.simps is_num_normalize right_minus numeral_inc
       del: add_uminus_conv_diff add: diff_conv_add_uminus)
 
 lemma diff_numeral_simps:
   "numeral m - numeral n = sub m n"
   "numeral m - - numeral n = numeral (m + n)"
   "- numeral m - numeral n = - numeral (m + n)"
   "- numeral m - - numeral n = sub n m"
   by (simp_all add: sub_def numeral_add numeral.simps is_num_normalize
       del: add_uminus_conv_diff add: diff_conv_add_uminus)
 
 lemma diff_numeral_special:
   "1 - numeral n = sub One n"
   "numeral m - 1 = sub m One"
   "1 - - numeral n = numeral (One + n)"
   "- numeral m - 1 = - numeral (m + One)"
   "- 1 - numeral n = - numeral (inc n)"
   "numeral m - - 1 = numeral (inc m)"
   "- 1 - - numeral n = sub n One"
   "- numeral m - - 1 = sub One m"
   "1 - 1 = 0"
   "- 1 - 1 = - 2"
   "1 - - 1 = 2"
   "- 1 - - 1 = 0"
   by (simp_all add: sub_def numeral_add numeral.simps is_num_normalize numeral_inc
       del: add_uminus_conv_diff add: diff_conv_add_uminus)
 
 end
 
 
 subsubsection \<open>Structures with multiplication: class \<open>semiring_numeral\<close>\<close>
 
 class semiring_numeral = semiring + monoid_mult
 begin
 
 subclass numeral ..
 
 lemma numeral_mult: "numeral (m * n) = numeral m * numeral n"
   by (induct n rule: num_induct)
     (simp_all add: numeral_One mult_inc numeral_inc numeral_add distrib_left)
 
 lemma numeral_times_numeral: "numeral m * numeral n = numeral (m * n)"
   by (rule numeral_mult [symmetric])
 
 lemma mult_2: "2 * z = z + z"
   by (simp add: one_add_one [symmetric] distrib_right)
 
 lemma mult_2_right: "z * 2 = z + z"
   by (simp add: one_add_one [symmetric] distrib_left)
 
 lemma left_add_twice:
   "a + (a + b) = 2 * a + b"
   by (simp add: mult_2 ac_simps)
 
 end
 
 
 subsubsection \<open>Structures with a zero: class \<open>semiring_1\<close>\<close>
 
 context semiring_1
 begin
 
 subclass semiring_numeral ..
 
 lemma of_nat_numeral [simp]: "of_nat (numeral n) = numeral n"
   by (induct n) (simp_all only: numeral.simps numeral_class.numeral.simps of_nat_add of_nat_1)
 
 end
 
 lemma nat_of_num_numeral [code_abbrev]: "nat_of_num = numeral"
 proof
   fix n
   have "numeral n = nat_of_num n"
     by (induct n) (simp_all add: numeral.simps)
   then show "nat_of_num n = numeral n"
     by simp
 qed
 
 lemma nat_of_num_code [code]:
   "nat_of_num One = 1"
   "nat_of_num (Bit0 n) = (let m = nat_of_num n in m + m)"
   "nat_of_num (Bit1 n) = (let m = nat_of_num n in Suc (m + m))"
   by (simp_all add: Let_def)
 
 
 subsubsection \<open>Equality: class \<open>semiring_char_0\<close>\<close>
 
 context semiring_char_0
 begin
 
 lemma numeral_eq_iff: "numeral m = numeral n \<longleftrightarrow> m = n"
   by (simp only: of_nat_numeral [symmetric] nat_of_num_numeral [symmetric]
     of_nat_eq_iff num_eq_iff)
 
 lemma numeral_eq_one_iff: "numeral n = 1 \<longleftrightarrow> n = One"
   by (rule numeral_eq_iff [of n One, unfolded numeral_One])
 
 lemma one_eq_numeral_iff: "1 = numeral n \<longleftrightarrow> One = n"
   by (rule numeral_eq_iff [of One n, unfolded numeral_One])
 
 lemma numeral_neq_zero: "numeral n \<noteq> 0"
   by (simp add: of_nat_numeral [symmetric] nat_of_num_numeral [symmetric] nat_of_num_pos)
 
 lemma zero_neq_numeral: "0 \<noteq> numeral n"
   unfolding eq_commute [of 0] by (rule numeral_neq_zero)
 
 lemmas eq_numeral_simps [simp] =
   numeral_eq_iff
   numeral_eq_one_iff
   one_eq_numeral_iff
   numeral_neq_zero
   zero_neq_numeral
 
 end
 
 
 subsubsection \<open>Comparisons: class \<open>linordered_nonzero_semiring\<close>\<close>
 
 context linordered_nonzero_semiring
 begin
 
 lemma numeral_le_iff: "numeral m \<le> numeral n \<longleftrightarrow> m \<le> n"
 proof -
   have "of_nat (numeral m) \<le> of_nat (numeral n) \<longleftrightarrow> m \<le> n"
     by (simp only: less_eq_num_def nat_of_num_numeral of_nat_le_iff)
   then show ?thesis by simp
 qed
 
 lemma one_le_numeral: "1 \<le> numeral n"
   using numeral_le_iff [of num.One n] by (simp add: numeral_One)
 
 lemma numeral_le_one_iff: "numeral n \<le> 1 \<longleftrightarrow> n \<le> num.One"
   using numeral_le_iff [of n num.One] by (simp add: numeral_One)
 
 lemma numeral_less_iff: "numeral m < numeral n \<longleftrightarrow> m < n"
 proof -
   have "of_nat (numeral m) < of_nat (numeral n) \<longleftrightarrow> m < n"
     unfolding less_num_def nat_of_num_numeral of_nat_less_iff ..
   then show ?thesis by simp
 qed
 
 lemma not_numeral_less_one: "\<not> numeral n < 1"
   using numeral_less_iff [of n num.One] by (simp add: numeral_One)
 
 lemma one_less_numeral_iff: "1 < numeral n \<longleftrightarrow> num.One < n"
   using numeral_less_iff [of num.One n] by (simp add: numeral_One)
 
 lemma zero_le_numeral: "0 \<le> numeral n"
   using dual_order.trans one_le_numeral zero_le_one by blast
 
 lemma zero_less_numeral: "0 < numeral n"
   using less_linear not_numeral_less_one order.strict_trans zero_less_one by blast
 
 lemma not_numeral_le_zero: "\<not> numeral n \<le> 0"
   by (simp add: not_le zero_less_numeral)
 
 lemma not_numeral_less_zero: "\<not> numeral n < 0"
   by (simp add: not_less zero_le_numeral)
 
 lemmas le_numeral_extra =
   zero_le_one not_one_le_zero
   order_refl [of 0] order_refl [of 1]
 
 lemmas less_numeral_extra =
   zero_less_one not_one_less_zero
   less_irrefl [of 0] less_irrefl [of 1]
 
 lemmas le_numeral_simps [simp] =
   numeral_le_iff
   one_le_numeral
   numeral_le_one_iff
   zero_le_numeral
   not_numeral_le_zero
 
 lemmas less_numeral_simps [simp] =
   numeral_less_iff
   one_less_numeral_iff
   not_numeral_less_one
   zero_less_numeral
   not_numeral_less_zero
 
 lemma min_0_1 [simp]:
   fixes min' :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
   defines "min' \<equiv> min"
   shows
     "min' 0 1 = 0"
     "min' 1 0 = 0"
     "min' 0 (numeral x) = 0"
     "min' (numeral x) 0 = 0"
     "min' 1 (numeral x) = 1"
     "min' (numeral x) 1 = 1"
   by (simp_all add: min'_def min_def le_num_One_iff)
 
 lemma max_0_1 [simp]:
   fixes max' :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
   defines "max' \<equiv> max"
   shows
     "max' 0 1 = 1"
     "max' 1 0 = 1"
     "max' 0 (numeral x) = numeral x"
     "max' (numeral x) 0 = numeral x"
     "max' 1 (numeral x) = numeral x"
     "max' (numeral x) 1 = numeral x"
   by (simp_all add: max'_def max_def le_num_One_iff)
 
 end
 
 text \<open>Unfold \<open>min\<close> and \<open>max\<close> on numerals.\<close>
 
 lemmas max_number_of [simp] =
   max_def [of "numeral u" "numeral v"]
   max_def [of "numeral u" "- numeral v"]
   max_def [of "- numeral u" "numeral v"]
   max_def [of "- numeral u" "- numeral v"] for u v
 
 lemmas min_number_of [simp] =
   min_def [of "numeral u" "numeral v"]
   min_def [of "numeral u" "- numeral v"]
   min_def [of "- numeral u" "numeral v"]
   min_def [of "- numeral u" "- numeral v"] for u v
 
 
 subsubsection \<open>Multiplication and negation: class \<open>ring_1\<close>\<close>
 
 context ring_1
 begin
 
 subclass neg_numeral ..
 
 lemma mult_neg_numeral_simps:
   "- numeral m * - numeral n = numeral (m * n)"
   "- numeral m * numeral n = - numeral (m * n)"
   "numeral m * - numeral n = - numeral (m * n)"
   by (simp_all only: mult_minus_left mult_minus_right minus_minus numeral_mult)
 
 lemma mult_minus1 [simp]: "- 1 * z = - z"
   by (simp add: numeral.simps)
 
 lemma mult_minus1_right [simp]: "z * - 1 = - z"
   by (simp add: numeral.simps)
 
 lemma minus_sub_one_diff_one [simp]:
   \<open>- sub m One - 1 = - numeral m\<close>
 proof -
   have \<open>sub m One + 1 = numeral m\<close>
     by (simp flip: eq_diff_eq add: diff_numeral_special)
   then have \<open>- (sub m One + 1) = - numeral m\<close>
     by simp
   then show ?thesis
     by simp
 qed
 
 end
 
 
 subsubsection \<open>Equality using \<open>iszero\<close> for rings with non-zero characteristic\<close>
 
 context ring_1
 begin
 
 definition iszero :: "'a \<Rightarrow> bool"
   where "iszero z \<longleftrightarrow> z = 0"
 
 lemma iszero_0 [simp]: "iszero 0"
   by (simp add: iszero_def)
 
 lemma not_iszero_1 [simp]: "\<not> iszero 1"
   by (simp add: iszero_def)
 
 lemma not_iszero_Numeral1: "\<not> iszero Numeral1"
   by (simp add: numeral_One)
 
 lemma not_iszero_neg_1 [simp]: "\<not> iszero (- 1)"
   by (simp add: iszero_def)
 
 lemma not_iszero_neg_Numeral1: "\<not> iszero (- Numeral1)"
   by (simp add: numeral_One)
 
 lemma iszero_neg_numeral [simp]: "iszero (- numeral w) \<longleftrightarrow> iszero (numeral w)"
   unfolding iszero_def by (rule neg_equal_0_iff_equal)
 
 lemma eq_iff_iszero_diff: "x = y \<longleftrightarrow> iszero (x - y)"
   unfolding iszero_def by (rule eq_iff_diff_eq_0)
 
 text \<open>
   The \<open>eq_numeral_iff_iszero\<close> lemmas are not declared \<open>[simp]\<close> by default,
   because for rings of characteristic zero, better simp rules are possible.
   For a type like integers mod \<open>n\<close>, type-instantiated versions of these rules
   should be added to the simplifier, along with a type-specific rule for
   deciding propositions of the form \<open>iszero (numeral w)\<close>.
 
   bh: Maybe it would not be so bad to just declare these as simp rules anyway?
   I should test whether these rules take precedence over the \<open>ring_char_0\<close>
   rules in the simplifier.
 \<close>
 
 lemma eq_numeral_iff_iszero:
   "numeral x = numeral y \<longleftrightarrow> iszero (sub x y)"
   "numeral x = - numeral y \<longleftrightarrow> iszero (numeral (x + y))"
   "- numeral x = numeral y \<longleftrightarrow> iszero (numeral (x + y))"
   "- numeral x = - numeral y \<longleftrightarrow> iszero (sub y x)"
   "numeral x = 1 \<longleftrightarrow> iszero (sub x One)"
   "1 = numeral y \<longleftrightarrow> iszero (sub One y)"
   "- numeral x = 1 \<longleftrightarrow> iszero (numeral (x + One))"
   "1 = - numeral y \<longleftrightarrow> iszero (numeral (One + y))"
   "numeral x = 0 \<longleftrightarrow> iszero (numeral x)"
   "0 = numeral y \<longleftrightarrow> iszero (numeral y)"
   "- numeral x = 0 \<longleftrightarrow> iszero (numeral x)"
   "0 = - numeral y \<longleftrightarrow> iszero (numeral y)"
   unfolding eq_iff_iszero_diff diff_numeral_simps diff_numeral_special
   by simp_all
 
 end
 
 
 subsubsection \<open>Equality and negation: class \<open>ring_char_0\<close>\<close>
 
 context ring_char_0
 begin
 
 lemma not_iszero_numeral [simp]: "\<not> iszero (numeral w)"
   by (simp add: iszero_def)
 
 lemma neg_numeral_eq_iff: "- numeral m = - numeral n \<longleftrightarrow> m = n"
   by simp
 
 lemma numeral_neq_neg_numeral: "numeral m \<noteq> - numeral n"
   by (simp add: eq_neg_iff_add_eq_0 numeral_plus_numeral)
 
 lemma neg_numeral_neq_numeral: "- numeral m \<noteq> numeral n"
   by (rule numeral_neq_neg_numeral [symmetric])
 
 lemma zero_neq_neg_numeral: "0 \<noteq> - numeral n"
   by simp
 
 lemma neg_numeral_neq_zero: "- numeral n \<noteq> 0"
   by simp
 
 lemma one_neq_neg_numeral: "1 \<noteq> - numeral n"
   using numeral_neq_neg_numeral [of One n] by (simp add: numeral_One)
 
 lemma neg_numeral_neq_one: "- numeral n \<noteq> 1"
   using neg_numeral_neq_numeral [of n One] by (simp add: numeral_One)
 
 lemma neg_one_neq_numeral: "- 1 \<noteq> numeral n"
   using neg_numeral_neq_numeral [of One n] by (simp add: numeral_One)
 
 lemma numeral_neq_neg_one: "numeral n \<noteq> - 1"
   using numeral_neq_neg_numeral [of n One] by (simp add: numeral_One)
 
 lemma neg_one_eq_numeral_iff: "- 1 = - numeral n \<longleftrightarrow> n = One"
   using neg_numeral_eq_iff [of One n] by (auto simp add: numeral_One)
 
 lemma numeral_eq_neg_one_iff: "- numeral n = - 1 \<longleftrightarrow> n = One"
   using neg_numeral_eq_iff [of n One] by (auto simp add: numeral_One)
 
 lemma neg_one_neq_zero: "- 1 \<noteq> 0"
   by simp
 
 lemma zero_neq_neg_one: "0 \<noteq> - 1"
   by simp
 
 lemma neg_one_neq_one: "- 1 \<noteq> 1"
   using neg_numeral_neq_numeral [of One One] by (simp only: numeral_One not_False_eq_True)
 
 lemma one_neq_neg_one: "1 \<noteq> - 1"
   using numeral_neq_neg_numeral [of One One] by (simp only: numeral_One not_False_eq_True)
 
 lemmas eq_neg_numeral_simps [simp] =
   neg_numeral_eq_iff
   numeral_neq_neg_numeral neg_numeral_neq_numeral
   one_neq_neg_numeral neg_numeral_neq_one
   zero_neq_neg_numeral neg_numeral_neq_zero
   neg_one_neq_numeral numeral_neq_neg_one
   neg_one_eq_numeral_iff numeral_eq_neg_one_iff
   neg_one_neq_zero zero_neq_neg_one
   neg_one_neq_one one_neq_neg_one
 
 end
 
 
 subsubsection \<open>Structures with negation and order: class \<open>linordered_idom\<close>\<close>
 
 context linordered_idom
 begin
 
 subclass ring_char_0 ..
 
 lemma neg_numeral_le_iff: "- numeral m \<le> - numeral n \<longleftrightarrow> n \<le> m"
   by (simp only: neg_le_iff_le numeral_le_iff)
 
 lemma neg_numeral_less_iff: "- numeral m < - numeral n \<longleftrightarrow> n < m"
   by (simp only: neg_less_iff_less numeral_less_iff)
 
 lemma neg_numeral_less_zero: "- numeral n < 0"
   by (simp only: neg_less_0_iff_less zero_less_numeral)
 
 lemma neg_numeral_le_zero: "- numeral n \<le> 0"
   by (simp only: neg_le_0_iff_le zero_le_numeral)
 
 lemma not_zero_less_neg_numeral: "\<not> 0 < - numeral n"
   by (simp only: not_less neg_numeral_le_zero)
 
 lemma not_zero_le_neg_numeral: "\<not> 0 \<le> - numeral n"
   by (simp only: not_le neg_numeral_less_zero)
 
 lemma neg_numeral_less_numeral: "- numeral m < numeral n"
   using neg_numeral_less_zero zero_less_numeral by (rule less_trans)
 
 lemma neg_numeral_le_numeral: "- numeral m \<le> numeral n"
   by (simp only: less_imp_le neg_numeral_less_numeral)
 
 lemma not_numeral_less_neg_numeral: "\<not> numeral m < - numeral n"
   by (simp only: not_less neg_numeral_le_numeral)
 
 lemma not_numeral_le_neg_numeral: "\<not> numeral m \<le> - numeral n"
   by (simp only: not_le neg_numeral_less_numeral)
 
 lemma neg_numeral_less_one: "- numeral m < 1"
   by (rule neg_numeral_less_numeral [of m One, unfolded numeral_One])
 
 lemma neg_numeral_le_one: "- numeral m \<le> 1"
   by (rule neg_numeral_le_numeral [of m One, unfolded numeral_One])
 
 lemma not_one_less_neg_numeral: "\<not> 1 < - numeral m"
   by (simp only: not_less neg_numeral_le_one)
 
 lemma not_one_le_neg_numeral: "\<not> 1 \<le> - numeral m"
   by (simp only: not_le neg_numeral_less_one)
 
 lemma not_numeral_less_neg_one: "\<not> numeral m < - 1"
   using not_numeral_less_neg_numeral [of m One] by (simp add: numeral_One)
 
 lemma not_numeral_le_neg_one: "\<not> numeral m \<le> - 1"
   using not_numeral_le_neg_numeral [of m One] by (simp add: numeral_One)
 
 lemma neg_one_less_numeral: "- 1 < numeral m"
   using neg_numeral_less_numeral [of One m] by (simp add: numeral_One)
 
 lemma neg_one_le_numeral: "- 1 \<le> numeral m"
   using neg_numeral_le_numeral [of One m] by (simp add: numeral_One)
 
 lemma neg_numeral_less_neg_one_iff: "- numeral m < - 1 \<longleftrightarrow> m \<noteq> One"
   by (cases m) simp_all
 
 lemma neg_numeral_le_neg_one: "- numeral m \<le> - 1"
   by simp
 
 lemma not_neg_one_less_neg_numeral: "\<not> - 1 < - numeral m"
   by simp
 
 lemma not_neg_one_le_neg_numeral_iff: "\<not> - 1 \<le> - numeral m \<longleftrightarrow> m \<noteq> One"
   by (cases m) simp_all
 
 lemma sub_non_negative: "sub n m \<ge> 0 \<longleftrightarrow> n \<ge> m"
   by (simp only: sub_def le_diff_eq) simp
 
 lemma sub_positive: "sub n m > 0 \<longleftrightarrow> n > m"
   by (simp only: sub_def less_diff_eq) simp
 
 lemma sub_non_positive: "sub n m \<le> 0 \<longleftrightarrow> n \<le> m"
   by (simp only: sub_def diff_le_eq) simp
 
 lemma sub_negative: "sub n m < 0 \<longleftrightarrow> n < m"
   by (simp only: sub_def diff_less_eq) simp
 
 lemmas le_neg_numeral_simps [simp] =
   neg_numeral_le_iff
   neg_numeral_le_numeral not_numeral_le_neg_numeral
   neg_numeral_le_zero not_zero_le_neg_numeral
   neg_numeral_le_one not_one_le_neg_numeral
   neg_one_le_numeral not_numeral_le_neg_one
   neg_numeral_le_neg_one not_neg_one_le_neg_numeral_iff
 
 lemma le_minus_one_simps [simp]:
   "- 1 \<le> 0"
   "- 1 \<le> 1"
   "\<not> 0 \<le> - 1"
   "\<not> 1 \<le> - 1"
   by simp_all
 
 lemmas less_neg_numeral_simps [simp] =
   neg_numeral_less_iff
   neg_numeral_less_numeral not_numeral_less_neg_numeral
   neg_numeral_less_zero not_zero_less_neg_numeral
   neg_numeral_less_one not_one_less_neg_numeral
   neg_one_less_numeral not_numeral_less_neg_one
   neg_numeral_less_neg_one_iff not_neg_one_less_neg_numeral
 
 lemma less_minus_one_simps [simp]:
   "- 1 < 0"
   "- 1 < 1"
   "\<not> 0 < - 1"
   "\<not> 1 < - 1"
   by (simp_all add: less_le)
 
 lemma abs_numeral [simp]: "\<bar>numeral n\<bar> = numeral n"
   by simp
 
 lemma abs_neg_numeral [simp]: "\<bar>- numeral n\<bar> = numeral n"
   by (simp only: abs_minus_cancel abs_numeral)
 
 lemma abs_neg_one [simp]: "\<bar>- 1\<bar> = 1"
   by simp
 
 end
 
 
 subsubsection \<open>Natural numbers\<close>
 
 lemma numeral_num_of_nat:
   "numeral (num_of_nat n) = n" if "n > 0"
   using that nat_of_num_numeral num_of_nat_inverse by simp
 
 lemma Suc_1 [simp]: "Suc 1 = 2"
   unfolding Suc_eq_plus1 by (rule one_add_one)
 
 lemma Suc_numeral [simp]: "Suc (numeral n) = numeral (n + One)"
   unfolding Suc_eq_plus1 by (rule numeral_plus_one)
 
 definition pred_numeral :: "num \<Rightarrow> nat"
   where "pred_numeral k = numeral k - 1"
 
 declare [[code drop: pred_numeral]]
 
 lemma numeral_eq_Suc: "numeral k = Suc (pred_numeral k)"
   by (simp add: pred_numeral_def)
 
 lemma eval_nat_numeral:
   "numeral One = Suc 0"
   "numeral (Bit0 n) = Suc (numeral (BitM n))"
   "numeral (Bit1 n) = Suc (numeral (Bit0 n))"
   by (simp_all add: numeral.simps BitM_plus_one)
 
 lemma pred_numeral_simps [simp]:
   "pred_numeral One = 0"
   "pred_numeral (Bit0 k) = numeral (BitM k)"
   "pred_numeral (Bit1 k) = numeral (Bit0 k)"
   by (simp_all only: pred_numeral_def eval_nat_numeral diff_Suc_Suc diff_0)
 
 lemma pred_numeral_inc [simp]:
   "pred_numeral (Num.inc k) = numeral k"
   by (simp only: pred_numeral_def numeral_inc diff_add_inverse2)
 
 lemma numeral_2_eq_2: "2 = Suc (Suc 0)"
   by (simp add: eval_nat_numeral)
 
 lemma numeral_3_eq_3: "3 = Suc (Suc (Suc 0))"
   by (simp add: eval_nat_numeral)
 
 lemma numeral_1_eq_Suc_0: "Numeral1 = Suc 0"
   by (simp only: numeral_One One_nat_def)
 
 lemma Suc_nat_number_of_add: "Suc (numeral v + n) = numeral (v + One) + n"
   by simp
 
 lemma numerals: "Numeral1 = (1::nat)" "2 = Suc (Suc 0)"
   by (rule numeral_One) (rule numeral_2_eq_2)
 
 lemmas numeral_nat = eval_nat_numeral BitM.simps One_nat_def
 
 text \<open>Comparisons involving \<^term>\<open>Suc\<close>.\<close>
 
 lemma eq_numeral_Suc [simp]: "numeral k = Suc n \<longleftrightarrow> pred_numeral k = n"
   by (simp add: numeral_eq_Suc)
 
 lemma Suc_eq_numeral [simp]: "Suc n = numeral k \<longleftrightarrow> n = pred_numeral k"
   by (simp add: numeral_eq_Suc)
 
 lemma less_numeral_Suc [simp]: "numeral k < Suc n \<longleftrightarrow> pred_numeral k < n"
   by (simp add: numeral_eq_Suc)
 
 lemma less_Suc_numeral [simp]: "Suc n < numeral k \<longleftrightarrow> n < pred_numeral k"
   by (simp add: numeral_eq_Suc)
 
 lemma le_numeral_Suc [simp]: "numeral k \<le> Suc n \<longleftrightarrow> pred_numeral k \<le> n"
   by (simp add: numeral_eq_Suc)
 
 lemma le_Suc_numeral [simp]: "Suc n \<le> numeral k \<longleftrightarrow> n \<le> pred_numeral k"
   by (simp add: numeral_eq_Suc)
 
 lemma diff_Suc_numeral [simp]: "Suc n - numeral k = n - pred_numeral k"
   by (simp add: numeral_eq_Suc)
 
 lemma diff_numeral_Suc [simp]: "numeral k - Suc n = pred_numeral k - n"
   by (simp add: numeral_eq_Suc)
 
 lemma max_Suc_numeral [simp]: "max (Suc n) (numeral k) = Suc (max n (pred_numeral k))"
   by (simp add: numeral_eq_Suc)
 
 lemma max_numeral_Suc [simp]: "max (numeral k) (Suc n) = Suc (max (pred_numeral k) n)"
   by (simp add: numeral_eq_Suc)
 
 lemma min_Suc_numeral [simp]: "min (Suc n) (numeral k) = Suc (min n (pred_numeral k))"
   by (simp add: numeral_eq_Suc)
 
 lemma min_numeral_Suc [simp]: "min (numeral k) (Suc n) = Suc (min (pred_numeral k) n)"
   by (simp add: numeral_eq_Suc)
 
 text \<open>For \<^term>\<open>case_nat\<close> and \<^term>\<open>rec_nat\<close>.\<close>
 
 lemma case_nat_numeral [simp]: "case_nat a f (numeral v) = (let pv = pred_numeral v in f pv)"
   by (simp add: numeral_eq_Suc)
 
 lemma case_nat_add_eq_if [simp]:
   "case_nat a f ((numeral v) + n) = (let pv = pred_numeral v in f (pv + n))"
   by (simp add: numeral_eq_Suc)
 
 lemma rec_nat_numeral [simp]:
   "rec_nat a f (numeral v) = (let pv = pred_numeral v in f pv (rec_nat a f pv))"
   by (simp add: numeral_eq_Suc Let_def)
 
 lemma rec_nat_add_eq_if [simp]:
   "rec_nat a f (numeral v + n) = (let pv = pred_numeral v in f (pv + n) (rec_nat a f (pv + n)))"
   by (simp add: numeral_eq_Suc Let_def)
 
 text \<open>Case analysis on \<^term>\<open>n < 2\<close>.\<close>
 lemma less_2_cases: "n < 2 \<Longrightarrow> n = 0 \<or> n = Suc 0"
   by (auto simp add: numeral_2_eq_2)
 
 lemma less_2_cases_iff: "n < 2 \<longleftrightarrow> n = 0 \<or> n = Suc 0"
   by (auto simp add: numeral_2_eq_2)
 
 text \<open>Removal of Small Numerals: 0, 1 and (in additive positions) 2.\<close>
 text \<open>bh: Are these rules really a good idea? LCP: well, it already happens for 0 and 1!\<close>
 
 lemma add_2_eq_Suc [simp]: "2 + n = Suc (Suc n)"
   by simp
 
 lemma add_2_eq_Suc' [simp]: "n + 2 = Suc (Suc n)"
   by simp
 
 text \<open>Can be used to eliminate long strings of Sucs, but not by default.\<close>
 lemma Suc3_eq_add_3: "Suc (Suc (Suc n)) = 3 + n"
   by simp
 
 lemmas nat_1_add_1 = one_add_one [where 'a=nat] (* legacy *)
 
 context semiring_numeral
 begin
 
 lemma numeral_add_unfold_funpow:
   \<open>numeral k + a = ((+) 1 ^^ numeral k) a\<close>
 proof (rule sym, induction k arbitrary: a)
   case One
   then show ?case
     by (simp add: numeral_One Num.numeral_One)
 next
   case (Bit0 k)
   then show ?case
     by (simp add: numeral_Bit0 Num.numeral_Bit0 ac_simps funpow_add)
 next
   case (Bit1 k)
   then show ?case
     by (simp add: numeral_Bit1 Num.numeral_Bit1 ac_simps funpow_add)
 qed
 
 end
 
 context semiring_1
 begin
 
 lemma numeral_unfold_funpow:
   \<open>numeral k = ((+) 1 ^^ numeral k) 0\<close>
   using numeral_add_unfold_funpow [of k 0] by simp
 
 end
 
 context
   includes lifting_syntax
 begin
 
 lemma transfer_rule_numeral:
   \<open>((=) ===> R) numeral numeral\<close>
     if [transfer_rule]: \<open>R 0 0\<close> \<open>R 1 1\<close>
       \<open>(R ===> R ===> R) (+) (+)\<close>
     for R :: \<open>'a::{semiring_numeral,monoid_add} \<Rightarrow> 'b::{semiring_numeral,monoid_add} \<Rightarrow> bool\<close>
 proof -
   have "((=) ===> R) (\<lambda>k. ((+) 1 ^^ numeral k) 0) (\<lambda>k. ((+) 1 ^^ numeral k) 0)"
     by transfer_prover
   moreover have \<open>numeral = (\<lambda>k. ((+) (1::'a) ^^ numeral k) 0)\<close>
     using numeral_add_unfold_funpow [where ?'a = 'a, of _ 0]
     by (simp add: fun_eq_iff)
   moreover have \<open>numeral = (\<lambda>k. ((+) (1::'b) ^^ numeral k) 0)\<close>
     using numeral_add_unfold_funpow [where ?'a = 'b, of _ 0]
     by (simp add: fun_eq_iff)
   ultimately show ?thesis
     by simp
 qed
 
 end
 
 
 subsection \<open>Particular lemmas concerning \<^term>\<open>2\<close>\<close>
 
 context linordered_field
 begin
 
 subclass field_char_0 ..
 
 lemma half_gt_zero_iff: "0 < a / 2 \<longleftrightarrow> 0 < a"
   by (auto simp add: field_simps)
 
 lemma half_gt_zero [simp]: "0 < a \<Longrightarrow> 0 < a / 2"
   by (simp add: half_gt_zero_iff)
 
 end
 
 
 subsection \<open>Numeral equations as default simplification rules\<close>
 
 declare (in numeral) numeral_One [simp]
 declare (in numeral) numeral_plus_numeral [simp]
 declare (in numeral) add_numeral_special [simp]
 declare (in neg_numeral) add_neg_numeral_simps [simp]
 declare (in neg_numeral) add_neg_numeral_special [simp]
 declare (in neg_numeral) diff_numeral_simps [simp]
 declare (in neg_numeral) diff_numeral_special [simp]
 declare (in semiring_numeral) numeral_times_numeral [simp]
 declare (in ring_1) mult_neg_numeral_simps [simp]
 
 
 subsubsection \<open>Special Simplification for Constants\<close>
 
 text \<open>These distributive laws move literals inside sums and differences.\<close>
 
 lemmas distrib_right_numeral [simp] = distrib_right [of _ _ "numeral v"] for v
 lemmas distrib_left_numeral [simp] = distrib_left [of "numeral v"] for v
 lemmas left_diff_distrib_numeral [simp] = left_diff_distrib [of _ _ "numeral v"] for v
 lemmas right_diff_distrib_numeral [simp] = right_diff_distrib [of "numeral v"] for v
 
 text \<open>These are actually for fields, like real\<close>
 
 lemmas zero_less_divide_iff_numeral [simp, no_atp] = zero_less_divide_iff [of "numeral w"] for w
 lemmas divide_less_0_iff_numeral [simp, no_atp] = divide_less_0_iff [of "numeral w"] for w
 lemmas zero_le_divide_iff_numeral [simp, no_atp] = zero_le_divide_iff [of "numeral w"] for w
 lemmas divide_le_0_iff_numeral [simp, no_atp] = divide_le_0_iff [of "numeral w"] for w
 
 text \<open>Replaces \<open>inverse #nn\<close> by \<open>1/#nn\<close>.  It looks
   strange, but then other simprocs simplify the quotient.\<close>
 
 lemmas inverse_eq_divide_numeral [simp] =
   inverse_eq_divide [of "numeral w"] for w
 
 lemmas inverse_eq_divide_neg_numeral [simp] =
   inverse_eq_divide [of "- numeral w"] for w
 
 text \<open>These laws simplify inequalities, moving unary minus from a term
   into the literal.\<close>
 
 lemmas equation_minus_iff_numeral [no_atp] =
   equation_minus_iff [of "numeral v"] for v
 
 lemmas minus_equation_iff_numeral [no_atp] =
   minus_equation_iff [of _ "numeral v"] for v
 
 lemmas le_minus_iff_numeral [no_atp] =
   le_minus_iff [of "numeral v"] for v
 
 lemmas minus_le_iff_numeral [no_atp] =
   minus_le_iff [of _ "numeral v"] for v
 
 lemmas less_minus_iff_numeral [no_atp] =
   less_minus_iff [of "numeral v"] for v
 
 lemmas minus_less_iff_numeral [no_atp] =
   minus_less_iff [of _ "numeral v"] for v
 
 (* FIXME maybe simproc *)
 
 text \<open>Cancellation of constant factors in comparisons (\<open><\<close> and \<open>\<le>\<close>)\<close>
 
 lemmas mult_less_cancel_left_numeral [simp, no_atp] = mult_less_cancel_left [of "numeral v"] for v
 lemmas mult_less_cancel_right_numeral [simp, no_atp] = mult_less_cancel_right [of _ "numeral v"] for v
 lemmas mult_le_cancel_left_numeral [simp, no_atp] = mult_le_cancel_left [of "numeral v"] for v
 lemmas mult_le_cancel_right_numeral [simp, no_atp] = mult_le_cancel_right [of _ "numeral v"] for v
 
 text \<open>Multiplying out constant divisors in comparisons (\<open><\<close>, \<open>\<le>\<close> and \<open>=\<close>)\<close>
 
 named_theorems divide_const_simps "simplification rules to simplify comparisons involving constant divisors"
 
 lemmas le_divide_eq_numeral1 [simp,divide_const_simps] =
   pos_le_divide_eq [of "numeral w", OF zero_less_numeral]
   neg_le_divide_eq [of "- numeral w", OF neg_numeral_less_zero] for w
 
 lemmas divide_le_eq_numeral1 [simp,divide_const_simps] =
   pos_divide_le_eq [of "numeral w", OF zero_less_numeral]
   neg_divide_le_eq [of "- numeral w", OF neg_numeral_less_zero] for w
 
 lemmas less_divide_eq_numeral1 [simp,divide_const_simps] =
   pos_less_divide_eq [of "numeral w", OF zero_less_numeral]
   neg_less_divide_eq [of "- numeral w", OF neg_numeral_less_zero] for w
 
 lemmas divide_less_eq_numeral1 [simp,divide_const_simps] =
   pos_divide_less_eq [of "numeral w", OF zero_less_numeral]
   neg_divide_less_eq [of "- numeral w", OF neg_numeral_less_zero] for w
 
 lemmas eq_divide_eq_numeral1 [simp,divide_const_simps] =
   eq_divide_eq [of _ _ "numeral w"]
   eq_divide_eq [of _ _ "- numeral w"] for w
 
 lemmas divide_eq_eq_numeral1 [simp,divide_const_simps] =
   divide_eq_eq [of _ "numeral w"]
   divide_eq_eq [of _ "- numeral w"] for w
 
 
 subsubsection \<open>Optional Simplification Rules Involving Constants\<close>
 
 text \<open>Simplify quotients that are compared with a literal constant.\<close>
 
 lemmas le_divide_eq_numeral [divide_const_simps] =
   le_divide_eq [of "numeral w"]
   le_divide_eq [of "- numeral w"] for w
 
 lemmas divide_le_eq_numeral [divide_const_simps] =
   divide_le_eq [of _ _ "numeral w"]
   divide_le_eq [of _ _ "- numeral w"] for w
 
 lemmas less_divide_eq_numeral [divide_const_simps] =
   less_divide_eq [of "numeral w"]
   less_divide_eq [of "- numeral w"] for w
 
 lemmas divide_less_eq_numeral [divide_const_simps] =
   divide_less_eq [of _ _ "numeral w"]
   divide_less_eq [of _ _ "- numeral w"] for w
 
 lemmas eq_divide_eq_numeral [divide_const_simps] =
   eq_divide_eq [of "numeral w"]
   eq_divide_eq [of "- numeral w"] for w
 
 lemmas divide_eq_eq_numeral [divide_const_simps] =
   divide_eq_eq [of _ _ "numeral w"]
   divide_eq_eq [of _ _ "- numeral w"] for w
 
 text \<open>Not good as automatic simprules because they cause case splits.\<close>
 
 lemmas [divide_const_simps] =
   le_divide_eq_1 divide_le_eq_1 less_divide_eq_1 divide_less_eq_1
 
 
 subsection \<open>Setting up simprocs\<close>
 
 lemma mult_numeral_1: "Numeral1 * a = a"
   for a :: "'a::semiring_numeral"
   by simp
 
 lemma mult_numeral_1_right: "a * Numeral1 = a"
   for a :: "'a::semiring_numeral"
   by simp
 
 lemma divide_numeral_1: "a / Numeral1 = a"
   for a :: "'a::field"
   by simp
 
 lemma inverse_numeral_1: "inverse Numeral1 = (Numeral1::'a::division_ring)"
   by simp
 
 text \<open>
   Theorem lists for the cancellation simprocs. The use of a binary
   numeral for 1 reduces the number of special cases.
 \<close>
 
 lemma mult_1s_semiring_numeral:
   "Numeral1 * a = a"
   "a * Numeral1 = a"
   for a :: "'a::semiring_numeral"
   by simp_all
 
 lemma mult_1s_ring_1:
   "- Numeral1 * b = - b"
   "b * - Numeral1 = - b"
   for b :: "'a::ring_1"
   by simp_all
 
 lemmas mult_1s = mult_1s_semiring_numeral mult_1s_ring_1
 
 setup \<open>
   Reorient_Proc.add
     (fn Const (\<^const_name>\<open>numeral\<close>, _) $ _ => true
       | Const (\<^const_name>\<open>uminus\<close>, _) $ (Const (\<^const_name>\<open>numeral\<close>, _) $ _) => true
       | _ => false)
 \<close>
 
 simproc_setup reorient_numeral ("numeral w = x" | "- numeral w = y") =
-  Reorient_Proc.proc
+  \<open>K Reorient_Proc.proc\<close>
 
 
 subsubsection \<open>Simplification of arithmetic operations on integer constants\<close>
 
 lemmas arith_special = (* already declared simp above *)
   add_numeral_special add_neg_numeral_special
   diff_numeral_special
 
 lemmas arith_extra_simps = (* rules already in simpset *)
   numeral_plus_numeral add_neg_numeral_simps add_0_left add_0_right
   minus_zero
   diff_numeral_simps diff_0 diff_0_right
   numeral_times_numeral mult_neg_numeral_simps
   mult_zero_left mult_zero_right
   abs_numeral abs_neg_numeral
 
 text \<open>
   For making a minimal simpset, one must include these default simprules.
   Also include \<open>simp_thms\<close>.
 \<close>
 
 lemmas arith_simps =
   add_num_simps mult_num_simps sub_num_simps
   BitM.simps dbl_simps dbl_inc_simps dbl_dec_simps
   abs_zero abs_one arith_extra_simps
 
 lemmas more_arith_simps =
   neg_le_iff_le
   minus_zero left_minus right_minus
   mult_1_left mult_1_right
   mult_minus_left mult_minus_right
   minus_add_distrib minus_minus mult.assoc
 
 lemmas of_nat_simps =
   of_nat_0 of_nat_1 of_nat_Suc of_nat_add of_nat_mult
 
 text \<open>Simplification of relational operations.\<close>
 
 lemmas eq_numeral_extra =
   zero_neq_one one_neq_zero
 
 lemmas rel_simps =
   le_num_simps less_num_simps eq_num_simps
   le_numeral_simps le_neg_numeral_simps le_minus_one_simps le_numeral_extra
   less_numeral_simps less_neg_numeral_simps less_minus_one_simps less_numeral_extra
   eq_numeral_simps eq_neg_numeral_simps eq_numeral_extra
 
 lemma Let_numeral [simp]: "Let (numeral v) f = f (numeral v)"
   \<comment> \<open>Unfold all \<open>let\<close>s involving constants\<close>
   unfolding Let_def ..
 
 lemma Let_neg_numeral [simp]: "Let (- numeral v) f = f (- numeral v)"
   \<comment> \<open>Unfold all \<open>let\<close>s involving constants\<close>
   unfolding Let_def ..
 
 declaration \<open>
 let
   fun number_of ctxt T n =
     if not (Sign.of_sort (Proof_Context.theory_of ctxt) (T, \<^sort>\<open>numeral\<close>))
     then raise CTERM ("number_of", [])
     else Numeral.mk_cnumber (Thm.ctyp_of ctxt T) n;
 in
   K (
     Lin_Arith.set_number_of number_of
     #> Lin_Arith.add_simps
       @{thms arith_simps more_arith_simps rel_simps pred_numeral_simps
         arith_special numeral_One of_nat_simps uminus_numeral_One
         Suc_numeral Let_numeral Let_neg_numeral Let_0 Let_1
         le_Suc_numeral le_numeral_Suc less_Suc_numeral less_numeral_Suc
         Suc_eq_numeral eq_numeral_Suc mult_Suc mult_Suc_right of_nat_numeral})
 end
 \<close>
 
 
 subsubsection \<open>Simplification of arithmetic when nested to the right\<close>
 
 lemma add_numeral_left [simp]: "numeral v + (numeral w + z) = (numeral(v + w) + z)"
   by (simp_all add: add.assoc [symmetric])
 
 lemma add_neg_numeral_left [simp]:
   "numeral v + (- numeral w + y) = (sub v w + y)"
   "- numeral v + (numeral w + y) = (sub w v + y)"
   "- numeral v + (- numeral w + y) = (- numeral(v + w) + y)"
   by (simp_all add: add.assoc [symmetric])
 
 lemma mult_numeral_left_semiring_numeral:
   "numeral v * (numeral w * z) = (numeral(v * w) * z :: 'a::semiring_numeral)"
   by (simp add: mult.assoc [symmetric])
 
 lemma mult_numeral_left_ring_1:
   "- numeral v * (numeral w * y) = (- numeral(v * w) * y :: 'a::ring_1)"
   "numeral v * (- numeral w * y) = (- numeral(v * w) * y :: 'a::ring_1)"
   "- numeral v * (- numeral w * y) = (numeral(v * w) * y :: 'a::ring_1)"
   by (simp_all add: mult.assoc [symmetric])
 
 lemmas mult_numeral_left [simp] =
   mult_numeral_left_semiring_numeral
   mult_numeral_left_ring_1
 
 hide_const (open) One Bit0 Bit1 BitM inc pow sqr sub dbl dbl_inc dbl_dec
 
 
 subsection \<open>Code module namespace\<close>
 
 code_identifier
   code_module Num \<rightharpoonup> (SML) Arith and (OCaml) Arith and (Haskell) Arith
 
 subsection \<open>Printing of evaluated natural numbers as numerals\<close>
 
 lemma [code_post]:
   "Suc 0 = 1"
   "Suc 1 = 2"
   "Suc (numeral n) = numeral (Num.inc n)"
   by (simp_all add: numeral_inc)
 
 lemmas [code_post] = Num.inc.simps
 
 
 subsection \<open>More on auxiliary conversion\<close>
 
 context semiring_1
 begin
 
 lemma numeral_num_of_nat_unfold:
   \<open>numeral (num_of_nat n) = (if n = 0 then 1 else of_nat n)\<close>
   by (induction n) (simp_all add: numeral_inc ac_simps)
 
 lemma num_of_nat_numeral_eq [simp]:
   \<open>num_of_nat (numeral q) = q\<close>
 proof (induction q)
   case One
   then show ?case
     by simp
 next
   case (Bit0 q)
   then have "num_of_nat (numeral (num.Bit0 q)) = num_of_nat (numeral q + numeral q)"
     by (simp only: Num.numeral_Bit0 Num.numeral_add)
   also have "\<dots> = num.Bit0 (num_of_nat (numeral q))"
     by (rule num_of_nat_double) simp
   finally show ?case
     using Bit0.IH by simp
 next
   case (Bit1 q)
   then have "num_of_nat (numeral (num.Bit1 q)) = num_of_nat (numeral q + numeral q + 1)"
     by (simp only: Num.numeral_Bit1 Num.numeral_add)
   also have "\<dots> = num_of_nat (numeral q + numeral q) + num_of_nat 1"
     by (rule num_of_nat_plus_distrib) auto
   also have "\<dots> = num.Bit0 (num_of_nat (numeral q)) + num_of_nat 1"
     by (subst num_of_nat_double) auto
   finally show ?case
     using Bit1.IH by simp
 qed
 
 end
 
 end
diff --git a/src/HOL/Numeral_Simprocs.thy b/src/HOL/Numeral_Simprocs.thy
--- a/src/HOL/Numeral_Simprocs.thy
+++ b/src/HOL/Numeral_Simprocs.thy
@@ -1,299 +1,299 @@
 (* Author: Various *)
 
 section \<open>Combination and Cancellation Simprocs for Numeral Expressions\<close>
 
 theory Numeral_Simprocs
 imports Parity
 begin
 
 ML_file \<open>~~/src/Provers/Arith/assoc_fold.ML\<close>
 ML_file \<open>~~/src/Provers/Arith/cancel_numerals.ML\<close>
 ML_file \<open>~~/src/Provers/Arith/combine_numerals.ML\<close>
 ML_file \<open>~~/src/Provers/Arith/cancel_numeral_factor.ML\<close>
 ML_file \<open>~~/src/Provers/Arith/extract_common_term.ML\<close>
 
 lemmas semiring_norm =
   Let_def arith_simps diff_nat_numeral rel_simps
   if_False if_True
   add_Suc add_numeral_left
   add_neg_numeral_left mult_numeral_left
   numeral_One [symmetric] uminus_numeral_One [symmetric] Suc_eq_plus1
   eq_numeral_iff_iszero not_iszero_Numeral1
 
 text \<open>For \<open>combine_numerals\<close>\<close>
 
 lemma left_add_mult_distrib: "i*u + (j*u + k) = (i+j)*u + (k::nat)"
 by (simp add: add_mult_distrib)
 
 text \<open>For \<open>cancel_numerals\<close>\<close>
 
 lemma nat_diff_add_eq1:
      "j <= (i::nat) ==> ((i*u + m) - (j*u + n)) = (((i-j)*u + m) - n)"
 by (simp split: nat_diff_split add: add_mult_distrib)
 
 lemma nat_diff_add_eq2:
      "i <= (j::nat) ==> ((i*u + m) - (j*u + n)) = (m - ((j-i)*u + n))"
 by (simp split: nat_diff_split add: add_mult_distrib)
 
 lemma nat_eq_add_iff1:
      "j <= (i::nat) ==> (i*u + m = j*u + n) = ((i-j)*u + m = n)"
 by (auto split: nat_diff_split simp add: add_mult_distrib)
 
 lemma nat_eq_add_iff2:
      "i <= (j::nat) ==> (i*u + m = j*u + n) = (m = (j-i)*u + n)"
 by (auto split: nat_diff_split simp add: add_mult_distrib)
 
 lemma nat_less_add_iff1:
      "j <= (i::nat) ==> (i*u + m < j*u + n) = ((i-j)*u + m < n)"
 by (auto split: nat_diff_split simp add: add_mult_distrib)
 
 lemma nat_less_add_iff2:
      "i <= (j::nat) ==> (i*u + m < j*u + n) = (m < (j-i)*u + n)"
 by (auto split: nat_diff_split simp add: add_mult_distrib)
 
 lemma nat_le_add_iff1:
      "j <= (i::nat) ==> (i*u + m <= j*u + n) = ((i-j)*u + m <= n)"
 by (auto split: nat_diff_split simp add: add_mult_distrib)
 
 lemma nat_le_add_iff2:
      "i <= (j::nat) ==> (i*u + m <= j*u + n) = (m <= (j-i)*u + n)"
 by (auto split: nat_diff_split simp add: add_mult_distrib)
 
 text \<open>For \<open>cancel_numeral_factors\<close>\<close>
 
 lemma nat_mult_le_cancel1: "(0::nat) < k ==> (k*m <= k*n) = (m<=n)"
 by auto
 
 lemma nat_mult_less_cancel1: "(0::nat) < k ==> (k*m < k*n) = (m<n)"
 by auto
 
 lemma nat_mult_eq_cancel1: "(0::nat) < k ==> (k*m = k*n) = (m=n)"
 by auto
 
 lemma nat_mult_div_cancel1: "(0::nat) < k ==> (k*m) div (k*n) = (m div n)"
 by auto
 
 lemma nat_mult_dvd_cancel_disj[simp]:
   "(k*m) dvd (k*n) = (k=0 \<or> m dvd (n::nat))"
 by (auto simp: dvd_eq_mod_eq_0 mod_mult_mult1)
 
 lemma nat_mult_dvd_cancel1: "0 < k \<Longrightarrow> (k*m) dvd (k*n::nat) = (m dvd n)"
 by(auto)
 
 text \<open>For \<open>cancel_factor\<close>\<close>
 
 lemmas nat_mult_le_cancel_disj = mult_le_cancel1
 
 lemmas nat_mult_less_cancel_disj = mult_less_cancel1
 
 lemma nat_mult_eq_cancel_disj:
   fixes k m n :: nat
   shows "k * m = k * n \<longleftrightarrow> k = 0 \<or> m = n"
   by (fact mult_cancel_left)
 
 lemma nat_mult_div_cancel_disj:
   fixes k m n :: nat
   shows "(k * m) div (k * n) = (if k = 0 then 0 else m div n)"
   by (fact div_mult_mult1_if)
 
 lemma numeral_times_minus_swap:
   fixes x:: "'a::comm_ring_1" shows  "numeral w * -x = x * - numeral w"
   by (simp add: ac_simps)
 
 ML_file \<open>Tools/numeral_simprocs.ML\<close>
 
 simproc_setup semiring_assoc_fold
   ("(a::'a::comm_semiring_1_cancel) * b") =
-  \<open>fn phi => Numeral_Simprocs.assoc_fold\<close>
+  \<open>K Numeral_Simprocs.assoc_fold\<close>
 
 (* TODO: see whether the type class can be generalized further *)
 simproc_setup int_combine_numerals
   ("(i::'a::comm_ring_1) + j" | "(i::'a::comm_ring_1) - j") =
-  \<open>fn phi => Numeral_Simprocs.combine_numerals\<close>
+  \<open>K Numeral_Simprocs.combine_numerals\<close>
 
 simproc_setup field_combine_numerals
   ("(i::'a::{field,ring_char_0}) + j"
   |"(i::'a::{field,ring_char_0}) - j") =
-  \<open>fn phi => Numeral_Simprocs.field_combine_numerals\<close>
+  \<open>K Numeral_Simprocs.field_combine_numerals\<close>
 
 simproc_setup inteq_cancel_numerals
   ("(l::'a::comm_ring_1) + m = n"
   |"(l::'a::comm_ring_1) = m + n"
   |"(l::'a::comm_ring_1) - m = n"
   |"(l::'a::comm_ring_1) = m - n"
   |"(l::'a::comm_ring_1) * m = n"
   |"(l::'a::comm_ring_1) = m * n"
   |"- (l::'a::comm_ring_1) = m"
   |"(l::'a::comm_ring_1) = - m") =
-  \<open>fn phi => Numeral_Simprocs.eq_cancel_numerals\<close>
+  \<open>K Numeral_Simprocs.eq_cancel_numerals\<close>
 
 simproc_setup intless_cancel_numerals
   ("(l::'a::linordered_idom) + m < n"
   |"(l::'a::linordered_idom) < m + n"
   |"(l::'a::linordered_idom) - m < n"
   |"(l::'a::linordered_idom) < m - n"
   |"(l::'a::linordered_idom) * m < n"
   |"(l::'a::linordered_idom) < m * n"
   |"- (l::'a::linordered_idom) < m"
   |"(l::'a::linordered_idom) < - m") =
-  \<open>fn phi => Numeral_Simprocs.less_cancel_numerals\<close>
+  \<open>K Numeral_Simprocs.less_cancel_numerals\<close>
 
 simproc_setup intle_cancel_numerals
   ("(l::'a::linordered_idom) + m \<le> n"
   |"(l::'a::linordered_idom) \<le> m + n"
   |"(l::'a::linordered_idom) - m \<le> n"
   |"(l::'a::linordered_idom) \<le> m - n"
   |"(l::'a::linordered_idom) * m \<le> n"
   |"(l::'a::linordered_idom) \<le> m * n"
   |"- (l::'a::linordered_idom) \<le> m"
   |"(l::'a::linordered_idom) \<le> - m") =
-  \<open>fn phi => Numeral_Simprocs.le_cancel_numerals\<close>
+  \<open>K Numeral_Simprocs.le_cancel_numerals\<close>
 
 simproc_setup ring_eq_cancel_numeral_factor
   ("(l::'a::{idom,ring_char_0}) * m = n"
   |"(l::'a::{idom,ring_char_0}) = m * n") =
-  \<open>fn phi => Numeral_Simprocs.eq_cancel_numeral_factor\<close>
+  \<open>K Numeral_Simprocs.eq_cancel_numeral_factor\<close>
 
 simproc_setup ring_less_cancel_numeral_factor
   ("(l::'a::linordered_idom) * m < n"
   |"(l::'a::linordered_idom) < m * n") =
-  \<open>fn phi => Numeral_Simprocs.less_cancel_numeral_factor\<close>
+  \<open>K Numeral_Simprocs.less_cancel_numeral_factor\<close>
 
 simproc_setup ring_le_cancel_numeral_factor
   ("(l::'a::linordered_idom) * m <= n"
   |"(l::'a::linordered_idom) <= m * n") =
-  \<open>fn phi => Numeral_Simprocs.le_cancel_numeral_factor\<close>
+  \<open>K Numeral_Simprocs.le_cancel_numeral_factor\<close>
 
 (* TODO: remove comm_ring_1 constraint if possible *)
 simproc_setup int_div_cancel_numeral_factors
   ("((l::'a::{euclidean_semiring_cancel,comm_ring_1,ring_char_0}) * m) div n"
   |"(l::'a::{euclidean_semiring_cancel,comm_ring_1,ring_char_0}) div (m * n)") =
-  \<open>fn phi => Numeral_Simprocs.div_cancel_numeral_factor\<close>
+  \<open>K Numeral_Simprocs.div_cancel_numeral_factor\<close>
 
 simproc_setup divide_cancel_numeral_factor
   ("((l::'a::{field,ring_char_0}) * m) / n"
   |"(l::'a::{field,ring_char_0}) / (m * n)"
   |"((numeral v)::'a::{field,ring_char_0}) / (numeral w)") =
-  \<open>fn phi => Numeral_Simprocs.divide_cancel_numeral_factor\<close>
+  \<open>K Numeral_Simprocs.divide_cancel_numeral_factor\<close>
 
 simproc_setup ring_eq_cancel_factor
   ("(l::'a::idom) * m = n" | "(l::'a::idom) = m * n") =
-  \<open>fn phi => Numeral_Simprocs.eq_cancel_factor\<close>
+  \<open>K Numeral_Simprocs.eq_cancel_factor\<close>
 
 simproc_setup linordered_ring_le_cancel_factor
   ("(l::'a::linordered_idom) * m <= n"
   |"(l::'a::linordered_idom) <= m * n") =
-  \<open>fn phi => Numeral_Simprocs.le_cancel_factor\<close>
+  \<open>K Numeral_Simprocs.le_cancel_factor\<close>
 
 simproc_setup linordered_ring_less_cancel_factor
   ("(l::'a::linordered_idom) * m < n"
   |"(l::'a::linordered_idom) < m * n") =
-  \<open>fn phi => Numeral_Simprocs.less_cancel_factor\<close>
+  \<open>K Numeral_Simprocs.less_cancel_factor\<close>
 
 simproc_setup int_div_cancel_factor
   ("((l::'a::euclidean_semiring_cancel) * m) div n"
   |"(l::'a::euclidean_semiring_cancel) div (m * n)") =
-  \<open>fn phi => Numeral_Simprocs.div_cancel_factor\<close>
+  \<open>K Numeral_Simprocs.div_cancel_factor\<close>
 
 simproc_setup int_mod_cancel_factor
   ("((l::'a::euclidean_semiring_cancel) * m) mod n"
   |"(l::'a::euclidean_semiring_cancel) mod (m * n)") =
-  \<open>fn phi => Numeral_Simprocs.mod_cancel_factor\<close>
+  \<open>K Numeral_Simprocs.mod_cancel_factor\<close>
 
 simproc_setup dvd_cancel_factor
   ("((l::'a::idom) * m) dvd n"
   |"(l::'a::idom) dvd (m * n)") =
-  \<open>fn phi => Numeral_Simprocs.dvd_cancel_factor\<close>
+  \<open>K Numeral_Simprocs.dvd_cancel_factor\<close>
 
 simproc_setup divide_cancel_factor
   ("((l::'a::field) * m) / n"
   |"(l::'a::field) / (m * n)") =
-  \<open>fn phi => Numeral_Simprocs.divide_cancel_factor\<close>
+  \<open>K Numeral_Simprocs.divide_cancel_factor\<close>
 
 ML_file \<open>Tools/nat_numeral_simprocs.ML\<close>
 
 simproc_setup nat_combine_numerals
   ("(i::nat) + j" | "Suc (i + j)") =
-  \<open>fn phi => Nat_Numeral_Simprocs.combine_numerals\<close>
+  \<open>K Nat_Numeral_Simprocs.combine_numerals\<close>
 
 simproc_setup nateq_cancel_numerals
   ("(l::nat) + m = n" | "(l::nat) = m + n" |
    "(l::nat) * m = n" | "(l::nat) = m * n" |
    "Suc m = n" | "m = Suc n") =
-  \<open>fn phi => Nat_Numeral_Simprocs.eq_cancel_numerals\<close>
+  \<open>K Nat_Numeral_Simprocs.eq_cancel_numerals\<close>
 
 simproc_setup natless_cancel_numerals
   ("(l::nat) + m < n" | "(l::nat) < m + n" |
    "(l::nat) * m < n" | "(l::nat) < m * n" |
    "Suc m < n" | "m < Suc n") =
-  \<open>fn phi => Nat_Numeral_Simprocs.less_cancel_numerals\<close>
+  \<open>K Nat_Numeral_Simprocs.less_cancel_numerals\<close>
 
 simproc_setup natle_cancel_numerals
   ("(l::nat) + m \<le> n" | "(l::nat) \<le> m + n" |
    "(l::nat) * m \<le> n" | "(l::nat) \<le> m * n" |
    "Suc m \<le> n" | "m \<le> Suc n") =
-  \<open>fn phi => Nat_Numeral_Simprocs.le_cancel_numerals\<close>
+  \<open>K Nat_Numeral_Simprocs.le_cancel_numerals\<close>
 
 simproc_setup natdiff_cancel_numerals
   ("((l::nat) + m) - n" | "(l::nat) - (m + n)" |
    "(l::nat) * m - n" | "(l::nat) - m * n" |
    "Suc m - n" | "m - Suc n") =
-  \<open>fn phi => Nat_Numeral_Simprocs.diff_cancel_numerals\<close>
+  \<open>K Nat_Numeral_Simprocs.diff_cancel_numerals\<close>
 
 simproc_setup nat_eq_cancel_numeral_factor
   ("(l::nat) * m = n" | "(l::nat) = m * n") =
-  \<open>fn phi => Nat_Numeral_Simprocs.eq_cancel_numeral_factor\<close>
+  \<open>K Nat_Numeral_Simprocs.eq_cancel_numeral_factor\<close>
 
 simproc_setup nat_less_cancel_numeral_factor
   ("(l::nat) * m < n" | "(l::nat) < m * n") =
-  \<open>fn phi => Nat_Numeral_Simprocs.less_cancel_numeral_factor\<close>
+  \<open>K Nat_Numeral_Simprocs.less_cancel_numeral_factor\<close>
 
 simproc_setup nat_le_cancel_numeral_factor
   ("(l::nat) * m <= n" | "(l::nat) <= m * n") =
-  \<open>fn phi => Nat_Numeral_Simprocs.le_cancel_numeral_factor\<close>
+  \<open>K Nat_Numeral_Simprocs.le_cancel_numeral_factor\<close>
 
 simproc_setup nat_div_cancel_numeral_factor
   ("((l::nat) * m) div n" | "(l::nat) div (m * n)") =
-  \<open>fn phi => Nat_Numeral_Simprocs.div_cancel_numeral_factor\<close>
+  \<open>K Nat_Numeral_Simprocs.div_cancel_numeral_factor\<close>
 
 simproc_setup nat_dvd_cancel_numeral_factor
   ("((l::nat) * m) dvd n" | "(l::nat) dvd (m * n)") =
-  \<open>fn phi => Nat_Numeral_Simprocs.dvd_cancel_numeral_factor\<close>
+  \<open>K Nat_Numeral_Simprocs.dvd_cancel_numeral_factor\<close>
 
 simproc_setup nat_eq_cancel_factor
   ("(l::nat) * m = n" | "(l::nat) = m * n") =
-  \<open>fn phi => Nat_Numeral_Simprocs.eq_cancel_factor\<close>
+  \<open>K Nat_Numeral_Simprocs.eq_cancel_factor\<close>
 
 simproc_setup nat_less_cancel_factor
   ("(l::nat) * m < n" | "(l::nat) < m * n") =
-  \<open>fn phi => Nat_Numeral_Simprocs.less_cancel_factor\<close>
+  \<open>K Nat_Numeral_Simprocs.less_cancel_factor\<close>
 
 simproc_setup nat_le_cancel_factor
   ("(l::nat) * m <= n" | "(l::nat) <= m * n") =
-  \<open>fn phi => Nat_Numeral_Simprocs.le_cancel_factor\<close>
+  \<open>K Nat_Numeral_Simprocs.le_cancel_factor\<close>
 
 simproc_setup nat_div_cancel_factor
   ("((l::nat) * m) div n" | "(l::nat) div (m * n)") =
-  \<open>fn phi => Nat_Numeral_Simprocs.div_cancel_factor\<close>
+  \<open>K Nat_Numeral_Simprocs.div_cancel_factor\<close>
 
 simproc_setup nat_dvd_cancel_factor
   ("((l::nat) * m) dvd n" | "(l::nat) dvd (m * n)") =
-  \<open>fn phi => Nat_Numeral_Simprocs.dvd_cancel_factor\<close>
+  \<open>K Nat_Numeral_Simprocs.dvd_cancel_factor\<close>
 
 declaration \<open>
   K (Lin_Arith.add_simprocs
       [\<^simproc>\<open>semiring_assoc_fold\<close>,
        \<^simproc>\<open>int_combine_numerals\<close>,
        \<^simproc>\<open>inteq_cancel_numerals\<close>,
        \<^simproc>\<open>intless_cancel_numerals\<close>,
        \<^simproc>\<open>intle_cancel_numerals\<close>,
        \<^simproc>\<open>field_combine_numerals\<close>,
        \<^simproc>\<open>nat_combine_numerals\<close>,
        \<^simproc>\<open>nateq_cancel_numerals\<close>,
        \<^simproc>\<open>natless_cancel_numerals\<close>,
        \<^simproc>\<open>natle_cancel_numerals\<close>,
        \<^simproc>\<open>natdiff_cancel_numerals\<close>,
        Numeral_Simprocs.field_divide_cancel_numeral_factor])
 \<close>
 
 end
diff --git a/src/HOL/Product_Type.thy b/src/HOL/Product_Type.thy
--- a/src/HOL/Product_Type.thy
+++ b/src/HOL/Product_Type.thy
@@ -1,1376 +1,1376 @@
 (*  Title:      HOL/Product_Type.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1992  University of Cambridge
 *)
 
 section \<open>Cartesian products\<close>
 
 theory Product_Type
   imports Typedef Inductive Fun
   keywords "inductive_set" "coinductive_set" :: thy_defn
 begin
 
 subsection \<open>\<^typ>\<open>bool\<close> is a datatype\<close>
 
 free_constructors (discs_sels) case_bool for True | False
   by auto
 
 text \<open>Avoid name clashes by prefixing the output of \<open>old_rep_datatype\<close> with \<open>old\<close>.\<close>
 
 setup \<open>Sign.mandatory_path "old"\<close>
 
 old_rep_datatype True False by (auto intro: bool_induct)
 
 setup \<open>Sign.parent_path\<close>
 
 text \<open>But erase the prefix for properties that are not generated by \<open>free_constructors\<close>.\<close>
 
 setup \<open>Sign.mandatory_path "bool"\<close>
 
 lemmas induct = old.bool.induct
 lemmas inducts = old.bool.inducts
 lemmas rec = old.bool.rec
 lemmas simps = bool.distinct bool.case bool.rec
 
 setup \<open>Sign.parent_path\<close>
 
 declare case_split [cases type: bool]
   \<comment> \<open>prefer plain propositional version\<close>
 
 lemma [code]: "HOL.equal False P \<longleftrightarrow> \<not> P"
   and [code]: "HOL.equal True P \<longleftrightarrow> P"
   and [code]: "HOL.equal P False \<longleftrightarrow> \<not> P"
   and [code]: "HOL.equal P True \<longleftrightarrow> P"
   and [code nbe]: "HOL.equal P P \<longleftrightarrow> True"
   by (simp_all add: equal)
 
 lemma If_case_cert:
   assumes "CASE \<equiv> (\<lambda>b. If b f g)"
   shows "(CASE True \<equiv> f) &&& (CASE False \<equiv> g)"
   using assms by simp_all
 
 setup \<open>Code.declare_case_global @{thm If_case_cert}\<close>
 
 code_printing
   constant "HOL.equal :: bool \<Rightarrow> bool \<Rightarrow> bool" \<rightharpoonup> (Haskell) infix 4 "=="
 | class_instance "bool" :: "equal" \<rightharpoonup> (Haskell) -
 
 
 subsection \<open>The \<open>unit\<close> type\<close>
 
 typedef unit = "{True}"
   by auto
 
 definition Unity :: unit  ("'(')")
   where "() = Abs_unit True"
 
 lemma unit_eq [no_atp]: "u = ()"
   by (induct u) (simp add: Unity_def)
 
 text \<open>
   Simplification procedure for @{thm [source] unit_eq}.  Cannot use
   this rule directly --- it loops!
 \<close>
 
 simproc_setup unit_eq ("x::unit") = \<open>
-  fn _ => fn _ => fn ct =>
+  K (K (fn ct =>
     if HOLogic.is_unit (Thm.term_of ct) then NONE
-    else SOME (mk_meta_eq @{thm unit_eq})
+    else SOME (mk_meta_eq @{thm unit_eq})))
 \<close>
 
 free_constructors case_unit for "()"
   by auto
 
 text \<open>Avoid name clashes by prefixing the output of \<open>old_rep_datatype\<close> with \<open>old\<close>.\<close>
 
 setup \<open>Sign.mandatory_path "old"\<close>
 
 old_rep_datatype "()" by simp
 
 setup \<open>Sign.parent_path\<close>
 
 text \<open>But erase the prefix for properties that are not generated by \<open>free_constructors\<close>.\<close>
 
 setup \<open>Sign.mandatory_path "unit"\<close>
 
 lemmas induct = old.unit.induct
 lemmas inducts = old.unit.inducts
 lemmas rec = old.unit.rec
 lemmas simps = unit.case unit.rec
 
 setup \<open>Sign.parent_path\<close>
 
 lemma unit_all_eq1: "(\<And>x::unit. PROP P x) \<equiv> PROP P ()"
   by simp
 
 lemma unit_all_eq2: "(\<And>x::unit. PROP P) \<equiv> PROP P"
   by (rule triv_forall_equality)
 
 text \<open>
   This rewrite counters the effect of simproc \<open>unit_eq\<close> on @{term
   [source] "\<lambda>u::unit. f u"}, replacing it by @{term [source]
   f} rather than by @{term [source] "\<lambda>u. f ()"}.
 \<close>
 
 lemma unit_abs_eta_conv [simp]: "(\<lambda>u::unit. f ()) = f"
   by (rule ext) simp
 
 lemma UNIV_unit: "UNIV = {()}"
   by auto
 
 instantiation unit :: default
 begin
 
 definition "default = ()"
 
 instance ..
 
 end
 
 instantiation unit :: "{complete_boolean_algebra,complete_linorder,wellorder}"
 begin
 
 definition less_eq_unit :: "unit \<Rightarrow> unit \<Rightarrow> bool"
   where "(_::unit) \<le> _ \<longleftrightarrow> True"
 
 lemma less_eq_unit [iff]: "u \<le> v" for u v :: unit
   by (simp add: less_eq_unit_def)
 
 definition less_unit :: "unit \<Rightarrow> unit \<Rightarrow> bool"
   where "(_::unit) < _ \<longleftrightarrow> False"
 
 lemma less_unit [iff]: "\<not> u < v" for u v :: unit
   by (simp_all add: less_eq_unit_def less_unit_def)
 
 definition bot_unit :: unit
   where [code_unfold]: "\<bottom> = ()"
 
 definition top_unit :: unit
   where [code_unfold]: "\<top> = ()"
 
 definition inf_unit :: "unit \<Rightarrow> unit \<Rightarrow> unit"
   where [simp]: "_ \<sqinter> _ = ()"
 
 definition sup_unit :: "unit \<Rightarrow> unit \<Rightarrow> unit"
   where [simp]: "_ \<squnion> _ = ()"
 
 definition Inf_unit :: "unit set \<Rightarrow> unit"
   where [simp]: "\<Sqinter>_ = ()"
 
 definition Sup_unit :: "unit set \<Rightarrow> unit"
   where [simp]: "\<Squnion>_ = ()"
 
 definition uminus_unit :: "unit \<Rightarrow> unit"
   where [simp]: "- _ = ()"
 
 declare less_eq_unit_def [abs_def, code_unfold]
   less_unit_def [abs_def, code_unfold]
   inf_unit_def [abs_def, code_unfold]
   sup_unit_def [abs_def, code_unfold]
   Inf_unit_def [abs_def, code_unfold]
   Sup_unit_def [abs_def, code_unfold]
   uminus_unit_def [abs_def, code_unfold]
 
 instance
   by intro_classes auto
 
 end
 
 lemma [code]: "HOL.equal u v \<longleftrightarrow> True" for u v :: unit
   unfolding equal unit_eq [of u] unit_eq [of v] by (rule iffI TrueI refl)+
 
 code_printing
   type_constructor unit \<rightharpoonup>
     (SML) "unit"
     and (OCaml) "unit"
     and (Haskell) "()"
     and (Scala) "Unit"
 | constant Unity \<rightharpoonup>
     (SML) "()"
     and (OCaml) "()"
     and (Haskell) "()"
     and (Scala) "()"
 | class_instance unit :: equal \<rightharpoonup>
     (Haskell) -
 | constant "HOL.equal :: unit \<Rightarrow> unit \<Rightarrow> bool" \<rightharpoonup>
     (Haskell) infix 4 "=="
 
 code_reserved SML
   unit
 
 code_reserved OCaml
   unit
 
 code_reserved Scala
   Unit
 
 
 subsection \<open>The product type\<close>
 
 subsubsection \<open>Type definition\<close>
 
 definition Pair_Rep :: "'a \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
   where "Pair_Rep a b = (\<lambda>x y. x = a \<and> y = b)"
 
 definition "prod = {f. \<exists>a b. f = Pair_Rep (a::'a) (b::'b)}"
 
 typedef ('a, 'b) prod ("(_ \<times>/ _)" [21, 20] 20) = "prod :: ('a \<Rightarrow> 'b \<Rightarrow> bool) set"
   unfolding prod_def by auto
 
 type_notation (ASCII)
   prod  (infixr "*" 20)
 
 definition Pair :: "'a \<Rightarrow> 'b \<Rightarrow> 'a \<times> 'b"
   where "Pair a b = Abs_prod (Pair_Rep a b)"
 
 lemma prod_cases: "(\<And>a b. P (Pair a b)) \<Longrightarrow> P p"
   by (cases p) (auto simp add: prod_def Pair_def Pair_Rep_def)
 
 free_constructors case_prod for Pair fst snd
 proof -
   fix P :: bool and p :: "'a \<times> 'b"
   show "(\<And>x1 x2. p = Pair x1 x2 \<Longrightarrow> P) \<Longrightarrow> P"
     by (cases p) (auto simp add: prod_def Pair_def Pair_Rep_def)
 next
   fix a c :: 'a and b d :: 'b
   have "Pair_Rep a b = Pair_Rep c d \<longleftrightarrow> a = c \<and> b = d"
     by (auto simp add: Pair_Rep_def fun_eq_iff)
   moreover have "Pair_Rep a b \<in> prod" and "Pair_Rep c d \<in> prod"
     by (auto simp add: prod_def)
   ultimately show "Pair a b = Pair c d \<longleftrightarrow> a = c \<and> b = d"
     by (simp add: Pair_def Abs_prod_inject)
 qed
 
 text \<open>Avoid name clashes by prefixing the output of \<open>old_rep_datatype\<close> with \<open>old\<close>.\<close>
 
 setup \<open>Sign.mandatory_path "old"\<close>
 
 old_rep_datatype Pair
   by (erule prod_cases) (rule prod.inject)
 
 setup \<open>Sign.parent_path\<close>
 
 text \<open>But erase the prefix for properties that are not generated by \<open>free_constructors\<close>.\<close>
 
 setup \<open>Sign.mandatory_path "prod"\<close>
 
 declare old.prod.inject [iff del]
 
 lemmas induct = old.prod.induct
 lemmas inducts = old.prod.inducts
 lemmas rec = old.prod.rec
 lemmas simps = prod.inject prod.case prod.rec
 
 setup \<open>Sign.parent_path\<close>
 
 declare prod.case [nitpick_simp del]
 declare old.prod.case_cong_weak [cong del]
 declare prod.case_eq_if [mono]
 declare prod.split [no_atp]
 declare prod.split_asm [no_atp]
 
 text \<open>
   @{thm [source] prod.split} could be declared as \<open>[split]\<close>
   done after the Splitter has been speeded up significantly;
   precompute the constants involved and don't do anything unless the
   current goal contains one of those constants.
 \<close>
 
 
 subsubsection \<open>Tuple syntax\<close>
 
 text \<open>
   Patterns -- extends pre-defined type \<^typ>\<open>pttrn\<close> used in
   abstractions.
 \<close>
 
 nonterminal tuple_args and patterns
 syntax
   "_tuple"      :: "'a \<Rightarrow> tuple_args \<Rightarrow> 'a \<times> 'b"        ("(1'(_,/ _'))")
   "_tuple_arg"  :: "'a \<Rightarrow> tuple_args"                   ("_")
   "_tuple_args" :: "'a \<Rightarrow> tuple_args \<Rightarrow> tuple_args"     ("_,/ _")
   "_pattern"    :: "pttrn \<Rightarrow> patterns \<Rightarrow> pttrn"         ("'(_,/ _')")
   ""            :: "pttrn \<Rightarrow> patterns"                  ("_")
   "_patterns"   :: "pttrn \<Rightarrow> patterns \<Rightarrow> patterns"      ("_,/ _")
   "_unit"       :: pttrn                                ("'(')")
 translations
   "(x, y)" \<rightleftharpoons> "CONST Pair x y"
   "_pattern x y" \<rightleftharpoons> "CONST Pair x y"
   "_patterns x y" \<rightleftharpoons> "CONST Pair x y"
   "_tuple x (_tuple_args y z)" \<rightleftharpoons> "_tuple x (_tuple_arg (_tuple y z))"
   "\<lambda>(x, y, zs). b" \<rightleftharpoons> "CONST case_prod (\<lambda>x (y, zs). b)"
   "\<lambda>(x, y). b" \<rightleftharpoons> "CONST case_prod (\<lambda>x y. b)"
   "_abs (CONST Pair x y) t" \<rightharpoonup> "\<lambda>(x, y). t"
   \<comment> \<open>This rule accommodates tuples in \<open>case C \<dots> (x, y) \<dots> \<Rightarrow> \<dots>\<close>:
      The \<open>(x, y)\<close> is parsed as \<open>Pair x y\<close> because it is \<open>logic\<close>,
      not \<open>pttrn\<close>.\<close>
   "\<lambda>(). b" \<rightleftharpoons> "CONST case_unit b"
   "_abs (CONST Unity) t" \<rightharpoonup> "\<lambda>(). t"
 
 text \<open>print \<^term>\<open>case_prod f\<close> as \<^term>\<open>\<lambda>(x, y). f x y\<close> and
   \<^term>\<open>case_prod (\<lambda>x. f x)\<close> as \<^term>\<open>\<lambda>(x, y). f x y\<close>\<close>
 
 typed_print_translation \<open>
   let
     fun case_prod_guess_names_tr' T [Abs (x, _, Abs _)] = raise Match
       | case_prod_guess_names_tr' T [Abs (x, xT, t)] =
           (case (head_of t) of
             Const (\<^const_syntax>\<open>case_prod\<close>, _) => raise Match
           | _ =>
             let
               val (_ :: yT :: _) = binder_types (domain_type T) handle Bind => raise Match;
               val (y, t') = Syntax_Trans.atomic_abs_tr' ("y", yT, incr_boundvars 1 t $ Bound 0);
               val (x', t'') = Syntax_Trans.atomic_abs_tr' (x, xT, t');
             in
               Syntax.const \<^syntax_const>\<open>_abs\<close> $
                 (Syntax.const \<^syntax_const>\<open>_pattern\<close> $ x' $ y) $ t''
             end)
       | case_prod_guess_names_tr' T [t] =
           (case head_of t of
             Const (\<^const_syntax>\<open>case_prod\<close>, _) => raise Match
           | _ =>
             let
               val (xT :: yT :: _) = binder_types (domain_type T) handle Bind => raise Match;
               val (y, t') =
                 Syntax_Trans.atomic_abs_tr' ("y", yT, incr_boundvars 2 t $ Bound 1 $ Bound 0);
               val (x', t'') = Syntax_Trans.atomic_abs_tr' ("x", xT, t');
             in
               Syntax.const \<^syntax_const>\<open>_abs\<close> $
                 (Syntax.const \<^syntax_const>\<open>_pattern\<close> $ x' $ y) $ t''
             end)
       | case_prod_guess_names_tr' _ _ = raise Match;
   in [(\<^const_syntax>\<open>case_prod\<close>, K case_prod_guess_names_tr')] end
 \<close>
 
 text \<open>Reconstruct pattern from (nested) \<^const>\<open>case_prod\<close>s,
   avoiding eta-contraction of body; required for enclosing "let",
   if "let" does not avoid eta-contraction, which has been observed to occur.\<close>
 
 print_translation \<open>
   let
     fun case_prod_tr' [Abs (x, T, t as (Abs abs))] =
           (* case_prod (\<lambda>x y. t) \<Rightarrow> \<lambda>(x, y) t *)
           let
             val (y, t') = Syntax_Trans.atomic_abs_tr' abs;
             val (x', t'') = Syntax_Trans.atomic_abs_tr' (x, T, t');
           in
             Syntax.const \<^syntax_const>\<open>_abs\<close> $
               (Syntax.const \<^syntax_const>\<open>_pattern\<close> $ x' $ y) $ t''
           end
       | case_prod_tr' [Abs (x, T, (s as Const (\<^const_syntax>\<open>case_prod\<close>, _) $ t))] =
           (* case_prod (\<lambda>x. (case_prod (\<lambda>y z. t))) \<Rightarrow> \<lambda>(x, y, z). t *)
           let
             val Const (\<^syntax_const>\<open>_abs\<close>, _) $
               (Const (\<^syntax_const>\<open>_pattern\<close>, _) $ y $ z) $ t' =
                 case_prod_tr' [t];
             val (x', t'') = Syntax_Trans.atomic_abs_tr' (x, T, t');
           in
             Syntax.const \<^syntax_const>\<open>_abs\<close> $
               (Syntax.const \<^syntax_const>\<open>_pattern\<close> $ x' $
                 (Syntax.const \<^syntax_const>\<open>_patterns\<close> $ y $ z)) $ t''
           end
       | case_prod_tr' [Const (\<^const_syntax>\<open>case_prod\<close>, _) $ t] =
           (* case_prod (case_prod (\<lambda>x y z. t)) \<Rightarrow> \<lambda>((x, y), z). t *)
           case_prod_tr' [(case_prod_tr' [t])]
             (* inner case_prod_tr' creates next pattern *)
       | case_prod_tr' [Const (\<^syntax_const>\<open>_abs\<close>, _) $ x_y $ Abs abs] =
           (* case_prod (\<lambda>pttrn z. t) \<Rightarrow> \<lambda>(pttrn, z). t *)
           let val (z, t) = Syntax_Trans.atomic_abs_tr' abs in
             Syntax.const \<^syntax_const>\<open>_abs\<close> $
               (Syntax.const \<^syntax_const>\<open>_pattern\<close> $ x_y $ z) $ t
           end
       | case_prod_tr' _ = raise Match;
   in [(\<^const_syntax>\<open>case_prod\<close>, K case_prod_tr')] end
 \<close>
 
 
 subsubsection \<open>Code generator setup\<close>
 
 code_printing
   type_constructor prod \<rightharpoonup>
     (SML) infix 2 "*"
     and (OCaml) infix 2 "*"
     and (Haskell) "!((_),/ (_))"
     and (Scala) "((_),/ (_))"
 | constant Pair \<rightharpoonup>
     (SML) "!((_),/ (_))"
     and (OCaml) "!((_),/ (_))"
     and (Haskell) "!((_),/ (_))"
     and (Scala) "!((_),/ (_))"
 | class_instance  prod :: equal \<rightharpoonup>
     (Haskell) -
 | constant "HOL.equal :: 'a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> bool" \<rightharpoonup>
     (Haskell) infix 4 "=="
 | constant fst \<rightharpoonup> (Haskell) "fst"
 | constant snd \<rightharpoonup> (Haskell) "snd"
 
 
 subsubsection \<open>Fundamental operations and properties\<close>
 
 lemma Pair_inject: "(a, b) = (a', b') \<Longrightarrow> (a = a' \<Longrightarrow> b = b' \<Longrightarrow> R) \<Longrightarrow> R"
   by simp
 
 lemma surj_pair [simp]: "\<exists>x y. p = (x, y)"
   by (cases p) simp
 
 lemma fst_eqD: "fst (x, y) = a \<Longrightarrow> x = a"
   by simp
 
 lemma snd_eqD: "snd (x, y) = a \<Longrightarrow> y = a"
   by simp
 
 lemma case_prod_unfold [nitpick_unfold]: "case_prod = (\<lambda>c p. c (fst p) (snd p))"
   by (simp add: fun_eq_iff split: prod.split)
 
 lemma case_prod_conv [simp, code]: "(case (a, b) of (c, d) \<Rightarrow> f c d) = f a b"
   by (fact prod.case)
 
 lemmas surjective_pairing = prod.collapse [symmetric]
 
 lemma prod_eq_iff: "s = t \<longleftrightarrow> fst s = fst t \<and> snd s = snd t"
   by (cases s, cases t) simp
 
 lemma prod_eqI [intro?]: "fst p = fst q \<Longrightarrow> snd p = snd q \<Longrightarrow> p = q"
   by (simp add: prod_eq_iff)
 
 lemma case_prodI: "f a b \<Longrightarrow> case (a, b) of (c, d) \<Rightarrow> f c d"
   by (rule prod.case [THEN iffD2])
 
 lemma case_prodD: "(case (a, b) of (c, d) \<Rightarrow> f c d) \<Longrightarrow> f a b"
   by (rule prod.case [THEN iffD1])
 
 lemma case_prod_Pair [simp]: "case_prod Pair = id"
   by (simp add: fun_eq_iff split: prod.split)
 
 lemma case_prod_eta: "(\<lambda>(x, y). f (x, y)) = f"
   \<comment> \<open>Subsumes the old \<open>split_Pair\<close> when \<^term>\<open>f\<close> is the identity function.\<close>
   by (simp add: fun_eq_iff split: prod.split)
 
 (* This looks like a sensible simp-rule but appears to do more harm than good:
 lemma case_prod_const [simp]: "(\<lambda>(_,_). c) = (\<lambda>_. c)"
 by(rule case_prod_eta)
 *)
 
 lemma case_prod_comp: "(case x of (a, b) \<Rightarrow> (f \<circ> g) a b) = f (g (fst x)) (snd x)"
   by (cases x) simp
 
 lemma The_case_prod: "The (case_prod P) = (THE xy. P (fst xy) (snd xy))"
   by (simp add: case_prod_unfold)
 
 lemma cond_case_prod_eta: "(\<And>x y. f x y = g (x, y)) \<Longrightarrow> (\<lambda>(x, y). f x y) = g"
   by (simp add: case_prod_eta)
 
 lemma split_paired_all [no_atp]: "(\<And>x. PROP P x) \<equiv> (\<And>a b. PROP P (a, b))"
 proof
   fix a b
   assume "\<And>x. PROP P x"
   then show "PROP P (a, b)" .
 next
   fix x
   assume "\<And>a b. PROP P (a, b)"
   from \<open>PROP P (fst x, snd x)\<close> show "PROP P x" by simp
 qed
 
 text \<open>
   The rule @{thm [source] split_paired_all} does not work with the
   Simplifier because it also affects premises in congrence rules,
   where this can lead to premises of the form \<open>\<And>a b. \<dots> = ?P(a, b)\<close>
   which cannot be solved by reflexivity.
 \<close>
 
 lemmas split_tupled_all = split_paired_all unit_all_eq2
 
 ML \<open>
   (* replace parameters of product type by individual component parameters *)
   local (* filtering with exists_paired_all is an essential optimization *)
     fun exists_paired_all (Const (\<^const_name>\<open>Pure.all\<close>, _) $ Abs (_, T, t)) =
           can HOLogic.dest_prodT T orelse exists_paired_all t
       | exists_paired_all (t $ u) = exists_paired_all t orelse exists_paired_all u
       | exists_paired_all (Abs (_, _, t)) = exists_paired_all t
       | exists_paired_all _ = false;
     val ss =
       simpset_of
        (put_simpset HOL_basic_ss \<^context>
         addsimps [@{thm split_paired_all}, @{thm unit_all_eq2}, @{thm unit_abs_eta_conv}]
         addsimprocs [\<^simproc>\<open>unit_eq\<close>]);
   in
     fun split_all_tac ctxt = SUBGOAL (fn (t, i) =>
       if exists_paired_all t then safe_full_simp_tac (put_simpset ss ctxt) i else no_tac);
 
     fun unsafe_split_all_tac ctxt = SUBGOAL (fn (t, i) =>
       if exists_paired_all t then full_simp_tac (put_simpset ss ctxt) i else no_tac);
 
     fun split_all ctxt th =
       if exists_paired_all (Thm.prop_of th)
       then full_simplify (put_simpset ss ctxt) th else th;
   end;
 \<close>
 
 setup \<open>map_theory_claset (fn ctxt => ctxt addSbefore ("split_all_tac", split_all_tac))\<close>
 
 lemma split_paired_All [simp, no_atp]: "(\<forall>x. P x) \<longleftrightarrow> (\<forall>a b. P (a, b))"
   \<comment> \<open>\<open>[iff]\<close> is not a good idea because it makes \<open>blast\<close> loop\<close>
   by fast
 
 lemma split_paired_Ex [simp, no_atp]: "(\<exists>x. P x) \<longleftrightarrow> (\<exists>a b. P (a, b))"
   by fast
 
 lemma split_paired_The [no_atp]: "(THE x. P x) = (THE (a, b). P (a, b))"
   \<comment> \<open>Can't be added to simpset: loops!\<close>
   by (simp add: case_prod_eta)
 
 text \<open>
   Simplification procedure for @{thm [source] cond_case_prod_eta}.  Using
   @{thm [source] case_prod_eta} as a rewrite rule is not general enough,
   and using @{thm [source] cond_case_prod_eta} directly would render some
   existing proofs very inefficient; similarly for \<open>prod.case_eq_if\<close>.
 \<close>
 
 ML \<open>
 local
   val cond_case_prod_eta_ss =
     simpset_of (put_simpset HOL_basic_ss \<^context> addsimps @{thms cond_case_prod_eta});
   fun Pair_pat k 0 (Bound m) = (m = k)
     | Pair_pat k i (Const (\<^const_name>\<open>Pair\<close>,  _) $ Bound m $ t) =
         i > 0 andalso m = k + i andalso Pair_pat k (i - 1) t
     | Pair_pat _ _ _ = false;
   fun no_args k i (Abs (_, _, t)) = no_args (k + 1) i t
     | no_args k i (t $ u) = no_args k i t andalso no_args k i u
     | no_args k i (Bound m) = m < k orelse m > k + i
     | no_args _ _ _ = true;
   fun split_pat tp i (Abs  (_, _, t)) = if tp 0 i t then SOME (i, t) else NONE
     | split_pat tp i (Const (\<^const_name>\<open>case_prod\<close>, _) $ Abs (_, _, t)) = split_pat tp (i + 1) t
     | split_pat tp i _ = NONE;
   fun metaeq ctxt lhs rhs = mk_meta_eq (Goal.prove ctxt [] []
         (HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)))
         (K (simp_tac (put_simpset cond_case_prod_eta_ss ctxt) 1)));
 
   fun beta_term_pat k i (Abs (_, _, t)) = beta_term_pat (k + 1) i t
     | beta_term_pat k i (t $ u) =
         Pair_pat k i (t $ u) orelse (beta_term_pat k i t andalso beta_term_pat k i u)
     | beta_term_pat k i t = no_args k i t;
   fun eta_term_pat k i (f $ arg) = no_args k i f andalso Pair_pat k i arg
     | eta_term_pat _ _ _ = false;
   fun subst arg k i (Abs (x, T, t)) = Abs (x, T, subst arg (k+1) i t)
     | subst arg k i (t $ u) =
         if Pair_pat k i (t $ u) then incr_boundvars k arg
         else (subst arg k i t $ subst arg k i u)
     | subst arg k i t = t;
 in
   fun beta_proc ctxt (s as Const (\<^const_name>\<open>case_prod\<close>, _) $ Abs (_, _, t) $ arg) =
         (case split_pat beta_term_pat 1 t of
           SOME (i, f) => SOME (metaeq ctxt s (subst arg 0 i f))
         | NONE => NONE)
     | beta_proc _ _ = NONE;
   fun eta_proc ctxt (s as Const (\<^const_name>\<open>case_prod\<close>, _) $ Abs (_, _, t)) =
         (case split_pat eta_term_pat 1 t of
           SOME (_, ft) => SOME (metaeq ctxt s (let val f $ _ = ft in f end))
         | NONE => NONE)
     | eta_proc _ _ = NONE;
 end;
 \<close>
 simproc_setup case_prod_beta ("case_prod f z") =
-  \<open>fn _ => fn ctxt => fn ct => beta_proc ctxt (Thm.term_of ct)\<close>
+  \<open>K (fn ctxt => fn ct => beta_proc ctxt (Thm.term_of ct))\<close>
 simproc_setup case_prod_eta ("case_prod f") =
-  \<open>fn _ => fn ctxt => fn ct => eta_proc ctxt (Thm.term_of ct)\<close>
+  \<open>K (fn ctxt => fn ct => eta_proc ctxt (Thm.term_of ct))\<close>
 
 lemma case_prod_beta': "(\<lambda>(x,y). f x y) = (\<lambda>x. f (fst x) (snd x))"
   by (auto simp: fun_eq_iff)
 
 text \<open>
   \<^medskip> \<^const>\<open>case_prod\<close> used as a logical connective or set former.
 
   \<^medskip> These rules are for use with \<open>blast\<close>; could instead
   call \<open>simp\<close> using @{thm [source] prod.split} as rewrite.\<close>
 
 lemma case_prodI2:
   "\<And>p. (\<And>a b. p = (a, b) \<Longrightarrow> c a b) \<Longrightarrow> case p of (a, b) \<Rightarrow> c a b"
   by (simp add: split_tupled_all)
 
 lemma case_prodI2':
   "\<And>p. (\<And>a b. (a, b) = p \<Longrightarrow> c a b x) \<Longrightarrow> (case p of (a, b) \<Rightarrow> c a b) x"
   by (simp add: split_tupled_all)
 
 lemma case_prodE [elim!]:
   "(case p of (a, b) \<Rightarrow> c a b) \<Longrightarrow> (\<And>x y. p = (x, y) \<Longrightarrow> c x y \<Longrightarrow> Q) \<Longrightarrow> Q"
   by (induct p) simp
 
 lemma case_prodE' [elim!]:
   "(case p of (a, b) \<Rightarrow> c a b) z \<Longrightarrow> (\<And>x y. p = (x, y) \<Longrightarrow> c x y z \<Longrightarrow> Q) \<Longrightarrow> Q"
   by (induct p) simp
 
 lemma case_prodE2:
   assumes q: "Q (case z of (a, b) \<Rightarrow> P a b)"
     and r: "\<And>x y. z = (x, y) \<Longrightarrow> Q (P x y) \<Longrightarrow> R"
   shows R
 proof (rule r)
   show "z = (fst z, snd z)" by simp
   then show "Q (P (fst z) (snd z))"
     using q by (simp add: case_prod_unfold)
 qed
 
 lemma case_prodD': "(case (a, b) of (c, d) \<Rightarrow> R c d) c \<Longrightarrow> R a b c"
   by simp
 
 lemma mem_case_prodI: "z \<in> c a b \<Longrightarrow> z \<in> (case (a, b) of (d, e) \<Rightarrow> c d e)"
   by simp
 
 lemma mem_case_prodI2 [intro!]:
   "\<And>p. (\<And>a b. p = (a, b) \<Longrightarrow> z \<in> c a b) \<Longrightarrow> z \<in> (case p of (a, b) \<Rightarrow> c a b)"
   by (simp only: split_tupled_all) simp
 
 declare mem_case_prodI [intro!] \<comment> \<open>postponed to maintain traditional declaration order!\<close>
 declare case_prodI2' [intro!] \<comment> \<open>postponed to maintain traditional declaration order!\<close>
 declare case_prodI2 [intro!] \<comment> \<open>postponed to maintain traditional declaration order!\<close>
 declare case_prodI [intro!] \<comment> \<open>postponed to maintain traditional declaration order!\<close>
 
 lemma mem_case_prodE [elim!]:
   assumes "z \<in> case_prod c p"
   obtains x y where "p = (x, y)" and "z \<in> c x y"
   using assms by (rule case_prodE2)
 
 ML \<open>
 local (* filtering with exists_p_split is an essential optimization *)
   fun exists_p_split (Const (\<^const_name>\<open>case_prod\<close>,_) $ _ $ (Const (\<^const_name>\<open>Pair\<close>,_)$_$_)) = true
     | exists_p_split (t $ u) = exists_p_split t orelse exists_p_split u
     | exists_p_split (Abs (_, _, t)) = exists_p_split t
     | exists_p_split _ = false;
 in
   fun split_conv_tac ctxt = SUBGOAL (fn (t, i) =>
     if exists_p_split t
     then safe_full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps @{thms case_prod_conv}) i
     else no_tac);
 end;
 \<close>
 
 (* This prevents applications of splitE for already splitted arguments leading
    to quite time-consuming computations (in particular for nested tuples) *)
 setup \<open>map_theory_claset (fn ctxt => ctxt addSbefore ("split_conv_tac", split_conv_tac))\<close>
 
 lemma split_eta_SetCompr [simp, no_atp]: "(\<lambda>u. \<exists>x y. u = (x, y) \<and> P (x, y)) = P"
   by (rule ext) fast
 
 lemma split_eta_SetCompr2 [simp, no_atp]: "(\<lambda>u. \<exists>x y. u = (x, y) \<and> P x y) = case_prod P"
   by (rule ext) fast
 
 lemma split_part [simp]: "(\<lambda>(a,b). P \<and> Q a b) = (\<lambda>ab. P \<and> case_prod Q ab)"
   \<comment> \<open>Allows simplifications of nested splits in case of independent predicates.\<close>
   by (rule ext) blast
 
 (* Do NOT make this a simp rule as it
    a) only helps in special situations
    b) can lead to nontermination in the presence of split_def
 *)
 lemma split_comp_eq:
   fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'c"
     and g :: "'d \<Rightarrow> 'a"
   shows "(\<lambda>u. f (g (fst u)) (snd u)) = case_prod (\<lambda>x. f (g x))"
   by (rule ext) auto
 
 lemma pair_imageI [intro]: "(a, b) \<in> A \<Longrightarrow> f a b \<in> (\<lambda>(a, b). f a b) ` A"
   by (rule image_eqI [where x = "(a, b)"]) auto
 
 lemma Collect_const_case_prod[simp]: "{(a,b). P} = (if P then UNIV else {})"
 by auto
 
 lemma The_split_eq [simp]: "(THE (x',y'). x = x' \<and> y = y') = (x, y)"
   by blast
 
 (*
 the following  would be slightly more general,
 but cannot be used as rewrite rule:
 ### Cannot add premise as rewrite rule because it contains (type) unknowns:
 ### ?y = .x
 Goal "[| P y; !!x. P x ==> x = y |] ==> (@(x',y). x = x' & P y) = (x,y)"
 by (rtac some_equality 1)
 by ( Simp_tac 1)
 by (split_all_tac 1)
 by (Asm_full_simp_tac 1)
 qed "The_split_eq";
 *)
 
 lemma case_prod_beta: "case_prod f p = f (fst p) (snd p)"
   by (fact prod.case_eq_if)
 
 lemma prod_cases3 [cases type]:
   obtains (fields) a b c where "y = (a, b, c)"
 proof (cases y)
   case (Pair a b)
   with that show ?thesis
     by (cases b) blast
 qed
 
 
 lemma prod_induct3 [case_names fields, induct type]:
   "(\<And>a b c. P (a, b, c)) \<Longrightarrow> P x"
   by (cases x) blast
 
 lemma prod_cases4 [cases type]:
   obtains (fields) a b c d where "y = (a, b, c, d)"
 proof (cases y)
   case (fields a b c)
   with that show ?thesis
     by (cases c) blast
 qed
 
 lemma prod_induct4 [case_names fields, induct type]:
   "(\<And>a b c d. P (a, b, c, d)) \<Longrightarrow> P x"
   by (cases x) blast
 
 lemma prod_cases5 [cases type]:
   obtains (fields) a b c d e where "y = (a, b, c, d, e)"
 proof (cases y)
   case (fields a b c d)
   with that show ?thesis
     by (cases d) blast
 qed
 
 lemma prod_induct5 [case_names fields, induct type]:
   "(\<And>a b c d e. P (a, b, c, d, e)) \<Longrightarrow> P x"
   by (cases x) blast
 
 lemma prod_cases6 [cases type]:
   obtains (fields) a b c d e f where "y = (a, b, c, d, e, f)"
 proof (cases y)
   case (fields a b c d e)
   with that show ?thesis
     by (cases e) blast
 qed
 
 lemma prod_induct6 [case_names fields, induct type]:
   "(\<And>a b c d e f. P (a, b, c, d, e, f)) \<Longrightarrow> P x"
   by (cases x) blast
 
 lemma prod_cases7 [cases type]:
   obtains (fields) a b c d e f g where "y = (a, b, c, d, e, f, g)"
 proof (cases y)
   case (fields a b c d e f)
   with that show ?thesis
     by (cases f) blast
 qed
 
 
 lemma prod_induct7 [case_names fields, induct type]:
   "(\<And>a b c d e f g. P (a, b, c, d, e, f, g)) \<Longrightarrow> P x"
   by (cases x) blast
 
 definition internal_case_prod :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'c"
   where "internal_case_prod \<equiv> case_prod"
 
 lemma internal_case_prod_conv: "internal_case_prod c (a, b) = c a b"
   by (simp only: internal_case_prod_def case_prod_conv)
 
 ML_file \<open>Tools/split_rule.ML\<close>
 
 hide_const internal_case_prod
 
 
 subsubsection \<open>Derived operations\<close>
 
 definition curry :: "('a \<times> 'b \<Rightarrow> 'c) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'c"
   where "curry = (\<lambda>c x y. c (x, y))"
 
 lemma curry_conv [simp, code]: "curry f a b = f (a, b)"
   by (simp add: curry_def)
 
 lemma curryI [intro!]: "f (a, b) \<Longrightarrow> curry f a b"
   by (simp add: curry_def)
 
 lemma curryD [dest!]: "curry f a b \<Longrightarrow> f (a, b)"
   by (simp add: curry_def)
 
 lemma curryE: "curry f a b \<Longrightarrow> (f (a, b) \<Longrightarrow> Q) \<Longrightarrow> Q"
   by (simp add: curry_def)
 
 lemma curry_case_prod [simp]: "curry (case_prod f) = f"
   by (simp add: curry_def case_prod_unfold)
 
 lemma case_prod_curry [simp]: "case_prod (curry f) = f"
   by (simp add: curry_def case_prod_unfold)
 
 lemma curry_K: "curry (\<lambda>x. c) = (\<lambda>x y. c)"
   by (simp add: fun_eq_iff)
 
 text \<open>The composition-uncurry combinator.\<close>
 
 definition scomp :: "('a \<Rightarrow> 'b \<times> 'c) \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> 'd) \<Rightarrow> 'a \<Rightarrow> 'd"  (infixl "\<circ>\<rightarrow>" 60)
   where "f \<circ>\<rightarrow> g = (\<lambda>x. case_prod g (f x))"
 
 no_notation scomp (infixl "\<circ>\<rightarrow>" 60)
 
 bundle state_combinator_syntax
 begin
 
 notation fcomp (infixl "\<circ>>" 60)
 notation scomp (infixl "\<circ>\<rightarrow>" 60)
 
 end
 
 context
   includes state_combinator_syntax
 begin
 
 lemma scomp_unfold: "(\<circ>\<rightarrow>) = (\<lambda>f g x. g (fst (f x)) (snd (f x)))"
   by (simp add: fun_eq_iff scomp_def case_prod_unfold)
 
 lemma scomp_apply [simp]: "(f \<circ>\<rightarrow> g) x = case_prod g (f x)"
   by (simp add: scomp_unfold case_prod_unfold)
 
 lemma Pair_scomp: "Pair x \<circ>\<rightarrow> f = f x"
   by (simp add: fun_eq_iff)
 
 lemma scomp_Pair: "x \<circ>\<rightarrow> Pair = x"
   by (simp add: fun_eq_iff)
 
 lemma scomp_scomp: "(f \<circ>\<rightarrow> g) \<circ>\<rightarrow> h = f \<circ>\<rightarrow> (\<lambda>x. g x \<circ>\<rightarrow> h)"
   by (simp add: fun_eq_iff scomp_unfold)
 
 lemma scomp_fcomp: "(f \<circ>\<rightarrow> g) \<circ>> h = f \<circ>\<rightarrow> (\<lambda>x. g x \<circ>> h)"
   by (simp add: fun_eq_iff scomp_unfold fcomp_def)
 
 lemma fcomp_scomp: "(f \<circ>> g) \<circ>\<rightarrow> h = f \<circ>> (g \<circ>\<rightarrow> h)"
   by (simp add: fun_eq_iff scomp_unfold)
 
 end
 
 code_printing
   constant scomp \<rightharpoonup> (Eval) infixl 3 "#->"
 
 text \<open>
   \<^term>\<open>map_prod\<close> --- action of the product functor upon functions.
 \<close>
 
 definition map_prod :: "('a \<Rightarrow> 'c) \<Rightarrow> ('b \<Rightarrow> 'd) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'c \<times> 'd"
   where "map_prod f g = (\<lambda>(x, y). (f x, g y))"
 
 lemma map_prod_simp [simp, code]: "map_prod f g (a, b) = (f a, g b)"
   by (simp add: map_prod_def)
 
 functor map_prod: map_prod
   by (auto simp add: split_paired_all)
 
 lemma fst_map_prod [simp]: "fst (map_prod f g x) = f (fst x)"
   by (cases x) simp_all
 
 lemma snd_map_prod [simp]: "snd (map_prod f g x) = g (snd x)"
   by (cases x) simp_all
 
 lemma fst_comp_map_prod [simp]: "fst \<circ> map_prod f g = f \<circ> fst"
   by (rule ext) simp_all
 
 lemma snd_comp_map_prod [simp]: "snd \<circ> map_prod f g = g \<circ> snd"
   by (rule ext) simp_all
 
 lemma map_prod_compose: "map_prod (f1 \<circ> f2) (g1 \<circ> g2) = (map_prod f1 g1 \<circ> map_prod f2 g2)"
   by (rule ext) (simp add: map_prod.compositionality comp_def)
 
 lemma map_prod_ident [simp]: "map_prod (\<lambda>x. x) (\<lambda>y. y) = (\<lambda>z. z)"
   by (rule ext) (simp add: map_prod.identity)
 
 lemma map_prod_imageI [intro]: "(a, b) \<in> R \<Longrightarrow> (f a, g b) \<in> map_prod f g ` R"
   by (rule image_eqI) simp_all
 
 lemma prod_fun_imageE [elim!]:
   assumes major: "c \<in> map_prod f g ` R"
     and cases: "\<And>x y. c = (f x, g y) \<Longrightarrow> (x, y) \<in> R \<Longrightarrow> P"
   shows P
 proof (rule major [THEN imageE])
   fix x
   assume "c = map_prod f g x" "x \<in> R"
   then show P
     using cases by (cases x) simp
 qed
 
 definition apfst :: "('a \<Rightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'c \<times> 'b"
   where "apfst f = map_prod f id"
 
 definition apsnd :: "('b \<Rightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'a \<times> 'c"
   where "apsnd f = map_prod id f"
 
 lemma apfst_conv [simp, code]: "apfst f (x, y) = (f x, y)"
   by (simp add: apfst_def)
 
 lemma apsnd_conv [simp, code]: "apsnd f (x, y) = (x, f y)"
   by (simp add: apsnd_def)
 
 lemma fst_apfst [simp]: "fst (apfst f x) = f (fst x)"
   by (cases x) simp
 
 lemma fst_comp_apfst [simp]: "fst \<circ> apfst f = f \<circ> fst"
   by (simp add: fun_eq_iff)
 
 lemma fst_apsnd [simp]: "fst (apsnd f x) = fst x"
   by (cases x) simp
 
 lemma fst_comp_apsnd [simp]: "fst \<circ> apsnd f = fst"
   by (simp add: fun_eq_iff)
 
 lemma snd_apfst [simp]: "snd (apfst f x) = snd x"
   by (cases x) simp
 
 lemma snd_comp_apfst [simp]: "snd \<circ> apfst f = snd"
   by (simp add: fun_eq_iff)
 
 lemma snd_apsnd [simp]: "snd (apsnd f x) = f (snd x)"
   by (cases x) simp
 
 lemma snd_comp_apsnd [simp]: "snd \<circ> apsnd f = f \<circ> snd"
   by (simp add: fun_eq_iff)
 
 lemma apfst_compose: "apfst f (apfst g x) = apfst (f \<circ> g) x"
   by (cases x) simp
 
 lemma apsnd_compose: "apsnd f (apsnd g x) = apsnd (f \<circ> g) x"
   by (cases x) simp
 
 lemma apfst_apsnd [simp]: "apfst f (apsnd g x) = (f (fst x), g (snd x))"
   by (cases x) simp
 
 lemma apsnd_apfst [simp]: "apsnd f (apfst g x) = (g (fst x), f (snd x))"
   by (cases x) simp
 
 lemma apfst_id [simp]: "apfst id = id"
   by (simp add: fun_eq_iff)
 
 lemma apsnd_id [simp]: "apsnd id = id"
   by (simp add: fun_eq_iff)
 
 lemma apfst_eq_conv [simp]: "apfst f x = apfst g x \<longleftrightarrow> f (fst x) = g (fst x)"
   by (cases x) simp
 
 lemma apsnd_eq_conv [simp]: "apsnd f x = apsnd g x \<longleftrightarrow> f (snd x) = g (snd x)"
   by (cases x) simp
 
 lemma apsnd_apfst_commute: "apsnd f (apfst g p) = apfst g (apsnd f p)"
   by simp
 
 context
 begin
 
 local_setup \<open>Local_Theory.map_background_naming (Name_Space.mandatory_path "prod")\<close>
 
 definition swap :: "'a \<times> 'b \<Rightarrow> 'b \<times> 'a"
   where "swap p = (snd p, fst p)"
 
 end
 
 lemma swap_simp [simp]: "prod.swap (x, y) = (y, x)"
   by (simp add: prod.swap_def)
 
 lemma swap_swap [simp]: "prod.swap (prod.swap p) = p"
   by (cases p) simp
 
 lemma swap_comp_swap [simp]: "prod.swap \<circ> prod.swap = id"
   by (simp add: fun_eq_iff)
 
 lemma pair_in_swap_image [simp]: "(y, x) \<in> prod.swap ` A \<longleftrightarrow> (x, y) \<in> A"
   by (auto intro!: image_eqI)
 
 lemma inj_swap [simp]: "inj_on prod.swap A"
   by (rule inj_onI) auto
 
 lemma swap_inj_on: "inj_on (\<lambda>(i, j). (j, i)) A"
   by (rule inj_onI) auto
 
 lemma surj_swap [simp]: "surj prod.swap"
   by (rule surjI [of _ prod.swap]) simp
 
 lemma bij_swap [simp]: "bij prod.swap"
   by (simp add: bij_def)
 
 lemma case_swap [simp]: "(case prod.swap p of (y, x) \<Rightarrow> f x y) = (case p of (x, y) \<Rightarrow> f x y)"
   by (cases p) simp
 
 lemma fst_swap [simp]: "fst (prod.swap x) = snd x"
   by (cases x) simp
 
 lemma snd_swap [simp]: "snd (prod.swap x) = fst x"
   by (cases x) simp
 
 text \<open>Disjoint union of a family of sets -- Sigma.\<close>
 
 definition Sigma :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> ('a \<times> 'b) set"
   where "Sigma A B \<equiv> \<Union>x\<in>A. \<Union>y\<in>B x. {Pair x y}"
 
 abbreviation Times :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<times> 'b) set"  (infixr "\<times>" 80)
   where "A \<times> B \<equiv> Sigma A (\<lambda>_. B)"
 
 hide_const (open) Times
 
 bundle no_Set_Product_syntax begin
 no_notation Product_Type.Times (infixr "\<times>" 80)
 end
 bundle Set_Product_syntax begin
 notation Product_Type.Times (infixr "\<times>" 80)
 end
 
 syntax
   "_Sigma" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<times> 'b) set"  ("(3SIGMA _:_./ _)" [0, 0, 10] 10)
 translations
   "SIGMA x:A. B" \<rightleftharpoons> "CONST Sigma A (\<lambda>x. B)"
 
 lemma SigmaI [intro!]: "a \<in> A \<Longrightarrow> b \<in> B a \<Longrightarrow> (a, b) \<in> Sigma A B"
   unfolding Sigma_def by blast
 
 lemma SigmaE [elim!]: "c \<in> Sigma A B \<Longrightarrow> (\<And>x y. x \<in> A \<Longrightarrow> y \<in> B x \<Longrightarrow> c = (x, y) \<Longrightarrow> P) \<Longrightarrow> P"
   \<comment> \<open>The general elimination rule.\<close>
   unfolding Sigma_def by blast
 
 text \<open>
   Elimination of \<^term>\<open>(a, b) \<in> A \<times> B\<close> -- introduces no
   eigenvariables.
 \<close>
 
 lemma SigmaD1: "(a, b) \<in> Sigma A B \<Longrightarrow> a \<in> A"
   by blast
 
 lemma SigmaD2: "(a, b) \<in> Sigma A B \<Longrightarrow> b \<in> B a"
   by blast
 
 lemma SigmaE2: "(a, b) \<in> Sigma A B \<Longrightarrow> (a \<in> A \<Longrightarrow> b \<in> B a \<Longrightarrow> P) \<Longrightarrow> P"
   by blast
 
 lemma Sigma_cong: "A = B \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> C x = D x) \<Longrightarrow> (SIGMA x:A. C x) = (SIGMA x:B. D x)"
   by auto
 
 lemma Sigma_mono: "A \<subseteq> C \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> B x \<subseteq> D x) \<Longrightarrow> Sigma A B \<subseteq> Sigma C D"
   by blast
 
 lemma Sigma_empty1 [simp]: "Sigma {} B = {}"
   by blast
 
 lemma Sigma_empty2 [simp]: "A \<times> {} = {}"
   by blast
 
 lemma UNIV_Times_UNIV [simp]: "UNIV \<times> UNIV = UNIV"
   by auto
 
 lemma Compl_Times_UNIV1 [simp]: "- (UNIV \<times> A) = UNIV \<times> (-A)"
   by auto
 
 lemma Compl_Times_UNIV2 [simp]: "- (A \<times> UNIV) = (-A) \<times> UNIV"
   by auto
 
 lemma mem_Sigma_iff [iff]: "(a, b) \<in> Sigma A B \<longleftrightarrow> a \<in> A \<and> b \<in> B a"
   by blast
 
 lemma mem_Times_iff: "x \<in> A \<times> B \<longleftrightarrow> fst x \<in> A \<and> snd x \<in> B"
   by (induct x) simp
 
 lemma Sigma_empty_iff: "(SIGMA i:I. X i) = {} \<longleftrightarrow> (\<forall>i\<in>I. X i = {})"
   by auto
 
 lemma Times_subset_cancel2: "x \<in> C \<Longrightarrow> A \<times> C \<subseteq> B \<times> C \<longleftrightarrow> A \<subseteq> B"
   by blast
 
 lemma Times_eq_cancel2: "x \<in> C \<Longrightarrow> A \<times> C = B \<times> C \<longleftrightarrow> A = B"
   by (blast elim: equalityE)
 
 lemma Collect_case_prod_Sigma: "{(x, y). P x \<and> Q x y} = (SIGMA x:Collect P. Collect (Q x))"
   by blast
 
 lemma Collect_case_prod [simp]: "{(a, b). P a \<and> Q b} = Collect P \<times> Collect Q "
   by (fact Collect_case_prod_Sigma)
 
 lemma Collect_case_prodD: "x \<in> Collect (case_prod A) \<Longrightarrow> A (fst x) (snd x)"
   by auto
 
 lemma Collect_case_prod_mono: "A \<le> B \<Longrightarrow> Collect (case_prod A) \<subseteq> Collect (case_prod B)"
   by auto (auto elim!: le_funE)
 
 lemma Collect_split_mono_strong:
   "X = fst ` A \<Longrightarrow> Y = snd ` A \<Longrightarrow> \<forall>a\<in>X. \<forall>b \<in> Y. P a b \<longrightarrow> Q a b
     \<Longrightarrow> A \<subseteq> Collect (case_prod P) \<Longrightarrow> A \<subseteq> Collect (case_prod Q)"
   by fastforce
 
 lemma UN_Times_distrib: "(\<Union>(a, b)\<in>A \<times> B. E a \<times> F b) = \<Union>(E ` A) \<times> \<Union>(F ` B)"
   \<comment> \<open>Suggested by Pierre Chartier\<close>
   by blast
 
 lemma split_paired_Ball_Sigma [simp, no_atp]: "(\<forall>z\<in>Sigma A B. P z) \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>B x. P (x, y))"
   by blast
 
 lemma split_paired_Bex_Sigma [simp, no_atp]: "(\<exists>z\<in>Sigma A B. P z) \<longleftrightarrow> (\<exists>x\<in>A. \<exists>y\<in>B x. P (x, y))"
   by blast
 
 lemma Sigma_Un_distrib1: "Sigma (I \<union> J) C = Sigma I C \<union> Sigma J C"
   by blast
 
 lemma Sigma_Un_distrib2: "(SIGMA i:I. A i \<union> B i) = Sigma I A \<union> Sigma I B"
   by blast
 
 lemma Sigma_Int_distrib1: "Sigma (I \<inter> J) C = Sigma I C \<inter> Sigma J C"
   by blast
 
 lemma Sigma_Int_distrib2: "(SIGMA i:I. A i \<inter> B i) = Sigma I A \<inter> Sigma I B"
   by blast
 
 lemma Sigma_Diff_distrib1: "Sigma (I - J) C = Sigma I C - Sigma J C"
   by blast
 
 lemma Sigma_Diff_distrib2: "(SIGMA i:I. A i - B i) = Sigma I A - Sigma I B"
   by blast
 
 lemma Sigma_Union: "Sigma (\<Union>X) B = (\<Union>A\<in>X. Sigma A B)"
   by blast
 
 lemma Pair_vimage_Sigma: "Pair x -` Sigma A f = (if x \<in> A then f x else {})"
   by auto
 
 text \<open>
   Non-dependent versions are needed to avoid the need for higher-order
   matching, especially when the rules are re-oriented.
 \<close>
 
 lemma Times_Un_distrib1: "(A \<union> B) \<times> C = A \<times> C \<union> B \<times> C "
   by (fact Sigma_Un_distrib1)
 
 lemma Times_Int_distrib1: "(A \<inter> B) \<times> C = A \<times> C \<inter> B \<times> C "
   by (fact Sigma_Int_distrib1)
 
 lemma Times_Diff_distrib1: "(A - B) \<times> C = A \<times> C - B \<times> C "
   by (fact Sigma_Diff_distrib1)
 
 lemma Times_empty [simp]: "A \<times> B = {} \<longleftrightarrow> A = {} \<or> B = {}"
   by auto
 
 lemma times_subset_iff: "A \<times> C \<subseteq> B \<times> D \<longleftrightarrow> A={} \<or> C={} \<or> A \<subseteq> B \<and> C \<subseteq> D"
   by blast
 
 lemma times_eq_iff: "A \<times> B = C \<times> D \<longleftrightarrow> A = C \<and> B = D \<or> (A = {} \<or> B = {}) \<and> (C = {} \<or> D = {})"
   by auto
 
 lemma fst_image_times [simp]: "fst ` (A \<times> B) = (if B = {} then {} else A)"
   by force
 
 lemma snd_image_times [simp]: "snd ` (A \<times> B) = (if A = {} then {} else B)"
   by force
 
 lemma fst_image_Sigma: "fst ` (Sigma A B) = {x \<in> A. B(x) \<noteq> {}}"
   by force
 
 lemma snd_image_Sigma: "snd ` (Sigma A B) = (\<Union> x \<in> A. B x)"
   by force
 
 lemma vimage_fst: "fst -` A = A \<times> UNIV"
   by auto
 
 lemma vimage_snd: "snd -` A = UNIV \<times> A"
   by auto
 
 lemma insert_Times_insert [simp]:
   "insert a A \<times> insert b B = insert (a,b) (A \<times> insert b B \<union> insert a A \<times> B)"
   by blast
 
 lemma vimage_Times: "f -` (A \<times> B) = (fst \<circ> f) -` A \<inter> (snd \<circ> f) -` B"
 proof (rule set_eqI)
   show "x \<in> f -` (A \<times> B) \<longleftrightarrow> x \<in> (fst \<circ> f) -` A \<inter> (snd \<circ> f) -` B" for x
     by (cases "f x") (auto split: prod.split)
 qed
 
 lemma Times_Int_Times: "A \<times> B \<inter> C \<times> D = (A \<inter> C) \<times> (B \<inter> D)"
   by auto
 
 lemma image_paired_Times:
    "(\<lambda>(x,y). (f x, g y)) ` (A \<times> B) = (f ` A) \<times> (g ` B)"
   by auto
 
 lemma product_swap: "prod.swap ` (A \<times> B) = B \<times> A"
   by (auto simp add: set_eq_iff)
 
 lemma swap_product: "(\<lambda>(i, j). (j, i)) ` (A \<times> B) = B \<times> A"
   by (auto simp add: set_eq_iff)
 
 lemma image_split_eq_Sigma: "(\<lambda>x. (f x, g x)) ` A = Sigma (f ` A) (\<lambda>x. g ` (f -` {x} \<inter> A))"
 proof (safe intro!: imageI)
   fix a b
   assume *: "a \<in> A" "b \<in> A" and eq: "f a = f b"
   show "(f b, g a) \<in> (\<lambda>x. (f x, g x)) ` A"
     using * eq[symmetric] by auto
 qed simp_all
 
 lemma subset_fst_snd: "A \<subseteq> (fst ` A \<times> snd ` A)"
   by force
 
 lemma inj_on_apfst [simp]: "inj_on (apfst f) (A \<times> UNIV) \<longleftrightarrow> inj_on f A"
   by (auto simp add: inj_on_def)
 
 lemma inj_apfst [simp]: "inj (apfst f) \<longleftrightarrow> inj f"
   using inj_on_apfst[of f UNIV] by simp
 
 lemma inj_on_apsnd [simp]: "inj_on (apsnd f) (UNIV \<times> A) \<longleftrightarrow> inj_on f A"
   by (auto simp add: inj_on_def)
 
 lemma inj_apsnd [simp]: "inj (apsnd f) \<longleftrightarrow> inj f"
   using inj_on_apsnd[of f UNIV] by simp
 
 context
 begin
 
 qualified definition product :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<times> 'b) set"
   where [code_abbrev]: "product A B = A \<times> B"
 
 lemma member_product: "x \<in> Product_Type.product A B \<longleftrightarrow> x \<in> A \<times> B"
   by (simp add: product_def)
 
 end
 
 text \<open>The following \<^const>\<open>map_prod\<close> lemmas are due to Joachim Breitner:\<close>
 
 lemma map_prod_inj_on:
   assumes "inj_on f A"
     and "inj_on g B"
   shows "inj_on (map_prod f g) (A \<times> B)"
 proof (rule inj_onI)
   fix x :: "'a \<times> 'c"
   fix y :: "'a \<times> 'c"
   assume "x \<in> A \<times> B"
   then have "fst x \<in> A" and "snd x \<in> B" by auto
   assume "y \<in> A \<times> B"
   then have "fst y \<in> A" and "snd y \<in> B" by auto
   assume "map_prod f g x = map_prod f g y"
   then have "fst (map_prod f g x) = fst (map_prod f g y)" by auto
   then have "f (fst x) = f (fst y)" by (cases x, cases y) auto
   with \<open>inj_on f A\<close> and \<open>fst x \<in> A\<close> and \<open>fst y \<in> A\<close> have "fst x = fst y"
     by (auto dest: inj_onD)
   moreover from \<open>map_prod f g x = map_prod f g y\<close>
   have "snd (map_prod f g x) = snd (map_prod f g y)" by auto
   then have "g (snd x) = g (snd y)" by (cases x, cases y) auto
   with \<open>inj_on g B\<close> and \<open>snd x \<in> B\<close> and \<open>snd y \<in> B\<close> have "snd x = snd y"
     by (auto dest: inj_onD)
   ultimately show "x = y" by (rule prod_eqI)
 qed
 
 lemma map_prod_surj:
   fixes f :: "'a \<Rightarrow> 'b"
     and g :: "'c \<Rightarrow> 'd"
   assumes "surj f" and "surj g"
   shows "surj (map_prod f g)"
   unfolding surj_def
 proof
   fix y :: "'b \<times> 'd"
   from \<open>surj f\<close> obtain a where "fst y = f a"
     by (auto elim: surjE)
   moreover
   from \<open>surj g\<close> obtain b where "snd y = g b"
     by (auto elim: surjE)
   ultimately have "(fst y, snd y) = map_prod f g (a,b)"
     by auto
   then show "\<exists>x. y = map_prod f g x"
     by auto
 qed
 
 lemma map_prod_surj_on:
   assumes "f ` A = A'" and "g ` B = B'"
   shows "map_prod f g ` (A \<times> B) = A' \<times> B'"
   unfolding image_def
 proof (rule set_eqI, rule iffI)
   fix x :: "'a \<times> 'c"
   assume "x \<in> {y::'a \<times> 'c. \<exists>x::'b \<times> 'd\<in>A \<times> B. y = map_prod f g x}"
   then obtain y where "y \<in> A \<times> B" and "x = map_prod f g y"
     by blast
   from \<open>image f A = A'\<close> and \<open>y \<in> A \<times> B\<close> have "f (fst y) \<in> A'"
     by auto
   moreover from \<open>image g B = B'\<close> and \<open>y \<in> A \<times> B\<close> have "g (snd y) \<in> B'"
     by auto
   ultimately have "(f (fst y), g (snd y)) \<in> (A' \<times> B')"
     by auto
   with \<open>x = map_prod f g y\<close> show "x \<in> A' \<times> B'"
     by (cases y) auto
 next
   fix x :: "'a \<times> 'c"
   assume "x \<in> A' \<times> B'"
   then have "fst x \<in> A'" and "snd x \<in> B'"
     by auto
   from \<open>image f A = A'\<close> and \<open>fst x \<in> A'\<close> have "fst x \<in> image f A"
     by auto
   then obtain a where "a \<in> A" and "fst x = f a"
     by (rule imageE)
   moreover from \<open>image g B = B'\<close> and \<open>snd x \<in> B'\<close> obtain b where "b \<in> B" and "snd x = g b"
     by auto
   ultimately have "(fst x, snd x) = map_prod f g (a, b)"
     by auto
   moreover from \<open>a \<in> A\<close> and  \<open>b \<in> B\<close> have "(a , b) \<in> A \<times> B"
     by auto
   ultimately have "\<exists>y \<in> A \<times> B. x = map_prod f g y"
     by auto
   then show "x \<in> {x. \<exists>y \<in> A \<times> B. x = map_prod f g y}"
     by auto
 qed
 
 
 subsection \<open>Simproc for rewriting a set comprehension into a pointfree expression\<close>
 
 ML_file \<open>Tools/set_comprehension_pointfree.ML\<close>
 
 setup \<open>
   Code_Preproc.map_pre (fn ctxt => ctxt addsimprocs
     [Simplifier.make_simproc \<^context> "set comprehension"
       {lhss = [\<^term>\<open>Collect P\<close>],
        proc = K Set_Comprehension_Pointfree.code_simproc}])
 \<close>
 
 subsection \<open>Lemmas about disjointness\<close>
 
 lemma disjnt_Times1_iff [simp]: "disjnt (C \<times> A) (C \<times> B) \<longleftrightarrow> C = {} \<or> disjnt A B"
   by (auto simp: disjnt_def)
 
 lemma disjnt_Times2_iff [simp]: "disjnt (A \<times> C) (B \<times> C) \<longleftrightarrow> C = {} \<or> disjnt A B"
   by (auto simp: disjnt_def)
 
 lemma disjnt_Sigma_iff: "disjnt (Sigma A C) (Sigma B C) \<longleftrightarrow> (\<forall>i \<in> A\<inter>B. C i = {}) \<or> disjnt A B"
   by (auto simp: disjnt_def)
 
 
 subsection \<open>Inductively defined sets\<close>
 
 (* simplify {(x1, ..., xn). (x1, ..., xn) : S} to S *)
 simproc_setup Collect_mem ("Collect t") = \<open>
-  fn _ => fn ctxt => fn ct =>
+  K (fn ctxt => fn ct =>
     (case Thm.term_of ct of
       S as Const (\<^const_name>\<open>Collect\<close>, Type (\<^type_name>\<open>fun\<close>, [_, T])) $ t =>
         let val (u, _, ps) = HOLogic.strip_ptupleabs t in
           (case u of
             (c as Const (\<^const_name>\<open>Set.member\<close>, _)) $ q $ S' =>
               (case try (HOLogic.strip_ptuple ps) q of
                 NONE => NONE
               | SOME ts =>
                   if not (Term.is_open S') andalso
                     ts = map Bound (length ps downto 0)
                   then
                     let val simp =
                       full_simp_tac (put_simpset HOL_basic_ss ctxt
                         addsimps [@{thm split_paired_all}, @{thm case_prod_conv}]) 1
                     in
                       SOME (Goal.prove ctxt [] []
                         (Const (\<^const_name>\<open>Pure.eq\<close>, T --> T --> propT) $ S $ S')
                         (K (EVERY
                           [resolve_tac ctxt [eq_reflection] 1,
                            resolve_tac ctxt @{thms subset_antisym} 1,
                            resolve_tac ctxt @{thms subsetI} 1,
                            dresolve_tac ctxt @{thms CollectD} 1, simp,
                            resolve_tac ctxt @{thms subsetI} 1,
                            resolve_tac ctxt @{thms CollectI} 1, simp])))
                     end
                   else NONE)
           | _ => NONE)
         end
-    | _ => NONE)
+    | _ => NONE))
 \<close>
 
 ML_file \<open>Tools/inductive_set.ML\<close>
 
 
 subsection \<open>Legacy theorem bindings and duplicates\<close>
 
 lemmas fst_conv = prod.sel(1)
 lemmas snd_conv = prod.sel(2)
 lemmas split_def = case_prod_unfold
 lemmas split_beta' = case_prod_beta'
 lemmas split_beta = prod.case_eq_if
 lemmas split_conv = case_prod_conv
 lemmas split = case_prod_conv
 
 hide_const (open) prod
 
 end
diff --git a/src/HOL/Set.thy b/src/HOL/Set.thy
--- a/src/HOL/Set.thy
+++ b/src/HOL/Set.thy
@@ -1,2044 +1,2042 @@
 (*  Title:      HOL/Set.thy
     Author:     Tobias Nipkow
     Author:     Lawrence C Paulson
     Author:     Markus Wenzel
 *)
 
 section \<open>Set theory for higher-order logic\<close>
 
 theory Set
   imports Lattices Boolean_Algebras
 begin
 
 subsection \<open>Sets as predicates\<close>
 
 typedecl 'a set
 
 axiomatization Collect :: "('a \<Rightarrow> bool) \<Rightarrow> 'a set" \<comment> \<open>comprehension\<close>
   and member :: "'a \<Rightarrow> 'a set \<Rightarrow> bool" \<comment> \<open>membership\<close>
   where mem_Collect_eq [iff, code_unfold]: "member a (Collect P) = P a"
     and Collect_mem_eq [simp]: "Collect (\<lambda>x. member x A) = A"
 
 notation
   member  ("'(\<in>')") and
   member  ("(_/ \<in> _)" [51, 51] 50)
 
 abbreviation not_member
   where "not_member x A \<equiv> \<not> (x \<in> A)" \<comment> \<open>non-membership\<close>
 notation
   not_member  ("'(\<notin>')") and
   not_member  ("(_/ \<notin> _)" [51, 51] 50)
 
 notation (ASCII)
   member  ("'(:')") and
   member  ("(_/ : _)" [51, 51] 50) and
   not_member  ("'(~:')") and
   not_member  ("(_/ ~: _)" [51, 51] 50)
 
 
 text \<open>Set comprehensions\<close>
 
 syntax
   "_Coll" :: "pttrn \<Rightarrow> bool \<Rightarrow> 'a set"    ("(1{_./ _})")
 translations
   "{x. P}" \<rightleftharpoons> "CONST Collect (\<lambda>x. P)"
 
 syntax (ASCII)
   "_Collect" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> 'a set"  ("(1{(_/: _)./ _})")
 syntax
   "_Collect" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> 'a set"  ("(1{(_/ \<in> _)./ _})")
 translations
   "{p:A. P}" \<rightharpoonup> "CONST Collect (\<lambda>p. p \<in> A \<and> P)"
 
 lemma CollectI: "P a \<Longrightarrow> a \<in> {x. P x}"
   by simp
 
 lemma CollectD: "a \<in> {x. P x} \<Longrightarrow> P a"
   by simp
 
 lemma Collect_cong: "(\<And>x. P x = Q x) \<Longrightarrow> {x. P x} = {x. Q x}"
   by simp
 
 text \<open>
   Simproc for pulling \<open>x = t\<close> in \<open>{x. \<dots> \<and> x = t \<and> \<dots>}\<close>
   to the front (and similarly for \<open>t = x\<close>):
 \<close>
 
 simproc_setup defined_Collect ("{x. P x \<and> Q x}") = \<open>
-  fn _ => Quantifier1.rearrange_Collect
+  K (Quantifier1.rearrange_Collect
     (fn ctxt =>
       resolve_tac ctxt @{thms Collect_cong} 1 THEN
       resolve_tac ctxt @{thms iffI} 1 THEN
       ALLGOALS
         (EVERY' [REPEAT_DETERM o eresolve_tac ctxt @{thms conjE},
-          DEPTH_SOLVE_1 o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms conjI})]))
+          DEPTH_SOLVE_1 o (assume_tac ctxt ORELSE' resolve_tac ctxt @{thms conjI})])))
 \<close>
 
 lemmas CollectE = CollectD [elim_format]
 
 lemma set_eqI:
   assumes "\<And>x. x \<in> A \<longleftrightarrow> x \<in> B"
   shows "A = B"
 proof -
   from assms have "{x. x \<in> A} = {x. x \<in> B}"
     by simp
   then show ?thesis by simp
 qed
 
 lemma set_eq_iff: "A = B \<longleftrightarrow> (\<forall>x. x \<in> A \<longleftrightarrow> x \<in> B)"
   by (auto intro:set_eqI)
 
 lemma Collect_eqI:
   assumes "\<And>x. P x = Q x"
   shows "Collect P = Collect Q"
   using assms by (auto intro: set_eqI)
 
 text \<open>Lifting of predicate class instances\<close>
 
 instantiation set :: (type) boolean_algebra
 begin
 
 definition less_eq_set
   where "A \<le> B \<longleftrightarrow> (\<lambda>x. member x A) \<le> (\<lambda>x. member x B)"
 
 definition less_set
   where "A < B \<longleftrightarrow> (\<lambda>x. member x A) < (\<lambda>x. member x B)"
 
 definition inf_set
   where "A \<sqinter> B = Collect ((\<lambda>x. member x A) \<sqinter> (\<lambda>x. member x B))"
 
 definition sup_set
   where "A \<squnion> B = Collect ((\<lambda>x. member x A) \<squnion> (\<lambda>x. member x B))"
 
 definition bot_set
   where "\<bottom> = Collect \<bottom>"
 
 definition top_set
   where "\<top> = Collect \<top>"
 
 definition uminus_set
   where "- A = Collect (- (\<lambda>x. member x A))"
 
 definition minus_set
   where "A - B = Collect ((\<lambda>x. member x A) - (\<lambda>x. member x B))"
 
 instance
   by standard
     (simp_all add: less_eq_set_def less_set_def inf_set_def sup_set_def
       bot_set_def top_set_def uminus_set_def minus_set_def
       less_le_not_le sup_inf_distrib1 diff_eq set_eqI fun_eq_iff
       del: inf_apply sup_apply bot_apply top_apply minus_apply uminus_apply)
 
 end
 
 text \<open>Set enumerations\<close>
 
 abbreviation empty :: "'a set" ("{}")
   where "{} \<equiv> bot"
 
 definition insert :: "'a \<Rightarrow> 'a set \<Rightarrow> 'a set"
   where insert_compr: "insert a B = {x. x = a \<or> x \<in> B}"
 
 syntax
   "_Finset" :: "args \<Rightarrow> 'a set"    ("{(_)}")
 translations
   "{x, xs}" \<rightleftharpoons> "CONST insert x {xs}"
   "{x}" \<rightleftharpoons> "CONST insert x {}"
 
 
 subsection \<open>Subsets and bounded quantifiers\<close>
 
 abbreviation subset :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool"
   where "subset \<equiv> less"
 
 abbreviation subset_eq :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool"
   where "subset_eq \<equiv> less_eq"
 
 notation
   subset  ("'(\<subset>')") and
   subset  ("(_/ \<subset> _)" [51, 51] 50) and
   subset_eq  ("'(\<subseteq>')") and
   subset_eq  ("(_/ \<subseteq> _)" [51, 51] 50)
 
 abbreviation (input)
   supset :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
   "supset \<equiv> greater"
 
 abbreviation (input)
   supset_eq :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
   "supset_eq \<equiv> greater_eq"
 
 notation
   supset  ("'(\<supset>')") and
   supset  ("(_/ \<supset> _)" [51, 51] 50) and
   supset_eq  ("'(\<supseteq>')") and
   supset_eq  ("(_/ \<supseteq> _)" [51, 51] 50)
 
 notation (ASCII output)
   subset  ("'(<')") and
   subset  ("(_/ < _)" [51, 51] 50) and
   subset_eq  ("'(<=')") and
   subset_eq  ("(_/ <= _)" [51, 51] 50)
 
 definition Ball :: "'a set \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
   where "Ball A P \<longleftrightarrow> (\<forall>x. x \<in> A \<longrightarrow> P x)"   \<comment> \<open>bounded universal quantifiers\<close>
 
 definition Bex :: "'a set \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
   where "Bex A P \<longleftrightarrow> (\<exists>x. x \<in> A \<and> P x)"   \<comment> \<open>bounded existential quantifiers\<close>
 
 syntax (ASCII)
   "_Ball"       :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool"      ("(3ALL (_/:_)./ _)" [0, 0, 10] 10)
   "_Bex"        :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool"      ("(3EX (_/:_)./ _)" [0, 0, 10] 10)
   "_Bex1"       :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool"      ("(3EX! (_/:_)./ _)" [0, 0, 10] 10)
   "_Bleast"     :: "id \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> 'a"           ("(3LEAST (_/:_)./ _)" [0, 0, 10] 10)
 
 syntax (input)
   "_Ball"       :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool"      ("(3! (_/:_)./ _)" [0, 0, 10] 10)
   "_Bex"        :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool"      ("(3? (_/:_)./ _)" [0, 0, 10] 10)
   "_Bex1"       :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool"      ("(3?! (_/:_)./ _)" [0, 0, 10] 10)
 
 syntax
   "_Ball"       :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool"      ("(3\<forall>(_/\<in>_)./ _)" [0, 0, 10] 10)
   "_Bex"        :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool"      ("(3\<exists>(_/\<in>_)./ _)" [0, 0, 10] 10)
   "_Bex1"       :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool"      ("(3\<exists>!(_/\<in>_)./ _)" [0, 0, 10] 10)
   "_Bleast"     :: "id \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> 'a"           ("(3LEAST(_/\<in>_)./ _)" [0, 0, 10] 10)
 
 translations
   "\<forall>x\<in>A. P" \<rightleftharpoons> "CONST Ball A (\<lambda>x. P)"
   "\<exists>x\<in>A. P" \<rightleftharpoons> "CONST Bex A (\<lambda>x. P)"
   "\<exists>!x\<in>A. P" \<rightharpoonup> "\<exists>!x. x \<in> A \<and> P"
   "LEAST x:A. P" \<rightharpoonup> "LEAST x. x \<in> A \<and> P"
 
 syntax (ASCII output)
   "_setlessAll" :: "[idt, 'a, bool] \<Rightarrow> bool"  ("(3ALL _<_./ _)"  [0, 0, 10] 10)
   "_setlessEx"  :: "[idt, 'a, bool] \<Rightarrow> bool"  ("(3EX _<_./ _)"  [0, 0, 10] 10)
   "_setleAll"   :: "[idt, 'a, bool] \<Rightarrow> bool"  ("(3ALL _<=_./ _)" [0, 0, 10] 10)
   "_setleEx"    :: "[idt, 'a, bool] \<Rightarrow> bool"  ("(3EX _<=_./ _)" [0, 0, 10] 10)
   "_setleEx1"   :: "[idt, 'a, bool] \<Rightarrow> bool"  ("(3EX! _<=_./ _)" [0, 0, 10] 10)
 
 syntax
   "_setlessAll" :: "[idt, 'a, bool] \<Rightarrow> bool"   ("(3\<forall>_\<subset>_./ _)"  [0, 0, 10] 10)
   "_setlessEx"  :: "[idt, 'a, bool] \<Rightarrow> bool"   ("(3\<exists>_\<subset>_./ _)"  [0, 0, 10] 10)
   "_setleAll"   :: "[idt, 'a, bool] \<Rightarrow> bool"   ("(3\<forall>_\<subseteq>_./ _)" [0, 0, 10] 10)
   "_setleEx"    :: "[idt, 'a, bool] \<Rightarrow> bool"   ("(3\<exists>_\<subseteq>_./ _)" [0, 0, 10] 10)
   "_setleEx1"   :: "[idt, 'a, bool] \<Rightarrow> bool"   ("(3\<exists>!_\<subseteq>_./ _)" [0, 0, 10] 10)
 
 translations
  "\<forall>A\<subset>B. P" \<rightharpoonup> "\<forall>A. A \<subset> B \<longrightarrow> P"
  "\<exists>A\<subset>B. P" \<rightharpoonup> "\<exists>A. A \<subset> B \<and> P"
  "\<forall>A\<subseteq>B. P" \<rightharpoonup> "\<forall>A. A \<subseteq> B \<longrightarrow> P"
  "\<exists>A\<subseteq>B. P" \<rightharpoonup> "\<exists>A. A \<subseteq> B \<and> P"
  "\<exists>!A\<subseteq>B. P" \<rightharpoonup> "\<exists>!A. A \<subseteq> B \<and> P"
 
 print_translation \<open>
   let
     val All_binder = Mixfix.binder_name \<^const_syntax>\<open>All\<close>;
     val Ex_binder = Mixfix.binder_name \<^const_syntax>\<open>Ex\<close>;
     val impl = \<^const_syntax>\<open>HOL.implies\<close>;
     val conj = \<^const_syntax>\<open>HOL.conj\<close>;
     val sbset = \<^const_syntax>\<open>subset\<close>;
     val sbset_eq = \<^const_syntax>\<open>subset_eq\<close>;
 
     val trans =
      [((All_binder, impl, sbset), \<^syntax_const>\<open>_setlessAll\<close>),
       ((All_binder, impl, sbset_eq), \<^syntax_const>\<open>_setleAll\<close>),
       ((Ex_binder, conj, sbset), \<^syntax_const>\<open>_setlessEx\<close>),
       ((Ex_binder, conj, sbset_eq), \<^syntax_const>\<open>_setleEx\<close>)];
 
     fun mk v (v', T) c n P =
       if v = v' andalso not (Term.exists_subterm (fn Free (x, _) => x = v | _ => false) n)
       then Syntax.const c $ Syntax_Trans.mark_bound_body (v', T) $ n $ P
       else raise Match;
 
     fun tr' q = (q, fn _ =>
       (fn [Const (\<^syntax_const>\<open>_bound\<close>, _) $ Free (v, Type (\<^type_name>\<open>set\<close>, _)),
           Const (c, _) $
             (Const (d, _) $ (Const (\<^syntax_const>\<open>_bound\<close>, _) $ Free (v', T)) $ n) $ P] =>
           (case AList.lookup (=) trans (q, c, d) of
             NONE => raise Match
           | SOME l => mk v (v', T) l n P)
         | _ => raise Match));
   in
     [tr' All_binder, tr' Ex_binder]
   end
 \<close>
 
 
 text \<open>
   \<^medskip>
   Translate between \<open>{e | x1\<dots>xn. P}\<close> and \<open>{u. \<exists>x1\<dots>xn. u = e \<and> P}\<close>;
   \<open>{y. \<exists>x1\<dots>xn. y = e \<and> P}\<close> is only translated if \<open>[0..n] \<subseteq> bvs e\<close>.
 \<close>
 
 syntax
   "_Setcompr" :: "'a \<Rightarrow> idts \<Rightarrow> bool \<Rightarrow> 'a set"    ("(1{_ |/_./ _})")
 
 parse_translation \<open>
   let
     val ex_tr = snd (Syntax_Trans.mk_binder_tr ("EX ", \<^const_syntax>\<open>Ex\<close>));
 
     fun nvars (Const (\<^syntax_const>\<open>_idts\<close>, _) $ _ $ idts) = nvars idts + 1
       | nvars _ = 1;
 
     fun setcompr_tr ctxt [e, idts, b] =
       let
         val eq = Syntax.const \<^const_syntax>\<open>HOL.eq\<close> $ Bound (nvars idts) $ e;
         val P = Syntax.const \<^const_syntax>\<open>HOL.conj\<close> $ eq $ b;
         val exP = ex_tr ctxt [idts, P];
       in Syntax.const \<^const_syntax>\<open>Collect\<close> $ absdummy dummyT exP end;
 
   in [(\<^syntax_const>\<open>_Setcompr\<close>, setcompr_tr)] end
 \<close>
 
 print_translation \<open>
  [Syntax_Trans.preserve_binder_abs2_tr' \<^const_syntax>\<open>Ball\<close> \<^syntax_const>\<open>_Ball\<close>,
   Syntax_Trans.preserve_binder_abs2_tr' \<^const_syntax>\<open>Bex\<close> \<^syntax_const>\<open>_Bex\<close>]
 \<close> \<comment> \<open>to avoid eta-contraction of body\<close>
 
 print_translation \<open>
 let
   val ex_tr' = snd (Syntax_Trans.mk_binder_tr' (\<^const_syntax>\<open>Ex\<close>, "DUMMY"));
 
   fun setcompr_tr' ctxt [Abs (abs as (_, _, P))] =
     let
       fun check (Const (\<^const_syntax>\<open>Ex\<close>, _) $ Abs (_, _, P), n) = check (P, n + 1)
         | check (Const (\<^const_syntax>\<open>HOL.conj\<close>, _) $
               (Const (\<^const_syntax>\<open>HOL.eq\<close>, _) $ Bound m $ e) $ P, n) =
             n > 0 andalso m = n andalso not (loose_bvar1 (P, n)) andalso
             subset (=) (0 upto (n - 1), add_loose_bnos (e, 0, []))
         | check _ = false;
 
         fun tr' (_ $ abs) =
           let val _ $ idts $ (_ $ (_ $ _ $ e) $ Q) = ex_tr' ctxt [abs]
           in Syntax.const \<^syntax_const>\<open>_Setcompr\<close> $ e $ idts $ Q end;
     in
       if check (P, 0) then tr' P
       else
         let
           val (x as _ $ Free(xN, _), t) = Syntax_Trans.atomic_abs_tr' abs;
           val M = Syntax.const \<^syntax_const>\<open>_Coll\<close> $ x $ t;
         in
           case t of
             Const (\<^const_syntax>\<open>HOL.conj\<close>, _) $
               (Const (\<^const_syntax>\<open>Set.member\<close>, _) $
                 (Const (\<^syntax_const>\<open>_bound\<close>, _) $ Free (yN, _)) $ A) $ P =>
             if xN = yN then Syntax.const \<^syntax_const>\<open>_Collect\<close> $ x $ A $ P else M
           | _ => M
         end
     end;
   in [(\<^const_syntax>\<open>Collect\<close>, setcompr_tr')] end
 \<close>
 
 simproc_setup defined_Bex ("\<exists>x\<in>A. P x \<and> Q x") = \<open>
-  fn _ => Quantifier1.rearrange_Bex
-    (fn ctxt => unfold_tac ctxt @{thms Bex_def})
+  K (Quantifier1.rearrange_Bex (fn ctxt => unfold_tac ctxt @{thms Bex_def}))
 \<close>
 
 simproc_setup defined_All ("\<forall>x\<in>A. P x \<longrightarrow> Q x") = \<open>
-  fn _ => Quantifier1.rearrange_Ball
-    (fn ctxt => unfold_tac ctxt @{thms Ball_def})
+  K (Quantifier1.rearrange_Ball (fn ctxt => unfold_tac ctxt @{thms Ball_def}))
 \<close>
 
 lemma ballI [intro!]: "(\<And>x. x \<in> A \<Longrightarrow> P x) \<Longrightarrow> \<forall>x\<in>A. P x"
   by (simp add: Ball_def)
 
 lemmas strip = impI allI ballI
 
 lemma bspec [dest?]: "\<forall>x\<in>A. P x \<Longrightarrow> x \<in> A \<Longrightarrow> P x"
   by (simp add: Ball_def)
 
 text \<open>Gives better instantiation for bound:\<close>
 setup \<open>
   map_theory_claset (fn ctxt =>
     ctxt addbefore ("bspec", fn ctxt' => dresolve_tac ctxt' @{thms bspec} THEN' assume_tac ctxt'))
 \<close>
 
 ML \<open>
 structure Simpdata =
 struct
   open Simpdata;
   val mksimps_pairs = [(\<^const_name>\<open>Ball\<close>, @{thms bspec})] @ mksimps_pairs;
 end;
 
 open Simpdata;
 \<close>
 
 declaration \<open>fn _ => Simplifier.map_ss (Simplifier.set_mksimps (mksimps mksimps_pairs))\<close>
 
 lemma ballE [elim]: "\<forall>x\<in>A. P x \<Longrightarrow> (P x \<Longrightarrow> Q) \<Longrightarrow> (x \<notin> A \<Longrightarrow> Q) \<Longrightarrow> Q"
   unfolding Ball_def by blast
 
 lemma bexI [intro]: "P x \<Longrightarrow> x \<in> A \<Longrightarrow> \<exists>x\<in>A. P x"
   \<comment> \<open>Normally the best argument order: \<open>P x\<close> constrains the choice of \<open>x \<in> A\<close>.\<close>
   unfolding Bex_def by blast
 
 lemma rev_bexI [intro?]: "x \<in> A \<Longrightarrow> P x \<Longrightarrow> \<exists>x\<in>A. P x"
   \<comment> \<open>The best argument order when there is only one \<open>x \<in> A\<close>.\<close>
   unfolding Bex_def by blast
 
 lemma bexCI: "(\<forall>x\<in>A. \<not> P x \<Longrightarrow> P a) \<Longrightarrow> a \<in> A \<Longrightarrow> \<exists>x\<in>A. P x"
   unfolding Bex_def by blast
 
 lemma bexE [elim!]: "\<exists>x\<in>A. P x \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> P x \<Longrightarrow> Q) \<Longrightarrow> Q"
   unfolding Bex_def by blast
 
 lemma ball_triv [simp]: "(\<forall>x\<in>A. P) \<longleftrightarrow> ((\<exists>x. x \<in> A) \<longrightarrow> P)"
   \<comment> \<open>trivial rewrite rule.\<close>
   by (simp add: Ball_def)
 
 lemma bex_triv [simp]: "(\<exists>x\<in>A. P) \<longleftrightarrow> ((\<exists>x. x \<in> A) \<and> P)"
   \<comment> \<open>Dual form for existentials.\<close>
   by (simp add: Bex_def)
 
 lemma bex_triv_one_point1 [simp]: "(\<exists>x\<in>A. x = a) \<longleftrightarrow> a \<in> A"
   by blast
 
 lemma bex_triv_one_point2 [simp]: "(\<exists>x\<in>A. a = x) \<longleftrightarrow> a \<in> A"
   by blast
 
 lemma bex_one_point1 [simp]: "(\<exists>x\<in>A. x = a \<and> P x) \<longleftrightarrow> a \<in> A \<and> P a"
   by blast
 
 lemma bex_one_point2 [simp]: "(\<exists>x\<in>A. a = x \<and> P x) \<longleftrightarrow> a \<in> A \<and> P a"
   by blast
 
 lemma ball_one_point1 [simp]: "(\<forall>x\<in>A. x = a \<longrightarrow> P x) \<longleftrightarrow> (a \<in> A \<longrightarrow> P a)"
   by blast
 
 lemma ball_one_point2 [simp]: "(\<forall>x\<in>A. a = x \<longrightarrow> P x) \<longleftrightarrow> (a \<in> A \<longrightarrow> P a)"
   by blast
 
 lemma ball_conj_distrib: "(\<forall>x\<in>A. P x \<and> Q x) \<longleftrightarrow> (\<forall>x\<in>A. P x) \<and> (\<forall>x\<in>A. Q x)"
   by blast
 
 lemma bex_disj_distrib: "(\<exists>x\<in>A. P x \<or> Q x) \<longleftrightarrow> (\<exists>x\<in>A. P x) \<or> (\<exists>x\<in>A. Q x)"
   by blast
 
 
 text \<open>Congruence rules\<close>
 
 lemma ball_cong:
   "\<lbrakk> A = B;  \<And>x. x \<in> B \<Longrightarrow> P x \<longleftrightarrow> Q x \<rbrakk> \<Longrightarrow>
     (\<forall>x\<in>A. P x) \<longleftrightarrow> (\<forall>x\<in>B. Q x)"
 by (simp add: Ball_def)
 
 lemma ball_cong_simp [cong]:
   "\<lbrakk> A = B;  \<And>x. x \<in> B =simp=> P x \<longleftrightarrow> Q x \<rbrakk> \<Longrightarrow>
     (\<forall>x\<in>A. P x) \<longleftrightarrow> (\<forall>x\<in>B. Q x)"
 by (simp add: simp_implies_def Ball_def)
 
 lemma bex_cong:
   "\<lbrakk> A = B;  \<And>x. x \<in> B \<Longrightarrow> P x \<longleftrightarrow> Q x \<rbrakk> \<Longrightarrow>
     (\<exists>x\<in>A. P x) \<longleftrightarrow> (\<exists>x\<in>B. Q x)"
 by (simp add: Bex_def cong: conj_cong)
 
 lemma bex_cong_simp [cong]:
   "\<lbrakk> A = B;  \<And>x. x \<in> B =simp=> P x \<longleftrightarrow> Q x \<rbrakk> \<Longrightarrow>
     (\<exists>x\<in>A. P x) \<longleftrightarrow> (\<exists>x\<in>B. Q x)"
 by (simp add: simp_implies_def Bex_def cong: conj_cong)
 
 lemma bex1_def: "(\<exists>!x\<in>X. P x) \<longleftrightarrow> (\<exists>x\<in>X. P x) \<and> (\<forall>x\<in>X. \<forall>y\<in>X. P x \<longrightarrow> P y \<longrightarrow> x = y)"
   by auto
 
 
 subsection \<open>Basic operations\<close>
 
 subsubsection \<open>Subsets\<close>
 
 lemma subsetI [intro!]: "(\<And>x. x \<in> A \<Longrightarrow> x \<in> B) \<Longrightarrow> A \<subseteq> B"
   by (simp add: less_eq_set_def le_fun_def)
 
 text \<open>
   \<^medskip>
   Map the type \<open>'a set \<Rightarrow> anything\<close> to just \<open>'a\<close>; for overloading constants
   whose first argument has type \<open>'a set\<close>.
 \<close>
 
 lemma subsetD [elim, intro?]: "A \<subseteq> B \<Longrightarrow> c \<in> A \<Longrightarrow> c \<in> B"
   by (simp add: less_eq_set_def le_fun_def)
   \<comment> \<open>Rule in Modus Ponens style.\<close>
 
 lemma rev_subsetD [intro?,no_atp]: "c \<in> A \<Longrightarrow> A \<subseteq> B \<Longrightarrow> c \<in> B"
   \<comment> \<open>The same, with reversed premises for use with @{method erule} -- cf. @{thm rev_mp}.\<close>
   by (rule subsetD)
 
 lemma subsetCE [elim,no_atp]: "A \<subseteq> B \<Longrightarrow> (c \<notin> A \<Longrightarrow> P) \<Longrightarrow> (c \<in> B \<Longrightarrow> P) \<Longrightarrow> P"
   \<comment> \<open>Classical elimination rule.\<close>
   by (auto simp add: less_eq_set_def le_fun_def)
 
 lemma subset_eq: "A \<subseteq> B \<longleftrightarrow> (\<forall>x\<in>A. x \<in> B)"
   by blast
 
 lemma contra_subsetD [no_atp]: "A \<subseteq> B \<Longrightarrow> c \<notin> B \<Longrightarrow> c \<notin> A"
   by blast
 
 lemma subset_refl: "A \<subseteq> A"
   by (fact order_refl) (* already [iff] *)
 
 lemma subset_trans: "A \<subseteq> B \<Longrightarrow> B \<subseteq> C \<Longrightarrow> A \<subseteq> C"
   by (fact order_trans)
 
 lemma subset_not_subset_eq [code]: "A \<subset> B \<longleftrightarrow> A \<subseteq> B \<and> \<not> B \<subseteq> A"
   by (fact less_le_not_le)
 
 lemma eq_mem_trans: "a = b \<Longrightarrow> b \<in> A \<Longrightarrow> a \<in> A"
   by simp
 
 lemmas basic_trans_rules [trans] =
   order_trans_rules rev_subsetD subsetD eq_mem_trans
 
 
 subsubsection \<open>Equality\<close>
 
 lemma subset_antisym [intro!]: "A \<subseteq> B \<Longrightarrow> B \<subseteq> A \<Longrightarrow> A = B"
   \<comment> \<open>Anti-symmetry of the subset relation.\<close>
   by (iprover intro: set_eqI subsetD)
 
 text \<open>\<^medskip> Equality rules from ZF set theory -- are they appropriate here?\<close>
 
 lemma equalityD1: "A = B \<Longrightarrow> A \<subseteq> B"
   by simp
 
 lemma equalityD2: "A = B \<Longrightarrow> B \<subseteq> A"
   by simp
 
 text \<open>
   \<^medskip>
   Be careful when adding this to the claset as \<open>subset_empty\<close> is in the
   simpset: \<^prop>\<open>A = {}\<close> goes to \<^prop>\<open>{} \<subseteq> A\<close> and \<^prop>\<open>A \<subseteq> {}\<close>
   and then back to \<^prop>\<open>A = {}\<close>!
 \<close>
 
 lemma equalityE: "A = B \<Longrightarrow> (A \<subseteq> B \<Longrightarrow> B \<subseteq> A \<Longrightarrow> P) \<Longrightarrow> P"
   by simp
 
 lemma equalityCE [elim]: "A = B \<Longrightarrow> (c \<in> A \<Longrightarrow> c \<in> B \<Longrightarrow> P) \<Longrightarrow> (c \<notin> A \<Longrightarrow> c \<notin> B \<Longrightarrow> P) \<Longrightarrow> P"
   by blast
 
 lemma eqset_imp_iff: "A = B \<Longrightarrow> x \<in> A \<longleftrightarrow> x \<in> B"
   by simp
 
 lemma eqelem_imp_iff: "x = y \<Longrightarrow> x \<in> A \<longleftrightarrow> y \<in> A"
   by simp
 
 
 subsubsection \<open>The empty set\<close>
 
 lemma empty_def: "{} = {x. False}"
   by (simp add: bot_set_def bot_fun_def)
 
 lemma empty_iff [simp]: "c \<in> {} \<longleftrightarrow> False"
   by (simp add: empty_def)
 
 lemma emptyE [elim!]: "a \<in> {} \<Longrightarrow> P"
   by simp
 
 lemma empty_subsetI [iff]: "{} \<subseteq> A"
   \<comment> \<open>One effect is to delete the ASSUMPTION \<^prop>\<open>{} \<subseteq> A\<close>\<close>
   by blast
 
 lemma equals0I: "(\<And>y. y \<in> A \<Longrightarrow> False) \<Longrightarrow> A = {}"
   by blast
 
 lemma equals0D: "A = {} \<Longrightarrow> a \<notin> A"
   \<comment> \<open>Use for reasoning about disjointness: \<open>A \<inter> B = {}\<close>\<close>
   by blast
 
 lemma ball_empty [simp]: "Ball {} P \<longleftrightarrow> True"
   by (simp add: Ball_def)
 
 lemma bex_empty [simp]: "Bex {} P \<longleftrightarrow> False"
   by (simp add: Bex_def)
 
 
 subsubsection \<open>The universal set -- UNIV\<close>
 
 abbreviation UNIV :: "'a set"
   where "UNIV \<equiv> top"
 
 lemma UNIV_def: "UNIV = {x. True}"
   by (simp add: top_set_def top_fun_def)
 
 lemma UNIV_I [simp]: "x \<in> UNIV"
   by (simp add: UNIV_def)
 
 declare UNIV_I [intro]  \<comment> \<open>unsafe makes it less likely to cause problems\<close>
 
 lemma UNIV_witness [intro?]: "\<exists>x. x \<in> UNIV"
   by simp
 
 lemma subset_UNIV: "A \<subseteq> UNIV"
   by (fact top_greatest) (* already simp *)
 
 text \<open>
   \<^medskip>
   Eta-contracting these two rules (to remove \<open>P\<close>) causes them
   to be ignored because of their interaction with congruence rules.
 \<close>
 
 lemma ball_UNIV [simp]: "Ball UNIV P \<longleftrightarrow> All P"
   by (simp add: Ball_def)
 
 lemma bex_UNIV [simp]: "Bex UNIV P \<longleftrightarrow> Ex P"
   by (simp add: Bex_def)
 
 lemma UNIV_eq_I: "(\<And>x. x \<in> A) \<Longrightarrow> UNIV = A"
   by auto
 
 lemma UNIV_not_empty [iff]: "UNIV \<noteq> {}"
   by (blast elim: equalityE)
 
 lemma empty_not_UNIV[simp]: "{} \<noteq> UNIV"
   by blast
 
 
 subsubsection \<open>The Powerset operator -- Pow\<close>
 
 definition Pow :: "'a set \<Rightarrow> 'a set set"
   where Pow_def: "Pow A = {B. B \<subseteq> A}"
 
 lemma Pow_iff [iff]: "A \<in> Pow B \<longleftrightarrow> A \<subseteq> B"
   by (simp add: Pow_def)
 
 lemma PowI: "A \<subseteq> B \<Longrightarrow> A \<in> Pow B"
   by (simp add: Pow_def)
 
 lemma PowD: "A \<in> Pow B \<Longrightarrow> A \<subseteq> B"
   by (simp add: Pow_def)
 
 lemma Pow_bottom: "{} \<in> Pow B"
   by simp
 
 lemma Pow_top: "A \<in> Pow A"
   by simp
 
 lemma Pow_not_empty: "Pow A \<noteq> {}"
   using Pow_top by blast
 
 
 subsubsection \<open>Set complement\<close>
 
 lemma Compl_iff [simp]: "c \<in> - A \<longleftrightarrow> c \<notin> A"
   by (simp add: fun_Compl_def uminus_set_def)
 
 lemma ComplI [intro!]: "(c \<in> A \<Longrightarrow> False) \<Longrightarrow> c \<in> - A"
   by (simp add: fun_Compl_def uminus_set_def) blast
 
 text \<open>
   \<^medskip>
   This form, with negated conclusion, works well with the Classical prover.
   Negated assumptions behave like formulae on the right side of the
   notional turnstile \dots
 \<close>
 
 lemma ComplD [dest!]: "c \<in> - A \<Longrightarrow> c \<notin> A"
   by simp
 
 lemmas ComplE = ComplD [elim_format]
 
 lemma Compl_eq: "- A = {x. \<not> x \<in> A}"
   by blast
 
 
 subsubsection \<open>Binary intersection\<close>
 
 abbreviation inter :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set"  (infixl "\<inter>" 70)
   where "(\<inter>) \<equiv> inf"
 
 notation (ASCII)
   inter  (infixl "Int" 70)
 
 lemma Int_def: "A \<inter> B = {x. x \<in> A \<and> x \<in> B}"
   by (simp add: inf_set_def inf_fun_def)
 
 lemma Int_iff [simp]: "c \<in> A \<inter> B \<longleftrightarrow> c \<in> A \<and> c \<in> B"
   unfolding Int_def by blast
 
 lemma IntI [intro!]: "c \<in> A \<Longrightarrow> c \<in> B \<Longrightarrow> c \<in> A \<inter> B"
   by simp
 
 lemma IntD1: "c \<in> A \<inter> B \<Longrightarrow> c \<in> A"
   by simp
 
 lemma IntD2: "c \<in> A \<inter> B \<Longrightarrow> c \<in> B"
   by simp
 
 lemma IntE [elim!]: "c \<in> A \<inter> B \<Longrightarrow> (c \<in> A \<Longrightarrow> c \<in> B \<Longrightarrow> P) \<Longrightarrow> P"
   by simp
 
 
 subsubsection \<open>Binary union\<close>
 
 abbreviation union :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set"  (infixl "\<union>" 65)
   where "union \<equiv> sup"
 
 notation (ASCII)
   union  (infixl "Un" 65)
 
 lemma Un_def: "A \<union> B = {x. x \<in> A \<or> x \<in> B}"
   by (simp add: sup_set_def sup_fun_def)
 
 lemma Un_iff [simp]: "c \<in> A \<union> B \<longleftrightarrow> c \<in> A \<or> c \<in> B"
   unfolding Un_def by blast
 
 lemma UnI1 [elim?]: "c \<in> A \<Longrightarrow> c \<in> A \<union> B"
   by simp
 
 lemma UnI2 [elim?]: "c \<in> B \<Longrightarrow> c \<in> A \<union> B"
   by simp
 
 text \<open>\<^medskip> Classical introduction rule: no commitment to \<open>A\<close> vs. \<open>B\<close>.\<close>
 lemma UnCI [intro!]: "(c \<notin> B \<Longrightarrow> c \<in> A) \<Longrightarrow> c \<in> A \<union> B"
   by auto
 
 lemma UnE [elim!]: "c \<in> A \<union> B \<Longrightarrow> (c \<in> A \<Longrightarrow> P) \<Longrightarrow> (c \<in> B \<Longrightarrow> P) \<Longrightarrow> P"
   unfolding Un_def by blast
 
 lemma insert_def: "insert a B = {x. x = a} \<union> B"
   by (simp add: insert_compr Un_def)
 
 
 subsubsection \<open>Set difference\<close>
 
 lemma Diff_iff [simp]: "c \<in> A - B \<longleftrightarrow> c \<in> A \<and> c \<notin> B"
   by (simp add: minus_set_def fun_diff_def)
 
 lemma DiffI [intro!]: "c \<in> A \<Longrightarrow> c \<notin> B \<Longrightarrow> c \<in> A - B"
   by simp
 
 lemma DiffD1: "c \<in> A - B \<Longrightarrow> c \<in> A"
   by simp
 
 lemma DiffD2: "c \<in> A - B \<Longrightarrow> c \<in> B \<Longrightarrow> P"
   by simp
 
 lemma DiffE [elim!]: "c \<in> A - B \<Longrightarrow> (c \<in> A \<Longrightarrow> c \<notin> B \<Longrightarrow> P) \<Longrightarrow> P"
   by simp
 
 lemma set_diff_eq: "A - B = {x. x \<in> A \<and> x \<notin> B}"
   by blast
 
 lemma Compl_eq_Diff_UNIV: "- A = (UNIV - A)"
   by blast
 
 
 subsubsection \<open>Augmenting a set -- \<^const>\<open>insert\<close>\<close>
 
 lemma insert_iff [simp]: "a \<in> insert b A \<longleftrightarrow> a = b \<or> a \<in> A"
   unfolding insert_def by blast
 
 lemma insertI1: "a \<in> insert a B"
   by simp
 
 lemma insertI2: "a \<in> B \<Longrightarrow> a \<in> insert b B"
   by simp
 
 lemma insertE [elim!]: "a \<in> insert b A \<Longrightarrow> (a = b \<Longrightarrow> P) \<Longrightarrow> (a \<in> A \<Longrightarrow> P) \<Longrightarrow> P"
   unfolding insert_def by blast
 
 lemma insertCI [intro!]: "(a \<notin> B \<Longrightarrow> a = b) \<Longrightarrow> a \<in> insert b B"
   \<comment> \<open>Classical introduction rule.\<close>
   by auto
 
 lemma subset_insert_iff: "A \<subseteq> insert x B \<longleftrightarrow> (if x \<in> A then A - {x} \<subseteq> B else A \<subseteq> B)"
   by auto
 
 lemma set_insert:
   assumes "x \<in> A"
   obtains B where "A = insert x B" and "x \<notin> B"
 proof
   show "A = insert x (A - {x})" using assms by blast
   show "x \<notin> A - {x}" by blast
 qed
 
 lemma insert_ident: "x \<notin> A \<Longrightarrow> x \<notin> B \<Longrightarrow> insert x A = insert x B \<longleftrightarrow> A = B"
   by auto
 
 lemma insert_eq_iff:
   assumes "a \<notin> A" "b \<notin> B"
   shows "insert a A = insert b B \<longleftrightarrow>
     (if a = b then A = B else \<exists>C. A = insert b C \<and> b \<notin> C \<and> B = insert a C \<and> a \<notin> C)"
     (is "?L \<longleftrightarrow> ?R")
 proof
   show ?R if ?L
   proof (cases "a = b")
     case True
     with assms \<open>?L\<close> show ?R
       by (simp add: insert_ident)
   next
     case False
     let ?C = "A - {b}"
     have "A = insert b ?C \<and> b \<notin> ?C \<and> B = insert a ?C \<and> a \<notin> ?C"
       using assms \<open>?L\<close> \<open>a \<noteq> b\<close> by auto
     then show ?R using \<open>a \<noteq> b\<close> by auto
   qed
   show ?L if ?R
     using that by (auto split: if_splits)
 qed
 
 lemma insert_UNIV: "insert x UNIV = UNIV"
   by auto
 
 
 subsubsection \<open>Singletons, using insert\<close>
 
 lemma singletonI [intro!]: "a \<in> {a}"
   \<comment> \<open>Redundant? But unlike \<open>insertCI\<close>, it proves the subgoal immediately!\<close>
   by (rule insertI1)
 
 lemma singletonD [dest!]: "b \<in> {a} \<Longrightarrow> b = a"
   by blast
 
 lemmas singletonE = singletonD [elim_format]
 
 lemma singleton_iff: "b \<in> {a} \<longleftrightarrow> b = a"
   by blast
 
 lemma singleton_inject [dest!]: "{a} = {b} \<Longrightarrow> a = b"
   by blast
 
 lemma singleton_insert_inj_eq [iff]: "{b} = insert a A \<longleftrightarrow> a = b \<and> A \<subseteq> {b}"
   by blast
 
 lemma singleton_insert_inj_eq' [iff]: "insert a A = {b} \<longleftrightarrow> a = b \<and> A \<subseteq> {b}"
   by blast
 
 lemma subset_singletonD: "A \<subseteq> {x} \<Longrightarrow> A = {} \<or> A = {x}"
   by fast
 
 lemma subset_singleton_iff: "X \<subseteq> {a} \<longleftrightarrow> X = {} \<or> X = {a}"
   by blast
 
 lemma subset_singleton_iff_Uniq: "(\<exists>a. A \<subseteq> {a}) \<longleftrightarrow> (\<exists>\<^sub>\<le>\<^sub>1x. x \<in> A)"
   unfolding Uniq_def by blast
 
 lemma singleton_conv [simp]: "{x. x = a} = {a}"
   by blast
 
 lemma singleton_conv2 [simp]: "{x. a = x} = {a}"
   by blast
 
 lemma Diff_single_insert: "A - {x} \<subseteq> B \<Longrightarrow> A \<subseteq> insert x B"
   by blast
 
 lemma subset_Diff_insert: "A \<subseteq> B - insert x C \<longleftrightarrow> A \<subseteq> B - C \<and> x \<notin> A"
   by blast
 
 lemma doubleton_eq_iff: "{a, b} = {c, d} \<longleftrightarrow> a = c \<and> b = d \<or> a = d \<and> b = c"
   by (blast elim: equalityE)
 
 lemma Un_singleton_iff: "A \<union> B = {x} \<longleftrightarrow> A = {} \<and> B = {x} \<or> A = {x} \<and> B = {} \<or> A = {x} \<and> B = {x}"
   by auto
 
 lemma singleton_Un_iff: "{x} = A \<union> B \<longleftrightarrow> A = {} \<and> B = {x} \<or> A = {x} \<and> B = {} \<or> A = {x} \<and> B = {x}"
   by auto
 
 
 subsubsection \<open>Image of a set under a function\<close>
 
 text \<open>Frequently \<open>b\<close> does not have the syntactic form of \<open>f x\<close>.\<close>
 
 definition image :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'b set"    (infixr "`" 90)
   where "f ` A = {y. \<exists>x\<in>A. y = f x}"
 
 lemma image_eqI [simp, intro]: "b = f x \<Longrightarrow> x \<in> A \<Longrightarrow> b \<in> f ` A"
   unfolding image_def by blast
 
 lemma imageI: "x \<in> A \<Longrightarrow> f x \<in> f ` A"
   by (rule image_eqI) (rule refl)
 
 lemma rev_image_eqI: "x \<in> A \<Longrightarrow> b = f x \<Longrightarrow> b \<in> f ` A"
   \<comment> \<open>This version's more effective when we already have the required \<open>x\<close>.\<close>
   by (rule image_eqI)
 
 lemma imageE [elim!]:
   assumes "b \<in> (\<lambda>x. f x) ` A"  \<comment> \<open>The eta-expansion gives variable-name preservation.\<close>
   obtains x where "b = f x" and "x \<in> A"
   using assms unfolding image_def by blast
 
 lemma Compr_image_eq: "{x \<in> f ` A. P x} = f ` {x \<in> A. P (f x)}"
   by auto
 
 lemma image_Un: "f ` (A \<union> B) = f ` A \<union> f ` B"
   by blast
 
 lemma image_iff: "z \<in> f ` A \<longleftrightarrow> (\<exists>x\<in>A. z = f x)"
   by blast
 
 lemma image_subsetI: "(\<And>x. x \<in> A \<Longrightarrow> f x \<in> B) \<Longrightarrow> f ` A \<subseteq> B"
   \<comment> \<open>Replaces the three steps \<open>subsetI\<close>, \<open>imageE\<close>,
     \<open>hypsubst\<close>, but breaks too many existing proofs.\<close>
   by blast
 
 lemma image_subset_iff: "f ` A \<subseteq> B \<longleftrightarrow> (\<forall>x\<in>A. f x \<in> B)"
   \<comment> \<open>This rewrite rule would confuse users if made default.\<close>
   by blast
 
 lemma subset_imageE:
   assumes "B \<subseteq> f ` A"
   obtains C where "C \<subseteq> A" and "B = f ` C"
 proof -
   from assms have "B = f ` {a \<in> A. f a \<in> B}" by fast
   moreover have "{a \<in> A. f a \<in> B} \<subseteq> A" by blast
   ultimately show thesis by (blast intro: that)
 qed
 
 lemma subset_image_iff: "B \<subseteq> f ` A \<longleftrightarrow> (\<exists>AA\<subseteq>A. B = f ` AA)"
   by (blast elim: subset_imageE)
 
 lemma image_ident [simp]: "(\<lambda>x. x) ` Y = Y"
   by blast
 
 lemma image_empty [simp]: "f ` {} = {}"
   by blast
 
 lemma image_insert [simp]: "f ` insert a B = insert (f a) (f ` B)"
   by blast
 
 lemma image_constant: "x \<in> A \<Longrightarrow> (\<lambda>x. c) ` A = {c}"
   by auto
 
 lemma image_constant_conv: "(\<lambda>x. c) ` A = (if A = {} then {} else {c})"
   by auto
 
 lemma image_image: "f ` (g ` A) = (\<lambda>x. f (g x)) ` A"
   by blast
 
 lemma insert_image [simp]: "x \<in> A \<Longrightarrow> insert (f x) (f ` A) = f ` A"
   by blast
 
 lemma image_is_empty [iff]: "f ` A = {} \<longleftrightarrow> A = {}"
   by blast
 
 lemma empty_is_image [iff]: "{} = f ` A \<longleftrightarrow> A = {}"
   by blast
 
 lemma image_Collect: "f ` {x. P x} = {f x | x. P x}"
   \<comment> \<open>NOT suitable as a default simp rule: the RHS isn't simpler than the LHS,
       with its implicit quantifier and conjunction.  Also image enjoys better
       equational properties than does the RHS.\<close>
   by blast
 
 lemma if_image_distrib [simp]:
   "(\<lambda>x. if P x then f x else g x) ` S = f ` (S \<inter> {x. P x}) \<union> g ` (S \<inter> {x. \<not> P x})"
   by auto
 
 lemma image_cong:
   "f ` M = g ` N" if "M = N" "\<And>x. x \<in> N \<Longrightarrow> f x = g x"
   using that by (simp add: image_def)
 
 lemma image_cong_simp [cong]:
   "f ` M = g ` N" if "M = N" "\<And>x. x \<in> N =simp=> f x = g x"
   using that image_cong [of M N f g] by (simp add: simp_implies_def)
 
 lemma image_Int_subset: "f ` (A \<inter> B) \<subseteq> f ` A \<inter> f ` B"
   by blast
 
 lemma image_diff_subset: "f ` A - f ` B \<subseteq> f ` (A - B)"
   by blast
 
 lemma Setcompr_eq_image: "{f x |x. x \<in> A} = f ` A"
   by blast
 
 lemma setcompr_eq_image: "{f x |x. P x} = f ` {x. P x}"
   by auto
 
 lemma ball_imageD: "\<forall>x\<in>f ` A. P x \<Longrightarrow> \<forall>x\<in>A. P (f x)"
   by simp
 
 lemma bex_imageD: "\<exists>x\<in>f ` A. P x \<Longrightarrow> \<exists>x\<in>A. P (f x)"
   by auto
 
 lemma image_add_0 [simp]: "(+) (0::'a::comm_monoid_add) ` S = S"
   by auto
 
 theorem Cantors_theorem: "\<nexists>f. f ` A = Pow A"
 proof
   assume "\<exists>f. f ` A = Pow A"
   then obtain f where f: "f ` A = Pow A" ..
   let ?X = "{a \<in> A. a \<notin> f a}"
   have "?X \<in> Pow A" by blast
   then have "?X \<in> f ` A" by (simp only: f)
   then obtain x where "x \<in> A" and "f x = ?X" by blast
   then show False by blast
 qed
 
 text \<open>\<^medskip> Range of a function -- just an abbreviation for image!\<close>
 
 abbreviation range :: "('a \<Rightarrow> 'b) \<Rightarrow> 'b set"  \<comment> \<open>of function\<close>
   where "range f \<equiv> f ` UNIV"
 
 lemma range_eqI: "b = f x \<Longrightarrow> b \<in> range f"
   by simp
 
 lemma rangeI: "f x \<in> range f"
   by simp
 
 lemma rangeE [elim?]: "b \<in> range (\<lambda>x. f x) \<Longrightarrow> (\<And>x. b = f x \<Longrightarrow> P) \<Longrightarrow> P"
   by (rule imageE)
 
 lemma range_subsetD: "range f \<subseteq> B \<Longrightarrow> f i \<in> B"
   by blast
 
 lemma full_SetCompr_eq: "{u. \<exists>x. u = f x} = range f"
   by auto
 
 lemma range_composition: "range (\<lambda>x. f (g x)) = f ` range g"
   by auto
 
 lemma range_constant [simp]: "range (\<lambda>_. x) = {x}"
   by (simp add: image_constant)
 
 lemma range_eq_singletonD: "range f = {a} \<Longrightarrow> f x = a"
   by auto
 
 
 subsubsection \<open>Some rules with \<open>if\<close>\<close>
 
 text \<open>Elimination of \<open>{x. \<dots> \<and> x = t \<and> \<dots>}\<close>.\<close>
 
 lemma Collect_conv_if: "{x. x = a \<and> P x} = (if P a then {a} else {})"
   by auto
 
 lemma Collect_conv_if2: "{x. a = x \<and> P x} = (if P a then {a} else {})"
   by auto
 
 text \<open>
   Rewrite rules for boolean case-splitting: faster than \<open>if_split [split]\<close>.
 \<close>
 
 lemma if_split_eq1: "(if Q then x else y) = b \<longleftrightarrow> (Q \<longrightarrow> x = b) \<and> (\<not> Q \<longrightarrow> y = b)"
   by (rule if_split)
 
 lemma if_split_eq2: "a = (if Q then x else y) \<longleftrightarrow> (Q \<longrightarrow> a = x) \<and> (\<not> Q \<longrightarrow> a = y)"
   by (rule if_split)
 
 text \<open>
   Split ifs on either side of the membership relation.
   Not for \<open>[simp]\<close> -- can cause goals to blow up!
 \<close>
 
 lemma if_split_mem1: "(if Q then x else y) \<in> b \<longleftrightarrow> (Q \<longrightarrow> x \<in> b) \<and> (\<not> Q \<longrightarrow> y \<in> b)"
   by (rule if_split)
 
 lemma if_split_mem2: "(a \<in> (if Q then x else y)) \<longleftrightarrow> (Q \<longrightarrow> a \<in> x) \<and> (\<not> Q \<longrightarrow> a \<in> y)"
   by (rule if_split [where P = "\<lambda>S. a \<in> S"])
 
 lemmas split_ifs = if_bool_eq_conj if_split_eq1 if_split_eq2 if_split_mem1 if_split_mem2
 
 (*Would like to add these, but the existing code only searches for the
   outer-level constant, which in this case is just Set.member; we instead need
   to use term-nets to associate patterns with rules.  Also, if a rule fails to
   apply, then the formula should be kept.
   [("uminus", Compl_iff RS iffD1), ("minus", [Diff_iff RS iffD1]),
    ("Int", [IntD1,IntD2]),
    ("Collect", [CollectD]), ("Inter", [InterD]), ("INTER", [INT_D])]
  *)
 
 
 subsection \<open>Further operations and lemmas\<close>
 
 subsubsection \<open>The ``proper subset'' relation\<close>
 
 lemma psubsetI [intro!]: "A \<subseteq> B \<Longrightarrow> A \<noteq> B \<Longrightarrow> A \<subset> B"
   unfolding less_le by blast
 
 lemma psubsetE [elim!]: "A \<subset> B \<Longrightarrow> (A \<subseteq> B \<Longrightarrow> \<not> B \<subseteq> A \<Longrightarrow> R) \<Longrightarrow> R"
   unfolding less_le by blast
 
 lemma psubset_insert_iff:
   "A \<subset> insert x B \<longleftrightarrow> (if x \<in> B then A \<subset> B else if x \<in> A then A - {x} \<subset> B else A \<subseteq> B)"
   by (auto simp add: less_le subset_insert_iff)
 
 lemma psubset_eq: "A \<subset> B \<longleftrightarrow> A \<subseteq> B \<and> A \<noteq> B"
   by (simp only: less_le)
 
 lemma psubset_imp_subset: "A \<subset> B \<Longrightarrow> A \<subseteq> B"
   by (simp add: psubset_eq)
 
 lemma psubset_trans: "A \<subset> B \<Longrightarrow> B \<subset> C \<Longrightarrow> A \<subset> C"
   unfolding less_le by (auto dest: subset_antisym)
 
 lemma psubsetD: "A \<subset> B \<Longrightarrow> c \<in> A \<Longrightarrow> c \<in> B"
   unfolding less_le by (auto dest: subsetD)
 
 lemma psubset_subset_trans: "A \<subset> B \<Longrightarrow> B \<subseteq> C \<Longrightarrow> A \<subset> C"
   by (auto simp add: psubset_eq)
 
 lemma subset_psubset_trans: "A \<subseteq> B \<Longrightarrow> B \<subset> C \<Longrightarrow> A \<subset> C"
   by (auto simp add: psubset_eq)
 
 lemma psubset_imp_ex_mem: "A \<subset> B \<Longrightarrow> \<exists>b. b \<in> B - A"
   unfolding less_le by blast
 
 lemma atomize_ball: "(\<And>x. x \<in> A \<Longrightarrow> P x) \<equiv> Trueprop (\<forall>x\<in>A. P x)"
   by (simp only: Ball_def atomize_all atomize_imp)
 
 lemmas [symmetric, rulify] = atomize_ball
   and [symmetric, defn] = atomize_ball
 
 lemma image_Pow_mono: "f ` A \<subseteq> B \<Longrightarrow> image f ` Pow A \<subseteq> Pow B"
   by blast
 
 lemma image_Pow_surj: "f ` A = B \<Longrightarrow> image f ` Pow A = Pow B"
   by (blast elim: subset_imageE)
 
 
 subsubsection \<open>Derived rules involving subsets.\<close>
 
 text \<open>\<open>insert\<close>.\<close>
 
 lemma subset_insertI: "B \<subseteq> insert a B"
   by (rule subsetI) (erule insertI2)
 
 lemma subset_insertI2: "A \<subseteq> B \<Longrightarrow> A \<subseteq> insert b B"
   by blast
 
 lemma subset_insert: "x \<notin> A \<Longrightarrow> A \<subseteq> insert x B \<longleftrightarrow> A \<subseteq> B"
   by blast
 
 
 text \<open>\<^medskip> Finite Union -- the least upper bound of two sets.\<close>
 
 lemma Un_upper1: "A \<subseteq> A \<union> B"
   by (fact sup_ge1)
 
 lemma Un_upper2: "B \<subseteq> A \<union> B"
   by (fact sup_ge2)
 
 lemma Un_least: "A \<subseteq> C \<Longrightarrow> B \<subseteq> C \<Longrightarrow> A \<union> B \<subseteq> C"
   by (fact sup_least)
 
 
 text \<open>\<^medskip> Finite Intersection -- the greatest lower bound of two sets.\<close>
 
 lemma Int_lower1: "A \<inter> B \<subseteq> A"
   by (fact inf_le1)
 
 lemma Int_lower2: "A \<inter> B \<subseteq> B"
   by (fact inf_le2)
 
 lemma Int_greatest: "C \<subseteq> A \<Longrightarrow> C \<subseteq> B \<Longrightarrow> C \<subseteq> A \<inter> B"
   by (fact inf_greatest)
 
 
 text \<open>\<^medskip> Set difference.\<close>
 
 lemma Diff_subset[simp]: "A - B \<subseteq> A"
   by blast
 
 lemma Diff_subset_conv: "A - B \<subseteq> C \<longleftrightarrow> A \<subseteq> B \<union> C"
   by blast
 
 
 subsubsection \<open>Equalities involving union, intersection, inclusion, etc.\<close>
 
 text \<open>\<open>{}\<close>.\<close>
 
 lemma Collect_const [simp]: "{s. P} = (if P then UNIV else {})"
   \<comment> \<open>supersedes \<open>Collect_False_empty\<close>\<close>
   by auto
 
 lemma subset_empty [simp]: "A \<subseteq> {} \<longleftrightarrow> A = {}"
   by (fact bot_unique)
 
 lemma not_psubset_empty [iff]: "\<not> (A < {})"
   by (fact not_less_bot) (* FIXME: already simp *)
 
 lemma Collect_subset [simp]: "{x\<in>A. P x} \<subseteq> A" by auto
 
 lemma Collect_empty_eq [simp]: "Collect P = {} \<longleftrightarrow> (\<forall>x. \<not> P x)"
   by blast
 
 lemma empty_Collect_eq [simp]: "{} = Collect P \<longleftrightarrow> (\<forall>x. \<not> P x)"
   by blast
 
 lemma Collect_neg_eq: "{x. \<not> P x} = - {x. P x}"
   by blast
 
 lemma Collect_disj_eq: "{x. P x \<or> Q x} = {x. P x} \<union> {x. Q x}"
   by blast
 
 lemma Collect_imp_eq: "{x. P x \<longrightarrow> Q x} = - {x. P x} \<union> {x. Q x}"
   by blast
 
 lemma Collect_conj_eq: "{x. P x \<and> Q x} = {x. P x} \<inter> {x. Q x}"
   by blast
 
 lemma Collect_mono_iff: "Collect P \<subseteq> Collect Q \<longleftrightarrow> (\<forall>x. P x \<longrightarrow> Q x)"
   by blast
 
 
 text \<open>\<^medskip> \<open>insert\<close>.\<close>
 
 lemma insert_is_Un: "insert a A = {a} \<union> A"
   \<comment> \<open>NOT SUITABLE FOR REWRITING since \<open>{a} \<equiv> insert a {}\<close>\<close>
   by blast
 
 lemma insert_not_empty [simp]: "insert a A \<noteq> {}"
   and empty_not_insert [simp]: "{} \<noteq> insert a A"
   by blast+
 
 lemma insert_absorb: "a \<in> A \<Longrightarrow> insert a A = A"
   \<comment> \<open>\<open>[simp]\<close> causes recursive calls when there are nested inserts\<close>
   \<comment> \<open>with \<^emph>\<open>quadratic\<close> running time\<close>
   by blast
 
 lemma insert_absorb2 [simp]: "insert x (insert x A) = insert x A"
   by blast
 
 lemma insert_commute: "insert x (insert y A) = insert y (insert x A)"
   by blast
 
 lemma insert_subset [simp]: "insert x A \<subseteq> B \<longleftrightarrow> x \<in> B \<and> A \<subseteq> B"
   by blast
 
 lemma mk_disjoint_insert: "a \<in> A \<Longrightarrow> \<exists>B. A = insert a B \<and> a \<notin> B"
   \<comment> \<open>use new \<open>B\<close> rather than \<open>A - {a}\<close> to avoid infinite unfolding\<close>
   by (rule exI [where x = "A - {a}"]) blast
 
 lemma insert_Collect: "insert a (Collect P) = {u. u \<noteq> a \<longrightarrow> P u}"
   by auto
 
 lemma insert_inter_insert [simp]: "insert a A \<inter> insert a B = insert a (A \<inter> B)"
   by blast
 
 lemma insert_disjoint [simp]:
   "insert a A \<inter> B = {} \<longleftrightarrow> a \<notin> B \<and> A \<inter> B = {}"
   "{} = insert a A \<inter> B \<longleftrightarrow> a \<notin> B \<and> {} = A \<inter> B"
   by auto
 
 lemma disjoint_insert [simp]:
   "B \<inter> insert a A = {} \<longleftrightarrow> a \<notin> B \<and> B \<inter> A = {}"
   "{} = A \<inter> insert b B \<longleftrightarrow> b \<notin> A \<and> {} = A \<inter> B"
   by auto
 
 
 text \<open>\<^medskip> \<open>Int\<close>\<close>
 
 lemma Int_absorb: "A \<inter> A = A"
   by (fact inf_idem) (* already simp *)
 
 lemma Int_left_absorb: "A \<inter> (A \<inter> B) = A \<inter> B"
   by (fact inf_left_idem)
 
 lemma Int_commute: "A \<inter> B = B \<inter> A"
   by (fact inf_commute)
 
 lemma Int_left_commute: "A \<inter> (B \<inter> C) = B \<inter> (A \<inter> C)"
   by (fact inf_left_commute)
 
 lemma Int_assoc: "(A \<inter> B) \<inter> C = A \<inter> (B \<inter> C)"
   by (fact inf_assoc)
 
 lemmas Int_ac = Int_assoc Int_left_absorb Int_commute Int_left_commute
   \<comment> \<open>Intersection is an AC-operator\<close>
 
 lemma Int_absorb1: "B \<subseteq> A \<Longrightarrow> A \<inter> B = B"
   by (fact inf_absorb2)
 
 lemma Int_absorb2: "A \<subseteq> B \<Longrightarrow> A \<inter> B = A"
   by (fact inf_absorb1)
 
 lemma Int_empty_left: "{} \<inter> B = {}"
   by (fact inf_bot_left) (* already simp *)
 
 lemma Int_empty_right: "A \<inter> {} = {}"
   by (fact inf_bot_right) (* already simp *)
 
 lemma disjoint_eq_subset_Compl: "A \<inter> B = {} \<longleftrightarrow> A \<subseteq> - B"
   by blast
 
 lemma disjoint_iff: "A \<inter> B = {} \<longleftrightarrow> (\<forall>x. x\<in>A \<longrightarrow> x \<notin> B)"
   by blast
 
 lemma disjoint_iff_not_equal: "A \<inter> B = {} \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>B. x \<noteq> y)"
   by blast
 
 lemma Int_UNIV_left: "UNIV \<inter> B = B"
   by (fact inf_top_left) (* already simp *)
 
 lemma Int_UNIV_right: "A \<inter> UNIV = A"
   by (fact inf_top_right) (* already simp *)
 
 lemma Int_Un_distrib: "A \<inter> (B \<union> C) = (A \<inter> B) \<union> (A \<inter> C)"
   by (fact inf_sup_distrib1)
 
 lemma Int_Un_distrib2: "(B \<union> C) \<inter> A = (B \<inter> A) \<union> (C \<inter> A)"
   by (fact inf_sup_distrib2)
 
 lemma Int_UNIV [simp]: "A \<inter> B = UNIV \<longleftrightarrow> A = UNIV \<and> B = UNIV"
   by (fact inf_eq_top_iff) (* already simp *)
 
 lemma Int_subset_iff [simp]: "C \<subseteq> A \<inter> B \<longleftrightarrow> C \<subseteq> A \<and> C \<subseteq> B"
   by (fact le_inf_iff)
 
 lemma Int_Collect: "x \<in> A \<inter> {x. P x} \<longleftrightarrow> x \<in> A \<and> P x"
   by blast
 
 
 text \<open>\<^medskip> \<open>Un\<close>.\<close>
 
 lemma Un_absorb: "A \<union> A = A"
   by (fact sup_idem) (* already simp *)
 
 lemma Un_left_absorb: "A \<union> (A \<union> B) = A \<union> B"
   by (fact sup_left_idem)
 
 lemma Un_commute: "A \<union> B = B \<union> A"
   by (fact sup_commute)
 
 lemma Un_left_commute: "A \<union> (B \<union> C) = B \<union> (A \<union> C)"
   by (fact sup_left_commute)
 
 lemma Un_assoc: "(A \<union> B) \<union> C = A \<union> (B \<union> C)"
   by (fact sup_assoc)
 
 lemmas Un_ac = Un_assoc Un_left_absorb Un_commute Un_left_commute
   \<comment> \<open>Union is an AC-operator\<close>
 
 lemma Un_absorb1: "A \<subseteq> B \<Longrightarrow> A \<union> B = B"
   by (fact sup_absorb2)
 
 lemma Un_absorb2: "B \<subseteq> A \<Longrightarrow> A \<union> B = A"
   by (fact sup_absorb1)
 
 lemma Un_empty_left: "{} \<union> B = B"
   by (fact sup_bot_left) (* already simp *)
 
 lemma Un_empty_right: "A \<union> {} = A"
   by (fact sup_bot_right) (* already simp *)
 
 lemma Un_UNIV_left: "UNIV \<union> B = UNIV"
   by (fact sup_top_left) (* already simp *)
 
 lemma Un_UNIV_right: "A \<union> UNIV = UNIV"
   by (fact sup_top_right) (* already simp *)
 
 lemma Un_insert_left [simp]: "(insert a B) \<union> C = insert a (B \<union> C)"
   by blast
 
 lemma Un_insert_right [simp]: "A \<union> (insert a B) = insert a (A \<union> B)"
   by blast
 
 lemma Int_insert_left: "(insert a B) \<inter> C = (if a \<in> C then insert a (B \<inter> C) else B \<inter> C)"
   by auto
 
 lemma Int_insert_left_if0 [simp]: "a \<notin> C \<Longrightarrow> (insert a B) \<inter> C = B \<inter> C"
   by auto
 
 lemma Int_insert_left_if1 [simp]: "a \<in> C \<Longrightarrow> (insert a B) \<inter> C = insert a (B \<inter> C)"
   by auto
 
 lemma Int_insert_right: "A \<inter> (insert a B) = (if a \<in> A then insert a (A \<inter> B) else A \<inter> B)"
   by auto
 
 lemma Int_insert_right_if0 [simp]: "a \<notin> A \<Longrightarrow> A \<inter> (insert a B) = A \<inter> B"
   by auto
 
 lemma Int_insert_right_if1 [simp]: "a \<in> A \<Longrightarrow> A \<inter> (insert a B) = insert a (A \<inter> B)"
   by auto
 
 lemma Un_Int_distrib: "A \<union> (B \<inter> C) = (A \<union> B) \<inter> (A \<union> C)"
   by (fact sup_inf_distrib1)
 
 lemma Un_Int_distrib2: "(B \<inter> C) \<union> A = (B \<union> A) \<inter> (C \<union> A)"
   by (fact sup_inf_distrib2)
 
 lemma Un_Int_crazy: "(A \<inter> B) \<union> (B \<inter> C) \<union> (C \<inter> A) = (A \<union> B) \<inter> (B \<union> C) \<inter> (C \<union> A)"
   by blast
 
 lemma subset_Un_eq: "A \<subseteq> B \<longleftrightarrow> A \<union> B = B"
   by (fact le_iff_sup)
 
 lemma Un_empty [iff]: "A \<union> B = {} \<longleftrightarrow> A = {} \<and> B = {}"
   by (fact sup_eq_bot_iff) (* FIXME: already simp *)
 
 lemma Un_subset_iff [simp]: "A \<union> B \<subseteq> C \<longleftrightarrow> A \<subseteq> C \<and> B \<subseteq> C"
   by (fact le_sup_iff)
 
 lemma Un_Diff_Int: "(A - B) \<union> (A \<inter> B) = A"
   by blast
 
 lemma Diff_Int2: "A \<inter> C - B \<inter> C = A \<inter> C - B"
   by blast
 
 lemma subset_UnE:
   assumes "C \<subseteq> A \<union> B"
   obtains A' B' where "A' \<subseteq> A" "B' \<subseteq> B" "C = A' \<union> B'"
 proof
   show "C \<inter> A \<subseteq> A" "C \<inter> B \<subseteq> B" "C = (C \<inter> A) \<union> (C \<inter> B)"
     using assms by blast+
 qed
 
 lemma Un_Int_eq [simp]: "(S \<union> T) \<inter> S = S" "(S \<union> T) \<inter> T = T" "S \<inter> (S \<union> T) = S" "T \<inter> (S \<union> T) = T"
   by auto
 
 lemma Int_Un_eq [simp]: "(S \<inter> T) \<union> S = S" "(S \<inter> T) \<union> T = T" "S \<union> (S \<inter> T) = S" "T \<union> (S \<inter> T) = T"
   by auto
 
 text \<open>\<^medskip> Set complement\<close>
 
 lemma Compl_disjoint [simp]: "A \<inter> - A = {}"
   by (fact inf_compl_bot)
 
 lemma Compl_disjoint2 [simp]: "- A \<inter> A = {}"
   by (fact compl_inf_bot)
 
 lemma Compl_partition: "A \<union> - A = UNIV"
   by (fact sup_compl_top)
 
 lemma Compl_partition2: "- A \<union> A = UNIV"
   by (fact compl_sup_top)
 
 lemma double_complement: "- (-A) = A" for A :: "'a set"
   by (fact double_compl) (* already simp *)
 
 lemma Compl_Un: "- (A \<union> B) = (- A) \<inter> (- B)"
   by (fact compl_sup) (* already simp *)
 
 lemma Compl_Int: "- (A \<inter> B) = (- A) \<union> (- B)"
   by (fact compl_inf) (* already simp *)
 
 lemma subset_Compl_self_eq: "A \<subseteq> - A \<longleftrightarrow> A = {}"
   by blast
 
 lemma Un_Int_assoc_eq: "(A \<inter> B) \<union> C = A \<inter> (B \<union> C) \<longleftrightarrow> C \<subseteq> A"
   \<comment> \<open>Halmos, Naive Set Theory, page 16.\<close>
   by blast
 
 lemma Compl_UNIV_eq: "- UNIV = {}"
   by (fact compl_top_eq) (* already simp *)
 
 lemma Compl_empty_eq: "- {} = UNIV"
   by (fact compl_bot_eq) (* already simp *)
 
 lemma Compl_subset_Compl_iff [iff]: "- A \<subseteq> - B \<longleftrightarrow> B \<subseteq> A"
   by (fact compl_le_compl_iff) (* FIXME: already simp *)
 
 lemma Compl_eq_Compl_iff [iff]: "- A = - B \<longleftrightarrow> A = B"
   for A B :: "'a set"
   by (fact compl_eq_compl_iff) (* FIXME: already simp *)
 
 lemma Compl_insert: "- insert x A = (- A) - {x}"
   by blast
 
 text \<open>\<^medskip> Bounded quantifiers.
 
   The following are not added to the default simpset because
   (a) they duplicate the body and (b) there are no similar rules for \<open>Int\<close>.
 \<close>
 
 lemma ball_Un: "(\<forall>x \<in> A \<union> B. P x) \<longleftrightarrow> (\<forall>x\<in>A. P x) \<and> (\<forall>x\<in>B. P x)"
   by blast
 
 lemma bex_Un: "(\<exists>x \<in> A \<union> B. P x) \<longleftrightarrow> (\<exists>x\<in>A. P x) \<or> (\<exists>x\<in>B. P x)"
   by blast
 
 
 text \<open>\<^medskip> Set difference.\<close>
 
 lemma Diff_eq: "A - B = A \<inter> (- B)"
   by blast
 
 lemma Diff_eq_empty_iff [simp]: "A - B = {} \<longleftrightarrow> A \<subseteq> B"
   by blast
 
 lemma Diff_cancel [simp]: "A - A = {}"
   by blast
 
 lemma Diff_idemp [simp]: "(A - B) - B = A - B"
   for A B :: "'a set"
   by blast
 
 lemma Diff_triv: "A \<inter> B = {} \<Longrightarrow> A - B = A"
   by (blast elim: equalityE)
 
 lemma empty_Diff [simp]: "{} - A = {}"
   by blast
 
 lemma Diff_empty [simp]: "A - {} = A"
   by blast
 
 lemma Diff_UNIV [simp]: "A - UNIV = {}"
   by blast
 
 lemma Diff_insert0 [simp]: "x \<notin> A \<Longrightarrow> A - insert x B = A - B"
   by blast
 
 lemma Diff_insert: "A - insert a B = A - B - {a}"
   \<comment> \<open>NOT SUITABLE FOR REWRITING since \<open>{a} \<equiv> insert a 0\<close>\<close>
   by blast
 
 lemma Diff_insert2: "A - insert a B = A - {a} - B"
   \<comment> \<open>NOT SUITABLE FOR REWRITING since \<open>{a} \<equiv> insert a 0\<close>\<close>
   by blast
 
 lemma insert_Diff_if: "insert x A - B = (if x \<in> B then A - B else insert x (A - B))"
   by auto
 
 lemma insert_Diff1 [simp]: "x \<in> B \<Longrightarrow> insert x A - B = A - B"
   by blast
 
 lemma insert_Diff_single[simp]: "insert a (A - {a}) = insert a A"
   by blast
 
 lemma insert_Diff: "a \<in> A \<Longrightarrow> insert a (A - {a}) = A"
   by blast
 
 lemma Diff_insert_absorb: "x \<notin> A \<Longrightarrow> (insert x A) - {x} = A"
   by auto
 
 lemma Diff_disjoint [simp]: "A \<inter> (B - A) = {}"
   by blast
 
 lemma Diff_partition: "A \<subseteq> B \<Longrightarrow> A \<union> (B - A) = B"
   by blast
 
 lemma double_diff: "A \<subseteq> B \<Longrightarrow> B \<subseteq> C \<Longrightarrow> B - (C - A) = A"
   by blast
 
 lemma Un_Diff_cancel [simp]: "A \<union> (B - A) = A \<union> B"
   by blast
 
 lemma Un_Diff_cancel2 [simp]: "(B - A) \<union> A = B \<union> A"
   by blast
 
 lemma Diff_Un: "A - (B \<union> C) = (A - B) \<inter> (A - C)"
   by blast
 
 lemma Diff_Int: "A - (B \<inter> C) = (A - B) \<union> (A - C)"
   by blast
 
 lemma Diff_Diff_Int: "A - (A - B) = A \<inter> B"
   by blast
 
 lemma Un_Diff: "(A \<union> B) - C = (A - C) \<union> (B - C)"
   by blast
 
 lemma Int_Diff: "(A \<inter> B) - C = A \<inter> (B - C)"
   by blast
 
 lemma Diff_Int_distrib: "C \<inter> (A - B) = (C \<inter> A) - (C \<inter> B)"
   by blast
 
 lemma Diff_Int_distrib2: "(A - B) \<inter> C = (A \<inter> C) - (B \<inter> C)"
   by blast
 
 lemma Diff_Compl [simp]: "A - (- B) = A \<inter> B"
   by auto
 
 lemma Compl_Diff_eq [simp]: "- (A - B) = - A \<union> B"
   by blast
 
 lemma subset_Compl_singleton [simp]: "A \<subseteq> - {b} \<longleftrightarrow> b \<notin> A"
   by blast
 
 text \<open>\<^medskip> Quantification over type \<^typ>\<open>bool\<close>.\<close>
 
 lemma bool_induct: "P True \<Longrightarrow> P False \<Longrightarrow> P x"
   by (cases x) auto
 
 lemma all_bool_eq: "(\<forall>b. P b) \<longleftrightarrow> P True \<and> P False"
   by (auto intro: bool_induct)
 
 lemma bool_contrapos: "P x \<Longrightarrow> \<not> P False \<Longrightarrow> P True"
   by (cases x) auto
 
 lemma ex_bool_eq: "(\<exists>b. P b) \<longleftrightarrow> P True \<or> P False"
   by (auto intro: bool_contrapos)
 
 lemma UNIV_bool: "UNIV = {False, True}"
   by (auto intro: bool_induct)
 
 text \<open>\<^medskip> \<open>Pow\<close>\<close>
 
 lemma Pow_empty [simp]: "Pow {} = {{}}"
   by (auto simp add: Pow_def)
 
 lemma Pow_singleton_iff [simp]: "Pow X = {Y} \<longleftrightarrow> X = {} \<and> Y = {}"
   by blast  (* somewhat slow *)
 
 lemma Pow_insert: "Pow (insert a A) = Pow A \<union> (insert a ` Pow A)"
   by (blast intro: image_eqI [where ?x = "u - {a}" for u])
 
 lemma Pow_Compl: "Pow (- A) = {- B | B. A \<in> Pow B}"
   by (blast intro: exI [where ?x = "- u" for u])
 
 lemma Pow_UNIV [simp]: "Pow UNIV = UNIV"
   by blast
 
 lemma Un_Pow_subset: "Pow A \<union> Pow B \<subseteq> Pow (A \<union> B)"
   by blast
 
 lemma Pow_Int_eq [simp]: "Pow (A \<inter> B) = Pow A \<inter> Pow B"
   by blast
 
 
 text \<open>\<^medskip> Miscellany.\<close>
 
 lemma Int_Diff_disjoint: "A \<inter> B \<inter> (A - B) = {}"
   by blast
 
 lemma Int_Diff_Un: "A \<inter> B \<union> (A - B) = A"
   by blast
 
 lemma set_eq_subset: "A = B \<longleftrightarrow> A \<subseteq> B \<and> B \<subseteq> A"
   by blast
 
 lemma subset_iff: "A \<subseteq> B \<longleftrightarrow> (\<forall>t. t \<in> A \<longrightarrow> t \<in> B)"
   by blast
 
 lemma subset_iff_psubset_eq: "A \<subseteq> B \<longleftrightarrow> A \<subset> B \<or> A = B"
   unfolding less_le by blast
 
 lemma all_not_in_conv [simp]: "(\<forall>x. x \<notin> A) \<longleftrightarrow> A = {}"
   by blast
 
 lemma ex_in_conv: "(\<exists>x. x \<in> A) \<longleftrightarrow> A \<noteq> {}"
   by blast
 
 lemma ball_simps [simp, no_atp]:
   "\<And>A P Q. (\<forall>x\<in>A. P x \<or> Q) \<longleftrightarrow> ((\<forall>x\<in>A. P x) \<or> Q)"
   "\<And>A P Q. (\<forall>x\<in>A. P \<or> Q x) \<longleftrightarrow> (P \<or> (\<forall>x\<in>A. Q x))"
   "\<And>A P Q. (\<forall>x\<in>A. P \<longrightarrow> Q x) \<longleftrightarrow> (P \<longrightarrow> (\<forall>x\<in>A. Q x))"
   "\<And>A P Q. (\<forall>x\<in>A. P x \<longrightarrow> Q) \<longleftrightarrow> ((\<exists>x\<in>A. P x) \<longrightarrow> Q)"
   "\<And>P. (\<forall>x\<in>{}. P x) \<longleftrightarrow> True"
   "\<And>P. (\<forall>x\<in>UNIV. P x) \<longleftrightarrow> (\<forall>x. P x)"
   "\<And>a B P. (\<forall>x\<in>insert a B. P x) \<longleftrightarrow> (P a \<and> (\<forall>x\<in>B. P x))"
   "\<And>P Q. (\<forall>x\<in>Collect Q. P x) \<longleftrightarrow> (\<forall>x. Q x \<longrightarrow> P x)"
   "\<And>A P f. (\<forall>x\<in>f`A. P x) \<longleftrightarrow> (\<forall>x\<in>A. P (f x))"
   "\<And>A P. (\<not> (\<forall>x\<in>A. P x)) \<longleftrightarrow> (\<exists>x\<in>A. \<not> P x)"
   by auto
 
 lemma bex_simps [simp, no_atp]:
   "\<And>A P Q. (\<exists>x\<in>A. P x \<and> Q) \<longleftrightarrow> ((\<exists>x\<in>A. P x) \<and> Q)"
   "\<And>A P Q. (\<exists>x\<in>A. P \<and> Q x) \<longleftrightarrow> (P \<and> (\<exists>x\<in>A. Q x))"
   "\<And>P. (\<exists>x\<in>{}. P x) \<longleftrightarrow> False"
   "\<And>P. (\<exists>x\<in>UNIV. P x) \<longleftrightarrow> (\<exists>x. P x)"
   "\<And>a B P. (\<exists>x\<in>insert a B. P x) \<longleftrightarrow> (P a \<or> (\<exists>x\<in>B. P x))"
   "\<And>P Q. (\<exists>x\<in>Collect Q. P x) \<longleftrightarrow> (\<exists>x. Q x \<and> P x)"
   "\<And>A P f. (\<exists>x\<in>f`A. P x) \<longleftrightarrow> (\<exists>x\<in>A. P (f x))"
   "\<And>A P. (\<not>(\<exists>x\<in>A. P x)) \<longleftrightarrow> (\<forall>x\<in>A. \<not> P x)"
   by auto
 
 lemma ex_image_cong_iff [simp, no_atp]:
   "(\<exists>x. x\<in>f`A) \<longleftrightarrow> A \<noteq> {}" "(\<exists>x. x\<in>f`A \<and> P x) \<longleftrightarrow> (\<exists>x\<in>A. P (f x))"
   by auto
 
 subsubsection \<open>Monotonicity of various operations\<close>
 
 lemma image_mono: "A \<subseteq> B \<Longrightarrow> f ` A \<subseteq> f ` B"
   by blast
 
 lemma Pow_mono: "A \<subseteq> B \<Longrightarrow> Pow A \<subseteq> Pow B"
   by blast
 
 lemma insert_mono: "C \<subseteq> D \<Longrightarrow> insert a C \<subseteq> insert a D"
   by blast
 
 lemma Un_mono: "A \<subseteq> C \<Longrightarrow> B \<subseteq> D \<Longrightarrow> A \<union> B \<subseteq> C \<union> D"
   by (fact sup_mono)
 
 lemma Int_mono: "A \<subseteq> C \<Longrightarrow> B \<subseteq> D \<Longrightarrow> A \<inter> B \<subseteq> C \<inter> D"
   by (fact inf_mono)
 
 lemma Diff_mono: "A \<subseteq> C \<Longrightarrow> D \<subseteq> B \<Longrightarrow> A - B \<subseteq> C - D"
   by blast
 
 lemma Compl_anti_mono: "A \<subseteq> B \<Longrightarrow> - B \<subseteq> - A"
   by (fact compl_mono)
 
 text \<open>\<^medskip> Monotonicity of implications.\<close>
 
 lemma in_mono: "A \<subseteq> B \<Longrightarrow> x \<in> A \<longrightarrow> x \<in> B"
   by (rule impI) (erule subsetD)
 
 lemma conj_mono: "P1 \<longrightarrow> Q1 \<Longrightarrow> P2 \<longrightarrow> Q2 \<Longrightarrow> (P1 \<and> P2) \<longrightarrow> (Q1 \<and> Q2)"
   by iprover
 
 lemma disj_mono: "P1 \<longrightarrow> Q1 \<Longrightarrow> P2 \<longrightarrow> Q2 \<Longrightarrow> (P1 \<or> P2) \<longrightarrow> (Q1 \<or> Q2)"
   by iprover
 
 lemma imp_mono: "Q1 \<longrightarrow> P1 \<Longrightarrow> P2 \<longrightarrow> Q2 \<Longrightarrow> (P1 \<longrightarrow> P2) \<longrightarrow> (Q1 \<longrightarrow> Q2)"
   by iprover
 
 lemma imp_refl: "P \<longrightarrow> P" ..
 
 lemma not_mono: "Q \<longrightarrow> P \<Longrightarrow> \<not> P \<longrightarrow> \<not> Q"
   by iprover
 
 lemma ex_mono: "(\<And>x. P x \<longrightarrow> Q x) \<Longrightarrow> (\<exists>x. P x) \<longrightarrow> (\<exists>x. Q x)"
   by iprover
 
 lemma all_mono: "(\<And>x. P x \<longrightarrow> Q x) \<Longrightarrow> (\<forall>x. P x) \<longrightarrow> (\<forall>x. Q x)"
   by iprover
 
 lemma Collect_mono: "(\<And>x. P x \<longrightarrow> Q x) \<Longrightarrow> Collect P \<subseteq> Collect Q"
   by blast
 
 lemma Int_Collect_mono: "A \<subseteq> B \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> P x \<longrightarrow> Q x) \<Longrightarrow> A \<inter> Collect P \<subseteq> B \<inter> Collect Q"
   by blast
 
 lemmas basic_monos =
   subset_refl imp_refl disj_mono conj_mono ex_mono Collect_mono in_mono
 
 lemma eq_to_mono: "a = b \<Longrightarrow> c = d \<Longrightarrow> b \<longrightarrow> d \<Longrightarrow> a \<longrightarrow> c"
   by iprover
 
 
 subsubsection \<open>Inverse image of a function\<close>
 
 definition vimage :: "('a \<Rightarrow> 'b) \<Rightarrow> 'b set \<Rightarrow> 'a set"  (infixr "-`" 90)
   where "f -` B \<equiv> {x. f x \<in> B}"
 
 lemma vimage_eq [simp]: "a \<in> f -` B \<longleftrightarrow> f a \<in> B"
   unfolding vimage_def by blast
 
 lemma vimage_singleton_eq: "a \<in> f -` {b} \<longleftrightarrow> f a = b"
   by simp
 
 lemma vimageI [intro]: "f a = b \<Longrightarrow> b \<in> B \<Longrightarrow> a \<in> f -` B"
   unfolding vimage_def by blast
 
 lemma vimageI2: "f a \<in> A \<Longrightarrow> a \<in> f -` A"
   unfolding vimage_def by fast
 
 lemma vimageE [elim!]: "a \<in> f -` B \<Longrightarrow> (\<And>x. f a = x \<Longrightarrow> x \<in> B \<Longrightarrow> P) \<Longrightarrow> P"
   unfolding vimage_def by blast
 
 lemma vimageD: "a \<in> f -` A \<Longrightarrow> f a \<in> A"
   unfolding vimage_def by fast
 
 lemma vimage_empty [simp]: "f -` {} = {}"
   by blast
 
 lemma vimage_Compl: "f -` (- A) = - (f -` A)"
   by blast
 
 lemma vimage_Un [simp]: "f -` (A \<union> B) = (f -` A) \<union> (f -` B)"
   by blast
 
 lemma vimage_Int [simp]: "f -` (A \<inter> B) = (f -` A) \<inter> (f -` B)"
   by fast
 
 lemma vimage_Collect_eq [simp]: "f -` Collect P = {y. P (f y)}"
   by blast
 
 lemma vimage_Collect: "(\<And>x. P (f x) = Q x) \<Longrightarrow> f -` (Collect P) = Collect Q"
   by blast
 
 lemma vimage_insert: "f -` (insert a B) = (f -` {a}) \<union> (f -` B)"
   \<comment> \<open>NOT suitable for rewriting because of the recurrence of \<open>{a}\<close>.\<close>
   by blast
 
 lemma vimage_Diff: "f -` (A - B) = (f -` A) - (f -` B)"
   by blast
 
 lemma vimage_UNIV [simp]: "f -` UNIV = UNIV"
   by blast
 
 lemma vimage_mono: "A \<subseteq> B \<Longrightarrow> f -` A \<subseteq> f -` B"
   \<comment> \<open>monotonicity\<close>
   by blast
 
 lemma vimage_image_eq: "f -` (f ` A) = {y. \<exists>x\<in>A. f x = f y}"
   by (blast intro: sym)
 
 lemma image_vimage_subset: "f ` (f -` A) \<subseteq> A"
   by blast
 
 lemma image_vimage_eq [simp]: "f ` (f -` A) = A \<inter> range f"
   by blast
 
 lemma image_subset_iff_subset_vimage: "f ` A \<subseteq> B \<longleftrightarrow> A \<subseteq> f -` B"
   by blast
 
 lemma subset_vimage_iff: "A \<subseteq> f -` B \<longleftrightarrow> (\<forall>x\<in>A. f x \<in> B)"
   by auto
 
 lemma vimage_const [simp]: "((\<lambda>x. c) -` A) = (if c \<in> A then UNIV else {})"
   by auto
 
 lemma vimage_if [simp]: "((\<lambda>x. if x \<in> B then c else d) -` A) =
    (if c \<in> A then (if d \<in> A then UNIV else B)
     else if d \<in> A then - B else {})"
   by (auto simp add: vimage_def)
 
 lemma vimage_inter_cong: "(\<And> w. w \<in> S \<Longrightarrow> f w = g w) \<Longrightarrow> f -` y \<inter> S = g -` y \<inter> S"
   by auto
 
 lemma vimage_ident [simp]: "(\<lambda>x. x) -` Y = Y"
   by blast
 
 
 subsubsection \<open>Singleton sets\<close>
 
 definition is_singleton :: "'a set \<Rightarrow> bool"
   where "is_singleton A \<longleftrightarrow> (\<exists>x. A = {x})"
 
 lemma is_singletonI [simp, intro!]: "is_singleton {x}"
   unfolding is_singleton_def by simp
 
 lemma is_singletonI': "A \<noteq> {} \<Longrightarrow> (\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x = y) \<Longrightarrow> is_singleton A"
   unfolding is_singleton_def by blast
 
 lemma is_singletonE: "is_singleton A \<Longrightarrow> (\<And>x. A = {x} \<Longrightarrow> P) \<Longrightarrow> P"
   unfolding is_singleton_def by blast
 
 
 subsubsection \<open>Getting the contents of a singleton set\<close>
 
 definition the_elem :: "'a set \<Rightarrow> 'a"
   where "the_elem X = (THE x. X = {x})"
 
 lemma the_elem_eq [simp]: "the_elem {x} = x"
   by (simp add: the_elem_def)
 
 lemma is_singleton_the_elem: "is_singleton A \<longleftrightarrow> A = {the_elem A}"
   by (auto simp: is_singleton_def)
 
 lemma the_elem_image_unique:
   assumes "A \<noteq> {}"
     and *: "\<And>y. y \<in> A \<Longrightarrow> f y = f x"
   shows "the_elem (f ` A) = f x"
   unfolding the_elem_def
 proof (rule the1_equality)
   from \<open>A \<noteq> {}\<close> obtain y where "y \<in> A" by auto
   with * have "f x = f y" by simp
   with \<open>y \<in> A\<close> have "f x \<in> f ` A" by blast
   with * show "f ` A = {f x}" by auto
   then show "\<exists>!x. f ` A = {x}" by auto
 qed
 
 
 subsubsection \<open>Monad operation\<close>
 
 definition bind :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> 'b set"
   where "bind A f = {x. \<exists>B \<in> f`A. x \<in> B}"
 
 hide_const (open) bind
 
 lemma bind_bind: "Set.bind (Set.bind A B) C = Set.bind A (\<lambda>x. Set.bind (B x) C)"
   for A :: "'a set"
   by (auto simp: bind_def)
 
 lemma empty_bind [simp]: "Set.bind {} f = {}"
   by (simp add: bind_def)
 
 lemma nonempty_bind_const: "A \<noteq> {} \<Longrightarrow> Set.bind A (\<lambda>_. B) = B"
   by (auto simp: bind_def)
 
 lemma bind_const: "Set.bind A (\<lambda>_. B) = (if A = {} then {} else B)"
   by (auto simp: bind_def)
 
 lemma bind_singleton_conv_image: "Set.bind A (\<lambda>x. {f x}) = f ` A"
   by (auto simp: bind_def)
 
 
 subsubsection \<open>Operations for execution\<close>
 
 definition is_empty :: "'a set \<Rightarrow> bool"
   where [code_abbrev]: "is_empty A \<longleftrightarrow> A = {}"
 
 hide_const (open) is_empty
 
 definition remove :: "'a \<Rightarrow> 'a set \<Rightarrow> 'a set"
   where [code_abbrev]: "remove x A = A - {x}"
 
 hide_const (open) remove
 
 lemma member_remove [simp]: "x \<in> Set.remove y A \<longleftrightarrow> x \<in> A \<and> x \<noteq> y"
   by (simp add: remove_def)
 
 definition filter :: "('a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> 'a set"
   where [code_abbrev]: "filter P A = {a \<in> A. P a}"
 
 hide_const (open) filter
 
 lemma member_filter [simp]: "x \<in> Set.filter P A \<longleftrightarrow> x \<in> A \<and> P x"
   by (simp add: filter_def)
 
 instantiation set :: (equal) equal
 begin
 
 definition "HOL.equal A B \<longleftrightarrow> A \<subseteq> B \<and> B \<subseteq> A"
 
 instance by standard (auto simp add: equal_set_def)
 
 end
 
 
 text \<open>Misc\<close>
 
 definition pairwise :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool"
   where "pairwise R S \<longleftrightarrow> (\<forall>x \<in> S. \<forall>y \<in> S. x \<noteq> y \<longrightarrow> R x y)"
 
 lemma pairwise_alt: "pairwise R S \<longleftrightarrow> (\<forall>x\<in>S. \<forall>y\<in>S-{x}. R x y)"
 by (auto simp add: pairwise_def)
 
 lemma pairwise_trivial [simp]: "pairwise (\<lambda>i j. j \<noteq> i) I"
   by (auto simp: pairwise_def)
 
 lemma pairwiseI [intro?]:
   "pairwise R S" if "\<And>x y. x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> x \<noteq> y \<Longrightarrow> R x y"
   using that by (simp add: pairwise_def)
 
 lemma pairwiseD:
   "R x y" and "R y x"
   if "pairwise R S" "x \<in> S" and "y \<in> S" and "x \<noteq> y"
   using that by (simp_all add: pairwise_def)
 
 lemma pairwise_empty [simp]: "pairwise P {}"
   by (simp add: pairwise_def)
 
 lemma pairwise_singleton [simp]: "pairwise P {A}"
   by (simp add: pairwise_def)
 
 lemma pairwise_insert:
   "pairwise r (insert x s) \<longleftrightarrow> (\<forall>y. y \<in> s \<and> y \<noteq> x \<longrightarrow> r x y \<and> r y x) \<and> pairwise r s"
   by (force simp: pairwise_def)
 
 lemma pairwise_subset: "pairwise P S \<Longrightarrow> T \<subseteq> S \<Longrightarrow> pairwise P T"
   by (force simp: pairwise_def)
 
 lemma pairwise_mono: "\<lbrakk>pairwise P A; \<And>x y. P x y \<Longrightarrow> Q x y; B \<subseteq> A\<rbrakk> \<Longrightarrow> pairwise Q B"
   by (fastforce simp: pairwise_def)
 
 lemma pairwise_imageI:
   "pairwise P (f ` A)"
   if "\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x \<noteq> y \<Longrightarrow> f x \<noteq> f y \<Longrightarrow> P (f x) (f y)"
   using that by (auto intro: pairwiseI)
 
 lemma pairwise_image: "pairwise r (f ` s) \<longleftrightarrow> pairwise (\<lambda>x y. (f x \<noteq> f y) \<longrightarrow> r (f x) (f y)) s"
   by (force simp: pairwise_def)
 
 definition disjnt :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool"
   where "disjnt A B \<longleftrightarrow> A \<inter> B = {}"
 
 lemma disjnt_self_iff_empty [simp]: "disjnt S S \<longleftrightarrow> S = {}"
   by (auto simp: disjnt_def)
 
 lemma disjnt_iff: "disjnt A B \<longleftrightarrow> (\<forall>x. \<not> (x \<in> A \<and> x \<in> B))"
   by (force simp: disjnt_def)
 
 lemma disjnt_sym: "disjnt A B \<Longrightarrow> disjnt B A"
   using disjnt_iff by blast
 
 lemma disjnt_empty1 [simp]: "disjnt {} A" and disjnt_empty2 [simp]: "disjnt A {}"
   by (auto simp: disjnt_def)
 
 lemma disjnt_insert1 [simp]: "disjnt (insert a X) Y \<longleftrightarrow> a \<notin> Y \<and> disjnt X Y"
   by (simp add: disjnt_def)
 
 lemma disjnt_insert2 [simp]: "disjnt Y (insert a X) \<longleftrightarrow> a \<notin> Y \<and> disjnt Y X"
   by (simp add: disjnt_def)
 
 lemma disjnt_subset1 : "\<lbrakk>disjnt X Y; Z \<subseteq> X\<rbrakk> \<Longrightarrow> disjnt Z Y"
   by (auto simp: disjnt_def)
 
 lemma disjnt_subset2 : "\<lbrakk>disjnt X Y; Z \<subseteq> Y\<rbrakk> \<Longrightarrow> disjnt X Z"
   by (auto simp: disjnt_def)
 
 lemma disjnt_Un1 [simp]: "disjnt (A \<union> B) C \<longleftrightarrow> disjnt A C \<and> disjnt B C"
   by (auto simp: disjnt_def)
 
 lemma disjnt_Un2 [simp]: "disjnt C (A \<union> B) \<longleftrightarrow> disjnt C A \<and> disjnt C B"
   by (auto simp: disjnt_def)
 
 lemma disjnt_Diff1: "disjnt (X-Y) (U-V)" and disjnt_Diff2: "disjnt (U-V) (X-Y)" if "X \<subseteq> V"
   using that by (auto simp: disjnt_def)
 
 lemma disjoint_image_subset: "\<lbrakk>pairwise disjnt \<A>; \<And>X. X \<in> \<A> \<Longrightarrow> f X \<subseteq> X\<rbrakk> \<Longrightarrow> pairwise disjnt (f `\<A>)"
   unfolding disjnt_def pairwise_def by fast
 
 lemma pairwise_disjnt_iff: "pairwise disjnt \<A> \<longleftrightarrow> (\<forall>x. \<exists>\<^sub>\<le>\<^sub>1 X. X \<in> \<A> \<and> x \<in> X)"
   by (auto simp: Uniq_def disjnt_iff pairwise_def)
 
 lemma disjnt_insert: \<^marker>\<open>contributor \<open>Lars Hupel\<close>\<close>
   \<open>disjnt (insert x M) N\<close> if \<open>x \<notin> N\<close> \<open>disjnt M N\<close>
   using that by (simp add: disjnt_def)
 
 lemma Int_emptyI: "(\<And>x. x \<in> A \<Longrightarrow> x \<in> B \<Longrightarrow> False) \<Longrightarrow> A \<inter> B = {}"
   by blast
 
 lemma in_image_insert_iff:
   assumes "\<And>C. C \<in> B \<Longrightarrow> x \<notin> C"
   shows "A \<in> insert x ` B \<longleftrightarrow> x \<in> A \<and> A - {x} \<in> B" (is "?P \<longleftrightarrow> ?Q")
 proof
   assume ?P then show ?Q
     using assms by auto
 next
   assume ?Q
   then have "x \<in> A" and "A - {x} \<in> B"
     by simp_all
   from \<open>A - {x} \<in> B\<close> have "insert x (A - {x}) \<in> insert x ` B"
     by (rule imageI)
   also from \<open>x \<in> A\<close>
   have "insert x (A - {x}) = A"
     by auto
   finally show ?P .
 qed
 
 hide_const (open) member not_member
 
 lemmas equalityI = subset_antisym
 lemmas set_mp = subsetD
 lemmas set_rev_mp = rev_subsetD
 
 ML \<open>
 val Ball_def = @{thm Ball_def}
 val Bex_def = @{thm Bex_def}
 val CollectD = @{thm CollectD}
 val CollectE = @{thm CollectE}
 val CollectI = @{thm CollectI}
 val Collect_conj_eq = @{thm Collect_conj_eq}
 val Collect_mem_eq = @{thm Collect_mem_eq}
 val IntD1 = @{thm IntD1}
 val IntD2 = @{thm IntD2}
 val IntE = @{thm IntE}
 val IntI = @{thm IntI}
 val Int_Collect = @{thm Int_Collect}
 val UNIV_I = @{thm UNIV_I}
 val UNIV_witness = @{thm UNIV_witness}
 val UnE = @{thm UnE}
 val UnI1 = @{thm UnI1}
 val UnI2 = @{thm UnI2}
 val ballE = @{thm ballE}
 val ballI = @{thm ballI}
 val bexCI = @{thm bexCI}
 val bexE = @{thm bexE}
 val bexI = @{thm bexI}
 val bex_triv = @{thm bex_triv}
 val bspec = @{thm bspec}
 val contra_subsetD = @{thm contra_subsetD}
 val equalityCE = @{thm equalityCE}
 val equalityD1 = @{thm equalityD1}
 val equalityD2 = @{thm equalityD2}
 val equalityE = @{thm equalityE}
 val equalityI = @{thm equalityI}
 val imageE = @{thm imageE}
 val imageI = @{thm imageI}
 val image_Un = @{thm image_Un}
 val image_insert = @{thm image_insert}
 val insert_commute = @{thm insert_commute}
 val insert_iff = @{thm insert_iff}
 val mem_Collect_eq = @{thm mem_Collect_eq}
 val rangeE = @{thm rangeE}
 val rangeI = @{thm rangeI}
 val range_eqI = @{thm range_eqI}
 val subsetCE = @{thm subsetCE}
 val subsetD = @{thm subsetD}
 val subsetI = @{thm subsetI}
 val subset_refl = @{thm subset_refl}
 val subset_trans = @{thm subset_trans}
 val vimageD = @{thm vimageD}
 val vimageE = @{thm vimageE}
 val vimageI = @{thm vimageI}
 val vimageI2 = @{thm vimageI2}
 val vimage_Collect = @{thm vimage_Collect}
 val vimage_Int = @{thm vimage_Int}
 val vimage_Un = @{thm vimage_Un}
 \<close>
 
 end
diff --git a/src/ZF/OrdQuant.thy b/src/ZF/OrdQuant.thy
--- a/src/ZF/OrdQuant.thy
+++ b/src/ZF/OrdQuant.thy
@@ -1,362 +1,360 @@
 (*  Title:      ZF/OrdQuant.thy
     Authors:    Krzysztof Grabczewski and L C Paulson
 *)
 
 section \<open>Special quantifiers\<close>
 
 theory OrdQuant imports Ordinal begin
 
 subsection \<open>Quantifiers and union operator for ordinals\<close>
 
 definition
   (* Ordinal Quantifiers *)
   oall :: "[i, i \<Rightarrow> o] \<Rightarrow> o"  where
     "oall(A, P) \<equiv> \<forall>x. x<A \<longrightarrow> P(x)"
 
 definition
   oex :: "[i, i \<Rightarrow> o] \<Rightarrow> o"  where
     "oex(A, P)  \<equiv> \<exists>x. x<A \<and> P(x)"
 
 definition
   (* Ordinal Union *)
   OUnion :: "[i, i \<Rightarrow> i] \<Rightarrow> i"  where
     "OUnion(i,B) \<equiv> {z: \<Union>x\<in>i. B(x). Ord(i)}"
 
 syntax
   "_oall"     :: "[idt, i, o] \<Rightarrow> o"        (\<open>(3\<forall>_<_./ _)\<close> 10)
   "_oex"      :: "[idt, i, o] \<Rightarrow> o"        (\<open>(3\<exists>_<_./ _)\<close> 10)
   "_OUNION"   :: "[idt, i, i] \<Rightarrow> i"        (\<open>(3\<Union>_<_./ _)\<close> 10)
 translations
   "\<forall>x<a. P" \<rightleftharpoons> "CONST oall(a, \<lambda>x. P)"
   "\<exists>x<a. P" \<rightleftharpoons> "CONST oex(a, \<lambda>x. P)"
   "\<Union>x<a. B" \<rightleftharpoons> "CONST OUnion(a, \<lambda>x. B)"
 
 
 subsubsection \<open>simplification of the new quantifiers\<close>
 
 
 (*MOST IMPORTANT that this is added to the simpset BEFORE Ord_atomize
   is proved.  Ord_atomize would convert this rule to
     x < 0 \<Longrightarrow> P(x) \<equiv> True, which causes dire effects!*)
 lemma [simp]: "(\<forall>x<0. P(x))"
 by (simp add: oall_def)
 
 lemma [simp]: "\<not>(\<exists>x<0. P(x))"
 by (simp add: oex_def)
 
 lemma [simp]: "(\<forall>x<succ(i). P(x)) <-> (Ord(i) \<longrightarrow> P(i) \<and> (\<forall>x<i. P(x)))"
 apply (simp add: oall_def le_iff)
 apply (blast intro: lt_Ord2)
 done
 
 lemma [simp]: "(\<exists>x<succ(i). P(x)) <-> (Ord(i) \<and> (P(i) | (\<exists>x<i. P(x))))"
 apply (simp add: oex_def le_iff)
 apply (blast intro: lt_Ord2)
 done
 
 subsubsection \<open>Union over ordinals\<close>
 
 lemma Ord_OUN [intro,simp]:
      "\<lbrakk>\<And>x. x<A \<Longrightarrow> Ord(B(x))\<rbrakk> \<Longrightarrow> Ord(\<Union>x<A. B(x))"
 by (simp add: OUnion_def ltI Ord_UN)
 
 lemma OUN_upper_lt:
      "\<lbrakk>a<A;  i < b(a);  Ord(\<Union>x<A. b(x))\<rbrakk> \<Longrightarrow> i < (\<Union>x<A. b(x))"
 by (unfold OUnion_def lt_def, blast )
 
 lemma OUN_upper_le:
      "\<lbrakk>a<A;  i\<le>b(a);  Ord(\<Union>x<A. b(x))\<rbrakk> \<Longrightarrow> i \<le> (\<Union>x<A. b(x))"
 apply (unfold OUnion_def, auto)
 apply (rule UN_upper_le )
 apply (auto simp add: lt_def)
 done
 
 lemma Limit_OUN_eq: "Limit(i) \<Longrightarrow> (\<Union>x<i. x) = i"
 by (simp add: OUnion_def Limit_Union_eq Limit_is_Ord)
 
 (* No < version of this theorem: consider that @{term"(\<Union>i\<in>nat.i)=nat"}! *)
 lemma OUN_least:
      "(\<And>x. x<A \<Longrightarrow> B(x) \<subseteq> C) \<Longrightarrow> (\<Union>x<A. B(x)) \<subseteq> C"
 by (simp add: OUnion_def UN_least ltI)
 
 lemma OUN_least_le:
      "\<lbrakk>Ord(i);  \<And>x. x<A \<Longrightarrow> b(x) \<le> i\<rbrakk> \<Longrightarrow> (\<Union>x<A. b(x)) \<le> i"
 by (simp add: OUnion_def UN_least_le ltI Ord_0_le)
 
 lemma le_implies_OUN_le_OUN:
      "\<lbrakk>\<And>x. x<A \<Longrightarrow> c(x) \<le> d(x)\<rbrakk> \<Longrightarrow> (\<Union>x<A. c(x)) \<le> (\<Union>x<A. d(x))"
 by (blast intro: OUN_least_le OUN_upper_le le_Ord2 Ord_OUN)
 
 lemma OUN_UN_eq:
      "(\<And>x. x \<in> A \<Longrightarrow> Ord(B(x)))
       \<Longrightarrow> (\<Union>z < (\<Union>x\<in>A. B(x)). C(z)) = (\<Union>x\<in>A. \<Union>z < B(x). C(z))"
 by (simp add: OUnion_def)
 
 lemma OUN_Union_eq:
      "(\<And>x. x \<in> X \<Longrightarrow> Ord(x))
       \<Longrightarrow> (\<Union>z < \<Union>(X). C(z)) = (\<Union>x\<in>X. \<Union>z < x. C(z))"
 by (simp add: OUnion_def)
 
 (*So that rule_format will get rid of this quantifier...*)
 lemma atomize_oall [symmetric, rulify]:
      "(\<And>x. x<A \<Longrightarrow> P(x)) \<equiv> Trueprop (\<forall>x<A. P(x))"
 by (simp add: oall_def atomize_all atomize_imp)
 
 subsubsection \<open>universal quantifier for ordinals\<close>
 
 lemma oallI [intro!]:
     "\<lbrakk>\<And>x. x<A \<Longrightarrow> P(x)\<rbrakk> \<Longrightarrow> \<forall>x<A. P(x)"
 by (simp add: oall_def)
 
 lemma ospec: "\<lbrakk>\<forall>x<A. P(x);  x<A\<rbrakk> \<Longrightarrow> P(x)"
 by (simp add: oall_def)
 
 lemma oallE:
     "\<lbrakk>\<forall>x<A. P(x);  P(x) \<Longrightarrow> Q;  \<not>x<A \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
 by (simp add: oall_def, blast)
 
 lemma rev_oallE [elim]:
     "\<lbrakk>\<forall>x<A. P(x);  \<not>x<A \<Longrightarrow> Q;  P(x) \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
 by (simp add: oall_def, blast)
 
 
 (*Trival rewrite rule.  @{term"(\<forall>x<a.P)<->P"} holds only if a is not 0!*)
 lemma oall_simp [simp]: "(\<forall>x<a. True) <-> True"
 by blast
 
 (*Congruence rule for rewriting*)
 lemma oall_cong [cong]:
     "\<lbrakk>a=a';  \<And>x. x<a' \<Longrightarrow> P(x) <-> P'(x)\<rbrakk>
      \<Longrightarrow> oall(a, \<lambda>x. P(x)) <-> oall(a', \<lambda>x. P'(x))"
 by (simp add: oall_def)
 
 
 subsubsection \<open>existential quantifier for ordinals\<close>
 
 lemma oexI [intro]:
     "\<lbrakk>P(x);  x<A\<rbrakk> \<Longrightarrow> \<exists>x<A. P(x)"
 apply (simp add: oex_def, blast)
 done
 
 (*Not of the general form for such rules... *)
 lemma oexCI:
    "\<lbrakk>\<forall>x<A. \<not>P(x) \<Longrightarrow> P(a);  a<A\<rbrakk> \<Longrightarrow> \<exists>x<A. P(x)"
 apply (simp add: oex_def, blast)
 done
 
 lemma oexE [elim!]:
     "\<lbrakk>\<exists>x<A. P(x);  \<And>x. \<lbrakk>x<A; P(x)\<rbrakk> \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
 apply (simp add: oex_def, blast)
 done
 
 lemma oex_cong [cong]:
     "\<lbrakk>a=a';  \<And>x. x<a' \<Longrightarrow> P(x) <-> P'(x)\<rbrakk>
      \<Longrightarrow> oex(a, \<lambda>x. P(x)) <-> oex(a', \<lambda>x. P'(x))"
 apply (simp add: oex_def cong add: conj_cong)
 done
 
 
 subsubsection \<open>Rules for Ordinal-Indexed Unions\<close>
 
 lemma OUN_I [intro]: "\<lbrakk>a<i;  b \<in> B(a)\<rbrakk> \<Longrightarrow> b: (\<Union>z<i. B(z))"
 by (unfold OUnion_def lt_def, blast)
 
 lemma OUN_E [elim!]:
     "\<lbrakk>b \<in> (\<Union>z<i. B(z));  \<And>a.\<lbrakk>b \<in> B(a);  a<i\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
 apply (unfold OUnion_def lt_def, blast)
 done
 
 lemma OUN_iff: "b \<in> (\<Union>x<i. B(x)) <-> (\<exists>x<i. b \<in> B(x))"
 by (unfold OUnion_def oex_def lt_def, blast)
 
 lemma OUN_cong [cong]:
     "\<lbrakk>i=j;  \<And>x. x<j \<Longrightarrow> C(x)=D(x)\<rbrakk> \<Longrightarrow> (\<Union>x<i. C(x)) = (\<Union>x<j. D(x))"
 by (simp add: OUnion_def lt_def OUN_iff)
 
 lemma lt_induct:
     "\<lbrakk>i<k;  \<And>x.\<lbrakk>x<k;  \<forall>y<x. P(y)\<rbrakk> \<Longrightarrow> P(x)\<rbrakk>  \<Longrightarrow>  P(i)"
 apply (simp add: lt_def oall_def)
 apply (erule conjE)
 apply (erule Ord_induct, assumption, blast)
 done
 
 
 subsection \<open>Quantification over a class\<close>
 
 definition
   "rall"     :: "[i\<Rightarrow>o, i\<Rightarrow>o] \<Rightarrow> o"  where
     "rall(M, P) \<equiv> \<forall>x. M(x) \<longrightarrow> P(x)"
 
 definition
   "rex"      :: "[i\<Rightarrow>o, i\<Rightarrow>o] \<Rightarrow> o"  where
     "rex(M, P) \<equiv> \<exists>x. M(x) \<and> P(x)"
 
 syntax
   "_rall"     :: "[pttrn, i\<Rightarrow>o, o] \<Rightarrow> o"        (\<open>(3\<forall>_[_]./ _)\<close> 10)
   "_rex"      :: "[pttrn, i\<Rightarrow>o, o] \<Rightarrow> o"        (\<open>(3\<exists>_[_]./ _)\<close> 10)
 translations
   "\<forall>x[M]. P" \<rightleftharpoons> "CONST rall(M, \<lambda>x. P)"
   "\<exists>x[M]. P" \<rightleftharpoons> "CONST rex(M, \<lambda>x. P)"
 
 
 subsubsection\<open>Relativized universal quantifier\<close>
 
 lemma rallI [intro!]: "\<lbrakk>\<And>x. M(x) \<Longrightarrow> P(x)\<rbrakk> \<Longrightarrow> \<forall>x[M]. P(x)"
 by (simp add: rall_def)
 
 lemma rspec: "\<lbrakk>\<forall>x[M]. P(x); M(x)\<rbrakk> \<Longrightarrow> P(x)"
 by (simp add: rall_def)
 
 (*Instantiates x first: better for automatic theorem proving?*)
 lemma rev_rallE [elim]:
     "\<lbrakk>\<forall>x[M]. P(x);  \<not> M(x) \<Longrightarrow> Q;  P(x) \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
 by (simp add: rall_def, blast)
 
 lemma rallE: "\<lbrakk>\<forall>x[M]. P(x);  P(x) \<Longrightarrow> Q;  \<not> M(x) \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
 by blast
 
 (*Trival rewrite rule;   (\<forall>x[M].P)<->P holds only if A is nonempty!*)
 lemma rall_triv [simp]: "(\<forall>x[M]. P) \<longleftrightarrow> ((\<exists>x. M(x)) \<longrightarrow> P)"
 by (simp add: rall_def)
 
 (*Congruence rule for rewriting*)
 lemma rall_cong [cong]:
     "(\<And>x. M(x) \<Longrightarrow> P(x) <-> P'(x)) \<Longrightarrow> (\<forall>x[M]. P(x)) <-> (\<forall>x[M]. P'(x))"
 by (simp add: rall_def)
 
 
 subsubsection\<open>Relativized existential quantifier\<close>
 
 lemma rexI [intro]: "\<lbrakk>P(x); M(x)\<rbrakk> \<Longrightarrow> \<exists>x[M]. P(x)"
 by (simp add: rex_def, blast)
 
 (*The best argument order when there is only one M(x)*)
 lemma rev_rexI: "\<lbrakk>M(x);  P(x)\<rbrakk> \<Longrightarrow> \<exists>x[M]. P(x)"
 by blast
 
 (*Not of the general form for such rules... *)
 lemma rexCI: "\<lbrakk>\<forall>x[M]. \<not>P(x) \<Longrightarrow> P(a); M(a)\<rbrakk> \<Longrightarrow> \<exists>x[M]. P(x)"
 by blast
 
 lemma rexE [elim!]: "\<lbrakk>\<exists>x[M]. P(x);  \<And>x. \<lbrakk>M(x); P(x)\<rbrakk> \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
 by (simp add: rex_def, blast)
 
 (*We do not even have (\<exists>x[M]. True) <-> True unless A is nonempty\<And>*)
 lemma rex_triv [simp]: "(\<exists>x[M]. P) \<longleftrightarrow> ((\<exists>x. M(x)) \<and> P)"
 by (simp add: rex_def)
 
 lemma rex_cong [cong]:
     "(\<And>x. M(x) \<Longrightarrow> P(x) <-> P'(x)) \<Longrightarrow> (\<exists>x[M]. P(x)) <-> (\<exists>x[M]. P'(x))"
 by (simp add: rex_def cong: conj_cong)
 
 lemma rall_is_ball [simp]: "(\<forall>x[\<lambda>z. z\<in>A]. P(x)) <-> (\<forall>x\<in>A. P(x))"
 by blast
 
 lemma rex_is_bex [simp]: "(\<exists>x[\<lambda>z. z\<in>A]. P(x)) <-> (\<exists>x\<in>A. P(x))"
 by blast
 
 lemma atomize_rall: "(\<And>x. M(x) \<Longrightarrow> P(x)) \<equiv> Trueprop (\<forall>x[M]. P(x))"
 by (simp add: rall_def atomize_all atomize_imp)
 
 declare atomize_rall [symmetric, rulify]
 
 lemma rall_simps1:
      "(\<forall>x[M]. P(x) \<and> Q)   <-> (\<forall>x[M]. P(x)) \<and> ((\<forall>x[M]. False) | Q)"
      "(\<forall>x[M]. P(x) | Q)   <-> ((\<forall>x[M]. P(x)) | Q)"
      "(\<forall>x[M]. P(x) \<longrightarrow> Q) <-> ((\<exists>x[M]. P(x)) \<longrightarrow> Q)"
      "(\<not>(\<forall>x[M]. P(x))) <-> (\<exists>x[M]. \<not>P(x))"
 by blast+
 
 lemma rall_simps2:
      "(\<forall>x[M]. P \<and> Q(x))   <-> ((\<forall>x[M]. False) | P) \<and> (\<forall>x[M]. Q(x))"
      "(\<forall>x[M]. P | Q(x))   <-> (P | (\<forall>x[M]. Q(x)))"
      "(\<forall>x[M]. P \<longrightarrow> Q(x)) <-> (P \<longrightarrow> (\<forall>x[M]. Q(x)))"
 by blast+
 
 lemmas rall_simps [simp] = rall_simps1 rall_simps2
 
 lemma rall_conj_distrib:
     "(\<forall>x[M]. P(x) \<and> Q(x)) <-> ((\<forall>x[M]. P(x)) \<and> (\<forall>x[M]. Q(x)))"
 by blast
 
 lemma rex_simps1:
      "(\<exists>x[M]. P(x) \<and> Q) <-> ((\<exists>x[M]. P(x)) \<and> Q)"
      "(\<exists>x[M]. P(x) | Q) <-> (\<exists>x[M]. P(x)) | ((\<exists>x[M]. True) \<and> Q)"
      "(\<exists>x[M]. P(x) \<longrightarrow> Q) <-> ((\<forall>x[M]. P(x)) \<longrightarrow> ((\<exists>x[M]. True) \<and> Q))"
      "(\<not>(\<exists>x[M]. P(x))) <-> (\<forall>x[M]. \<not>P(x))"
 by blast+
 
 lemma rex_simps2:
      "(\<exists>x[M]. P \<and> Q(x)) <-> (P \<and> (\<exists>x[M]. Q(x)))"
      "(\<exists>x[M]. P | Q(x)) <-> ((\<exists>x[M]. True) \<and> P) | (\<exists>x[M]. Q(x))"
      "(\<exists>x[M]. P \<longrightarrow> Q(x)) <-> (((\<forall>x[M]. False) | P) \<longrightarrow> (\<exists>x[M]. Q(x)))"
 by blast+
 
 lemmas rex_simps [simp] = rex_simps1 rex_simps2
 
 lemma rex_disj_distrib:
     "(\<exists>x[M]. P(x) | Q(x)) <-> ((\<exists>x[M]. P(x)) | (\<exists>x[M]. Q(x)))"
 by blast
 
 
 subsubsection\<open>One-point rule for bounded quantifiers\<close>
 
 lemma rex_triv_one_point1 [simp]: "(\<exists>x[M]. x=a) <-> ( M(a))"
 by blast
 
 lemma rex_triv_one_point2 [simp]: "(\<exists>x[M]. a=x) <-> ( M(a))"
 by blast
 
 lemma rex_one_point1 [simp]: "(\<exists>x[M]. x=a \<and> P(x)) <-> ( M(a) \<and> P(a))"
 by blast
 
 lemma rex_one_point2 [simp]: "(\<exists>x[M]. a=x \<and> P(x)) <-> ( M(a) \<and> P(a))"
 by blast
 
 lemma rall_one_point1 [simp]: "(\<forall>x[M]. x=a \<longrightarrow> P(x)) <-> ( M(a) \<longrightarrow> P(a))"
 by blast
 
 lemma rall_one_point2 [simp]: "(\<forall>x[M]. a=x \<longrightarrow> P(x)) <-> ( M(a) \<longrightarrow> P(a))"
 by blast
 
 
 subsubsection\<open>Sets as Classes\<close>
 
 definition
   setclass :: "[i,i] \<Rightarrow> o"       (\<open>##_\<close> [40] 40)  where
    "setclass(A) \<equiv> \<lambda>x. x \<in> A"
 
 lemma setclass_iff [simp]: "setclass(A,x) <-> x \<in> A"
 by (simp add: setclass_def)
 
 lemma rall_setclass_is_ball [simp]: "(\<forall>x[##A]. P(x)) <-> (\<forall>x\<in>A. P(x))"
 by auto
 
 lemma rex_setclass_is_bex [simp]: "(\<exists>x[##A]. P(x)) <-> (\<exists>x\<in>A. P(x))"
 by auto
 
 
 ML
 \<open>
 val Ord_atomize =
   atomize ([(\<^const_name>\<open>oall\<close>, @{thms ospec}), (\<^const_name>\<open>rall\<close>, @{thms rspec})] @
     ZF_conn_pairs, ZF_mem_pairs);
 \<close>
 declaration \<open>fn _ =>
   Simplifier.map_ss (Simplifier.set_mksimps (fn ctxt =>
     map mk_eq o Ord_atomize o Variable.gen_all ctxt))
 \<close>
 
 text \<open>Setting up the one-point-rule simproc\<close>
 
 simproc_setup defined_rex ("\<exists>x[M]. P(x) \<and> Q(x)") = \<open>
-  fn _ => Quantifier1.rearrange_Bex
-    (fn ctxt => unfold_tac ctxt @{thms rex_def})
+  K (Quantifier1.rearrange_Bex (fn ctxt => unfold_tac ctxt @{thms rex_def}))
 \<close>
 
 simproc_setup defined_rall ("\<forall>x[M]. P(x) \<longrightarrow> Q(x)") = \<open>
-  fn _ => Quantifier1.rearrange_Ball
-    (fn ctxt => unfold_tac ctxt @{thms rall_def})
+  K (Quantifier1.rearrange_Ball (fn ctxt => unfold_tac ctxt @{thms rall_def}))
 \<close>
 
 end
diff --git a/src/ZF/pair.thy b/src/ZF/pair.thy
--- a/src/ZF/pair.thy
+++ b/src/ZF/pair.thy
@@ -1,185 +1,183 @@
 (*  Title:      ZF/pair.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1992  University of Cambridge
 *)
 
 section\<open>Ordered Pairs\<close>
 
 theory pair imports upair
 begin
 
 ML_file \<open>simpdata.ML\<close>
 
 setup \<open>
   map_theory_simpset
     (Simplifier.set_mksimps (fn ctxt => map mk_eq o ZF_atomize o Variable.gen_all ctxt)
       #> Simplifier.add_cong @{thm if_weak_cong})
 \<close>
 
 ML \<open>val ZF_ss = simpset_of \<^context>\<close>
 
 simproc_setup defined_Bex ("\<exists>x\<in>A. P(x) \<and> Q(x)") = \<open>
-  fn _ => Quantifier1.rearrange_Bex
-    (fn ctxt => unfold_tac ctxt @{thms Bex_def})
+  K (Quantifier1.rearrange_Bex (fn ctxt => unfold_tac ctxt @{thms Bex_def}))
 \<close>
 
 simproc_setup defined_Ball ("\<forall>x\<in>A. P(x) \<longrightarrow> Q(x)") = \<open>
-  fn _ => Quantifier1.rearrange_Ball
-    (fn ctxt => unfold_tac ctxt @{thms Ball_def})
+  K (Quantifier1.rearrange_Ball (fn ctxt => unfold_tac ctxt @{thms Ball_def}))
 \<close>
 
 
 (** Lemmas for showing that \<langle>a,b\<rangle> uniquely determines a and b **)
 
 lemma singleton_eq_iff [iff]: "{a} = {b} \<longleftrightarrow> a=b"
 by (rule extension [THEN iff_trans], blast)
 
 lemma doubleton_eq_iff: "{a,b} = {c,d} \<longleftrightarrow> (a=c \<and> b=d) | (a=d \<and> b=c)"
 by (rule extension [THEN iff_trans], blast)
 
 lemma Pair_iff [simp]: "\<langle>a,b\<rangle> = \<langle>c,d\<rangle> \<longleftrightarrow> a=c \<and> b=d"
 by (simp add: Pair_def doubleton_eq_iff, blast)
 
 lemmas Pair_inject = Pair_iff [THEN iffD1, THEN conjE, elim!]
 
 lemmas Pair_inject1 = Pair_iff [THEN iffD1, THEN conjunct1]
 lemmas Pair_inject2 = Pair_iff [THEN iffD1, THEN conjunct2]
 
 lemma Pair_not_0: "\<langle>a,b\<rangle> \<noteq> 0"
   unfolding Pair_def
 apply (blast elim: equalityE)
 done
 
 lemmas Pair_neq_0 = Pair_not_0 [THEN notE, elim!]
 
 declare sym [THEN Pair_neq_0, elim!]
 
 lemma Pair_neq_fst: "\<langle>a,b\<rangle>=a \<Longrightarrow> P"
 proof (unfold Pair_def)
   assume eq: "{{a, a}, {a, b}} = a"
   have  "{a, a} \<in> {{a, a}, {a, b}}" by (rule consI1)
   hence "{a, a} \<in> a" by (simp add: eq)
   moreover have "a \<in> {a, a}" by (rule consI1)
   ultimately show "P" by (rule mem_asym)
 qed
 
 lemma Pair_neq_snd: "\<langle>a,b\<rangle>=b \<Longrightarrow> P"
 proof (unfold Pair_def)
   assume eq: "{{a, a}, {a, b}} = b"
   have  "{a, b} \<in> {{a, a}, {a, b}}" by blast
   hence "{a, b} \<in> b" by (simp add: eq)
   moreover have "b \<in> {a, b}" by blast
   ultimately show "P" by (rule mem_asym)
 qed
 
 
 subsection\<open>Sigma: Disjoint Union of a Family of Sets\<close>
 
 text\<open>Generalizes Cartesian product\<close>
 
 lemma Sigma_iff [simp]: "\<langle>a,b\<rangle>: Sigma(A,B) \<longleftrightarrow> a \<in> A \<and> b \<in> B(a)"
 by (simp add: Sigma_def)
 
 lemma SigmaI [TC,intro!]: "\<lbrakk>a \<in> A;  b \<in> B(a)\<rbrakk> \<Longrightarrow> \<langle>a,b\<rangle> \<in> Sigma(A,B)"
 by simp
 
 lemmas SigmaD1 = Sigma_iff [THEN iffD1, THEN conjunct1]
 lemmas SigmaD2 = Sigma_iff [THEN iffD1, THEN conjunct2]
 
 (*The general elimination rule*)
 lemma SigmaE [elim!]:
     "\<lbrakk>c \<in> Sigma(A,B);
         \<And>x y.\<lbrakk>x \<in> A;  y \<in> B(x);  c=\<langle>x,y\<rangle>\<rbrakk> \<Longrightarrow> P
 \<rbrakk> \<Longrightarrow> P"
 by (unfold Sigma_def, blast)
 
 lemma SigmaE2 [elim!]:
     "\<lbrakk>\<langle>a,b\<rangle> \<in> Sigma(A,B);
         \<lbrakk>a \<in> A;  b \<in> B(a)\<rbrakk> \<Longrightarrow> P
 \<rbrakk> \<Longrightarrow> P"
 by (unfold Sigma_def, blast)
 
 lemma Sigma_cong:
     "\<lbrakk>A=A';  \<And>x. x \<in> A' \<Longrightarrow> B(x)=B'(x)\<rbrakk> \<Longrightarrow>
      Sigma(A,B) = Sigma(A',B')"
 by (simp add: Sigma_def)
 
 (*Sigma_cong, Pi_cong NOT given to Addcongs: they cause
   flex-flex pairs and the "Check your prover" error.  Most
   Sigmas and Pis are abbreviated as * or -> *)
 
 lemma Sigma_empty1 [simp]: "Sigma(0,B) = 0"
 by blast
 
 lemma Sigma_empty2 [simp]: "A*0 = 0"
 by blast
 
 lemma Sigma_empty_iff: "A*B=0 \<longleftrightarrow> A=0 | B=0"
 by blast
 
 
 subsection\<open>Projections \<^term>\<open>fst\<close> and \<^term>\<open>snd\<close>\<close>
 
 lemma fst_conv [simp]: "fst(\<langle>a,b\<rangle>) = a"
 by (simp add: fst_def)
 
 lemma snd_conv [simp]: "snd(\<langle>a,b\<rangle>) = b"
 by (simp add: snd_def)
 
 lemma fst_type [TC]: "p \<in> Sigma(A,B) \<Longrightarrow> fst(p) \<in> A"
 by auto
 
 lemma snd_type [TC]: "p \<in> Sigma(A,B) \<Longrightarrow> snd(p) \<in> B(fst(p))"
 by auto
 
 lemma Pair_fst_snd_eq: "a \<in> Sigma(A,B) \<Longrightarrow> <fst(a),snd(a)> = a"
 by auto
 
 
 subsection\<open>The Eliminator, \<^term>\<open>split\<close>\<close>
 
 (*A META-equality, so that it applies to higher types as well...*)
 lemma split [simp]: "split(\<lambda>x y. c(x,y), \<langle>a,b\<rangle>) \<equiv> c(a,b)"
 by (simp add: split_def)
 
 lemma split_type [TC]:
     "\<lbrakk>p \<in> Sigma(A,B);
          \<And>x y.\<lbrakk>x \<in> A; y \<in> B(x)\<rbrakk> \<Longrightarrow> c(x,y):C(\<langle>x,y\<rangle>)
 \<rbrakk> \<Longrightarrow> split(\<lambda>x y. c(x,y), p) \<in> C(p)"
 by (erule SigmaE, auto)
 
 lemma expand_split:
   "u \<in> A*B \<Longrightarrow>
         R(split(c,u)) \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>B. u = \<langle>x,y\<rangle> \<longrightarrow> R(c(x,y)))"
 by (auto simp add: split_def)
 
 
 subsection\<open>A version of \<^term>\<open>split\<close> for Formulae: Result Type \<^typ>\<open>o\<close>\<close>
 
 lemma splitI: "R(a,b) \<Longrightarrow> split(R, \<langle>a,b\<rangle>)"
 by (simp add: split_def)
 
 lemma splitE:
     "\<lbrakk>split(R,z);  z \<in> Sigma(A,B);
         \<And>x y. \<lbrakk>z = \<langle>x,y\<rangle>;  R(x,y)\<rbrakk> \<Longrightarrow> P
 \<rbrakk> \<Longrightarrow> P"
 by (auto simp add: split_def)
 
 lemma splitD: "split(R,\<langle>a,b\<rangle>) \<Longrightarrow> R(a,b)"
 by (simp add: split_def)
 
 text \<open>
   \bigskip Complex rules for Sigma.
 \<close>
 
 lemma split_paired_Bex_Sigma [simp]:
      "(\<exists>z \<in> Sigma(A,B). P(z)) \<longleftrightarrow> (\<exists>x \<in> A. \<exists>y \<in> B(x). P(\<langle>x,y\<rangle>))"
 by blast
 
 lemma split_paired_Ball_Sigma [simp]:
      "(\<forall>z \<in> Sigma(A,B). P(z)) \<longleftrightarrow> (\<forall>x \<in> A. \<forall>y \<in> B(x). P(\<langle>x,y\<rangle>))"
 by blast
 
 end