diff --git a/src/Doc/Datatypes/Datatypes.thy b/src/Doc/Datatypes/Datatypes.thy
--- a/src/Doc/Datatypes/Datatypes.thy
+++ b/src/Doc/Datatypes/Datatypes.thy
@@ -1,3677 +1,3679 @@
 (*  Title:      Doc/Datatypes/Datatypes.thy
     Author:     Julian Biendarra, TU Muenchen
     Author:     Jasmin Blanchette, TU Muenchen
     Author:     Martin Desharnais, Ecole de technologie superieure
     Author:     Lorenz Panny, TU Muenchen
     Author:     Andrei Popescu, TU Muenchen
     Author:     Dmitriy Traytel, TU Muenchen
 
 Tutorial for (co)datatype definitions.
 *)
 
 theory Datatypes
 imports
   Setup
   "HOL-Library.BNF_Axiomatization"
   "HOL-Library.Countable"
   "HOL-Library.FSet"
   "HOL-Library.Simps_Case_Conv"
 begin
 
 
 (*<*)
 unbundle cardinal_syntax
 (*>*)
 
 section \<open>Introduction
   \label{sec:introduction}\<close>
 
 text \<open>
 The 2013 edition of Isabelle introduced a definitional package for freely
 generated datatypes and codatatypes. This package replaces the earlier
 implementation due to Berghofer and Wenzel @{cite "Berghofer-Wenzel:1999:TPHOL"}.
 Perhaps the main advantage of the new package is that it supports recursion
 through a large class of non-datatypes, such as finite sets:
 \<close>
 
     datatype 'a tree\<^sub>f\<^sub>s = Node\<^sub>f\<^sub>s (lbl\<^sub>f\<^sub>s: 'a) (sub\<^sub>f\<^sub>s: "'a tree\<^sub>f\<^sub>s fset")
 
 text \<open>
 \noindent
 Another strong point is the support for local definitions:
 \<close>
 
     context linorder
     begin
     datatype flag = Less | Eq | Greater
     end
 
 text \<open>
 \noindent
 Furthermore, the package provides a lot of convenience, including automatically
 generated discriminators, selectors, and relators as well as a wealth of
 properties about them.
 
 In addition to inductive datatypes, the package supports coinductive
 datatypes, or \emph{codatatypes}, which allow infinite values. For example, the
 following command introduces the type of lazy lists, which comprises both finite
 and infinite values:
 \<close>
 
 (*<*)
     locale early
     locale late
 (*>*)
     codatatype (*<*)(in early) (*>*)'a llist = LNil | LCons 'a "'a llist"
 
 text \<open>
 \noindent
 Mixed inductive--coinductive recursion is possible via nesting. Compare the
 following four Rose tree examples:
 \<close>
 
     datatype (*<*)(in early) (*>*)'a tree\<^sub>f\<^sub>f = Node\<^sub>f\<^sub>f 'a "'a tree\<^sub>f\<^sub>f list"
     datatype (*<*)(in early) (*>*)'a tree\<^sub>f\<^sub>i = Node\<^sub>f\<^sub>i 'a "'a tree\<^sub>f\<^sub>i llist"
     codatatype (*<*)(in early) (*>*)'a tree\<^sub>i\<^sub>f = Node\<^sub>i\<^sub>f 'a "'a tree\<^sub>i\<^sub>f list"
     codatatype (*<*)(in early) (*>*)'a tree\<^sub>i\<^sub>i = Node\<^sub>i\<^sub>i 'a "'a tree\<^sub>i\<^sub>i llist"
 
 text \<open>
 The first two tree types allow only paths of finite length, whereas the last two
 allow infinite paths. Orthogonally, the nodes in the first and third types have
 finitely many direct subtrees, whereas those of the second and fourth may have
 infinite branching.
 
 The package is part of \<^theory>\<open>Main\<close>. Additional functionality is provided by
 the theory \<^file>\<open>~~/src/HOL/Library/BNF_Axiomatization.thy\<close>.
 
 The package, like its predecessor, fully adheres to the LCF philosophy
 @{cite mgordon79}: The characteristic theorems associated with the specified
 (co)datatypes are derived rather than introduced axiomatically.%
 \footnote{However, some of the
 internal constructions and most of the internal proof obligations are omitted
 if the \<open>quick_and_dirty\<close> option is enabled.}
 The package is described in a number of scientific papers
 @{cite "traytel-et-al-2012" and "blanchette-et-al-2014-impl" and
 "panny-et-al-2014" and "blanchette-et-al-2015-wit"}.
 The central notion is that of a \emph{bounded natural functor} (BNF)---a
 well-behaved type constructor for which nested (co)recursion is supported.
 
 This tutorial is organized as follows:
 
 \begin{itemize}
 \setlength{\itemsep}{0pt}
 
 \item Section \ref{sec:defining-datatypes}, ``Defining Datatypes,''
 describes how to specify datatypes using the @{command datatype} command.
 
 \item Section \ref{sec:defining-primitively-recursive-functions}, ``Defining
 Primitively Recursive Functions,'' describes how to specify functions
 using @{command primrec}. (A separate tutorial @{cite "isabelle-function"}
 describes the more powerful \keyw{fun} and \keyw{function} commands.)
 
 \item Section \ref{sec:defining-codatatypes}, ``Defining Codatatypes,''
 describes how to specify codatatypes using the @{command codatatype} command.
 
 \item Section \ref{sec:defining-primitively-corecursive-functions},
 ``Defining Primitively Corecursive Functions,'' describes how to specify
 functions using the @{command primcorec} and
 @{command primcorecursive} commands. (A separate tutorial
 @{cite "isabelle-corec"} describes the more powerful \keyw{corec} and
 \keyw{corecursive} commands.)
 
 \item Section \ref{sec:registering-bounded-natural-functors}, ``Registering
 Bounded Natural Functors,'' explains how to use the @{command bnf} command
 to register arbitrary type constructors as BNFs.
 
 \item Section
 \ref{sec:deriving-destructors-and-theorems-for-free-constructors},
 ``Deriving Destructors and Theorems for Free Constructors,'' explains how to
 use the command @{command free_constructors} to derive destructor constants
 and theorems for freely generated types, as performed internally by
 @{command datatype} and @{command codatatype}.
 
 %\item Section \ref{sec:using-the-standard-ml-interface}, ``Using the Standard
 %ML Interface,'' describes the package's programmatic interface.
 
 \item Section \ref{sec:selecting-plugins}, ``Selecting Plugins,'' is concerned
 with the package's interoperability with other Isabelle packages and tools, such
 as the code generator, Transfer, Lifting, and Quickcheck.
 
 \item Section \ref{sec:known-bugs-and-limitations}, ``Known Bugs and
 Limitations,'' concludes with known open issues.
 \end{itemize}
 
 \newbox\boxA
 \setbox\boxA=\hbox{\texttt{NOSPAM}}
 
 \newcommand\authoremaili{\texttt{jasmin.blan{\color{white}NOSPAM}\kern-\wd\boxA{}chette@\allowbreak
 gmail.\allowbreak com}}
 
 Comments and bug reports concerning either the package or this tutorial should
 be directed to the second author at \authoremaili{} or to the
 \texttt{cl-isabelle-users} mailing list.
 \<close>
 
 
 section \<open>Defining Datatypes
   \label{sec:defining-datatypes}\<close>
 
 text \<open>
 Datatypes can be specified using the @{command datatype} command.
 \<close>
 
 
 subsection \<open>Introductory Examples
   \label{ssec:datatype-introductory-examples}\<close>
 
 text \<open>
 Datatypes are illustrated through concrete examples featuring different flavors
 of recursion. More examples can be found in the directory
 \<^dir>\<open>~~/src/HOL/Datatype_Examples\<close>.
 \<close>
 
 
 subsubsection \<open>Nonrecursive Types
   \label{sssec:datatype-nonrecursive-types}\<close>
 
 text \<open>
 Datatypes are introduced by specifying the desired names and argument types for
 their constructors. \emph{Enumeration} types are the simplest form of datatype.
 All their constructors are nullary:
 \<close>
 
     datatype trool = Truue | Faalse | Perhaaps
 
 text \<open>
 \noindent
 \<^const>\<open>Truue\<close>, \<^const>\<open>Faalse\<close>, and \<^const>\<open>Perhaaps\<close> have the type \<^typ>\<open>trool\<close>.
 
 Polymorphic types are possible, such as the following option type, modeled after
 its homologue from the \<^theory>\<open>HOL.Option\<close> theory:
 \<close>
 
 (*<*)
     hide_const None Some map_option
     hide_type option
 (*>*)
     datatype 'a option = None | Some 'a
 
 text \<open>
 \noindent
 The constructors are \<open>None :: 'a option\<close> and
 \<open>Some :: 'a \<Rightarrow> 'a option\<close>.
 
 The next example has three type parameters:
 \<close>
 
     datatype ('a, 'b, 'c) triple = Triple 'a 'b 'c
 
 text \<open>
 \noindent
 The constructor is
 \<open>Triple :: 'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> ('a, 'b, 'c) triple\<close>.
 Unlike in Standard ML, curried constructors are supported. The uncurried variant
 is also possible:
 \<close>
 
     datatype ('a, 'b, 'c) triple\<^sub>u = Triple\<^sub>u "'a * 'b * 'c"
 
 text \<open>
 \noindent
 Occurrences of nonatomic types on the right-hand side of the equal sign must be
 enclosed in double quotes, as is customary in Isabelle.
 \<close>
 
 
 subsubsection \<open>Simple Recursion
   \label{sssec:datatype-simple-recursion}\<close>
 
 text \<open>
 Natural numbers are the simplest example of a recursive type:
 \<close>
 
     datatype nat = Zero | Succ nat
 
 text \<open>
 \noindent
 Lists were shown in the introduction. Terminated lists are a variant that
 stores a value of type \<^typ>\<open>'b\<close> at the very end:
 \<close>
 
     datatype (*<*)(in early) (*>*)('a, 'b) tlist = TNil 'b | TCons 'a "('a, 'b) tlist"
 
 
 subsubsection \<open>Mutual Recursion
   \label{sssec:datatype-mutual-recursion}\<close>
 
 text \<open>
 \emph{Mutually recursive} types are introduced simultaneously and may refer to
 each other. The example below introduces a pair of types for even and odd
 natural numbers:
 \<close>
 
     datatype even_nat = Even_Zero | Even_Succ odd_nat
     and odd_nat = Odd_Succ even_nat
 
 text \<open>
 \noindent
 Arithmetic expressions are defined via terms, terms via factors, and factors via
 expressions:
 \<close>
 
     datatype ('a, 'b) exp =
       Term "('a, 'b) trm" | Sum "('a, 'b) trm" "('a, 'b) exp"
     and ('a, 'b) trm =
       Factor "('a, 'b) fct" | Prod "('a, 'b) fct" "('a, 'b) trm"
     and ('a, 'b) fct =
       Const 'a | Var 'b | Expr "('a, 'b) exp"
 
 
 subsubsection \<open>Nested Recursion
   \label{sssec:datatype-nested-recursion}\<close>
 
 text \<open>
 \emph{Nested recursion} occurs when recursive occurrences of a type appear under
 a type constructor. The introduction showed some examples of trees with nesting
 through lists. A more complex example, that reuses our \<^type>\<open>option\<close> type,
 follows:
 \<close>
 
     datatype 'a btree =
       BNode 'a "'a btree option" "'a btree option"
 
 text \<open>
 \noindent
 Not all nestings are admissible. For example, this command will fail:
 \<close>
 
     datatype 'a wrong = W1 | W2 (*<*)'a
     typ (*>*)"'a wrong \<Rightarrow> 'a"
 
 text \<open>
 \noindent
 The issue is that the function arrow \<open>\<Rightarrow>\<close> allows recursion
 only through its right-hand side. This issue is inherited by polymorphic
 datatypes defined in terms of~\<open>\<Rightarrow>\<close>:
 \<close>
 
     datatype ('a, 'b) fun_copy = Fun "'a \<Rightarrow> 'b"
     datatype 'a also_wrong = W1 | W2 (*<*)'a
     typ (*>*)"('a also_wrong, 'a) fun_copy"
 
 text \<open>
 \noindent
 The following definition of \<^typ>\<open>'a\<close>-branching trees is legal:
 \<close>
 
     datatype 'a ftree = FTLeaf 'a | FTNode "'a \<Rightarrow> 'a ftree"
 
 text \<open>
 \noindent
 And so is the definition of hereditarily finite sets:
 \<close>
 
     datatype hfset = HFSet "hfset fset"
 
 text \<open>
 \noindent
 In general, type constructors \<open>('a\<^sub>1, \<dots>, 'a\<^sub>m) t\<close>
 allow recursion on a subset of their type arguments \<open>'a\<^sub>1\<close>, \ldots,
 \<open>'a\<^sub>m\<close>. These type arguments are called \emph{live}; the remaining
 type arguments are called \emph{dead}. In \<^typ>\<open>'a \<Rightarrow> 'b\<close> and
 \<^typ>\<open>('a, 'b) fun_copy\<close>, the type variable \<^typ>\<open>'a\<close> is dead and
 \<^typ>\<open>'b\<close> is live.
 
 Type constructors must be registered as BNFs to have live arguments. This is
 done automatically for datatypes and codatatypes introduced by the
 @{command datatype} and @{command codatatype} commands.
 Section~\ref{sec:registering-bounded-natural-functors} explains how to
 register arbitrary type constructors as BNFs.
 
 Here is another example that fails:
 \<close>
 
     datatype 'a pow_list = PNil 'a (*<*)'a
     datatype 'a pow_list' = PNil' 'a (*>*)| PCons "('a * 'a) pow_list"
 
 text \<open>
 \noindent
 This attempted definition features a different flavor of nesting, where the
 recursive call in the type specification occurs around (rather than inside)
 another type constructor.
 \<close>
 
 
 subsubsection \<open>Auxiliary Constants
   \label{sssec:datatype-auxiliary-constants}\<close>
 
 text \<open>
 The @{command datatype} command introduces various constants in addition to
 the constructors. With each datatype are associated set functions, a map
 function, a predicator, a relator, discriminators, and selectors, all of which can be given
 custom names. In the example below, the familiar names \<open>null\<close>, \<open>hd\<close>,
 \<open>tl\<close>, \<open>set\<close>, \<open>map\<close>, and \<open>list_all2\<close> override the
 default names \<open>is_Nil\<close>, \<open>un_Cons1\<close>, \<open>un_Cons2\<close>,
 \<open>set_list\<close>, \<open>map_list\<close>, and \<open>rel_list\<close>:
 \<close>
 
 (*<*)
     no_translations
       "[x, xs]" == "x # [xs]"
       "[x]" == "x # []"
 
     no_notation
       Nil ("[]") and
       Cons (infixr "#" 65)
 
     hide_type list
     hide_const Nil Cons case_list hd tl set map list_all2 rec_list size_list list_all
 
     context early
     begin
 (*>*)
     datatype (set: 'a) list =
       null: Nil
     | Cons (hd: 'a) (tl: "'a list")
     for
       map: map
       rel: list_all2
       pred: list_all
     where
       "tl Nil = Nil"
 
 text \<open>
 \noindent
 The types of the constants that appear in the specification are listed below.
 
 \medskip
 
 \begin{tabular}{@ {}ll@ {}}
 Constructors: &
   \<open>Nil :: 'a list\<close> \\
 &
   \<open>Cons :: 'a \<Rightarrow> 'a list \<Rightarrow> 'a list\<close> \\
 Discriminator: &
   \<open>null :: 'a list \<Rightarrow> bool\<close> \\
 Selectors: &
   \<open>hd :: 'a list \<Rightarrow> 'a\<close> \\
 &
   \<open>tl :: 'a list \<Rightarrow> 'a list\<close> \\
 Set function: &
   \<open>set :: 'a list \<Rightarrow> 'a set\<close> \\
 Map function: &
   \<open>map :: ('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list\<close> \\
 Relator: &
   \<open>list_all2 :: ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> bool\<close>
 \end{tabular}
 
 \medskip
 
 The discriminator \<^const>\<open>null\<close> and the selectors \<^const>\<open>hd\<close> and \<^const>\<open>tl\<close>
 are characterized by the following conditional equations:
 %
 \[@{thm list.collapse(1)[of xs, no_vars]}
   \qquad @{thm list.collapse(2)[of xs, no_vars]}\]
 %
 For two-constructor datatypes, a single discriminator constant is sufficient.
 The discriminator associated with \<^const>\<open>Cons\<close> is simply
 \<^term>\<open>\<lambda>xs. \<not> null xs\<close>.
 
 The \keyw{where} clause at the end of the command specifies a default value for
 selectors applied to constructors on which they are not a priori specified.
 In the example, it is used to ensure that the tail of the empty list is itself
 (instead of being left unspecified).
 
 Because \<^const>\<open>Nil\<close> is nullary, it is also possible to use
 \<^term>\<open>\<lambda>xs. xs = Nil\<close> as a discriminator. This is the default behavior
 if we omit the identifier \<^const>\<open>null\<close> and the associated colon. Some users
 argue against this, because the mixture of constructors and selectors in the
 characteristic theorems can lead Isabelle's automation to switch between the
 constructor and the destructor view in surprising ways.
 
 The usual mixfix syntax annotations are available for both types and
 constructors. For example:
 \<close>
 
 (*<*)
     end
 (*>*)
     datatype ('a, 'b) prod (infixr "*" 20) = Pair 'a 'b
 
 text \<open>\blankline\<close>
 
     datatype (set: 'a) list =
       null: Nil ("[]")
     | Cons (hd: 'a) (tl: "'a list") (infixr "#" 65)
     for
       map: map
       rel: list_all2
       pred: list_all
 
 text \<open>
 \noindent
 Incidentally, this is how the traditional syntax can be set up:
 \<close>
 
     syntax "_list" :: "args \<Rightarrow> 'a list" ("[(_)]")
 
 text \<open>\blankline\<close>
 
     translations
       "[x, xs]" == "x # [xs]"
       "[x]" == "x # []"
 
 
 subsection \<open>Command Syntax
   \label{ssec:datatype-command-syntax}\<close>
 
 subsubsection \<open>\keyw{datatype}
   \label{sssec:datatype}\<close>
 
 text \<open>
 \begin{matharray}{rcl}
   @{command_def "datatype"} & : & \<open>local_theory \<rightarrow> local_theory\<close>
 \end{matharray}
 
 \<^rail>\<open>
   @@{command datatype} target? @{syntax dt_options}? @{syntax dt_spec}
   ;
   @{syntax_def dt_options}: '(' ((@{syntax plugins} | 'discs_sels') + ',') ')'
   ;
   @{syntax_def plugins}: 'plugins' ('only' | 'del') ':' (name +)
   ;
   @{syntax_def dt_spec}: (@{syntax dt_name} '=' (@{syntax dt_ctor} + '|') \<newline>
      @{syntax map_rel_pred}? (@'where' (prop + '|'))? + @'and')
   ;
   @{syntax_def map_rel_pred}: @'for' ((('map' | 'rel' | 'pred') ':' name) +)
 \<close>
 
 \medskip
 
 \noindent
 The @{command datatype} command introduces a set of mutually recursive
 datatypes specified by their constructors.
 
 The syntactic entity \synt{target} can be used to specify a local
 context (e.g., \<open>(in linorder)\<close> @{cite "isabelle-isar-ref"}),
 and \synt{prop} denotes a HOL proposition.
 
 The optional target is optionally followed by a combination of the following
 options:
 
 \begin{itemize}
 \setlength{\itemsep}{0pt}
 
 \item
 The \<open>plugins\<close> option indicates which plugins should be enabled
 (\<open>only\<close>) or disabled (\<open>del\<close>). By default, all plugins are enabled.
 
 \item
 The \<open>discs_sels\<close> option indicates that discriminators and selectors
 should be generated. The option is implicitly enabled if names are specified for
 discriminators or selectors.
 \end{itemize}
 
 The optional \keyw{where} clause specifies default values for selectors.
 Each proposition must be an equation of the form
 \<open>un_D (C \<dots>) = \<dots>\<close>, where \<open>C\<close> is a constructor and
 \<open>un_D\<close> is a selector.
 
 The left-hand sides of the datatype equations specify the name of the type to
 define, its type parameters, and additional information:
 
 \<^rail>\<open>
   @{syntax_def dt_name}: @{syntax tyargs}? name mixfix?
   ;
   @{syntax_def tyargs}: typefree | '(' (('dead' | name ':')? typefree + ',') ')'
 \<close>
 
 \medskip
 
 \noindent
 The syntactic entity \synt{name} denotes an identifier, \synt{mixfix} denotes
 the usual parenthesized mixfix notation, and \synt{typefree} denotes fixed type
 variable (\<^typ>\<open>'a\<close>, \<^typ>\<open>'b\<close>, \ldots) @{cite "isabelle-isar-ref"}.
 
 The optional names preceding the type variables allow to override the default
 names of the set functions (\<open>set\<^sub>1_t\<close>, \ldots, \<open>set\<^sub>m_t\<close>). Type
 arguments can be marked as dead by entering \<open>dead\<close> in front of the
 type variable (e.g., \<open>(dead 'a)\<close>); otherwise, they are live or dead
 (and a set function is generated or not) depending on where they occur in the
 right-hand sides of the definition. Declaring a type argument as dead can speed
 up the type definition but will prevent any later (co)recursion through that
 type argument.
 
 Inside a mutually recursive specification, all defined datatypes must
 mention exactly the same type variables in the same order.
 
 \<^rail>\<open>
   @{syntax_def dt_ctor}: (name ':')? name (@{syntax dt_ctor_arg} * ) mixfix?
 \<close>
 
 \medskip
 
 \noindent
 The main constituents of a constructor specification are the name of the
 constructor and the list of its argument types. An optional discriminator name
 can be supplied at the front. If discriminators are enabled (cf.\ the
 \<open>discs_sels\<close> option) but no name is supplied, the default is
 \<open>\<lambda>x. x = C\<^sub>j\<close> for nullary constructors and
 \<open>t.is_C\<^sub>j\<close> otherwise.
 
 \<^rail>\<open>
   @{syntax_def dt_ctor_arg}: type | '(' name ':' type ')'
 \<close>
 
 \medskip
 
 \noindent
 The syntactic entity \synt{type} denotes a HOL type @{cite "isabelle-isar-ref"}.
 
 In addition to the type of a constructor argument, it is possible to specify a
 name for the corresponding selector. The same selector name can be reused for
 arguments to several constructors as long as the arguments share the same type.
 If selectors are enabled (cf.\ the \<open>discs_sels\<close> option) but no name is
 supplied, the default name is \<open>un_C\<^sub>ji\<close>.
 \<close>
 
 
 subsubsection \<open>\keyw{datatype_compat}
   \label{sssec:datatype-compat}\<close>
 
 text \<open>
 \begin{matharray}{rcl}
   @{command_def "datatype_compat"} & : & \<open>local_theory \<rightarrow> local_theory\<close>
 \end{matharray}
 
 \<^rail>\<open>
   @@{command datatype_compat} (name +)
 \<close>
 
 \medskip
 
 \noindent
 The @{command datatype_compat} command registers new-style datatypes as
 old-style datatypes and invokes the old-style plugins. For example:
 \<close>
 
     datatype_compat even_nat odd_nat
 
 text \<open>\blankline\<close>
 
     ML \<open>Old_Datatype_Data.get_info \<^theory> \<^type_name>\<open>even_nat\<close>\<close>
 
 text \<open>
 The syntactic entity \synt{name} denotes an identifier @{cite "isabelle-isar-ref"}.
 
 The command is sometimes useful when migrating from the old datatype package to
 the new one.
 
 A few remarks concern nested recursive datatypes:
 
 \begin{itemize}
 \setlength{\itemsep}{0pt}
 
 \item The old-style, nested-as-mutual induction rule and recursor theorems are
 generated under their usual names but with ``\<open>compat_\<close>'' prefixed
 (e.g., \<open>compat_tree.induct\<close>, \<open>compat_tree.inducts\<close>, and
 \<open>compat_tree.rec\<close>). These theorems should be identical to the ones
 generated by the old datatype package, \emph{up to the order of the
 premises}---meaning that the subgoals generated by the \<open>induct\<close> or
 \<open>induction\<close> method may be in a different order than before.
 
 \item All types through which recursion takes place must be new-style datatypes
 or the function type.
 \end{itemize}
 \<close>
 
 
 subsection \<open>Generated Constants
   \label{ssec:datatype-generated-constants}\<close>
 
 text \<open>
 Given a datatype \<open>('a\<^sub>1, \<dots>, 'a\<^sub>m) t\<close> with $m$ live type variables
 and $n$ constructors \<open>t.C\<^sub>1\<close>, \ldots, \<open>t.C\<^sub>n\<close>, the following
 auxiliary constants are introduced:
 
 \medskip
 
 \begin{tabular}{@ {}ll@ {}}
 Case combinator: &
   \<open>t.case_t\<close> (rendered using the familiar \<open>case\<close>--\<open>of\<close> syntax) \\
 Discriminators: &
   \<open>t.is_C\<^sub>1\<close>$, \ldots, $\<open>t.is_C\<^sub>n\<close> \\
 Selectors: &
   \<open>t.un_C\<^sub>11\<close>$, \ldots, $\<open>t.un_C\<^sub>1k\<^sub>1\<close> \\
 & \quad\vdots \\
 & \<open>t.un_C\<^sub>n1\<close>$, \ldots, $\<open>t.un_C\<^sub>nk\<^sub>n\<close> \\
 Set functions: &
   \<open>t.set\<^sub>1_t\<close>, \ldots, \<open>t.set\<^sub>m_t\<close> \\
 Map function: &
   \<open>t.map_t\<close> \\
 Relator: &
   \<open>t.rel_t\<close> \\
 Recursor: &
   \<open>t.rec_t\<close>
 \end{tabular}
 
 \medskip
 
 \noindent
 The discriminators and selectors are generated only if the \<open>discs_sels\<close>
 option is enabled or if names are specified for discriminators or selectors.
 The set functions, map function, predicator, and relator are generated only if $m > 0$.
 
 In addition, some of the plugins introduce their own constants
 (Section~\ref{sec:selecting-plugins}). The case combinator, discriminators,
 and selectors are collectively called \emph{destructors}. The prefix
 ``\<open>t.\<close>'' is an optional component of the names and is normally hidden.
 \<close>
 
 
 subsection \<open>Generated Theorems
   \label{ssec:datatype-generated-theorems}\<close>
 
 text \<open>
 The characteristic theorems generated by @{command datatype} are grouped in
 three broad categories:
 
 \begin{itemize}
 \setlength{\itemsep}{0pt}
 
 \item The \emph{free constructor theorems}
 (Section~\ref{sssec:free-constructor-theorems}) are properties of the
 constructors and destructors that can be derived for any freely generated type.
 Internally, the derivation is performed by @{command free_constructors}.
 
 \item The \emph{functorial theorems} (Section~\ref{sssec:functorial-theorems})
 are properties of datatypes related to their BNF nature.
 
 \item The \emph{inductive theorems} (Section~\ref{sssec:inductive-theorems})
 are properties of datatypes related to their inductive nature.
 
 \end{itemize}
 
 \noindent
 The full list of named theorems can be obtained by issuing the command
 \keyw{print_theorems} immediately after the datatype definition. This list
 includes theorems produced by plugins (Section~\ref{sec:selecting-plugins}),
 but normally excludes low-level theorems that reveal internal constructions.
 To make these accessible, add the line
 \<close>
 
     declare [[bnf_internals]]
 (*<*)
     declare [[bnf_internals = false]]
 (*>*)
 
 
 subsubsection \<open>Free Constructor Theorems
   \label{sssec:free-constructor-theorems}\<close>
 
 (*<*)
     consts nonnull :: 'a
 (*>*)
 
 text \<open>
 The free constructor theorems are partitioned in three subgroups. The first
 subgroup of properties is concerned with the constructors. They are listed below
 for \<^typ>\<open>'a list\<close>:
 
 \begin{indentblock}
 \begin{description}
 
 \item[\<open>t.\<close>\hthm{inject} \<open>[iff, induct_simp]\<close>\rm:] ~ \\
 @{thm list.inject[no_vars]}
 
 \item[\<open>t.\<close>\hthm{distinct} \<open>[simp, induct_simp]\<close>\rm:] ~ \\
 @{thm list.distinct(1)[no_vars]} \\
 @{thm list.distinct(2)[no_vars]}
 
 \item[\<open>t.\<close>\hthm{exhaust} \<open>[cases t, case_names C\<^sub>1 \<dots> C\<^sub>n]\<close>\rm:] ~ \\
 @{thm list.exhaust[no_vars]}
 
 \item[\<open>t.\<close>\hthm{nchotomy}\rm:] ~ \\
 @{thm list.nchotomy[no_vars]}
 
 \end{description}
 \end{indentblock}
 
 \noindent
 In addition, these nameless theorems are registered as safe elimination rules:
 
 \begin{indentblock}
 \begin{description}
 
 \item[\<open>t.\<close>\hthm{distinct {\upshape[}THEN notE}\<open>, elim!\<close>\hthm{\upshape]}\rm:] ~ \\
 @{thm list.distinct(1)[THEN notE, elim!, no_vars]} \\
 @{thm list.distinct(2)[THEN notE, elim!, no_vars]}
 
 \end{description}
 \end{indentblock}
 
 \noindent
 The next subgroup is concerned with the case combinator:
 
 \begin{indentblock}
 \begin{description}
 
 \item[\<open>t.\<close>\hthm{case} \<open>[simp, code]\<close>\rm:] ~ \\
 @{thm list.case(1)[no_vars]} \\
 @{thm list.case(2)[no_vars]} \\
 The \<open>[code]\<close> attribute is set by the \<open>code\<close> plugin
 (Section~\ref{ssec:code-generator}).
 
 \item[\<open>t.\<close>\hthm{case_cong} \<open>[fundef_cong]\<close>\rm:] ~ \\
 @{thm list.case_cong[no_vars]}
 
 \item[\<open>t.\<close>\hthm{case_cong_weak} \<open>[cong]\<close>\rm:] ~ \\
 @{thm list.case_cong_weak[no_vars]}
 
 \item[\<open>t.\<close>\hthm{case_distrib}\rm:] ~ \\
 @{thm list.case_distrib[no_vars]}
 
 \item[\<open>t.\<close>\hthm{split}\rm:] ~ \\
 @{thm list.split[no_vars]}
 
 \item[\<open>t.\<close>\hthm{split_asm}\rm:] ~ \\
 @{thm list.split_asm[no_vars]}
 
 \item[\<open>t.\<close>\hthm{splits} = \<open>split split_asm\<close>]
 
 \end{description}
 \end{indentblock}
 
 \noindent
 The third subgroup revolves around discriminators and selectors:
 
 \begin{indentblock}
 \begin{description}
 
 \item[\<open>t.\<close>\hthm{disc} \<open>[simp]\<close>\rm:] ~ \\
 @{thm list.disc(1)[no_vars]} \\
 @{thm list.disc(2)[no_vars]}
 
 \item[\<open>t.\<close>\hthm{discI}\rm:] ~ \\
 @{thm list.discI(1)[no_vars]} \\
 @{thm list.discI(2)[no_vars]}
 
 \item[\<open>t.\<close>\hthm{sel} \<open>[simp, code]\<close>\rm:] ~ \\
 @{thm list.sel(1)[no_vars]} \\
 @{thm list.sel(2)[no_vars]} \\
 The \<open>[code]\<close> attribute is set by the \<open>code\<close> plugin
 (Section~\ref{ssec:code-generator}).
 
 \item[\<open>t.\<close>\hthm{collapse} \<open>[simp]\<close>\rm:] ~ \\
 @{thm list.collapse(1)[no_vars]} \\
 @{thm list.collapse(2)[no_vars]} \\
 The \<open>[simp]\<close> attribute is exceptionally omitted for datatypes equipped
 with a single nullary constructor, because a property of the form
 \<^prop>\<open>x = C\<close> is not suitable as a simplification rule.
 
 \item[\<open>t.\<close>\hthm{distinct_disc} \<open>[dest]\<close>\rm:] ~ \\
 These properties are missing for \<^typ>\<open>'a list\<close> because there is only one
 proper discriminator. If the datatype had been introduced with a second
 discriminator called \<^const>\<open>nonnull\<close>, they would have read as follows: \\[\jot]
 \<^prop>\<open>null list \<Longrightarrow> \<not> nonnull list\<close> \\
 \<^prop>\<open>nonnull list \<Longrightarrow> \<not> null list\<close>
 
 \item[\<open>t.\<close>\hthm{exhaust_disc} \<open>[case_names C\<^sub>1 \<dots> C\<^sub>n]\<close>\rm:] ~ \\
 @{thm list.exhaust_disc[no_vars]}
 
 \item[\<open>t.\<close>\hthm{exhaust_sel} \<open>[case_names C\<^sub>1 \<dots> C\<^sub>n]\<close>\rm:] ~ \\
 @{thm list.exhaust_sel[no_vars]}
 
 \item[\<open>t.\<close>\hthm{expand}\rm:] ~ \\
 @{thm list.expand[no_vars]}
 
 \item[\<open>t.\<close>\hthm{split_sel}\rm:] ~ \\
 @{thm list.split_sel[no_vars]}
 
 \item[\<open>t.\<close>\hthm{split_sel_asm}\rm:] ~ \\
 @{thm list.split_sel_asm[no_vars]}
 
 \item[\<open>t.\<close>\hthm{split_sels} = \<open>split_sel split_sel_asm\<close>]
 
 \item[\<open>t.\<close>\hthm{case_eq_if}\rm:] ~ \\
 @{thm list.case_eq_if[no_vars]}
 
 \item[\<open>t.\<close>\hthm{disc_eq_case}\rm:] ~ \\
 @{thm list.disc_eq_case(1)[no_vars]} \\
 @{thm list.disc_eq_case(2)[no_vars]}
 
 \end{description}
 \end{indentblock}
 
 \noindent
 In addition, equational versions of \<open>t.disc\<close> are registered with the
 \<open>[code]\<close> attribute. The \<open>[code]\<close> attribute is set by the
 \<open>code\<close> plugin (Section~\ref{ssec:code-generator}).
 \<close>
 
 
 subsubsection \<open>Functorial Theorems
   \label{sssec:functorial-theorems}\<close>
 
 text \<open>
 The functorial theorems are generated for type constructors with at least
 one live type argument (e.g., \<^typ>\<open>'a list\<close>). They are partitioned in two
 subgroups. The first subgroup consists of properties involving the
 constructors or the destructors and either a set function, the map function,
 the predicator, or the relator:
 
 \begin{indentblock}
 \begin{description}
 
 \item[\<open>t.\<close>\hthm{case_transfer} \<open>[transfer_rule]\<close>\rm:] ~ \\
 @{thm list.case_transfer[no_vars]} \\
 This property is generated by the \<open>transfer\<close> plugin
 (Section~\ref{ssec:transfer}).
 %The \<open>[transfer_rule]\<close> attribute is set by the \<open>transfer\<close> plugin
 %(Section~\ref{ssec:transfer}).
 
 \item[\<open>t.\<close>\hthm{sel_transfer} \<open>[transfer_rule]\<close>\rm:] ~ \\
 This property is missing for \<^typ>\<open>'a list\<close> because there is no common
 selector to all constructors. \\
 The \<open>[transfer_rule]\<close> attribute is set by the \<open>transfer\<close> plugin
 (Section~\ref{ssec:transfer}).
 
 \item[\<open>t.\<close>\hthm{ctr_transfer} \<open>[transfer_rule]\<close>\rm:] ~ \\
 @{thm list.ctr_transfer(1)[no_vars]} \\
 @{thm list.ctr_transfer(2)[no_vars]} \\
 The \<open>[transfer_rule]\<close> attribute is set by the \<open>transfer\<close> plugin
 (Section~\ref{ssec:transfer}) .
 
 \item[\<open>t.\<close>\hthm{disc_transfer} \<open>[transfer_rule]\<close>\rm:] ~ \\
 @{thm list.disc_transfer(1)[no_vars]} \\
 @{thm list.disc_transfer(2)[no_vars]} \\
 The \<open>[transfer_rule]\<close> attribute is set by the \<open>transfer\<close> plugin
 (Section~\ref{ssec:transfer}).
 
 \item[\<open>t.\<close>\hthm{set} \<open>[simp, code]\<close>\rm:] ~ \\
 @{thm list.set(1)[no_vars]} \\
 @{thm list.set(2)[no_vars]} \\
 The \<open>[code]\<close> attribute is set by the \<open>code\<close> plugin
 (Section~\ref{ssec:code-generator}).
 
 \item[\<open>t.\<close>\hthm{set_cases} \<open>[consumes 1, cases set: set\<^sub>i_t]\<close>\rm:] ~ \\
 @{thm list.set_cases[no_vars]}
 
 \item[\<open>t.\<close>\hthm{set_intros}\rm:] ~ \\
 @{thm list.set_intros(1)[no_vars]} \\
 @{thm list.set_intros(2)[no_vars]}
 
 \item[\<open>t.\<close>\hthm{set_sel}\rm:] ~ \\
 @{thm list.set_sel[no_vars]}
 
 \item[\<open>t.\<close>\hthm{map} \<open>[simp, code]\<close>\rm:] ~ \\
 @{thm list.map(1)[no_vars]} \\
 @{thm list.map(2)[no_vars]} \\
 The \<open>[code]\<close> attribute is set by the \<open>code\<close> plugin
 (Section~\ref{ssec:code-generator}).
 
 \item[\<open>t.\<close>\hthm{map_disc_iff} \<open>[simp]\<close>\rm:] ~ \\
 @{thm list.map_disc_iff[no_vars]}
 
 \item[\<open>t.\<close>\hthm{map_sel}\rm:] ~ \\
 @{thm list.map_sel[no_vars]}
 
 \item[\<open>t.\<close>\hthm{pred_inject} \<open>[simp]\<close>\rm:] ~ \\
 @{thm list.pred_inject(1)[no_vars]} \\
 @{thm list.pred_inject(2)[no_vars]}
 
 \item[\<open>t.\<close>\hthm{rel_inject} \<open>[simp]\<close>\rm:] ~ \\
 @{thm list.rel_inject(1)[no_vars]} \\
 @{thm list.rel_inject(2)[no_vars]}
 
 \item[\<open>t.\<close>\hthm{rel_distinct} \<open>[simp]\<close>\rm:] ~ \\
 @{thm list.rel_distinct(1)[no_vars]} \\
 @{thm list.rel_distinct(2)[no_vars]}
 
 \item[\<open>t.\<close>\hthm{rel_intros}\rm:] ~ \\
 @{thm list.rel_intros(1)[no_vars]} \\
 @{thm list.rel_intros(2)[no_vars]}
 
 \item[\<open>t.\<close>\hthm{rel_cases} \<open>[consumes 1, case_names t\<^sub>1 \<dots> t\<^sub>m, cases pred]\<close>\rm:] ~ \\
 @{thm list.rel_cases[no_vars]}
 
 \item[\<open>t.\<close>\hthm{rel_sel}\rm:] ~ \\
 @{thm list.rel_sel[no_vars]}
 
 \end{description}
 \end{indentblock}
 
 \noindent
 In addition, equational versions of \<open>t.rel_inject\<close> and \<open>rel_distinct\<close> are registered with the \<open>[code]\<close> attribute. The
 \<open>[code]\<close> attribute is set by the \<open>code\<close> plugin
 (Section~\ref{ssec:code-generator}).
 
 The second subgroup consists of more abstract properties of the set functions,
 the map function, the predicator, and the relator:
 
 \begin{indentblock}
 \begin{description}
 
 \item[\<open>t.\<close>\hthm{inj_map}\rm:] ~ \\
 @{thm list.inj_map[no_vars]}
 
 \item[\<open>t.\<close>\hthm{inj_map_strong}\rm:] ~ \\
 @{thm list.inj_map_strong[no_vars]}
 
 \item[\<open>t.\<close>\hthm{map_comp}\rm:] ~ \\
 @{thm list.map_comp[no_vars]}
 
 \item[\<open>t.\<close>\hthm{map_cong0}\rm:] ~ \\
 @{thm list.map_cong0[no_vars]}
 
 \item[\<open>t.\<close>\hthm{map_cong} \<open>[fundef_cong]\<close>\rm:] ~ \\
 @{thm list.map_cong[no_vars]}
 
 \item[\<open>t.\<close>\hthm{map_cong_pred}\rm:] ~ \\
 @{thm list.map_cong_pred[no_vars]}
 
 \item[\<open>t.\<close>\hthm{map_cong_simp}\rm:] ~ \\
 @{thm list.map_cong_simp[no_vars]}
 
 \item[\<open>t.\<close>\hthm{map_id0}\rm:] ~ \\
 @{thm list.map_id0[no_vars]}
 
 \item[\<open>t.\<close>\hthm{map_id}\rm:] ~ \\
 @{thm list.map_id[no_vars]}
 
 \item[\<open>t.\<close>\hthm{map_ident}\rm:] ~ \\
 @{thm list.map_ident[no_vars]}
 
 \item[\<open>t.\<close>\hthm{map_transfer} \<open>[transfer_rule]\<close>\rm:] ~ \\
 @{thm list.map_transfer[no_vars]} \\
 The \<open>[transfer_rule]\<close> attribute is set by the \<open>transfer\<close> plugin
 (Section~\ref{ssec:transfer}) for type constructors with no dead type arguments.
 
 \item[\<open>t.\<close>\hthm{pred_cong} \<open>[fundef_cong]\<close>\rm:] ~ \\
 @{thm list.pred_cong[no_vars]}
 
 \item[\<open>t.\<close>\hthm{pred_cong_simp}\rm:] ~ \\
 @{thm list.pred_cong_simp[no_vars]}
 
 \item[\<open>t.\<close>\hthm{pred_map}\rm:] ~ \\
 @{thm list.pred_map[no_vars]}
 
 \item[\<open>t.\<close>\hthm{pred_mono_strong}\rm:] ~ \\
 @{thm list.pred_mono_strong[no_vars]}
 
 \item[\<open>t.\<close>\hthm{pred_rel}\rm:] ~ \\
 @{thm list.pred_rel[no_vars]}
 
 \item[\<open>t.\<close>\hthm{pred_set}\rm:] ~ \\
 @{thm list.pred_set[no_vars]}
 
 \item[\<open>t.\<close>\hthm{pred_transfer} \<open>[transfer_rule]\<close>\rm:] ~ \\
 @{thm list.pred_transfer[no_vars]} \\
 The \<open>[transfer_rule]\<close> attribute is set by the \<open>transfer\<close> plugin
 (Section~\ref{ssec:transfer}) for type constructors with no dead type arguments.
 
 \item[\<open>t.\<close>\hthm{pred_True}\rm:] ~ \\
 @{thm list.pred_True[no_vars]}
 
 \item[\<open>t.\<close>\hthm{set_map}\rm:] ~ \\
 @{thm list.set_map[no_vars]}
 
 \item[\<open>t.\<close>\hthm{set_transfer} \<open>[transfer_rule]\<close>\rm:] ~ \\
 @{thm list.set_transfer[no_vars]} \\
 The \<open>[transfer_rule]\<close> attribute is set by the \<open>transfer\<close> plugin
 (Section~\ref{ssec:transfer}) for type constructors with no dead type arguments.
 
 \item[\<open>t.\<close>\hthm{rel_compp} \<open>[relator_distr]\<close>\rm:] ~ \\
 @{thm list.rel_compp[no_vars]} \\
 The \<open>[relator_distr]\<close> attribute is set by the \<open>lifting\<close> plugin
 (Section~\ref{ssec:lifting}).
 
 \item[\<open>t.\<close>\hthm{rel_conversep}\rm:] ~ \\
 @{thm list.rel_conversep[no_vars]}
 
 \item[\<open>t.\<close>\hthm{rel_eq}\rm:] ~ \\
 @{thm list.rel_eq[no_vars]}
 
 \item[\<open>t.\<close>\hthm{rel_eq_onp}\rm:] ~ \\
 @{thm list.rel_eq_onp[no_vars]}
 
 \item[\<open>t.\<close>\hthm{rel_flip}\rm:] ~ \\
 @{thm list.rel_flip[no_vars]}
 
 \item[\<open>t.\<close>\hthm{rel_map}\rm:] ~ \\
 @{thm list.rel_map(1)[no_vars]} \\
 @{thm list.rel_map(2)[no_vars]}
 
 \item[\<open>t.\<close>\hthm{rel_mono} \<open>[mono, relator_mono]\<close>\rm:] ~ \\
 @{thm list.rel_mono[no_vars]} \\
 The \<open>[relator_mono]\<close> attribute is set by the \<open>lifting\<close> plugin
 (Section~\ref{ssec:lifting}).
 
 \item[\<open>t.\<close>\hthm{rel_mono_strong}\rm:] ~ \\
 @{thm list.rel_mono_strong[no_vars]}
 
 \item[\<open>t.\<close>\hthm{rel_cong} \<open>[fundef_cong]\<close>\rm:] ~ \\
 @{thm list.rel_cong[no_vars]}
 
 \item[\<open>t.\<close>\hthm{rel_cong_simp}\rm:] ~ \\
 @{thm list.rel_cong_simp[no_vars]}
 
 \item[\<open>t.\<close>\hthm{rel_refl}\rm:] ~ \\
 @{thm list.rel_refl[no_vars]}
 
 \item[\<open>t.\<close>\hthm{rel_refl_strong}\rm:] ~ \\
 @{thm list.rel_refl_strong[no_vars]}
 
 \item[\<open>t.\<close>\hthm{rel_reflp}\rm:] ~ \\
 @{thm list.rel_reflp[no_vars]}
 
 \item[\<open>t.\<close>\hthm{rel_symp}\rm:] ~ \\
 @{thm list.rel_symp[no_vars]}
 
 \item[\<open>t.\<close>\hthm{rel_transp}\rm:] ~ \\
 @{thm list.rel_transp[no_vars]}
 
 \item[\<open>t.\<close>\hthm{rel_transfer} \<open>[transfer_rule]\<close>\rm:] ~ \\
 @{thm list.rel_transfer[no_vars]} \\
 The \<open>[transfer_rule]\<close> attribute is set by the \<open>transfer\<close> plugin
 (Section~\ref{ssec:transfer}) for type constructors with no dead type arguments.
 
 \end{description}
 \end{indentblock}
 \<close>
 
 
 subsubsection \<open>Inductive Theorems
   \label{sssec:inductive-theorems}\<close>
 
 text \<open>
 The inductive theorems are as follows:
 
 \begin{indentblock}
 \begin{description}
 
 \item[\<open>t.\<close>\hthm{induct} \<open>[case_names C\<^sub>1 \<dots> C\<^sub>n, induct t]\<close>\rm:] ~ \\
 @{thm list.induct[no_vars]}
 
 \item[\<open>t.\<close>\hthm{rel_induct} \<open>[case_names C\<^sub>1 \<dots> C\<^sub>n, induct pred]\<close>\rm:] ~ \\
 @{thm list.rel_induct[no_vars]}
 
 \item[\begin{tabular}{@ {}l@ {}}
   \<open>t\<^sub>1_\<dots>_t\<^sub>m.\<close>\hthm{induct} \<open>[case_names C\<^sub>1 \<dots> C\<^sub>n]\<close>\rm: \\
   \<open>t\<^sub>1_\<dots>_t\<^sub>m.\<close>\hthm{rel_induct} \<open>[case_names C\<^sub>1 \<dots> C\<^sub>n]\<close>\rm: \\
 \end{tabular}] ~ \\
 Given $m > 1$ mutually recursive datatypes, this induction rule can be used to
 prove $m$ properties simultaneously.
 
 \item[\<open>t.\<close>\hthm{rec} \<open>[simp, code]\<close>\rm:] ~ \\
 @{thm list.rec(1)[no_vars]} \\
 @{thm list.rec(2)[no_vars]} \\
 The \<open>[code]\<close> attribute is set by the \<open>code\<close> plugin
 (Section~\ref{ssec:code-generator}).
 
 \item[\<open>t.\<close>\hthm{rec_o_map}\rm:] ~ \\
 @{thm list.rec_o_map[no_vars]}
 
 \item[\<open>t.\<close>\hthm{rec_transfer} \<open>[transfer_rule]\<close>\rm:] ~ \\
 @{thm list.rec_transfer[no_vars]} \\
 The \<open>[transfer_rule]\<close> attribute is set by the \<open>transfer\<close> plugin
 (Section~\ref{ssec:transfer}) for type constructors with no dead type arguments.
 
 \end{description}
 \end{indentblock}
 
 \noindent
 For convenience, @{command datatype} also provides the following collection:
 
 \begin{indentblock}
 \begin{description}
 
 \item[\<open>t.\<close>\hthm{simps}] = \<open>t.inject\<close> \<open>t.distinct\<close> \<open>t.case\<close> \<open>t.rec\<close> \<open>t.map\<close> \<open>t.rel_inject\<close> \\
 \<open>t.rel_distinct\<close> \<open>t.set\<close>
 
 \end{description}
 \end{indentblock}
 \<close>
 
 
 subsection \<open>Proof Method
   \label{ssec:datatype-proof-method}\<close>
 
 subsubsection \<open>\textit{countable_datatype}
   \label{sssec:datatype-compat}\<close>
 
 text \<open>
 The theory \<^file>\<open>~~/src/HOL/Library/Countable.thy\<close> provides a
 proof method called @{method countable_datatype} that can be used to prove the
 countability of many datatypes, building on the countability of the types
 appearing in their definitions and of any type arguments. For example:
 \<close>
 
     instance list :: (countable) countable
       by countable_datatype
 
 
 subsection \<open>Antiquotation
   \label{ssec:datatype-antiquotation}\<close>
 
 subsubsection \<open>\textit{datatype}
   \label{sssec:datatype-datatype}\<close>
 
 text \<open>
 The \textit{datatype} antiquotation, written
 \texttt{\char`\\\char`<\char`^}\verb|datatype>|\guilsinglleft\textit{t}\guilsinglright{}
 or \texttt{@}\verb|{datatype| \textit{t}\verb|}|, where \textit{t} is a type
 name, expands to \LaTeX{} code for the definition of the datatype, with each
 constructor listed with its argument types. For example, if \textit{t} is
 @{type option}:
 
 \begin{quote}
 \<^datatype>\<open>option\<close>
 \end{quote}
 \<close>
 
 
 subsection \<open>Compatibility Issues
   \label{ssec:datatype-compatibility-issues}\<close>
 
 text \<open>
 The command @{command datatype} has been designed to be highly compatible with
 the old, pre-Isabelle2015 command, to ease migration. There are nonetheless a
 few incompatibilities that may arise when porting:
 
 \begin{itemize}
 \setlength{\itemsep}{0pt}
 
 \item \emph{The Standard ML interfaces are different.} Tools and extensions
 written to call the old ML interfaces will need to be adapted to the new
 interfaces. The \<open>BNF_LFP_Compat\<close> structure provides convenience functions
 that simulate the old interfaces in terms of the new ones.
 
 \item \emph{The recursor \<open>rec_t\<close> has a different signature for nested
 recursive datatypes.} In the old package, nested recursion through non-functions
 was internally reduced to mutual recursion. This reduction was visible in the
 type of the recursor, used by \keyw{primrec}. Recursion through functions was
 handled specially. In the new package, nested recursion (for functions and
 non-functions) is handled in a more modular fashion. The old-style recursor can
 be generated on demand using @{command primrec} if the recursion is via
 new-style datatypes, as explained in
 Section~\ref{sssec:primrec-nested-as-mutual-recursion}, or using
 @{command datatype_compat}.
 
 \item \emph{Accordingly, the induction rule is different for nested recursive
 datatypes.} Again, the old-style induction rule can be generated on demand
 using @{command primrec} if the recursion is via new-style datatypes, as
 explained in Section~\ref{sssec:primrec-nested-as-mutual-recursion}, or using
 @{command datatype_compat}. For recursion through functions, the old-style
 induction rule can be obtained by applying the \<open>[unfolded
 all_mem_range]\<close> attribute on \<open>t.induct\<close>.
 
 \item \emph{The \<^const>\<open>size\<close> function has a slightly different definition.}
 The new function returns \<open>1\<close> instead of \<open>0\<close> for some nonrecursive
 constructors. This departure from the old behavior made it possible to implement
 \<^const>\<open>size\<close> in terms of the generic function \<open>t.size_t\<close>. Moreover,
 the new function considers nested occurrences of a value, in the nested
 recursive case. The old behavior can be obtained by disabling the \<open>size\<close>
 plugin (Section~\ref{sec:selecting-plugins}) and instantiating the
 \<open>size\<close> type class manually.
 
 \item \emph{The internal constructions are completely different.} Proof texts
 that unfold the definition of constants introduced by the old command will
 be difficult to port.
 
 \item \emph{Some constants and theorems have different names.}
 For non-mutually recursive datatypes,
 the alias \<open>t.inducts\<close> for \<open>t.induct\<close> is no longer generated.
 For $m > 1$ mutually recursive datatypes,
 \<open>rec_t\<^sub>1_\<dots>_t\<^sub>m_i\<close> has been renamed
 \<open>rec_t\<^sub>i\<close> for each \<open>i \<in> {1, \<dots>, m}\<close>,
 \<open>t\<^sub>1_\<dots>_t\<^sub>m.inducts(i)\<close> has been renamed
 \<open>t\<^sub>i.induct\<close> for each \<open>i \<in> {1, \<dots>, m}\<close>, and the
 collection \<open>t\<^sub>1_\<dots>_t\<^sub>m.size\<close> (generated by the
 \<open>size\<close> plugin, Section~\ref{ssec:size}) has been divided into
 \<open>t\<^sub>1.size\<close>, \ldots, \<open>t\<^sub>m.size\<close>.
 
 \item \emph{The \<open>t.simps\<close> collection has been extended.}
 Previously available theorems are available at the same index as before.
 
 \item \emph{Variables in generated properties have different names.} This is
 rarely an issue, except in proof texts that refer to variable names in the
 \<open>[where \<dots>]\<close> attribute. The solution is to use the more robust
 \<open>[of \<dots>]\<close> syntax.
 \end{itemize}
 \<close>
 
 
 section \<open>Defining Primitively Recursive Functions
   \label{sec:defining-primitively-recursive-functions}\<close>
 
 text \<open>
 Recursive functions over datatypes can be specified using the @{command primrec}
 command, which supports primitive recursion, or using the \keyw{fun},
 \keyw{function}, and \keyw{partial_function} commands. In this tutorial, the
 focus is on @{command primrec}; \keyw{fun} and \keyw{function} are described in
 a separate tutorial @{cite "isabelle-function"}.
 
 Because it is restricted to primitive recursion, @{command primrec} is less
 powerful than \keyw{fun} and \keyw{function}. However, there are primitively
 recursive specifications (e.g., based on infinitely branching or mutually
 recursive datatypes) for which \keyw{fun}'s termination check fails. It is also
 good style to use the simpler @{command primrec} mechanism when it works, both
 as an optimization and as documentation.
 \<close>
 
 
 subsection \<open>Introductory Examples
   \label{ssec:primrec-introductory-examples}\<close>
 
 text \<open>
 Primitive recursion is illustrated through concrete examples based on the
 datatypes defined in Section~\ref{ssec:datatype-introductory-examples}. More
 examples can be found in the directory \<^dir>\<open>~~/src/HOL/Datatype_Examples\<close>.
 \<close>
 
 
 subsubsection \<open>Nonrecursive Types
   \label{sssec:primrec-nonrecursive-types}\<close>
 
 text \<open>
 Primitive recursion removes one layer of constructors on the left-hand side in
 each equation. For example:
 \<close>
 
     primrec (nonexhaustive) bool_of_trool :: "trool \<Rightarrow> bool" where
       "bool_of_trool Faalse \<longleftrightarrow> False"
     | "bool_of_trool Truue \<longleftrightarrow> True"
 
 text \<open>\blankline\<close>
 
     primrec the_list :: "'a option \<Rightarrow> 'a list" where
       "the_list None = []"
     | "the_list (Some a) = [a]"
 
 text \<open>\blankline\<close>
 
     primrec the_default :: "'a \<Rightarrow> 'a option \<Rightarrow> 'a" where
       "the_default d None = d"
     | "the_default _ (Some a) = a"
 
 text \<open>\blankline\<close>
 
     primrec mirrror :: "('a, 'b, 'c) triple \<Rightarrow> ('c, 'b, 'a) triple" where
       "mirrror (Triple a b c) = Triple c b a"
 
 text \<open>
 \noindent
 The equations can be specified in any order, and it is acceptable to leave out
 some cases, which are then unspecified. Pattern matching on the left-hand side
 is restricted to a single datatype, which must correspond to the same argument
 in all equations.
 \<close>
 
 
 subsubsection \<open>Simple Recursion
   \label{sssec:primrec-simple-recursion}\<close>
 
 text \<open>
 For simple recursive types, recursive calls on a constructor argument are
 allowed on the right-hand side:
 \<close>
 
     primrec replicate :: "nat \<Rightarrow> 'a \<Rightarrow> 'a list" where
       "replicate Zero _ = []"
     | "replicate (Succ n) x = x # replicate n x"
 
 text \<open>\blankline\<close>
 
     primrec (nonexhaustive) at :: "'a list \<Rightarrow> nat \<Rightarrow> 'a" where
       "at (x # xs) j =
          (case j of
             Zero \<Rightarrow> x
           | Succ j' \<Rightarrow> at xs j')"
 
 text \<open>\blankline\<close>
 
     primrec (*<*)(in early) (transfer) (*>*)tfold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) tlist \<Rightarrow> 'b" where
       "tfold _ (TNil y) = y"
     | "tfold f (TCons x xs) = f x (tfold f xs)"
 
 text \<open>
 \noindent
 Pattern matching is only available for the argument on which the recursion takes
 place. Fortunately, it is easy to generate pattern-maching equations using the
 @{command simps_of_case} command provided by the theory
 \<^file>\<open>~~/src/HOL/Library/Simps_Case_Conv.thy\<close>.
 \<close>
 
     simps_of_case at_simps_alt: at.simps
 
 text \<open>
 This generates the lemma collection @{thm [source] at_simps_alt}:
 %
 \[@{thm at_simps_alt(1)[no_vars]}
   \qquad @{thm at_simps_alt(2)[no_vars]}\]
 %
 The next example is defined using \keyw{fun} to escape the syntactic
 restrictions imposed on primitively recursive functions:
 \<close>
 
     fun at_least_two :: "nat \<Rightarrow> bool" where
       "at_least_two (Succ (Succ _)) \<longleftrightarrow> True"
     | "at_least_two _ \<longleftrightarrow> False"
 
 
 subsubsection \<open>Mutual Recursion
   \label{sssec:primrec-mutual-recursion}\<close>
 
 text \<open>
 The syntax for mutually recursive functions over mutually recursive datatypes
 is straightforward:
 \<close>
 
     primrec
       nat_of_even_nat :: "even_nat \<Rightarrow> nat" and
       nat_of_odd_nat :: "odd_nat \<Rightarrow> nat"
     where
       "nat_of_even_nat Even_Zero = Zero"
     | "nat_of_even_nat (Even_Succ n) = Succ (nat_of_odd_nat n)"
     | "nat_of_odd_nat (Odd_Succ n) = Succ (nat_of_even_nat n)"
 
 text \<open>\blankline\<close>
 
     primrec
       eval\<^sub>e :: "('a \<Rightarrow> int) \<Rightarrow> ('b \<Rightarrow> int) \<Rightarrow> ('a, 'b) exp \<Rightarrow> int" and
       eval\<^sub>t :: "('a \<Rightarrow> int) \<Rightarrow> ('b \<Rightarrow> int) \<Rightarrow> ('a, 'b) trm \<Rightarrow> int" and
       eval\<^sub>f :: "('a \<Rightarrow> int) \<Rightarrow> ('b \<Rightarrow> int) \<Rightarrow> ('a, 'b) fct \<Rightarrow> int"
     where
       "eval\<^sub>e \<gamma> \<xi> (Term t) = eval\<^sub>t \<gamma> \<xi> t"
     | "eval\<^sub>e \<gamma> \<xi> (Sum t e) = eval\<^sub>t \<gamma> \<xi> t + eval\<^sub>e \<gamma> \<xi> e"
     | "eval\<^sub>t \<gamma> \<xi> (Factor f) = eval\<^sub>f \<gamma> \<xi> f"
     | "eval\<^sub>t \<gamma> \<xi> (Prod f t) = eval\<^sub>f \<gamma> \<xi> f + eval\<^sub>t \<gamma> \<xi> t"
     | "eval\<^sub>f \<gamma> _ (Const a) = \<gamma> a"
     | "eval\<^sub>f _ \<xi> (Var b) = \<xi> b"
     | "eval\<^sub>f \<gamma> \<xi> (Expr e) = eval\<^sub>e \<gamma> \<xi> e"
 
 text \<open>
 \noindent
 Mutual recursion is possible within a single type, using \keyw{fun}:
 \<close>
 
     fun
       even :: "nat \<Rightarrow> bool" and
       odd :: "nat \<Rightarrow> bool"
     where
       "even Zero = True"
     | "even (Succ n) = odd n"
     | "odd Zero = False"
     | "odd (Succ n) = even n"
 
 
 subsubsection \<open>Nested Recursion
   \label{sssec:primrec-nested-recursion}\<close>
 
 text \<open>
 In a departure from the old datatype package, nested recursion is normally
 handled via the map functions of the nesting type constructors. For example,
 recursive calls are lifted to lists using \<^const>\<open>map\<close>:
 \<close>
 
 (*<*)
     datatype 'a tree\<^sub>f\<^sub>f = Node\<^sub>f\<^sub>f (lbl\<^sub>f\<^sub>f: 'a) (sub\<^sub>f\<^sub>f: "'a tree\<^sub>f\<^sub>f list")
 (*>*)
     primrec at\<^sub>f\<^sub>f :: "'a tree\<^sub>f\<^sub>f \<Rightarrow> nat list \<Rightarrow> 'a" where
       "at\<^sub>f\<^sub>f (Node\<^sub>f\<^sub>f a ts) js =
          (case js of
             [] \<Rightarrow> a
           | j # js' \<Rightarrow> at (map (\<lambda>t. at\<^sub>f\<^sub>f t js') ts) j)"
 
 text \<open>
 \noindent
 The next example features recursion through the \<open>option\<close> type. Although
 \<open>option\<close> is not a new-style datatype, it is registered as a BNF with the
 map function \<^const>\<open>map_option\<close>:
 \<close>
 
     primrec (*<*)(in early) (*>*)sum_btree :: "('a::{zero,plus}) btree \<Rightarrow> 'a" where
       "sum_btree (BNode a lt rt) =
          a + the_default 0 (map_option sum_btree lt) +
            the_default 0 (map_option sum_btree rt)"
 
 text \<open>
 \noindent
 The same principle applies for arbitrary type constructors through which
 recursion is possible. Notably, the map function for the function type
 (\<open>\<Rightarrow>\<close>) is simply composition (\<open>(\<circ>)\<close>):
 \<close>
 
     primrec (*<*)(in early) (*>*)relabel_ft :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a ftree \<Rightarrow> 'a ftree" where
       "relabel_ft f (FTLeaf x) = FTLeaf (f x)"
     | "relabel_ft f (FTNode g) = FTNode (relabel_ft f \<circ> g)"
 
 text \<open>
 \noindent
 For convenience, recursion through functions can also be expressed using
 $\lambda$-abstractions and function application rather than through composition.
 For example:
 \<close>
 
     primrec relabel_ft :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a ftree \<Rightarrow> 'a ftree" where
       "relabel_ft f (FTLeaf x) = FTLeaf (f x)"
     | "relabel_ft f (FTNode g) = FTNode (\<lambda>x. relabel_ft f (g x))"
 
 text \<open>\blankline\<close>
 
     primrec (nonexhaustive) subtree_ft :: "'a \<Rightarrow> 'a ftree \<Rightarrow> 'a ftree" where
       "subtree_ft x (FTNode g) = g x"
 
 text \<open>
 \noindent
 For recursion through curried $n$-ary functions, $n$ applications of
 \<^term>\<open>(\<circ>)\<close> are necessary. The examples below illustrate the case where
 $n = 2$:
 \<close>
 
     datatype 'a ftree2 = FTLeaf2 'a | FTNode2 "'a \<Rightarrow> 'a \<Rightarrow> 'a ftree2"
 
 text \<open>\blankline\<close>
 
     primrec (*<*)(in early) (*>*)relabel_ft2 :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a ftree2 \<Rightarrow> 'a ftree2" where
       "relabel_ft2 f (FTLeaf2 x) = FTLeaf2 (f x)"
     | "relabel_ft2 f (FTNode2 g) = FTNode2 ((\<circ>) ((\<circ>) (relabel_ft2 f)) g)"
 
 text \<open>\blankline\<close>
 
     primrec relabel_ft2 :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a ftree2 \<Rightarrow> 'a ftree2" where
       "relabel_ft2 f (FTLeaf2 x) = FTLeaf2 (f x)"
     | "relabel_ft2 f (FTNode2 g) = FTNode2 (\<lambda>x y. relabel_ft2 f (g x y))"
 
 text \<open>\blankline\<close>
 
     primrec (nonexhaustive) subtree_ft2 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a ftree2 \<Rightarrow> 'a ftree2" where
       "subtree_ft2 x y (FTNode2 g) = g x y"
 
 text \<open>
 For any datatype featuring nesting, the predicator can be used instead of the
 map function, typically when defining predicates. For example:
 \<close>
 
     primrec increasing_tree :: "int \<Rightarrow> int tree\<^sub>f\<^sub>f \<Rightarrow> bool" where
       "increasing_tree m (Node\<^sub>f\<^sub>f n ts) \<longleftrightarrow>
        n \<ge> m \<and> list_all (increasing_tree (n + 1)) ts"
 
 
 subsubsection \<open>Nested-as-Mutual Recursion
   \label{sssec:primrec-nested-as-mutual-recursion}\<close>
 
 (*<*)
     locale n2m
     begin
 (*>*)
 
 text \<open>
 For compatibility with the old package, but also because it is sometimes
 convenient in its own right, it is possible to treat nested recursive datatypes
 as mutually recursive ones if the recursion takes place though new-style
 datatypes. For example:
 \<close>
 
     primrec (nonexhaustive)
       at\<^sub>f\<^sub>f :: "'a tree\<^sub>f\<^sub>f \<Rightarrow> nat list \<Rightarrow> 'a" and
       ats\<^sub>f\<^sub>f :: "'a tree\<^sub>f\<^sub>f list \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> 'a"
     where
       "at\<^sub>f\<^sub>f (Node\<^sub>f\<^sub>f a ts) js =
          (case js of
             [] \<Rightarrow> a
           | j # js' \<Rightarrow> ats\<^sub>f\<^sub>f ts j js')"
     | "ats\<^sub>f\<^sub>f (t # ts) j =
          (case j of
             Zero \<Rightarrow> at\<^sub>f\<^sub>f t
           | Succ j' \<Rightarrow> ats\<^sub>f\<^sub>f ts j')"
 
 text \<open>
 \noindent
 Appropriate induction rules are generated as
 @{thm [source] at\<^sub>f\<^sub>f.induct},
 @{thm [source] ats\<^sub>f\<^sub>f.induct}, and
 @{thm [source] at\<^sub>f\<^sub>f_ats\<^sub>f\<^sub>f.induct}. The
 induction rules and the underlying recursors are generated dynamically
 and are kept in a cache to speed up subsequent definitions.
 
 Here is a second example:
 \<close>
 
     primrec
       sum_btree :: "('a::{zero,plus}) btree \<Rightarrow> 'a" and
       sum_btree_option :: "'a btree option \<Rightarrow> 'a"
     where
       "sum_btree (BNode a lt rt) =
          a + sum_btree_option lt + sum_btree_option rt"
     | "sum_btree_option None = 0"
     | "sum_btree_option (Some t) = sum_btree t"
 
 text \<open>
 %  * can pretend a nested type is mutually recursive (if purely inductive)
 %  * avoids the higher-order map
 %  * e.g.
 
 %  * this can always be avoided;
 %     * e.g. in our previous example, we first mapped the recursive
 %       calls, then we used a generic at function to retrieve the result
 %
 %  * there's no hard-and-fast rule of when to use one or the other,
 %    just like there's no rule when to use fold and when to use
 %    primrec
 %
 %  * higher-order approach, considering nesting as nesting, is more
 %    compositional -- e.g. we saw how we could reuse an existing polymorphic
 %    at or the_default, whereas \<^const>\<open>ats\<^sub>f\<^sub>f\<close> is much more specific
 %
 %  * but:
 %     * is perhaps less intuitive, because it requires higher-order thinking
 %     * may seem inefficient, and indeed with the code generator the
 %       mutually recursive version might be nicer
 %     * is somewhat indirect -- must apply a map first, then compute a result
 %       (cannot mix)
 %     * the auxiliary functions like \<^const>\<open>ats\<^sub>f\<^sub>f\<close> are sometimes useful in own right
 %
 %  * impact on automation unclear
 %
 \<close>
 (*<*)
     end
 (*>*)
 
 
 subsection \<open>Command Syntax
   \label{ssec:primrec-command-syntax}\<close>
 
 subsubsection \<open>\keyw{primrec}
   \label{sssec:primrec}\<close>
 
 text \<open>
 \begin{matharray}{rcl}
   @{command_def "primrec"} & : & \<open>local_theory \<rightarrow> local_theory\<close>
 \end{matharray}
 
 \<^rail>\<open>
   @@{command primrec} target? @{syntax pr_options}? fixes \<newline>
   @'where' (@{syntax pr_equation} + '|')
   ;
   @{syntax_def pr_options}: '(' ((@{syntax plugins} | 'nonexhaustive' | 'transfer') + ',') ')'
   ;
   @{syntax_def pr_equation}: thmdecl? prop
 \<close>
 
 \medskip
 
 \noindent
 The @{command primrec} command introduces a set of mutually recursive functions
 over datatypes.
 
 The syntactic entity \synt{target} can be used to specify a local context,
 \synt{fixes} denotes a list of names with optional type signatures,
 \synt{thmdecl} denotes an optional name for the formula that follows, and
 \synt{prop} denotes a HOL proposition @{cite "isabelle-isar-ref"}.
 
 The optional target is optionally followed by a combination of the following
 options:
 
 \begin{itemize}
 \setlength{\itemsep}{0pt}
 
 \item
 The \<open>plugins\<close> option indicates which plugins should be enabled
 (\<open>only\<close>) or disabled (\<open>del\<close>). By default, all plugins are enabled.
 
 \item
 The \<open>nonexhaustive\<close> option indicates that the functions are not
 necessarily specified for all constructors. It can be used to suppress the
 warning that is normally emitted when some constructors are missing.
 
 \item
 The \<open>transfer\<close> option indicates that an unconditional transfer rule
 should be generated and proved \<open>by transfer_prover\<close>. The
 \<open>[transfer_rule]\<close> attribute is set on the generated theorem.
 \end{itemize}
 
 %%% TODO: elaborate on format of the equations
 %%% TODO: elaborate on mutual and nested-to-mutual
 \<close>
 
 
 subsection \<open>Generated Theorems
   \label{ssec:primrec-generated-theorems}\<close>
 
 (*<*)
     context early
     begin
 (*>*)
 
 text \<open>
 The @{command primrec} command generates the following properties (listed
 for \<^const>\<open>tfold\<close>):
 
 \begin{indentblock}
 \begin{description}
 
 \item[\<open>f.\<close>\hthm{simps} \<open>[simp, code]\<close>\rm:] ~ \\
 @{thm tfold.simps(1)[no_vars]} \\
 @{thm tfold.simps(2)[no_vars]} \\
 The \<open>[code]\<close> attribute is set by the \<open>code\<close> plugin
 (Section~\ref{ssec:code-generator}).
 
 \item[\<open>f.\<close>\hthm{transfer} \<open>[transfer_rule]\<close>\rm:] ~ \\
 @{thm tfold.transfer[no_vars]} \\
 This theorem is generated by the \<open>transfer\<close> plugin
 (Section~\ref{ssec:transfer}) for functions declared with the \<open>transfer\<close>
 option enabled.
 
 \item[\<open>f.\<close>\hthm{induct} \<open>[case_names C\<^sub>1 \<dots> C\<^sub>n]\<close>\rm:] ~ \\
 This induction rule is generated for nested-as-mutual recursive functions
 (Section~\ref{sssec:primrec-nested-as-mutual-recursion}).
 
 \item[\<open>f\<^sub>1_\<dots>_f\<^sub>m.\<close>\hthm{induct} \<open>[case_names C\<^sub>1 \<dots> C\<^sub>n]\<close>\rm:] ~ \\
 This induction rule is generated for nested-as-mutual recursive functions
 (Section~\ref{sssec:primrec-nested-as-mutual-recursion}). Given $m > 1$ mutually
 recursive functions, this rule can be used to prove $m$ properties
 simultaneously.
 
 \end{description}
 \end{indentblock}
 \<close>
 
 (*<*)
     end
 (*>*)
 
 
 subsection \<open>Recursive Default Values for Selectors
   \label{ssec:primrec-recursive-default-values-for-selectors}\<close>
 
 text \<open>
 A datatype selector \<open>un_D\<close> can have a default value for each constructor
 on which it is not otherwise specified. Occasionally, it is useful to have the
 default value be defined recursively. This leads to a chicken-and-egg
 situation, because the datatype is not introduced yet at the moment when the
 selectors are introduced. Of course, we can always define the selectors
 manually afterward, but we then have to state and prove all the characteristic
 theorems ourselves instead of letting the package do it.
 
 Fortunately, there is a workaround that relies on overloading to relieve us
 from the tedium of manual derivations:
 
 \begin{enumerate}
 \setlength{\itemsep}{0pt}
 
 \item
 Introduce a fully unspecified constant \<open>un_D\<^sub>0 :: 'a\<close> using
 @{command consts}.
 
 \item
 Define the datatype, specifying \<open>un_D\<^sub>0\<close> as the selector's default
 value.
 
 \item
 Define the behavior of \<open>un_D\<^sub>0\<close> on values of the newly introduced
 datatype using the \keyw{overloading} command.
 
 \item
 Derive the desired equation on \<open>un_D\<close> from the characteristic equations
 for \<open>un_D\<^sub>0\<close>.
 \end{enumerate}
 
 \noindent
 The following example illustrates this procedure:
 \<close>
 
 (*<*)
     hide_const termi
 (*>*)
     consts termi\<^sub>0 :: 'a
 
 text \<open>\blankline\<close>
 
     datatype ('a, 'b) tlist =
       TNil (termi: 'b)
     | TCons (thd: 'a) (ttl: "('a, 'b) tlist")
     where
       "ttl (TNil y) = TNil y"
     | "termi (TCons _ xs) = termi\<^sub>0 xs"
 
 text \<open>\blankline\<close>
 
     overloading
       termi\<^sub>0 \<equiv> "termi\<^sub>0 :: ('a, 'b) tlist \<Rightarrow> 'b"
     begin
     primrec termi\<^sub>0 :: "('a, 'b) tlist \<Rightarrow> 'b" where
       "termi\<^sub>0 (TNil y) = y"
     | "termi\<^sub>0 (TCons x xs) = termi\<^sub>0 xs"
     end
 
 text \<open>\blankline\<close>
 
     lemma termi_TCons[simp]: "termi (TCons x xs) = termi xs"
       by (cases xs) auto
 
 
 subsection \<open>Compatibility Issues
   \label{ssec:primrec-compatibility-issues}\<close>
 
 text \<open>
 The command @{command primrec}'s behavior on new-style datatypes has been
 designed to be highly compatible with that for old, pre-Isabelle2015 datatypes,
 to ease migration. There is nonetheless at least one incompatibility that may
 arise when porting to the new package:
 
 \begin{itemize}
 \setlength{\itemsep}{0pt}
 
 \item \emph{Some theorems have different names.}
 For $m > 1$ mutually recursive functions,
 \<open>f\<^sub>1_\<dots>_f\<^sub>m.simps\<close> has been broken down into separate
 subcollections \<open>f\<^sub>i.simps\<close>.
 \end{itemize}
 \<close>
 
 
 section \<open>Defining Codatatypes
   \label{sec:defining-codatatypes}\<close>
 
 text \<open>
 Codatatypes can be specified using the @{command codatatype} command. The
 command is first illustrated through concrete examples featuring different
 flavors of corecursion. More examples can be found in the directory
 \<^dir>\<open>~~/src/HOL/Datatype_Examples\<close>. The \emph{Archive of Formal Proofs} also
 includes some useful codatatypes, notably for lazy lists @{cite
 "lochbihler-2010"}.
 \<close>
 
 
 subsection \<open>Introductory Examples
   \label{ssec:codatatype-introductory-examples}\<close>
 
 subsubsection \<open>Simple Corecursion
   \label{sssec:codatatype-simple-corecursion}\<close>
 
 text \<open>
 Non-corecursive codatatypes coincide with the corresponding datatypes, so they
 are rarely used in practice. \emph{Corecursive codatatypes} have the same syntax
 as recursive datatypes, except for the command name. For example, here is the
 definition of lazy lists:
 \<close>
 
     codatatype (lset: 'a) llist =
       lnull: LNil
     | LCons (lhd: 'a) (ltl: "'a llist")
     for
       map: lmap
       rel: llist_all2
       pred: llist_all
     where
       "ltl LNil = LNil"
 
 text \<open>
 \noindent
 Lazy lists can be infinite, such as \<open>LCons 0 (LCons 0 (\<dots>))\<close> and
 \<open>LCons 0 (LCons 1 (LCons 2 (\<dots>)))\<close>. Here is a related type, that of
 infinite streams:
 \<close>
 
     codatatype (sset: 'a) stream =
       SCons (shd: 'a) (stl: "'a stream")
     for
       map: smap
       rel: stream_all2
 
 text \<open>
 \noindent
 Another interesting type that can
 be defined as a codatatype is that of the extended natural numbers:
 \<close>
 
     codatatype enat = EZero | ESucc enat
 
 text \<open>
 \noindent
 This type has exactly one infinite element, \<open>ESucc (ESucc (ESucc (\<dots>)))\<close>,
 that represents $\infty$. In addition, it has finite values of the form
 \<open>ESucc (\<dots> (ESucc EZero)\<dots>)\<close>.
 
 Here is an example with many constructors:
 \<close>
 
     codatatype 'a process =
       Fail
     | Skip (cont: "'a process")
     | Action (prefix: 'a) (cont: "'a process")
     | Choice (left: "'a process") (right: "'a process")
 
 text \<open>
 \noindent
 Notice that the \<^const>\<open>cont\<close> selector is associated with both \<^const>\<open>Skip\<close>
 and \<^const>\<open>Action\<close>.
 \<close>
 
 
 subsubsection \<open>Mutual Corecursion
   \label{sssec:codatatype-mutual-corecursion}\<close>
 
 text \<open>
 \noindent
 The example below introduces a pair of \emph{mutually corecursive} types:
 \<close>
 
     codatatype even_enat = Even_EZero | Even_ESucc odd_enat
     and odd_enat = Odd_ESucc even_enat
 
 
 subsubsection \<open>Nested Corecursion
   \label{sssec:codatatype-nested-corecursion}\<close>
 
 text \<open>
 \noindent
 The next examples feature \emph{nested corecursion}:
 \<close>
 
     codatatype 'a tree\<^sub>i\<^sub>i = Node\<^sub>i\<^sub>i (lbl\<^sub>i\<^sub>i: 'a) (sub\<^sub>i\<^sub>i: "'a tree\<^sub>i\<^sub>i llist")
 
 text \<open>\blankline\<close>
 
     codatatype 'a tree\<^sub>i\<^sub>s = Node\<^sub>i\<^sub>s (lbl\<^sub>i\<^sub>s: 'a) (sub\<^sub>i\<^sub>s: "'a tree\<^sub>i\<^sub>s fset")
 
 text \<open>\blankline\<close>
 
     codatatype 'a sm = SM (accept: bool) (trans: "'a \<Rightarrow> 'a sm")
 
 
 subsection \<open>Command Syntax
   \label{ssec:codatatype-command-syntax}\<close>
 
 subsubsection \<open>\keyw{codatatype}
   \label{sssec:codatatype}\<close>
 
 text \<open>
 \begin{matharray}{rcl}
   @{command_def "codatatype"} & : & \<open>local_theory \<rightarrow> local_theory\<close>
 \end{matharray}
 
 \<^rail>\<open>
   @@{command codatatype} target? @{syntax dt_options}? @{syntax dt_spec}
 \<close>
 
 \medskip
 
 \noindent
 Definitions of codatatypes have almost exactly the same syntax as for datatypes
 (Section~\ref{ssec:datatype-command-syntax}). The \<open>discs_sels\<close> option
 is superfluous because discriminators and selectors are always generated for
 codatatypes.
 \<close>
 
 
 subsection \<open>Generated Constants
   \label{ssec:codatatype-generated-constants}\<close>
 
 text \<open>
 Given a codatatype \<open>('a\<^sub>1, \<dots>, 'a\<^sub>m) t\<close>
 with $m > 0$ live type variables and $n$ constructors \<open>t.C\<^sub>1\<close>,
 \ldots, \<open>t.C\<^sub>n\<close>, the same auxiliary constants are generated as for
 datatypes (Section~\ref{ssec:datatype-generated-constants}), except that the
 recursor is replaced by a dual concept:
 
 \medskip
 
 \begin{tabular}{@ {}ll@ {}}
 Corecursor: &
   \<open>t.corec_t\<close>
 \end{tabular}
 \<close>
 
 
 subsection \<open>Generated Theorems
   \label{ssec:codatatype-generated-theorems}\<close>
 
 text \<open>
 The characteristic theorems generated by @{command codatatype} are grouped in
 three broad categories:
 
 \begin{itemize}
 \setlength{\itemsep}{0pt}
 
 \item The \emph{free constructor theorems}
 (Section~\ref{sssec:free-constructor-theorems}) are properties of the
 constructors and destructors that can be derived for any freely generated type.
 
 \item The \emph{functorial theorems}
 (Section~\ref{sssec:functorial-theorems}) are properties of datatypes related to
 their BNF nature.
 
 \item The \emph{coinductive theorems} (Section~\ref{sssec:coinductive-theorems})
 are properties of datatypes related to their coinductive nature.
 \end{itemize}
 
 \noindent
 The first two categories are exactly as for datatypes.
 \<close>
 
 
 subsubsection \<open>Coinductive Theorems
   \label{sssec:coinductive-theorems}\<close>
 
 text \<open>
 The coinductive theorems are listed below for \<^typ>\<open>'a llist\<close>:
 
 \begin{indentblock}
 \begin{description}
 
 \item[\begin{tabular}{@ {}l@ {}}
   \<open>t.\<close>\hthm{coinduct} \<open>[consumes m, case_names t\<^sub>1 \<dots> t\<^sub>m,\<close> \\
   \phantom{\<open>t.\<close>\hthm{coinduct} \<open>[\<close>}\<open>case_conclusion D\<^sub>1 \<dots>
   D\<^sub>n, coinduct t]\<close>\rm:
 \end{tabular}] ~ \\
 @{thm llist.coinduct[no_vars]}
 
 \item[\begin{tabular}{@ {}l@ {}}
   \<open>t.\<close>\hthm{coinduct_strong} \<open>[consumes m, case_names t\<^sub>1 \<dots> t\<^sub>m,\<close> \\
   \phantom{\<open>t.\<close>\hthm{coinduct_strong} \<open>[\<close>}\<open>case_conclusion D\<^sub>1 \<dots> D\<^sub>n]\<close>\rm:
 \end{tabular}] ~ \\
 @{thm llist.coinduct_strong[no_vars]}
 
 \item[\begin{tabular}{@ {}l@ {}}
   \<open>t.\<close>\hthm{rel_coinduct} \<open>[consumes m, case_names t\<^sub>1 \<dots> t\<^sub>m,\<close> \\
   \phantom{\<open>t.\<close>\hthm{rel_coinduct} \<open>[\<close>}\<open>case_conclusion D\<^sub>1 \<dots>
   D\<^sub>n, coinduct pred]\<close>\rm:
 \end{tabular}] ~ \\
 @{thm llist.rel_coinduct[no_vars]}
 
 \item[\begin{tabular}{@ {}l@ {}}
   \<open>t\<^sub>1_\<dots>_t\<^sub>m.\<close>\hthm{coinduct} \<open>[case_names t\<^sub>1 \<dots> t\<^sub>m, case_conclusion D\<^sub>1 \<dots> D\<^sub>n]\<close> \\
   \<open>t\<^sub>1_\<dots>_t\<^sub>m.\<close>\hthm{coinduct_strong} \<open>[case_names t\<^sub>1 \<dots> t\<^sub>m,\<close> \\
   \phantom{\<open>t\<^sub>1_\<dots>_t\<^sub>m.\<close>\hthm{coinduct_strong} \<open>[\<close>}\<open>case_conclusion D\<^sub>1 \<dots> D\<^sub>n]\<close>\rm: \\
   \<open>t\<^sub>1_\<dots>_t\<^sub>m.\<close>\hthm{rel_coinduct} \<open>[case_names t\<^sub>1 \<dots> t\<^sub>m,\<close> \\
   \phantom{\<open>t\<^sub>1_\<dots>_t\<^sub>m.\<close>\hthm{rel_coinduct} \<open>[\<close>}\<open>case_conclusion D\<^sub>1 \<dots> D\<^sub>n]\<close>\rm: \\
 \end{tabular}] ~ \\
 Given $m > 1$ mutually corecursive codatatypes, these coinduction rules can be
 used to prove $m$ properties simultaneously.
 
 \item[\begin{tabular}{@ {}l@ {}}
   \<open>t\<^sub>1_\<dots>_t\<^sub>m.\<close>\hthm{set_induct} \<open>[case_names C\<^sub>1 \<dots> C\<^sub>n,\<close> \\
   \phantom{\<open>t\<^sub>1_\<dots>_t\<^sub>m.\<close>\hthm{set_induct} \<open>[\<close>}\<open>induct set: set\<^sub>j_t\<^sub>1, \<dots>, induct set: set\<^sub>j_t\<^sub>m]\<close>\rm: \\
 \end{tabular}] ~ \\
 @{thm llist.set_induct[no_vars]} \\
 If $m = 1$, the attribute \<open>[consumes 1]\<close> is generated as well.
 
 \item[\<open>t.\<close>\hthm{corec}\rm:] ~ \\
 @{thm llist.corec(1)[no_vars]} \\
 @{thm llist.corec(2)[no_vars]}
 
 \item[\<open>t.\<close>\hthm{corec_code} \<open>[code]\<close>\rm:] ~ \\
 @{thm llist.corec_code[no_vars]} \\
 The \<open>[code]\<close> attribute is set by the \<open>code\<close> plugin
 (Section~\ref{ssec:code-generator}).
 
 \item[\<open>t.\<close>\hthm{corec_disc}\rm:] ~ \\
 @{thm llist.corec_disc(1)[no_vars]} \\
 @{thm llist.corec_disc(2)[no_vars]}
 
 \item[\<open>t.\<close>\hthm{corec_disc_iff} \<open>[simp]\<close>\rm:] ~ \\
 @{thm llist.corec_disc_iff(1)[no_vars]} \\
 @{thm llist.corec_disc_iff(2)[no_vars]}
 
 \item[\<open>t.\<close>\hthm{corec_sel} \<open>[simp]\<close>\rm:] ~ \\
 @{thm llist.corec_sel(1)[no_vars]} \\
 @{thm llist.corec_sel(2)[no_vars]}
 
 \item[\<open>t.\<close>\hthm{map_o_corec}\rm:] ~ \\
 @{thm llist.map_o_corec[no_vars]}
 
 \item[\<open>t.\<close>\hthm{corec_transfer} \<open>[transfer_rule]\<close>\rm:] ~ \\
 @{thm llist.corec_transfer[no_vars]} \\
 The \<open>[transfer_rule]\<close> attribute is set by the \<open>transfer\<close> plugin
 (Section~\ref{ssec:transfer}) for type constructors with no dead type arguments.
 
 \end{description}
 \end{indentblock}
 
 \noindent
 For convenience, @{command codatatype} also provides the following collection:
 
 \begin{indentblock}
 \begin{description}
 
 \item[\<open>t.\<close>\hthm{simps}] = \<open>t.inject\<close> \<open>t.distinct\<close> \<open>t.case\<close> \<open>t.corec_disc_iff\<close> \<open>t.corec_sel\<close> \\
 \<open>t.map\<close> \<open>t.rel_inject\<close> \<open>t.rel_distinct\<close> \<open>t.set\<close>
 
 \end{description}
 \end{indentblock}
 \<close>
 
 
 subsection \<open>Antiquotation
   \label{ssec:codatatype-antiquotation}\<close>
 
 subsubsection \<open>\textit{codatatype}
   \label{sssec:codatatype-codatatype}\<close>
 
 text \<open>
 The \textit{codatatype} antiquotation, written
 \texttt{\char`\\\char`<\char`^}\verb|codatatype>|\guilsinglleft\textit{t}\guilsinglright{}
 or \texttt{@}\verb|{codatatype| \textit{t}\verb|}|, where \textit{t} is a type
 name, expands to \LaTeX{} code for the definition of the codatatype, with each
 constructor listed with its argument types. For example, if \textit{t} is
 @{type llist}:
 
 \begin{quote}
 \<^codatatype>\<open>llist\<close>
 \end{quote}
 \<close>
 
 
 section \<open>Defining Primitively Corecursive Functions
   \label{sec:defining-primitively-corecursive-functions}\<close>
 
 text \<open>
 Corecursive functions can be specified using the @{command primcorec} and
 \keyw{prim\-corec\-ursive} commands, which support primitive corecursion.
 Other approaches include the more general \keyw{partial_function} command, the
 \keyw{corec} and \keyw{corecursive} commands, and techniques based on domains
 and topologies @{cite "lochbihler-hoelzl-2014"}. In this tutorial, the focus is
 on @{command primcorec} and @{command primcorecursive}; \keyw{corec} and
 \keyw{corecursive} are described in a separate tutorial
 @{cite "isabelle-corec"}. More examples can be found in the directories
 \<^dir>\<open>~~/src/HOL/Datatype_Examples\<close> and \<^dir>\<open>~~/src/HOL/Corec_Examples\<close>.
 
 Whereas recursive functions consume datatypes one constructor at a time,
 corecursive functions construct codatatypes one constructor at a time.
 Partly reflecting a lack of agreement among proponents of coalgebraic methods,
 Isabelle supports three competing syntaxes for specifying a function $f$:
 
 \begin{itemize}
 \setlength{\itemsep}{0pt}
 
 \abovedisplayskip=.5\abovedisplayskip
 \belowdisplayskip=.5\belowdisplayskip
 
 \item The \emph{destructor view} specifies $f$ by implications of the form
 \[\<open>\<dots> \<Longrightarrow> is_C\<^sub>j (f x\<^sub>1 \<dots> x\<^sub>n)\<close>\] and
 equations of the form
 \[\<open>un_C\<^sub>ji (f x\<^sub>1 \<dots> x\<^sub>n) = \<dots>\<close>\]
 This style is popular in the coalgebraic literature.
 
 \item The \emph{constructor view} specifies $f$ by equations of the form
 \[\<open>\<dots> \<Longrightarrow> f x\<^sub>1 \<dots> x\<^sub>n = C\<^sub>j \<dots>\<close>\]
 This style is often more concise than the previous one.
 
 \item The \emph{code view} specifies $f$ by a single equation of the form
 \[\<open>f x\<^sub>1 \<dots> x\<^sub>n = \<dots>\<close>\]
 with restrictions on the format of the right-hand side. Lazy functional
 programming languages such as Haskell support a generalized version of this
 style.
 \end{itemize}
 
 All three styles are available as input syntax. Whichever syntax is chosen,
 characteristic theorems for all three styles are generated.
 
 %%% TODO: partial_function? E.g. for defining tail recursive function on lazy
 %%% lists (cf. terminal0 in TLList.thy)
 \<close>
 
 
 subsection \<open>Introductory Examples
   \label{ssec:primcorec-introductory-examples}\<close>
 
 text \<open>
 Primitive corecursion is illustrated through concrete examples based on the
 codatatypes defined in Section~\ref{ssec:codatatype-introductory-examples}. More
 examples can be found in the directory \<^dir>\<open>~~/src/HOL/Datatype_Examples\<close>.
 The code view is favored in the examples below. Sections
 \ref{ssec:primrec-constructor-view} and \ref{ssec:primrec-destructor-view}
 present the same examples expressed using the constructor and destructor views.
 \<close>
 
 
 subsubsection \<open>Simple Corecursion
   \label{sssec:primcorec-simple-corecursion}\<close>
 
 text \<open>
 Following the code view, corecursive calls are allowed on the right-hand side as
 long as they occur under a constructor, which itself appears either directly to
 the right of the equal sign or in a conditional expression:
 \<close>
 
     primcorec (*<*)(transfer) (*>*)literate :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a llist" where
       "literate g x = LCons x (literate g (g x))"
 
 text \<open>\blankline\<close>
 
     primcorec siterate :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a stream" where
       "siterate g x = SCons x (siterate g (g x))"
 
 text \<open>
 \noindent
 The constructor ensures that progress is made---i.e., the function is
 \emph{productive}. The above functions compute the infinite lazy list or stream
 \<open>[x, g x, g (g x), \<dots>]\<close>. Productivity guarantees that prefixes
 \<open>[x, g x, g (g x), \<dots>, (g ^^ k) x]\<close> of arbitrary finite length
 \<open>k\<close> can be computed by unfolding the code equation a finite number of
 times.
 
 Corecursive functions construct codatatype values, but nothing prevents them
 from also consuming such values. The following function drops every second
 element in a stream:
 \<close>
 
     primcorec every_snd :: "'a stream \<Rightarrow> 'a stream" where
       "every_snd s = SCons (shd s) (stl (stl s))"
 
 text \<open>
 \noindent
 Constructs such as \<open>let\<close>--\<open>in\<close>, \<open>if\<close>--\<open>then\<close>--\<open>else\<close>, and \<open>case\<close>--\<open>of\<close> may
 appear around constructors that guard corecursive calls:
 \<close>
 
     primcorec lapp :: "'a llist \<Rightarrow> 'a llist \<Rightarrow> 'a llist" where
       "lapp xs ys =
          (case xs of
             LNil \<Rightarrow> ys
           | LCons x xs' \<Rightarrow> LCons x (lapp xs' ys))"
 
 text \<open>
 \noindent
 For technical reasons, \<open>case\<close>--\<open>of\<close> is only supported for
 case distinctions on (co)datatypes that provide discriminators and selectors.
 
 Pattern matching is not supported by @{command primcorec}. Fortunately, it is
 easy to generate pattern-maching equations using the @{command simps_of_case}
 command provided by the theory \<^file>\<open>~~/src/HOL/Library/Simps_Case_Conv.thy\<close>.
 \<close>
 
     simps_of_case lapp_simps: lapp.code
 
 text \<open>
 This generates the lemma collection @{thm [source] lapp_simps}:
 %
 \begin{gather*}
   @{thm lapp_simps(1)[no_vars]} \\
   @{thm lapp_simps(2)[no_vars]}
 \end{gather*}
 %
 Corecursion is useful to specify not only functions but also infinite objects:
 \<close>
 
     primcorec infty :: enat where
       "infty = ESucc infty"
 
 text \<open>
 \noindent
 The example below constructs a pseudorandom process value. It takes a stream of
 actions (\<open>s\<close>), a pseudorandom function generator (\<open>f\<close>), and a
 pseudorandom seed (\<open>n\<close>):
 \<close>
 
 (*<*)
     context early
     begin
 (*>*)
     primcorec
       random_process :: "'a stream \<Rightarrow> (int \<Rightarrow> int) \<Rightarrow> int \<Rightarrow> 'a process"
     where
       "random_process s f n =
          (if n mod 4 = 0 then
             Fail
           else if n mod 4 = 1 then
             Skip (random_process s f (f n))
           else if n mod 4 = 2 then
             Action (shd s) (random_process (stl s) f (f n))
           else
             Choice (random_process (every_snd s) (f \<circ> f) (f n))
               (random_process (every_snd (stl s)) (f \<circ> f) (f (f n))))"
 (*<*)
     end
 (*>*)
 
 text \<open>
 \noindent
 The main disadvantage of the code view is that the conditions are tested
 sequentially. This is visible in the generated theorems. The constructor and
 destructor views offer nonsequential alternatives.
 \<close>
 
 
 subsubsection \<open>Mutual Corecursion
   \label{sssec:primcorec-mutual-corecursion}\<close>
 
 text \<open>
 The syntax for mutually corecursive functions over mutually corecursive
 datatypes is unsurprising:
 \<close>
 
     primcorec
       even_infty :: even_enat and
       odd_infty :: odd_enat
     where
       "even_infty = Even_ESucc odd_infty"
     | "odd_infty = Odd_ESucc even_infty"
 
 
 subsubsection \<open>Nested Corecursion
   \label{sssec:primcorec-nested-corecursion}\<close>
 
 text \<open>
 The next pair of examples generalize the \<^const>\<open>literate\<close> and \<^const>\<open>siterate\<close>
 functions (Section~\ref{sssec:primcorec-nested-corecursion}) to possibly
 infinite trees in which subnodes are organized either as a lazy list (\<open>tree\<^sub>i\<^sub>i\<close>) or as a finite set (\<open>tree\<^sub>i\<^sub>s\<close>). They rely on the map functions of
 the nesting type constructors to lift the corecursive calls:
 \<close>
 
     primcorec iterate\<^sub>i\<^sub>i :: "('a \<Rightarrow> 'a llist) \<Rightarrow> 'a \<Rightarrow> 'a tree\<^sub>i\<^sub>i" where
       "iterate\<^sub>i\<^sub>i g x = Node\<^sub>i\<^sub>i x (lmap (iterate\<^sub>i\<^sub>i g) (g x))"
 
 text \<open>\blankline\<close>
 
     primcorec iterate\<^sub>i\<^sub>s :: "('a \<Rightarrow> 'a fset) \<Rightarrow> 'a \<Rightarrow> 'a tree\<^sub>i\<^sub>s" where
       "iterate\<^sub>i\<^sub>s g x = Node\<^sub>i\<^sub>s x (fimage (iterate\<^sub>i\<^sub>s g) (g x))"
 
 text \<open>
 \noindent
 Both examples follow the usual format for constructor arguments associated
 with nested recursive occurrences of the datatype. Consider
 \<^const>\<open>iterate\<^sub>i\<^sub>i\<close>. The term \<^term>\<open>g x\<close> constructs an \<^typ>\<open>'a llist\<close>
 value, which is turned into an \<^typ>\<open>'a tree\<^sub>i\<^sub>i llist\<close> value using
 \<^const>\<open>lmap\<close>.
 
 This format may sometimes feel artificial. The following function constructs
 a tree with a single, infinite branch from a stream:
 \<close>
 
     primcorec tree\<^sub>i\<^sub>i_of_stream :: "'a stream \<Rightarrow> 'a tree\<^sub>i\<^sub>i" where
       "tree\<^sub>i\<^sub>i_of_stream s =
          Node\<^sub>i\<^sub>i (shd s) (lmap tree\<^sub>i\<^sub>i_of_stream (LCons (stl s) LNil))"
 
 text \<open>
 \noindent
 A more natural syntax, also supported by Isabelle, is to move corecursive calls
 under constructors:
 \<close>
 
     primcorec (*<*)(in late) (*>*)tree\<^sub>i\<^sub>i_of_stream :: "'a stream \<Rightarrow> 'a tree\<^sub>i\<^sub>i" where
       "tree\<^sub>i\<^sub>i_of_stream s =
          Node\<^sub>i\<^sub>i (shd s) (LCons (tree\<^sub>i\<^sub>i_of_stream (stl s)) LNil)"
 
 text \<open>
 The next example illustrates corecursion through functions, which is a bit
 special. Deterministic finite automata (DFAs) are traditionally defined as
 5-tuples \<open>(Q, \<Sigma>, \<delta>, q\<^sub>0, F)\<close>, where \<open>Q\<close> is a finite set of states,
 \<open>\<Sigma>\<close> is a finite alphabet, \<open>\<delta>\<close> is a transition function, \<open>q\<^sub>0\<close>
 is an initial state, and \<open>F\<close> is a set of final states. The following
 function translates a DFA into a state machine:
 \<close>
 
     primcorec (*<*)(in early) (*>*)sm_of_dfa :: "('q \<Rightarrow> 'a \<Rightarrow> 'q) \<Rightarrow> 'q set \<Rightarrow> 'q \<Rightarrow> 'a sm" where
       "sm_of_dfa \<delta> F q = SM (q \<in> F) (sm_of_dfa \<delta> F \<circ> \<delta> q)"
 
 text \<open>
 \noindent
 The map function for the function type (\<open>\<Rightarrow>\<close>) is composition
 (\<open>(\<circ>)\<close>). For convenience, corecursion through functions can
 also be expressed using $\lambda$-abstractions and function application rather
 than through composition. For example:
 \<close>
 
     primcorec sm_of_dfa :: "('q \<Rightarrow> 'a \<Rightarrow> 'q) \<Rightarrow> 'q set \<Rightarrow> 'q \<Rightarrow> 'a sm" where
       "sm_of_dfa \<delta> F q = SM (q \<in> F) (\<lambda>a. sm_of_dfa \<delta> F (\<delta> q a))"
 
 text \<open>\blankline\<close>
 
     primcorec empty_sm :: "'a sm" where
       "empty_sm = SM False (\<lambda>_. empty_sm)"
 
 text \<open>\blankline\<close>
 
     primcorec not_sm :: "'a sm \<Rightarrow> 'a sm" where
       "not_sm M = SM (\<not> accept M) (\<lambda>a. not_sm (trans M a))"
 
 text \<open>\blankline\<close>
 
     primcorec or_sm :: "'a sm \<Rightarrow> 'a sm \<Rightarrow> 'a sm" where
       "or_sm M N =
          SM (accept M \<or> accept N) (\<lambda>a. or_sm (trans M a) (trans N a))"
 
 text \<open>
 \noindent
 For recursion through curried $n$-ary functions, $n$ applications of
 \<^term>\<open>(\<circ>)\<close> are necessary. The examples below illustrate the case where
 $n = 2$:
 \<close>
 
     codatatype ('a, 'b) sm2 =
       SM2 (accept2: bool) (trans2: "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) sm2")
 
 text \<open>\blankline\<close>
 
     primcorec
       (*<*)(in early) (*>*)sm2_of_dfa :: "('q \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'q) \<Rightarrow> 'q set \<Rightarrow> 'q \<Rightarrow> ('a, 'b) sm2"
     where
       "sm2_of_dfa \<delta> F q = SM2 (q \<in> F) ((\<circ>) ((\<circ>) (sm2_of_dfa \<delta> F)) (\<delta> q))"
 
 text \<open>\blankline\<close>
 
     primcorec
       sm2_of_dfa :: "('q \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'q) \<Rightarrow> 'q set \<Rightarrow> 'q \<Rightarrow> ('a, 'b) sm2"
     where
       "sm2_of_dfa \<delta> F q = SM2 (q \<in> F) (\<lambda>a b. sm2_of_dfa \<delta> F (\<delta> q a b))"
 
 
 subsubsection \<open>Nested-as-Mutual Corecursion
   \label{sssec:primcorec-nested-as-mutual-corecursion}\<close>
 
 text \<open>
 Just as it is possible to recurse over nested recursive datatypes as if they
 were mutually recursive
 (Section~\ref{sssec:primrec-nested-as-mutual-recursion}), it is possible to
 pretend that nested codatatypes are mutually corecursive. For example:
 \<close>
 
 (*<*)
     context late
     begin
 (*>*)
     primcorec
       iterate\<^sub>i\<^sub>i :: "('a \<Rightarrow> 'a llist) \<Rightarrow> 'a \<Rightarrow> 'a tree\<^sub>i\<^sub>i" and
       iterates\<^sub>i\<^sub>i :: "('a \<Rightarrow> 'a llist) \<Rightarrow> 'a llist \<Rightarrow> 'a tree\<^sub>i\<^sub>i llist"
     where
       "iterate\<^sub>i\<^sub>i g x = Node\<^sub>i\<^sub>i x (iterates\<^sub>i\<^sub>i g (g x))"
     | "iterates\<^sub>i\<^sub>i g xs =
          (case xs of
             LNil \<Rightarrow> LNil
           | LCons x xs' \<Rightarrow> LCons (iterate\<^sub>i\<^sub>i g x) (iterates\<^sub>i\<^sub>i g xs'))"
 
 text \<open>
 \noindent
 Coinduction rules are generated as
 @{thm [source] iterate\<^sub>i\<^sub>i.coinduct},
 @{thm [source] iterates\<^sub>i\<^sub>i.coinduct}, and
 @{thm [source] iterate\<^sub>i\<^sub>i_iterates\<^sub>i\<^sub>i.coinduct}
 and analogously for \<open>coinduct_strong\<close>. These rules and the
 underlying corecursors are generated dynamically and are kept in a cache
 to speed up subsequent definitions.
 \<close>
 
 (*<*)
     end
 (*>*)
 
 
 subsubsection \<open>Constructor View
   \label{ssec:primrec-constructor-view}\<close>
 
 (*<*)
     locale ctr_view
     begin
 (*>*)
 
 text \<open>
 The constructor view is similar to the code view, but there is one separate
 conditional equation per constructor rather than a single unconditional
 equation. Examples that rely on a single constructor, such as \<^const>\<open>literate\<close>
 and \<^const>\<open>siterate\<close>, are identical in both styles.
 
 Here is an example where there is a difference:
 \<close>
 
     primcorec lapp :: "'a llist \<Rightarrow> 'a llist \<Rightarrow> 'a llist" where
       "lnull xs \<Longrightarrow> lnull ys \<Longrightarrow> lapp xs ys = LNil"
     | "_ \<Longrightarrow> lapp xs ys = LCons (lhd (if lnull xs then ys else xs))
          (if xs = LNil then ltl ys else lapp (ltl xs) ys)"
 
 text \<open>
 \noindent
 With the constructor view, we must distinguish between the \<^const>\<open>LNil\<close> and
 the \<^const>\<open>LCons\<close> case. The condition for \<^const>\<open>LCons\<close> is
 left implicit, as the negation of that for \<^const>\<open>LNil\<close>.
 
 For this example, the constructor view is slightly more involved than the
 code equation. Recall the code view version presented in
 Section~\ref{sssec:primcorec-simple-corecursion}.
 % TODO: \[{thm code_view.lapp.code}\]
 The constructor view requires us to analyze the second argument (\<^term>\<open>ys\<close>).
 The code equation generated from the constructor view also suffers from this.
 % TODO: \[{thm lapp.code}\]
 
 In contrast, the next example is arguably more naturally expressed in the
 constructor view:
 \<close>
 
     primcorec
       random_process :: "'a stream \<Rightarrow> (int \<Rightarrow> int) \<Rightarrow> int \<Rightarrow> 'a process"
     where
       "n mod 4 = 0 \<Longrightarrow> random_process s f n = Fail"
     | "n mod 4 = 1 \<Longrightarrow>
          random_process s f n = Skip (random_process s f (f n))"
     | "n mod 4 = 2 \<Longrightarrow>
          random_process s f n = Action (shd s) (random_process (stl s) f (f n))"
     | "n mod 4 = 3 \<Longrightarrow>
          random_process s f n = Choice (random_process (every_snd s) f (f n))
            (random_process (every_snd (stl s)) f (f n))"
 (*<*)
     end
 (*>*)
 
 text \<open>
 \noindent
 Since there is no sequentiality, we can apply the equation for \<^const>\<open>Choice\<close>
 without having first to discharge \<^term>\<open>n mod (4::int) \<noteq> 0\<close>,
 \<^term>\<open>n mod (4::int) \<noteq> 1\<close>, and
 \<^term>\<open>n mod (4::int) \<noteq> 2\<close>.
 The price to pay for this elegance is that we must discharge exclusiveness proof
 obligations, one for each pair of conditions
 \<^term>\<open>(n mod (4::int) = i, n mod (4::int) = j)\<close>
 with \<^term>\<open>i < j\<close>. If we prefer not to discharge any obligations, we can
 enable the \<open>sequential\<close> option. This pushes the problem to the users of
 the generated properties.
 %Here are more examples to conclude:
 \<close>
 
 
 subsubsection \<open>Destructor View
   \label{ssec:primrec-destructor-view}\<close>
 
 (*<*)
     locale dtr_view
     begin
 (*>*)
 
 text \<open>
 The destructor view is in many respects dual to the constructor view. Conditions
 determine which constructor to choose, and these conditions are interpreted
 sequentially or not depending on the \<open>sequential\<close> option.
 Consider the following examples:
 \<close>
 
     primcorec literate :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a llist" where
       "\<not> lnull (literate _ x)"
     | "lhd (literate _ x) = x"
     | "ltl (literate g x) = literate g (g x)"
 
 text \<open>\blankline\<close>
 
     primcorec siterate :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a stream" where
       "shd (siterate _ x) = x"
     | "stl (siterate g x) = siterate g (g x)"
 
 text \<open>\blankline\<close>
 
     primcorec every_snd :: "'a stream \<Rightarrow> 'a stream" where
       "shd (every_snd s) = shd s"
     | "stl (every_snd s) = stl (stl s)"
 
 text \<open>
 \noindent
 The first formula in the \<^const>\<open>literate\<close> specification indicates which
 constructor to choose. For \<^const>\<open>siterate\<close> and \<^const>\<open>every_snd\<close>, no such
 formula is necessary, since the type has only one constructor. The last two
 formulas are equations specifying the value of the result for the relevant
 selectors. Corecursive calls appear directly to the right of the equal sign.
 Their arguments are unrestricted.
 
 The next example shows how to specify functions that rely on more than one
 constructor:
 \<close>
 
     primcorec lapp :: "'a llist \<Rightarrow> 'a llist \<Rightarrow> 'a llist" where
       "lnull xs \<Longrightarrow> lnull ys \<Longrightarrow> lnull (lapp xs ys)"
     | "lhd (lapp xs ys) = lhd (if lnull xs then ys else xs)"
     | "ltl (lapp xs ys) = (if xs = LNil then ltl ys else lapp (ltl xs) ys)"
 
 text \<open>
 \noindent
 For a codatatype with $n$ constructors, it is sufficient to specify $n - 1$
 discriminator formulas. The command will then assume that the remaining
 constructor should be taken otherwise. This can be made explicit by adding
 \<close>
 
 (*<*)
     end
 
     locale dtr_view2
     begin
 
     primcorec lapp :: "'a llist \<Rightarrow> 'a llist \<Rightarrow> 'a llist" where
       "lnull xs \<Longrightarrow> lnull ys \<Longrightarrow> lnull (lapp xs ys)"
     | "lhd (lapp xs ys) = lhd (if lnull xs then ys else xs)"
     | "ltl (lapp xs ys) = (if xs = LNil then ltl ys else lapp (ltl xs) ys)" |
 (*>*)
       "_ \<Longrightarrow> \<not> lnull (lapp xs ys)"
 
 text \<open>
 \noindent
 to the specification. The generated selector theorems are conditional.
 
 The next example illustrates how to cope with selectors defined for several
 constructors:
 \<close>
 
     primcorec
       random_process :: "'a stream \<Rightarrow> (int \<Rightarrow> int) \<Rightarrow> int \<Rightarrow> 'a process"
     where
       "n mod 4 = 0 \<Longrightarrow> random_process s f n = Fail"
     | "n mod 4 = 1 \<Longrightarrow> is_Skip (random_process s f n)"
     | "n mod 4 = 2 \<Longrightarrow> is_Action (random_process s f n)"
     | "n mod 4 = 3 \<Longrightarrow> is_Choice (random_process s f n)"
     | "cont (random_process s f n) = random_process s f (f n)" of Skip
     | "prefix (random_process s f n) = shd s"
     | "cont (random_process s f n) = random_process (stl s) f (f n)" of Action
     | "left (random_process s f n) = random_process (every_snd s) f (f n)"
     | "right (random_process s f n) = random_process (every_snd (stl s)) f (f n)"
 
 text \<open>
 \noindent
 Using the \<open>of\<close> keyword, different equations are specified for \<^const>\<open>cont\<close> depending on which constructor is selected.
 
 Here are more examples to conclude:
 \<close>
 
     primcorec
       even_infty :: even_enat and
       odd_infty :: odd_enat
     where
       "even_infty \<noteq> Even_EZero"
     | "un_Even_ESucc even_infty = odd_infty"
     | "un_Odd_ESucc odd_infty = even_infty"
 
 text \<open>\blankline\<close>
 
     primcorec iterate\<^sub>i\<^sub>i :: "('a \<Rightarrow> 'a llist) \<Rightarrow> 'a \<Rightarrow> 'a tree\<^sub>i\<^sub>i" where
       "lbl\<^sub>i\<^sub>i (iterate\<^sub>i\<^sub>i g x) = x"
     | "sub\<^sub>i\<^sub>i (iterate\<^sub>i\<^sub>i g x) = lmap (iterate\<^sub>i\<^sub>i g) (g x)"
 (*<*)
     end
 (*>*)
 
 
 subsection \<open>Command Syntax
   \label{ssec:primcorec-command-syntax}\<close>
 
 subsubsection \<open>\keyw{primcorec} and \keyw{primcorecursive}
   \label{sssec:primcorecursive-and-primcorec}\<close>
 
 text \<open>
 \begin{matharray}{rcl}
   @{command_def "primcorec"} & : & \<open>local_theory \<rightarrow> local_theory\<close> \\
   @{command_def "primcorecursive"} & : & \<open>local_theory \<rightarrow> proof(prove)\<close>
 \end{matharray}
 
 \<^rail>\<open>
   (@@{command primcorec} | @@{command primcorecursive}) target? \<newline>
     @{syntax pcr_options}? fixes @'where' (@{syntax pcr_formula} + '|')
   ;
   @{syntax_def pcr_options}: '(' ((@{syntax plugins} | 'sequential' | 'exhaustive' | 'transfer') + ',') ')'
   ;
   @{syntax_def pcr_formula}: thmdecl? prop (@'of' (term * ))?
 \<close>
 
 \medskip
 
 \noindent
 The @{command primcorec} and @{command primcorecursive} commands introduce a set
 of mutually corecursive functions over codatatypes.
 
 The syntactic entity \synt{target} can be used to specify a local context,
 \synt{fixes} denotes a list of names with optional type signatures,
 \synt{thmdecl} denotes an optional name for the formula that follows, and
 \synt{prop} denotes a HOL proposition @{cite "isabelle-isar-ref"}.
 
 The optional target is optionally followed by a combination of the following
 options:
 
 \begin{itemize}
 \setlength{\itemsep}{0pt}
 
 \item
 The \<open>plugins\<close> option indicates which plugins should be enabled
 (\<open>only\<close>) or disabled (\<open>del\<close>). By default, all plugins are enabled.
 
 \item
 The \<open>sequential\<close> option indicates that the conditions in specifications
 expressed using the constructor or destructor view are to be interpreted
 sequentially.
 
 \item
 The \<open>exhaustive\<close> option indicates that the conditions in specifications
 expressed using the constructor or destructor view cover all possible cases.
 This generally gives rise to an additional proof obligation.
 
 \item
 The \<open>transfer\<close> option indicates that an unconditional transfer rule
 should be generated and proved \<open>by transfer_prover\<close>. The
 \<open>[transfer_rule]\<close> attribute is set on the generated theorem.
 \end{itemize}
 
 The @{command primcorec} command is an abbreviation for @{command
 primcorecursive} with \<open>by auto?\<close> to discharge any emerging proof
 obligations.
 
 %%% TODO: elaborate on format of the propositions
 %%% TODO: elaborate on mutual and nested-to-mutual
 \<close>
 
 
 subsection \<open>Generated Theorems
   \label{ssec:primcorec-generated-theorems}\<close>
 
 text \<open>
 The @{command primcorec} and @{command primcorecursive} commands generate the
 following properties (listed for \<^const>\<open>literate\<close>):
 
 \begin{indentblock}
 \begin{description}
 
 \item[\<open>f.\<close>\hthm{code} \<open>[code]\<close>\rm:] ~ \\
 @{thm literate.code[no_vars]} \\
 The \<open>[code]\<close> attribute is set by the \<open>code\<close> plugin
 (Section~\ref{ssec:code-generator}).
 
 \item[\<open>f.\<close>\hthm{ctr}\rm:] ~ \\
 @{thm literate.ctr[no_vars]}
 
 \item[\<open>f.\<close>\hthm{disc} \<open>[simp, code]\<close>\rm:] ~ \\
 @{thm literate.disc[no_vars]} \\
 The \<open>[code]\<close> attribute is set by the \<open>code\<close> plugin
 (Section~\ref{ssec:code-generator}). The \<open>[simp]\<close> attribute is set only
 for functions for which \<open>f.disc_iff\<close> is not available.
 
 \item[\<open>f.\<close>\hthm{disc_iff} \<open>[simp]\<close>\rm:] ~ \\
 @{thm literate.disc_iff[no_vars]} \\
 This property is generated only for functions declared with the
 \<open>exhaustive\<close> option or whose conditions are trivially exhaustive.
 
 \item[\<open>f.\<close>\hthm{sel} \<open>[simp, code]\<close>\rm:] ~ \\
 @{thm literate.disc[no_vars]} \\
 The \<open>[code]\<close> attribute is set by the \<open>code\<close> plugin
 (Section~\ref{ssec:code-generator}).
 
 \item[\<open>f.\<close>\hthm{exclude}\rm:] ~ \\
 These properties are missing for \<^const>\<open>literate\<close> because no exclusiveness
 proof obligations arose. In general, the properties correspond to the
 discharged proof obligations.
 
 \item[\<open>f.\<close>\hthm{exhaust}\rm:] ~ \\
 This property is missing for \<^const>\<open>literate\<close> because no exhaustiveness
 proof obligation arose. In general, the property correspond to the discharged
 proof obligation.
 
 \item[\begin{tabular}{@ {}l@ {}}
   \<open>f.\<close>\hthm{coinduct} \<open>[consumes m, case_names t\<^sub>1 \<dots> t\<^sub>m,\<close> \\
   \phantom{\<open>f.\<close>\hthm{coinduct} \<open>[\<close>}\<open>case_conclusion D\<^sub>1 \<dots>
   D\<^sub>n]\<close>\rm:
 \end{tabular}] ~ \\
 This coinduction rule is generated for nested-as-mutual corecursive functions
 (Section~\ref{sssec:primcorec-nested-as-mutual-corecursion}).
 
 \item[\begin{tabular}{@ {}l@ {}}
   \<open>f.\<close>\hthm{coinduct_strong} \<open>[consumes m, case_names t\<^sub>1 \<dots> t\<^sub>m,\<close> \\
   \phantom{\<open>f.\<close>\hthm{coinduct_strong} \<open>[\<close>}\<open>case_conclusion D\<^sub>1 \<dots>
   D\<^sub>n]\<close>\rm:
 \end{tabular}] ~ \\
 This coinduction rule is generated for nested-as-mutual corecursive functions
 (Section~\ref{sssec:primcorec-nested-as-mutual-corecursion}).
 
 \item[\begin{tabular}{@ {}l@ {}}
   \<open>f\<^sub>1_\<dots>_f\<^sub>m.\<close>\hthm{coinduct} \<open>[case_names t\<^sub>1 \<dots> t\<^sub>m,\<close> \\
   \phantom{\<open>f.\<close>\hthm{coinduct} \<open>[\<close>}\<open>case_conclusion D\<^sub>1 \<dots>
   D\<^sub>n]\<close>\rm:
 \end{tabular}] ~ \\
 This coinduction rule is generated for nested-as-mutual corecursive functions
 (Section~\ref{sssec:primcorec-nested-as-mutual-corecursion}). Given $m > 1$
 mutually corecursive functions, this rule can be used to prove $m$ properties
 simultaneously.
 
 \item[\begin{tabular}{@ {}l@ {}}
   \<open>f\<^sub>1_\<dots>_f\<^sub>m.\<close>\hthm{coinduct_strong} \<open>[case_names t\<^sub>1 \<dots> t\<^sub>m,\<close> \\
   \phantom{\<open>f.\<close>\hthm{coinduct_strong} \<open>[\<close>}\<open>case_conclusion D\<^sub>1 \<dots>
   D\<^sub>n]\<close>\rm:
 \end{tabular}] ~ \\
 This coinduction rule is generated for nested-as-mutual corecursive functions
 (Section~\ref{sssec:primcorec-nested-as-mutual-corecursion}). Given $m > 1$
 mutually corecursive functions, this rule can be used to prove $m$ properties
 simultaneously.
 
 \end{description}
 \end{indentblock}
 
 \noindent
 For convenience, @{command primcorec} and @{command primcorecursive} also
 provide the following collection:
 
 \begin{indentblock}
 \begin{description}
 
 \item[\<open>f.\<close>\hthm{simps}] = \<open>f.disc_iff\<close> (or \<open>f.disc\<close>) \<open>t.sel\<close>
 
 \end{description}
 \end{indentblock}
 \<close>
 
 
 (*
 subsection \<open>Recursive Default Values for Selectors
   \label{ssec:primcorec-recursive-default-values-for-selectors}\<close>
 
 text \<open>
 partial_function to the rescue
 \<close>
 *)
 
 
 section \<open>Registering Bounded Natural Functors
   \label{sec:registering-bounded-natural-functors}\<close>
 
 text \<open>
 The (co)datatype package can be set up to allow nested recursion through
 arbitrary type constructors, as long as they adhere to the BNF requirements
 and are registered as BNFs. It is also possible to declare a BNF abstractly
 without specifying its internal structure.
 \<close>
 
 
 subsection \<open>Bounded Natural Functors
   \label{ssec:bounded-natural-functors}\<close>
 
 text \<open>
 Bounded natural functors (BNFs) are a semantic criterion for where
 (co)re\-cur\-sion may appear on the right-hand side of an equation
 @{cite "traytel-et-al-2012" and "blanchette-et-al-2015-wit"}.
 
 An $n$-ary BNF is a type constructor equipped with a map function
 (functorial action), $n$ set functions (natural transformations),
 and an infinite cardinal bound that satisfy certain properties.
 For example, \<^typ>\<open>'a llist\<close> is a unary BNF.
 Its predicator \<open>llist_all ::
   ('a \<Rightarrow> bool) \<Rightarrow>
   'a llist \<Rightarrow> bool\<close>
 extends unary predicates over elements to unary predicates over
 lazy lists.
 Similarly, its relator \<open>llist_all2 ::
   ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow>
   'a llist \<Rightarrow> 'b llist \<Rightarrow> bool\<close>
 extends binary predicates over elements to binary predicates over parallel
 lazy lists. The cardinal bound limits the number of elements returned by the
 set function; it may not depend on the cardinality of \<^typ>\<open>'a\<close>.
 
 The type constructors introduced by @{command datatype} and
 @{command codatatype} are automatically registered as BNFs. In addition, a
 number of old-style datatypes and non-free types are preregistered.
 
 Given an $n$-ary BNF, the $n$ type variables associated with set functions,
 and on which the map function acts, are \emph{live}; any other variables are
 \emph{dead}. Nested (co)recursion can only take place through live variables.
 \<close>
 
 
 subsection \<open>Introductory Examples
   \label{ssec:bnf-introductory-examples}\<close>
 
 text \<open>
 The example below shows how to register a type as a BNF using the @{command bnf}
 command. Some of the proof obligations are best viewed with the bundle
 "cardinal_syntax" included.
 
 The type is simply a copy of the function space \<^typ>\<open>'d \<Rightarrow> 'a\<close>, where \<^typ>\<open>'a\<close>
 is live and \<^typ>\<open>'d\<close> is dead. We introduce it together with its map function,
 set function, predicator, and relator.
 \<close>
 
     typedef ('d, 'a) fn = "UNIV :: ('d \<Rightarrow> 'a) set"
       by simp
 
 text \<open>\blankline\<close>
 
     setup_lifting type_definition_fn
 
 text \<open>\blankline\<close>
 
     lift_definition map_fn :: "('a \<Rightarrow> 'b) \<Rightarrow> ('d, 'a) fn \<Rightarrow> ('d, 'b) fn" is "(\<circ>)" .
     lift_definition set_fn :: "('d, 'a) fn \<Rightarrow> 'a set" is range .
 
 text \<open>\blankline\<close>
 
     lift_definition
       pred_fn :: "('a \<Rightarrow> bool) \<Rightarrow> ('d, 'a) fn \<Rightarrow> bool"
     is
       "pred_fun (\<lambda>_. True)" .
 
     lift_definition
       rel_fn :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('d, 'a) fn \<Rightarrow> ('d, 'b) fn \<Rightarrow> bool"
     is
       "rel_fun (=)" .
 
 text \<open>\blankline\<close>
 
     bnf "('d, 'a) fn"
       map: map_fn
       sets: set_fn
       bd: "natLeq +c |UNIV :: 'd set|"
       rel: rel_fn
       pred: pred_fn
     proof -
       show "map_fn id = id"
         by transfer auto
     next
       fix f :: "'a \<Rightarrow> 'b" and g :: "'b \<Rightarrow> 'c"
       show "map_fn (g \<circ> f) = map_fn g \<circ> map_fn f"
         by transfer (auto simp add: comp_def)
     next
       fix F :: "('d, 'a) fn" and f g :: "'a \<Rightarrow> 'b"
       assume "\<And>x. x \<in> set_fn F \<Longrightarrow> f x = g x"
       then show "map_fn f F = map_fn g F"
         by transfer auto
     next
       fix f :: "'a \<Rightarrow> 'b"
       show "set_fn \<circ> map_fn f = (`) f \<circ> set_fn"
         by transfer (auto simp add: comp_def)
     next
       show "card_order (natLeq +c |UNIV :: 'd set| )"
         apply (rule card_order_csum)
         apply (rule natLeq_card_order)
         by (rule card_of_card_order_on)
     next
       show "cinfinite (natLeq +c |UNIV :: 'd set| )"
         apply (rule cinfinite_csum)
         apply (rule disjI1)
         by (rule natLeq_cinfinite)
     next
       fix F :: "('d, 'a) fn"
       have "|set_fn F| \<le>o |UNIV :: 'd set|" (is "_ \<le>o ?U")
         by transfer (rule card_of_image)
       also have "?U \<le>o natLeq +c ?U"
         by (rule ordLeq_csum2) (rule card_of_Card_order)
       finally show "|set_fn F| \<le>o natLeq +c |UNIV :: 'd set|" .
     next
       fix R :: "'a \<Rightarrow> 'b \<Rightarrow> bool" and S :: "'b \<Rightarrow> 'c \<Rightarrow> bool"
       show "rel_fn R OO rel_fn S \<le> rel_fn (R OO S)"
         by (rule, transfer) (auto simp add: rel_fun_def)
     next
       fix R :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
       show "rel_fn R = (\<lambda>x y. \<exists>z. set_fn z \<subseteq> {(x, y). R x y} \<and> map_fn fst z = x \<and> map_fn snd z = y)"
         unfolding fun_eq_iff relcompp.simps conversep.simps
         by transfer (force simp: rel_fun_def subset_iff)
     next
       fix P :: "'a \<Rightarrow> bool"
       show "pred_fn P = (\<lambda>x. Ball (set_fn x) P)"
         unfolding fun_eq_iff by transfer simp
     qed
 
 text \<open>\blankline\<close>
 
     print_theorems
     print_bnfs
 
 text \<open>
 \noindent
 Using \keyw{print_theorems} and @{command print_bnfs}, we can contemplate and
 show the world what we have achieved.
 
 This particular example does not need any nonemptiness witness, because the
 one generated by default is good enough, but in general this would be
 necessary. See \<^file>\<open>~~/src/HOL/Basic_BNFs.thy\<close>,
 \<^file>\<open>~~/src/HOL/Library/Countable_Set_Type.thy\<close>,
 \<^file>\<open>~~/src/HOL/Library/FSet.thy\<close>, and
 \<^file>\<open>~~/src/HOL/Library/Multiset.thy\<close> for further examples of BNF
 registration, some of which feature custom witnesses.
 
 For many typedefs and quotient types, lifting the BNF structure from the raw typ
 to the abstract type can be done uniformly. This is the task of the @{command lift_bnf}
 command. Using @{command lift_bnf}, the above registration of \<^typ>\<open>('d, 'a) fn\<close> as a
 BNF becomes much shorter:
 \<close>
 
 (*<*)
     context early
     begin
 (*>*)
     lift_bnf (*<*)(no_warn_wits) (*>*)('d, 'a) fn
       by force+
 (*<*)
     end
 (*>*)
 
 text \<open>
 For type copies (@{command typedef}s with \<^term>\<open>UNIV\<close> as the representing set),
 the proof obligations are so simple that they can be
 discharged automatically, yielding another command, @{command copy_bnf}, which
 does not emit any proof obligations:
 \<close>
 
 (*<*)
     context late
     begin
 (*>*)
     copy_bnf ('d, 'a) fn
 (*<*)
     end
 (*>*)
 
 text \<open>
 Since record schemas are type copies, @{command copy_bnf} can be used to
 register them as BNFs:
 \<close>
 
     record 'a point =
       xval :: 'a
       yval :: 'a
 
 text \<open>\blankline\<close>
 
     copy_bnf (*<*)(no_warn_transfer) (*>*)('a, 'z) point_ext
 
 text \<open>
 In the general case, the proof obligations generated by @{command lift_bnf} are
 simpler than the acual BNF properties. In particular, no cardinality reasoning
 is required. Consider the following type of nonempty lists:
 \<close>
 
     typedef 'a nonempty_list = "{xs :: 'a list. xs \<noteq> []}" by auto
 
 text \<open>
 The @{command lift_bnf} command requires us to prove that the set of nonempty lists
 is closed under the map function and the zip function. The latter only
 occurs implicitly in the goal, in form of the variable
 \<^term>\<open>zs :: ('a \<times> 'b) list\<close>.
 \<close>
 
     lift_bnf (*<*)(no_warn_wits,no_warn_transfer) (*>*)'a nonempty_list
     proof -
       fix f (*<*):: "'a \<Rightarrow> 'c"(*>*)and xs :: "'a list"
       assume "xs \<in> {xs. xs \<noteq> []}"
       then show "map f xs \<in> {xs. xs \<noteq> []}"
         by (cases xs(*<*) rule: list.exhaust(*>*)) auto
     next
       fix zs :: "('a \<times> 'b) list"
       assume "map fst zs \<in> {xs. xs \<noteq> []}" "map snd zs \<in> {xs. xs \<noteq> []}"
       then show "\<exists>zs'\<in>{xs. xs \<noteq> []}.
             set zs' \<subseteq> set zs \<and>
             map fst zs' = map fst zs \<and>
             map snd zs' = map snd zs"
         by (cases zs (*<*)rule: list.exhaust(*>*)) (auto intro!: exI[of _ zs])
     qed
 
 text \<open>The @{command lift_bnf} command also supports quotient types. Here is an example
 that defines the option type as a quotient of the sum type. The proof obligations
-generated by @{command lift_bnf} for quotients are different from the ones for typedefs.\<close>
+generated by @{command lift_bnf} for quotients are different from the ones for typedefs.
+You can find additional examples of usages of @{command lift_bnf} for both quotients and subtypes
+in the session \emph{HOL-Datatype_Examples}.\<close>
 
     inductive ignore_Inl :: "'a + 'a \<Rightarrow> 'a + 'a \<Rightarrow> bool" where
       "ignore_Inl (Inl x) (Inl y)"
     | "ignore_Inl (Inr x) (Inr x)"
 
     (*<*)
     inductive_simps ignore_Inl_simps[simp]:
       "ignore_Inl (Inl x) y"
       "ignore_Inl (Inr x') y"
       "ignore_Inl y (Inl x)"
       "ignore_Inl y (Inr x')"
     (*>*)
 
     lemma ignore_Inl_equivp:
       "ignore_Inl x x"
       "ignore_Inl x y \<Longrightarrow> ignore_Inl y x"
       "ignore_Inl x y \<Longrightarrow> ignore_Inl y z \<Longrightarrow> ignore_Inl x z"
       by (cases x; cases y; cases z; auto)+
 
     quotient_type 'a myoption = "'a + 'a" / ignore_Inl
       unfolding equivp_reflp_symp_transp reflp_def symp_def transp_def
       by (blast intro: ignore_Inl_equivp)
 
     lift_bnf 'a myoption (*<*)[wits: "Inl undefined :: 'a + 'a"](*>*)
 
     proof -
       fix P :: "'a \<Rightarrow> 'b \<Rightarrow> bool" and Q :: "'b \<Rightarrow> 'c \<Rightarrow> bool"
       assume "P OO Q \<noteq> bot"
       then show "rel_sum P P OO ignore_Inl OO rel_sum Q Q
          \<le> ignore_Inl OO rel_sum (P OO Q) (P OO Q) OO ignore_Inl"
         by (fastforce(*<*) elim!: ignore_Inl.cases simp add: relcompp_apply fun_eq_iff rel_sum.simps(*>*))
     next
       fix S :: "'a set set"
       let ?eq = "{(x, x'). ignore_Inl x x'}"
       let ?in = "\<lambda>A. {x. Basic_BNFs.setl x \<union> Basic_BNFs.setr x \<subseteq> A}"
       assume "S \<noteq> {}" "\<Inter> S \<noteq> {}"
       show "(\<Inter>A\<in>S. ?eq `` ?in A) \<subseteq> ?eq `` ?in (\<Inter> S)"
       proof (intro subsetI)
         fix x
         assume "x \<in> (\<Inter>A\<in>S. ?eq `` ?in A)"
         with \<open>\<Inter> S \<noteq> {}\<close> show "x \<in> ?eq `` ?in (\<Inter> S)"
           by (cases x) (fastforce(*<*) dest!: spec[where x="Inl _"](*>*))+
       qed
     (*<*)next
       fix a :: 'a
       assume "a \<in> (\<Inter>mx\<in>{mx. ignore_Inl (map_sum Inr Inr (Inl undefined)) mx}.
         \<Union> (Basic_BNFs.setr ` (Basic_BNFs.setl mx \<union> Basic_BNFs.setr mx)))"
       then show False
         by (auto simp: setr.simps)(*>*)
     qed
 
 
 text \<open>
 The next example declares a BNF axiomatically. This can be convenient for
 reasoning abstractly about an arbitrary BNF. The @{command bnf_axiomatization}
 command below introduces a type \<open>('a, 'b, 'c) F\<close>, three set constants,
 a map function, a predicator, a relator, and a nonemptiness witness that depends only on
 \<^typ>\<open>'a\<close>. The type \<open>'a \<Rightarrow> ('a, 'b, 'c) F\<close> of the witness can be read
 as an implication: Given a witness for \<^typ>\<open>'a\<close>, we can construct a witness for
 \<open>('a, 'b, 'c) F\<close>. The BNF properties are postulated as axioms.
 \<close>
 
     bnf_axiomatization (setA: 'a, setB: 'b, setC: 'c) F
       [wits: "'a \<Rightarrow> ('a, 'b, 'c) F"]
 
 text \<open>\blankline\<close>
 
     print_theorems
     print_bnfs
 
 
 subsection \<open>Command Syntax
   \label{ssec:bnf-command-syntax}\<close>
 
 subsubsection \<open>\keyw{bnf}
   \label{sssec:bnf}\<close>
 
 text \<open>
 \begin{matharray}{rcl}
   @{command_def "bnf"} & : & \<open>local_theory \<rightarrow> proof(prove)\<close>
 \end{matharray}
 
 \<^rail>\<open>
   @@{command bnf} target? (name ':')? type \<newline>
     'map:' term ('sets:' (term +))? 'bd:' term \<newline>
     ('wits:' (term +))? ('rel:' term)? \<newline>
     ('pred:' term)? @{syntax plugins}?
 \<close>
 
 \medskip
 
 \noindent
 The @{command bnf} command registers an existing type as a bounded natural
 functor (BNF). The type must be equipped with an appropriate map function
 (functorial action). In addition, custom set functions, predicators, relators, and
 nonemptiness witnesses can be specified; otherwise, default versions are used.
 
 The syntactic entity \synt{target} can be used to specify a local context,
 \synt{type} denotes a HOL type, and \synt{term} denotes a HOL term
 @{cite "isabelle-isar-ref"}.
 
 The @{syntax plugins} option indicates which plugins should be enabled
 (\<open>only\<close>) or disabled (\<open>del\<close>). By default, all plugins are enabled.
 
 %%% TODO: elaborate on proof obligations
 \<close>
 
 subsubsection \<open>\keyw{lift_bnf}
   \label{sssec:lift-bnf}\<close>
 
 text \<open>
 \begin{matharray}{rcl}
   @{command_def "lift_bnf"} & : & \<open>local_theory \<rightarrow> proof(prove)\<close>
 \end{matharray}
 
 \<^rail>\<open>
   @@{command lift_bnf} target? lb_options? \<newline>
     @{syntax tyargs} name wit_terms?  \<newline>
     ('via' thm)? @{syntax map_rel_pred}?
   ;
   @{syntax_def lb_options}: '(' ((@{syntax plugins} | 'no_warn_wits' | 'no_warn_transfer') + ',') ')'
   ;
   @{syntax_def wit_terms}: '[' 'wits' ':' terms ']'
 \<close>
 \medskip
 
 \noindent
 The @{command lift_bnf} command registers as a BNF an existing type (the
 \emph{abstract type}) that was defined as a subtype of a BNF (the \emph{raw
 type}) using the @{command typedef} command or as a quotient type of a BNF (also, the
 \emph{raw type}) using the @{command quotient_type}. To achieve this, it lifts the BNF
 structure on the raw type to the abstract type following a \<^term>\<open>type_definition\<close> or a
 \<^term>\<open>Quotient\<close> theorem. The theorem is usually inferred from the type, but can
 also be explicitly supplied by means of the optional \<open>via\<close> clause. In
 addition, custom names for the set functions, the map function, the predicator, and the relator,
 as well as nonemptiness witnesses can be specified.
 
 Nonemptiness witnesses are not lifted from the raw type's BNF, as this would be
 incomplete. They must be given as terms (on the raw type) and proved to be
 witnesses. The command warns about witness types that are present in the raw
 type's BNF but not supplied by the user. The warning can be disabled by
 specifying the \<open>no_warn_wits\<close> option.
 \<close>
 
 subsubsection \<open>\keyw{copy_bnf}
   \label{sssec:copy-bnf}\<close>
 
 text \<open>
 \begin{matharray}{rcl}
   @{command_def "copy_bnf"} & : & \<open>local_theory \<rightarrow> local_theory\<close>
 \end{matharray}
 
 \<^rail>\<open>
   @@{command copy_bnf} target? cb_options? \<newline>
     @{syntax tyargs} name ('via' thm)? @{syntax map_rel_pred}?
   ;
   @{syntax_def cb_options}: '(' ((@{syntax plugins} | 'no_warn_transfer') + ',') ')'
 
 \<close>
 \medskip
 
 \noindent
 The @{command copy_bnf} command performs the same lifting as @{command lift_bnf}
 for type copies (@{command typedef}s with \<^term>\<open>UNIV\<close> as the representing set),
 without requiring the user to discharge any proof obligations or provide
 nonemptiness witnesses.
 \<close>
 
 subsubsection \<open>\keyw{bnf_axiomatization}
   \label{sssec:bnf-axiomatization}\<close>
 
 text \<open>
 \begin{matharray}{rcl}
   @{command_def "bnf_axiomatization"} & : & \<open>local_theory \<rightarrow> local_theory\<close>
 \end{matharray}
 
 \<^rail>\<open>
   @@{command bnf_axiomatization} target? ('(' @{syntax plugins} ')')? \<newline>
     @{syntax tyargs}? name @{syntax wit_types}? \<newline>
     mixfix? @{syntax map_rel_pred}?
   ;
   @{syntax_def wit_types}: '[' 'wits' ':' types ']'
 \<close>
 
 \medskip
 
 \noindent
 The @{command bnf_axiomatization} command declares a new type and associated constants
 (map, set, predicator, relator, and cardinal bound) and asserts the BNF properties for
 these constants as axioms.
 
 The syntactic entity \synt{target} can be used to specify a local context,
 \synt{name} denotes an identifier, \synt{typefree} denotes fixed type variable
 (\<^typ>\<open>'a\<close>, \<^typ>\<open>'b\<close>, \ldots), \synt{mixfix} denotes the usual parenthesized
 mixfix notation, and \synt{types} denotes a space-separated list of types
 @{cite "isabelle-isar-ref"}.
 
 The @{syntax plugins} option indicates which plugins should be enabled
 (\<open>only\<close>) or disabled (\<open>del\<close>). By default, all plugins are enabled.
 
 Type arguments are live by default; they can be marked as dead by entering
 \<open>dead\<close> in front of the type variable (e.g., \<open>(dead 'a)\<close>)
 instead of an identifier for the corresponding set function. Witnesses can be
 specified by their types. Otherwise, the syntax of @{command bnf_axiomatization}
 is identical to the left-hand side of a @{command datatype} or
 @{command codatatype} definition.
 
 The command is useful to reason abstractly about BNFs. The axioms are safe
 because there exist BNFs of arbitrary large arities. Applications must import
 the \<^file>\<open>~~/src/HOL/Library/BNF_Axiomatization.thy\<close> theory
 to use this functionality.
 \<close>
 
 
 subsubsection \<open>\keyw{print_bnfs}
   \label{sssec:print-bnfs}\<close>
 
 text \<open>
 \begin{matharray}{rcl}
   @{command_def "print_bnfs"} & : & \<open>local_theory \<rightarrow>\<close>
 \end{matharray}
 
 \<^rail>\<open>
   @@{command print_bnfs}
 \<close>
 \<close>
 
 
 section \<open>Deriving Destructors and Theorems for Free Constructors
   \label{sec:deriving-destructors-and-theorems-for-free-constructors}\<close>
 
 text \<open>
 The derivation of convenience theorems for types equipped with free constructors,
 as performed internally by @{command datatype} and @{command codatatype},
 is available as a stand-alone command called @{command free_constructors}.
 
 %  * need for this is rare but may arise if you want e.g. to add destructors to
 %    a type not introduced by ...
 %
 %  * @{command free_constructors}
 %    * \<open>plugins\<close>, \<open>discs_sels\<close>
 %    * hack to have both co and nonco view via locale (cf. ext nats)
 \<close>
 
 
 (*
 subsection \<open>Introductory Example
   \label{ssec:ctors-introductory-example}\<close>
 *)
 
 
 subsection \<open>Command Syntax
   \label{ssec:ctors-command-syntax}\<close>
 
 subsubsection \<open>\keyw{free_constructors}
   \label{sssec:free-constructors}\<close>
 
 text \<open>
 \begin{matharray}{rcl}
   @{command_def "free_constructors"} & : & \<open>local_theory \<rightarrow> proof(prove)\<close>
 \end{matharray}
 
 \<^rail>\<open>
   @@{command free_constructors} target? @{syntax dt_options} \<newline>
     name 'for' (@{syntax fc_ctor} + '|') \<newline>
   (@'where' (prop + '|'))?
   ;
   @{syntax_def fc_ctor}: (name ':')? term (name * )
 \<close>
 
 \medskip
 
 \noindent
 The @{command free_constructors} command generates destructor constants for
 freely constructed types as well as properties about constructors and
 destructors. It also registers the constants and theorems in a data structure
 that is queried by various tools (e.g., \keyw{function}).
 
 The syntactic entity \synt{target} can be used to specify a local context,
 \synt{name} denotes an identifier, \synt{prop} denotes a HOL proposition, and
 \synt{term} denotes a HOL term @{cite "isabelle-isar-ref"}.
 
 The syntax resembles that of @{command datatype} and @{command codatatype}
 definitions (Sections
 \ref{ssec:datatype-command-syntax}~and~\ref{ssec:codatatype-command-syntax}).
 A constructor is specified by an optional name for the discriminator, the
 constructor itself (as a term), and a list of optional names for the selectors.
 
 Section~\ref{ssec:datatype-generated-theorems} lists the generated theorems.
 For bootstrapping reasons, the generally useful \<open>[fundef_cong]\<close>
 attribute is not set on the generated \<open>case_cong\<close> theorem. It can be
 added manually using \keyw{declare}.
 \<close>
 
 
 subsubsection \<open>\keyw{simps_of_case}
   \label{sssec:simps-of-case}\<close>
 
 text \<open>
 \begin{matharray}{rcl}
   @{command_def "simps_of_case"} & : & \<open>local_theory \<rightarrow> local_theory\<close>
 \end{matharray}
 
 \<^rail>\<open>
   @@{command simps_of_case} target? (name ':')? \<newline>
     (thm + ) (@'splits' ':' (thm + ))?
 \<close>
 
 \medskip
 
 \noindent
 The @{command simps_of_case} command provided by theory
 \<^file>\<open>~~/src/HOL/Library/Simps_Case_Conv.thy\<close> converts a single equation with
 a complex case expression on the right-hand side into a set of pattern-matching
 equations. For example,
 \<close>
 
 (*<*)
     context late
     begin
 (*>*)
     simps_of_case lapp_simps: lapp.code
 
 text \<open>
 \noindent
 translates @{thm lapp.code[no_vars]} into
 %
 \begin{gather*}
   @{thm lapp_simps(1)[no_vars]} \\
   @{thm lapp_simps(2)[no_vars]}
 \end{gather*}
 \<close>
 
 
 subsubsection \<open>\keyw{case_of_simps}
   \label{sssec:case-of-simps}\<close>
 
 text \<open>
 \begin{matharray}{rcl}
   @{command_def "case_of_simps"} & : & \<open>local_theory \<rightarrow> local_theory\<close>
 \end{matharray}
 
 \<^rail>\<open>
   @@{command case_of_simps} target? (name ':')? \<newline>
     (thm + )
 \<close>
 
 \medskip
 
 \noindent
 The \keyw{case_of_simps} command provided by theory
 \<^file>\<open>~~/src/HOL/Library/Simps_Case_Conv.thy\<close> converts a set of
 pattern-matching equations into single equation with a complex case expression
 on the right-hand side (cf.\ @{command simps_of_case}). For example,
 \<close>
 
     case_of_simps lapp_case: lapp_simps
 
 text \<open>
 \noindent
 translates
 %
 \begin{gather*}
   @{thm lapp_simps(1)[no_vars]} \\
   @{thm lapp_simps(2)[no_vars]}
 \end{gather*}
 %
 into @{thm lapp_case[no_vars]}.
 \<close>
 (*<*)
     end
 (*>*)
 
 
 (*
 section \<open>Using the Standard ML Interface
   \label{sec:using-the-standard-ml-interface}\<close>
 
 text \<open>
 The package's programmatic interface.
 \<close>
 *)
 
 
 section \<open>Selecting Plugins
   \label{sec:selecting-plugins}\<close>
 
 text \<open>
 Plugins extend the (co)datatype package to interoperate with other Isabelle
 packages and tools, such as the code generator, Transfer, Lifting, and
 Quickcheck. They can be enabled or disabled individually using the
 @{syntax plugins} option to the commands @{command datatype},
 @{command primrec}, @{command codatatype}, @{command primcorec},
 @{command primcorecursive}, @{command bnf}, @{command bnf_axiomatization}, and
 @{command free_constructors}. For example:
 \<close>
 
     datatype (plugins del: code "quickcheck") color = Red | Black
 
 text \<open>
 Beyond the standard plugins, the \emph{Archive of Formal Proofs} includes a
 \keyw{derive} command that derives class instances of datatypes
 @{cite "sternagel-thiemann-2015"}.
 \<close>
 
 subsection \<open>Code Generator
   \label{ssec:code-generator}\<close>
 
 text \<open>
 The \hthm{code} plugin registers freely generated types, including
 (co)datatypes, and (co)recursive functions for code generation. No distinction
 is made between datatypes and codatatypes. This means that for target languages
 with a strict evaluation strategy (e.g., Standard ML), programs that attempt to
 produce infinite codatatype values will not terminate.
 
 For types, the plugin derives the following properties:
 
 \begin{indentblock}
 \begin{description}
 
 \item[\<open>t.\<close>\hthm{eq.refl} \<open>[code nbe]\<close>\rm:] ~ \\
 @{thm list.eq.refl[no_vars]}
 
 \item[\<open>t.\<close>\hthm{eq.simps} \<open>[code]\<close>\rm:] ~ \\
 @{thm list.eq.simps(1)[no_vars]} \\
 @{thm list.eq.simps(2)[no_vars]} \\
 @{thm list.eq.simps(3)[no_vars]} \\
 @{thm list.eq.simps(4)[no_vars]} \\
 @{thm list.eq.simps(5)[no_vars]} \\
 @{thm list.eq.simps(6)[no_vars]}
 
 \end{description}
 \end{indentblock}
 
 In addition, the plugin sets the \<open>[code]\<close> attribute on a number of
 properties of freely generated types and of (co)recursive functions, as
 documented in Sections \ref{ssec:datatype-generated-theorems},
 \ref{ssec:primrec-generated-theorems}, \ref{ssec:codatatype-generated-theorems},
 and~\ref{ssec:primcorec-generated-theorems}.
 \<close>
 
 
 subsection \<open>Size
   \label{ssec:size}\<close>
 
 text \<open>
 For each datatype \<open>t\<close>, the \hthm{size} plugin generates a generic size
 function \<open>t.size_t\<close> as well as a specific instance
 \<open>size :: t \<Rightarrow> nat\<close> belonging to the \<open>size\<close> type class. The
 \keyw{fun} command relies on \<^const>\<open>size\<close> to prove termination of recursive
 functions on datatypes.
 
 The plugin derives the following properties:
 
 \begin{indentblock}
 \begin{description}
 
 \item[\<open>t.\<close>\hthm{size} \<open>[simp, code]\<close>\rm:] ~ \\
 @{thm list.size(1)[no_vars]} \\
 @{thm list.size(2)[no_vars]} \\
 @{thm list.size(3)[no_vars]} \\
 @{thm list.size(4)[no_vars]}
 
 \item[\<open>t.\<close>\hthm{size_gen}\rm:] ~ \\
 @{thm list.size_gen(1)[no_vars]} \\
 @{thm list.size_gen(2)[no_vars]}
 
 \item[\<open>t.\<close>\hthm{size_gen_o_map}\rm:] ~ \\
 @{thm list.size_gen_o_map[no_vars]}
 
 \item[\<open>t.\<close>\hthm{size_neq}\rm:] ~ \\
 This property is missing for \<^typ>\<open>'a list\<close>. If the \<^term>\<open>size\<close> function
 always evaluates to a non-zero value, this theorem has the form
 \<^prop>\<open>\<not> size x = 0\<close>.
 
 \end{description}
 \end{indentblock}
 
 The \<open>t.size\<close> and \<open>t.size_t\<close> functions generated for datatypes
 defined by nested recursion through a datatype \<open>u\<close> depend on
 \<open>u.size_u\<close>.
 
 If the recursion is through a non-datatype \<open>u\<close> with type arguments
 \<open>'a\<^sub>1, \<dots>, 'a\<^sub>m\<close>, by default \<open>u\<close> values are given a size of 0. This
 can be improved upon by registering a custom size function of type
 \<open>('a\<^sub>1 \<Rightarrow> nat) \<Rightarrow> \<dots> \<Rightarrow> ('a\<^sub>m \<Rightarrow> nat) \<Rightarrow> u \<Rightarrow> nat\<close> using
 the ML function \<^ML>\<open>BNF_LFP_Size.register_size\<close> or
 \<^ML>\<open>BNF_LFP_Size.register_size_global\<close>. See theory
 \<^file>\<open>~~/src/HOL/Library/Multiset.thy\<close> for an example.
 \<close>
 
 
 subsection \<open>Transfer
   \label{ssec:transfer}\<close>
 
 text \<open>
 For each (co)datatype with live type arguments and each manually registered BNF,
 the \hthm{transfer} plugin generates a predicator \<open>t.pred_t\<close> and
 properties that guide the Transfer tool.
 
 For types with at least one live type argument and \emph{no dead type
 arguments}, the plugin derives the following properties:
 
 \begin{indentblock}
 \begin{description}
 
 \item[\<open>t.\<close>\hthm{Domainp_rel} \<open>[relator_domain]\<close>\rm:] ~ \\
 @{thm list.Domainp_rel[no_vars]}
 
 \item[\<open>t.\<close>\hthm{left_total_rel} \<open>[transfer_rule]\<close>\rm:] ~ \\
 @{thm list.left_total_rel[no_vars]}
 
 \item[\<open>t.\<close>\hthm{left_unique_rel} \<open>[transfer_rule]\<close>\rm:] ~ \\
 @{thm list.left_unique_rel[no_vars]}
 
 \item[\<open>t.\<close>\hthm{right_total_rel} \<open>[transfer_rule]\<close>\rm:] ~ \\
 @{thm list.right_total_rel[no_vars]}
 
 \item[\<open>t.\<close>\hthm{right_unique_rel} \<open>[transfer_rule]\<close>\rm:] ~ \\
 @{thm list.right_unique_rel[no_vars]}
 
 \item[\<open>t.\<close>\hthm{bi_total_rel} \<open>[transfer_rule]\<close>\rm:] ~ \\
 @{thm list.bi_total_rel[no_vars]}
 
 \item[\<open>t.\<close>\hthm{bi_unique_rel} \<open>[transfer_rule]\<close>\rm:] ~ \\
 @{thm list.bi_unique_rel[no_vars]}
 
 \end{description}
 \end{indentblock}
 
 For (co)datatypes with at least one live type argument, the plugin sets the
 \<open>[transfer_rule]\<close> attribute on the following (co)datatypes properties:
 \<open>t.case_\<close>\allowbreak \<open>transfer\<close>,
 \<open>t.sel_\<close>\allowbreak \<open>transfer\<close>,
 \<open>t.ctr_\<close>\allowbreak \<open>transfer\<close>,
 \<open>t.disc_\<close>\allowbreak \<open>transfer\<close>,
 \<open>t.rec_\<close>\allowbreak \<open>transfer\<close>, and
 \<open>t.corec_\<close>\allowbreak \<open>transfer\<close>.
 For (co)datatypes that further have \emph{no dead type arguments}, the plugin
 sets \<open>[transfer_rule]\<close> on
 \<open>t.set_\<close>\allowbreak \<open>transfer\<close>,
 \<open>t.map_\<close>\allowbreak \<open>transfer\<close>, and
 \<open>t.rel_\<close>\allowbreak \<open>transfer\<close>.
 
 For @{command primrec}, @{command primcorec}, and @{command primcorecursive},
 the plugin implements the generation of the \<open>f.transfer\<close> property,
 conditioned by the \<open>transfer\<close> option, and sets the
 \<open>[transfer_rule]\<close> attribute on these.
 \<close>
 
 
 subsection \<open>Lifting
   \label{ssec:lifting}\<close>
 
 text \<open>
 For each (co)datatype and each manually registered BNF with at least one live
 type argument \emph{and no dead type arguments}, the \hthm{lifting} plugin
 generates properties and attributes that guide the Lifting tool.
 
 The plugin derives the following property:
 
 \begin{indentblock}
 \begin{description}
 
 \item[\<open>t.\<close>\hthm{Quotient} \<open>[quot_map]\<close>\rm:] ~ \\
 @{thm list.Quotient[no_vars]}
 
 \end{description}
 \end{indentblock}
 
 In addition, the plugin sets the \<open>[relator_eq]\<close> attribute on a
 variant of the \<open>t.rel_eq_onp\<close> property, the \<open>[relator_mono]\<close>
 attribute on \<open>t.rel_mono\<close>, and the \<open>[relator_distr]\<close> attribute
 on \<open>t.rel_compp\<close>.
 \<close>
 
 
 subsection \<open>Quickcheck
   \label{ssec:quickcheck}\<close>
 
 text \<open>
 The integration of datatypes with Quickcheck is accomplished by the
 \hthm{quick\-check} plugin. It combines a number of subplugins that instantiate
 specific type classes. The subplugins can be enabled or disabled individually.
 They are listed below:
 
 \begin{indentblock}
 \hthm{quickcheck_random} \\
 \hthm{quickcheck_exhaustive} \\
 \hthm{quickcheck_bounded_forall} \\
 \hthm{quickcheck_full_exhaustive} \\
 \hthm{quickcheck_narrowing}
 \end{indentblock}
 \<close>
 
 
 subsection \<open>Program Extraction
   \label{ssec:program-extraction}\<close>
 
 text \<open>
 The \hthm{extraction} plugin provides realizers for induction and case analysis,
 to enable program extraction from proofs involving datatypes. This functionality
 is only available with full proof objects, i.e., with the \emph{HOL-Proofs}
 session.
 \<close>
 
 
 section \<open>Known Bugs and Limitations
   \label{sec:known-bugs-and-limitations}\<close>
 
 text \<open>
 This section lists the known bugs and limitations of the (co)datatype package at
 the time of this writing.
 
 \begin{enumerate}
 \setlength{\itemsep}{0pt}
 
 \item
 \emph{Defining mutually (co)recursive (co)datatypes can be slow.} Fortunately,
 it is always possible to recast mutual specifications to nested ones, which are
 processed more efficiently.
 
 \item
 \emph{Locally fixed types and terms cannot be used in type specifications.}
 The limitation on types can be circumvented by adding type arguments to the local
 (co)datatypes to abstract over the locally fixed types.
 
 \item
 \emph{The \emph{\keyw{primcorec}} command does not allow user-specified names and
 attributes next to the entered formulas.} The less convenient syntax, using the
 \keyw{lemmas} command, is available as an alternative.
 
 \item
 \emph{The \emph{\keyw{primcorec}} command does not allow corecursion under
 \<open>case\<close>--\<open>of\<close> for datatypes that are defined without
 discriminators and selectors.}
 
 \item
 \emph{There is no way to use an overloaded constant from a syntactic type
 class, such as \<open>0\<close>, as a constructor.}
 
 \item
 \emph{There is no way to register the same type as both a datatype and a
 codatatype.} This affects types such as the extended natural numbers, for which
 both views would make sense (for a different set of constructors).
 
 \item
 \emph{The names of variables are often suboptimal in the properties generated by
 the package.}
 
 \item
 \emph{The compatibility layer sometimes produces induction principles with a
 slightly different ordering of the premises than the old package.}
 
 \end{enumerate}
 \<close>
 
 
 text \<open>
 \section*{Acknowledgment}
 
 Tobias Nipkow and Makarius Wenzel encouraged us to implement the new
 (co)datatype package. Andreas Lochbihler provided lots of comments on earlier
 versions of the package, especially on the coinductive part. Brian Huffman
 suggested major simplifications to the internal constructions. Ond\v{r}ej
 Kun\v{c}ar implemented the \<open>transfer\<close> and \<open>lifting\<close> plugins.
 Christian Sternagel and Ren\'e Thiemann ported the \keyw{derive} command
 from the \emph{Archive of Formal Proofs} to the new datatypes. Gerwin Klein and
 Lars Noschinski implemented the @{command simps_of_case} and @{command
 case_of_simps} commands. Florian Haftmann, Christian Urban, and Makarius
 Wenzel provided general advice on Isabelle and package writing. Stefan Milius
 and Lutz Schr\"oder found an elegant proof that eliminated one of the BNF
 proof obligations. Mamoun Filali-Amine, Gerwin Klein, Andreas Lochbihler,
 Tobias Nipkow, and Christian Sternagel suggested many textual improvements to
 this tutorial.
 \<close>
 
 end
diff --git a/src/HOL/Datatype_Examples/Cyclic_List.thy b/src/HOL/Datatype_Examples/Cyclic_List.thy
new file mode 100644
--- /dev/null
+++ b/src/HOL/Datatype_Examples/Cyclic_List.thy
@@ -0,0 +1,43 @@
+theory Cyclic_List imports
+  "HOL-Library.Confluent_Quotient"
+begin
+
+inductive cyclic1 :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" for xs where
+  "cyclic1 xs (rotate1 xs)"
+
+abbreviation cyclic :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
+  "cyclic \<equiv> equivclp cyclic1"
+
+lemma cyclic_mapI: "cyclic xs ys \<Longrightarrow> cyclic (map f xs) (map f ys)"
+  by(induction rule: equivclp_induct)
+    (auto 4 4 elim!: cyclic1.cases simp add: rotate1_map[symmetric] intro: equivclp_into_equivclp cyclic1.intros)
+
+quotient_type 'a cyclic_list = "'a list" / cyclic by simp
+
+lemma map_respect_cyclic: includes lifting_syntax shows
+  "((=) ===> cyclic ===> cyclic) map map"
+  by(auto simp add: rel_fun_def cyclic_mapI)
+
+lemma confluentp_cyclic1: "confluentp cyclic1"
+  by(intro strong_confluentp_imp_confluentp strong_confluentpI)(auto simp add: cyclic1.simps)
+
+lemma cyclic_set_eq: "cyclic xs ys \<Longrightarrow> set xs = set ys"
+  by(induction rule: converse_equivclp_induct)(simp_all add: cyclic1.simps, safe, simp_all)
+
+lemma retract_cyclic1:
+  assumes "cyclic1 (map f xs) ys"
+  shows "\<exists>zs. cyclic xs zs \<and> ys = map f zs"
+  using assms by(auto simp add: cyclic1.simps rotate1_map intro: cyclic1.intros symclpI1)
+
+lemma confluent_quotient_cyclic1:
+  "confluent_quotient cyclic1 cyclic cyclic cyclic cyclic cyclic (map fst) (map snd) (map fst) (map snd) list_all2 list_all2 list_all2 set set"
+  by(unfold_locales)
+    (auto dest: retract_cyclic1 cyclic_set_eq simp add: list.in_rel list.rel_compp map_respect_cyclic[THEN rel_funD, OF refl] confluentp_cyclic1 intro: rtranclp_mono[THEN predicate2D, OF symclp_greater])
+
+lift_bnf 'a cyclic_list [wits: "[]"]
+  subgoal by(rule confluent_quotient.subdistributivity[OF confluent_quotient_cyclic1])
+  subgoal by(force dest: cyclic_set_eq)
+  subgoal by(auto elim: allE[where x="[]"])
+  done
+
+end
diff --git a/src/HOL/Datatype_Examples/Dlist.thy b/src/HOL/Datatype_Examples/Dlist.thy
new file mode 100644
--- /dev/null
+++ b/src/HOL/Datatype_Examples/Dlist.thy
@@ -0,0 +1,82 @@
+theory Dlist imports
+  "HOL-Library.Confluent_Quotient"
+begin
+
+context begin
+
+qualified definition dlist_eq where "dlist_eq = BNF_Def.vimage2p remdups remdups (=)"
+
+lemma equivp_dlist_eq: "equivp dlist_eq"
+  unfolding dlist_eq_def by(rule equivp_vimage2p)(rule identity_equivp)
+
+quotient_type 'a dlist = "'a list" / dlist_eq
+  by (rule equivp_dlist_eq)
+
+qualified inductive double :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
+  "double (xs @ ys) (xs @ x # ys)" if "x \<in> set ys"
+
+qualified lemma strong_confluentp_double: "strong_confluentp double"
+proof
+  fix xs ys zs :: "'a list"
+  assume ys: "double xs ys" and zs: "double xs zs"
+  consider (left) as y bs z cs where "xs = as @ bs @ cs" "ys = as @ y # bs @ cs" "zs = as @ bs @ z # cs" "y \<in> set (bs @ cs)" "z \<in> set cs"
+    | (right) as y bs z cs where "xs = as @ bs @ cs" "ys = as @ bs @ y # cs" "zs = as @ z # bs @ cs" "y \<in> set cs" "z \<in> set (bs @ cs)"
+  proof -
+    show thesis using ys zs
+      by(clarsimp simp add: double.simps append_eq_append_conv2)(auto intro: that)
+  qed
+  then show "\<exists>us. double\<^sup>*\<^sup>* ys us \<and> double\<^sup>=\<^sup>= zs us"
+  proof cases
+    case left
+    let ?us = "as @ y # bs @ z # cs"
+    have "double ys ?us" "double zs ?us" using left
+      by(auto 4 4 simp add: double.simps)(metis append_Cons append_assoc)+
+    then show ?thesis by blast
+  next
+    case right
+    let ?us = "as @ z # bs @ y # cs"
+    have "double ys ?us" "double zs ?us" using right
+      by(auto 4 4 simp add: double.simps)(metis append_Cons append_assoc)+
+    then show ?thesis by blast
+  qed
+qed
+
+qualified lemma double_Cons1 [simp]: "double xs (x # xs)" if "x \<in> set xs"
+  using double.intros[of x xs "[]"] that by simp
+
+qualified lemma double_Cons_same [simp]: "double xs ys \<Longrightarrow> double (x # xs) (x # ys)"
+  by(auto simp add: double.simps Cons_eq_append_conv)
+
+qualified lemma doubles_Cons_same: "double\<^sup>*\<^sup>* xs ys \<Longrightarrow> double\<^sup>*\<^sup>* (x # xs) (x # ys)"
+  by(induction rule: rtranclp_induct)(auto intro: rtranclp.rtrancl_into_rtrancl)
+
+qualified lemma remdups_into_doubles: "double\<^sup>*\<^sup>* (remdups xs) xs"
+  by(induction xs)(auto intro: doubles_Cons_same rtranclp.rtrancl_into_rtrancl)
+
+qualified lemma dlist_eq_into_doubles: "dlist_eq \<le> equivclp double"
+  by(auto 4 4 simp add: dlist_eq_def vimage2p_def
+     intro: equivclp_trans converse_rtranclp_into_equivclp rtranclp_into_equivclp remdups_into_doubles)
+
+qualified lemma factor_double_map: "double (map f xs) ys \<Longrightarrow> \<exists>zs. dlist_eq xs zs \<and> ys = map f zs"
+  by(auto simp add: double.simps dlist_eq_def vimage2p_def map_eq_append_conv)
+    (metis list.simps(9) map_append remdups.simps(2) remdups_append2)
+
+qualified lemma dlist_eq_set_eq: "dlist_eq xs ys \<Longrightarrow> set xs = set ys"
+  by(simp add: dlist_eq_def vimage2p_def)(metis set_remdups)
+
+qualified lemma dlist_eq_map_respect: "dlist_eq xs ys \<Longrightarrow> dlist_eq (map f xs) (map f ys)"
+  by(clarsimp simp add: dlist_eq_def vimage2p_def)(metis remdups_map_remdups)
+
+qualified lemma confluent_quotient_dlist:
+  "confluent_quotient double dlist_eq dlist_eq dlist_eq dlist_eq dlist_eq (map fst) (map snd) (map fst) (map snd) list_all2 list_all2 list_all2 set set"
+  by(unfold_locales)(auto intro: strong_confluentp_imp_confluentp strong_confluentp_double dest: factor_double_map dlist_eq_into_doubles[THEN predicate2D] dlist_eq_set_eq simp add: list.in_rel list.rel_compp dlist_eq_map_respect equivp_dlist_eq equivp_imp_transp)
+
+lift_bnf 'a dlist [wits: "[]"]
+  subgoal for A B by(rule confluent_quotient.subdistributivity[OF confluent_quotient_dlist])
+  subgoal by(force dest: dlist_eq_set_eq intro: equivp_reflp[OF equivp_dlist_eq])
+  subgoal by(auto simp add: dlist_eq_def vimage2p_def)
+  done
+
+end
+
+end
diff --git a/src/HOL/Datatype_Examples/Free_Idempotent_Monoid.thy b/src/HOL/Datatype_Examples/Free_Idempotent_Monoid.thy
new file mode 100644
--- /dev/null
+++ b/src/HOL/Datatype_Examples/Free_Idempotent_Monoid.thy
@@ -0,0 +1,265 @@
+theory Free_Idempotent_Monoid imports
+  "HOL-Library.Confluent_Quotient"
+begin
+
+inductive cancel1 :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
+where cancel1: "xs \<noteq> [] \<Longrightarrow> cancel1 (gs @ xs @ xs @ gs') (gs @ xs @ gs')"
+
+abbreviation cancel where "cancel \<equiv> cancel1\<^sup>*\<^sup>*"
+
+lemma cancel1_append_same1:
+  assumes "cancel1 xs ys"
+  shows "cancel1 (zs @ xs) (zs @ ys)"
+using assms
+proof cases
+  case (cancel1 ys gs gs')
+  from \<open>ys \<noteq> []\<close> have "cancel1 ((zs @ gs) @ ys @ ys @ gs') ((zs @ gs) @ ys @ gs')" ..
+  with cancel1 show ?thesis by simp
+qed
+
+lemma cancel_append_same1: "cancel (zs @ xs) (zs @ ys)" if "cancel xs ys"
+  using that by induction(blast intro: rtranclp.rtrancl_into_rtrancl cancel1_append_same1)+
+
+lemma cancel1_append_same2: "cancel1 xs ys \<Longrightarrow> cancel1 (xs @ zs) (ys @ zs)"
+by(cases rule: cancel1.cases)(auto intro: cancel1.intros)
+
+lemma cancel_append_same2: "cancel (xs @ zs) (ys @ zs)" if "cancel xs ys"
+  using that by induction(blast intro: rtranclp.rtrancl_into_rtrancl cancel1_append_same2)+
+
+lemma cancel1_same:
+  assumes "xs \<noteq> []"
+  shows "cancel1 (xs @ xs) xs"
+proof -
+  have "cancel1 ([] @ xs @ xs @ []) ([] @ xs @ [])" using assms ..
+  thus ?thesis by simp
+qed
+
+lemma cancel_same: "cancel (xs @ xs) xs"
+  by(cases "xs = []")(auto intro: cancel1_same)
+
+abbreviation (input) eq :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
+where "eq \<equiv> equivclp cancel1"
+
+lemma eq_sym: "eq x y \<Longrightarrow> eq y x"
+  by(rule equivclp_sym)
+
+lemma equivp_eq: "equivp eq" by simp
+
+lemma eq_append_same1: "eq xs' ys' \<Longrightarrow> eq (xs @ xs') (xs @ ys')"
+  by(induction rule: equivclp_induct)(auto intro: cancel1_append_same1 equivclp_into_equivclp)
+
+lemma append_eq_cong: "\<lbrakk>eq xs ys; eq xs' ys'\<rbrakk> \<Longrightarrow> eq (xs @ xs') (ys @ ys')"
+  by(induction rule: equivclp_induct)(auto intro: eq_append_same1 equivclp_into_equivclp cancel1_append_same2)
+
+
+quotient_type 'a fim = "'a list" / eq by simp
+
+instantiation fim :: (type) monoid_add begin
+lift_definition zero_fim :: "'a fim" is "[]" .
+lift_definition plus_fim :: "'a fim \<Rightarrow> 'a fim \<Rightarrow> 'a fim" is "(@)" by(rule append_eq_cong)
+instance by(intro_classes; transfer; simp)
+end
+
+lemma plus_idem_fim [simp]: fixes x :: "'a fim" shows "x + x = x"
+proof transfer
+  fix xs :: "'a list"
+  show "eq (xs @ xs) xs"
+  proof(cases "xs = []")
+    case False thus ?thesis using cancel1_same[of xs] by(auto)
+  qed simp
+qed
+
+
+inductive pcancel1 :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
+  pcancel1: "pcancel1 (concat xss) (concat yss)" if "list_all2 (\<lambda>xs ys. xs = ys \<or> xs = ys @ ys) xss yss"
+
+lemma cancel1_into_pcancel1: "pcancel1 xs ys" if "cancel1 xs ys"
+  using that
+proof cases
+  case (cancel1 xs gs gs')
+  let ?xss = "[gs, xs @ xs, gs']" and ?yss = "[gs, xs, gs']"
+  have "pcancel1 (concat ?xss) (concat ?yss)" by(rule pcancel1.intros) simp
+  then show ?thesis using cancel1 by simp
+qed
+
+lemma pcancel_into_cancel: "cancel1\<^sup>*\<^sup>* xs ys" if "pcancel1 xs ys"
+  using that
+proof cases
+  case (pcancel1 xss yss)
+  from pcancel1(3) show ?thesis unfolding pcancel1(1-2)
+    apply induction
+     apply simp
+    apply(auto intro: cancel_append_same1)
+    apply(rule rtranclp_trans)
+    apply(subst append_assoc[symmetric])
+     apply(rule cancel_append_same2)
+     apply(rule cancel_same)
+    apply(auto intro: cancel_append_same1)
+    done
+qed
+
+lemma pcancel1_cancel1_confluent:
+  assumes "pcancel1 xs ys"
+    and "cancel1 zs ys"
+  shows "\<exists>us. cancel us xs \<and> pcancel1 us zs"
+proof -
+  let ?P = "\<lambda>xs ys. xs = ys \<or> xs = ys @ ys"
+  consider ass as2 bs1 bss bs2 cs1 css ass' as2bs1 bss' bs2cs1 css'
+    where "ys = concat ass @ as2 @ bs1 @ concat bss @ bs2 @ cs1 @ concat css"
+     and "xs = concat ass' @ as2bs1 @ concat bss' @ bs2cs1 @ concat css'"
+     and "zs = concat ass @ as2 @ bs1 @ concat bss @ bs2 @ bs1 @ concat bss @ bs2 @ cs1 @ concat css"
+     and "list_all2 ?P ass' ass"
+     and "list_all2 ?P bss' bss"
+     and "list_all2 ?P css' css"
+     and "?P as2bs1 (as2 @ bs1)"
+     and "?P bs2cs1 (bs2 @ cs1)"
+   | ass as2 bs cs1 css ass' css'
+   where "ys = concat ass @ as2 @ bs @ cs1 @ concat css"
+     and "xs = concat ass' @ as2 @ bs @ cs1 @ as2 @ bs @ cs1 @ concat css'"
+     and "zs = concat ass @ as2 @ bs @ bs @ cs1 @ concat css"
+     and "list_all2 ?P ass' ass"
+     and "list_all2 ?P css' css"
+  proof -
+    from assms obtain xss bs as cs yss
+      where xs: "xs = concat xss" and zs: "zs = as @ bs @ bs @ cs"
+      and xss: "list_all2 (\<lambda>xs ys. xs = ys \<or> xs = ys @ ys) xss yss"
+      and ys: "ys = as @ bs @ cs"
+      and yss: "concat yss = as @ bs @ cs"
+      and bs: "bs \<noteq> []"
+      by(clarsimp simp add: pcancel1.simps cancel1.simps)
+    from yss bs obtain ass as2 BS bcss
+      where yss: "yss = ass @ (as2 @ BS) # bcss"
+       and as: "as = concat ass @ as2"
+       and eq: "bs @ cs = BS @ concat bcss"
+      by(auto simp add: concat_eq_append_conv split: if_split_asm)
+    define bcss' where "bcss' = (if bcss = [] then [[]] else bcss)"
+    have bcss': "bcss' \<noteq> []" by(simp add: bcss'_def)
+    from eq consider us where "bs = BS @ us" "concat bcss = us @ cs" "bcss \<noteq> []" |
+      "BS = bs @ cs" "bcss = []" |
+      us where "BS = bs @ us" "cs = us @ concat bcss"
+      by(cases "bcss = []")(auto simp add: append_eq_append_conv2)
+    then show thesis
+    proof cases
+      case 1
+      from 1(2,3) obtain bss bs2 cs1 css
+        where "bcss = bss @ (bs2 @ cs1) # css"
+          and us: "us = concat bss @ bs2"
+          and cs: "cs = cs1 @ concat css" by(auto simp add: concat_eq_append_conv)
+      with 1 xs xss ys yss zs as that(1)[of ass as2 BS bss bs2 cs1 css] show ?thesis
+        by(clarsimp simp add: list_all2_append2 list_all2_Cons2)
+    next
+      case 2
+      with xs xss ys yss zs as show ?thesis
+        using that(1)[of ass as2 bs "[]" "[]" "[]" "[cs]" _ "as2 @ bs" "[]" "[]" "[cs]"]
+        using that(2)[of ass as2 bs cs "[]"]
+        by(auto simp add: list_all2_append2 list_all2_Cons2)
+    next
+      case 3
+      with xs xss ys yss zs as show ?thesis
+        using that(1)[of ass as2 "[]" "[bs]" "[]" "us" "bcss" _ "as2" "[bs]"] that(2)[of ass as2 bs us bcss]
+        by(auto simp add: list_all2_append2 list_all2_Cons2)
+    qed
+  qed
+  then show ?thesis
+  proof cases
+    case 1
+    let ?us = "concat ass' @ as2bs1 @ concat bss' @ bs2 @ bs1 @ concat bss' @ bs2cs1 @ concat css'"
+    have "?us = concat (ass' @ [as2bs1] @ bss' @ [bs2 @ bs1] @ bss' @ [bs2cs1] @ css')" by simp
+    also have "pcancel1 \<dots> (concat (ass @ [as2 @ bs1] @ bss @ [bs2 @ bs1] @ bss @ [bs2 @ cs1] @ css))"
+      by(rule pcancel1.intros)(use 1 in \<open>simp add: list_all2_appendI\<close>)
+    also have "\<dots> = zs" using 1 by simp
+    also have "cancel ?us xs"
+    proof -
+      define as2b where "as2b = (if as2bs1 = as2 @ bs1 then as2 else as2 @ bs1 @ as2)"
+      have as2bs1: "as2bs1 = as2b @ bs1" using 1 by(auto simp add: as2b_def)
+      define b2cs where "b2cs = (if bs2cs1 = bs2 @ cs1 then cs1 else cs1 @ bs2 @ cs1)"
+      have bs2cs1: "bs2cs1 = bs2 @ b2cs" using 1 by(auto simp add: b2cs_def)
+      have "?us = (concat ass' @ as2b) @ ((bs1 @ concat bss' @ bs2) @ (bs1 @ concat bss' @ bs2)) @ b2cs @ concat css'"
+        by(simp add: as2bs1 bs2cs1)
+      also have "cancel \<dots> ((concat ass' @ as2b) @ (bs1 @ concat bss' @ bs2) @ b2cs @ concat css')"
+        by(rule cancel_append_same1 cancel_append_same2 cancel_same)+
+      also have "\<dots> = xs" using 1 bs2cs1 as2bs1 by simp
+      finally show ?thesis .
+    qed
+    ultimately show ?thesis by blast
+  next
+    case 2
+    let ?us = "concat ass' @ as2 @ bs @ bs @ cs1 @ as2 @ bs @ bs @ cs1 @ concat css'"
+    have "?us = concat (ass' @ [as2 @ bs @ bs @ cs1 @ as2 @ bs @ bs @ cs1] @ css')" by simp
+    also have "pcancel1 \<dots> (concat (ass @ [as2 @ bs @ bs @ cs1] @ css))"
+      by(intro pcancel1.intros list_all2_appendI)(simp_all add: 2)
+    also have "\<dots> = zs" using 2 by simp
+    also have "cancel ?us xs"
+    proof -
+      have "?us = (concat ass' @ as2) @ (bs @ bs) @ cs1 @ as2 @ bs @ bs @ cs1 @ concat css'" by simp
+      also have "cancel \<dots> ((concat ass' @ as2) @ bs @ cs1 @ as2 @ bs @ bs @ cs1 @ concat css')"
+        by(rule cancel_append_same1 cancel_append_same2 cancel_same)+
+      also have "\<dots> = (concat ass' @ as2 @ bs @ cs1 @ as2) @ (bs @ bs) @ cs1 @ concat css'" by simp
+      also have "cancel \<dots> ((concat ass' @ as2 @ bs @ cs1 @ as2) @ bs @ cs1 @ concat css')"
+        by(rule cancel_append_same1 cancel_append_same2 cancel_same)+
+      also have "\<dots> = xs" using 2 by simp
+      finally show ?thesis .
+    qed
+    ultimately show ?thesis by blast
+  qed
+qed
+
+lemma pcancel1_cancel_confluent:
+  assumes "pcancel1 xs ys"
+    and "cancel zs ys"
+  shows "\<exists>us. cancel us xs \<and> pcancel1 us zs"
+  using assms(2,1)
+  by(induction arbitrary: xs)(fastforce elim!: rtranclp_trans dest: pcancel1_cancel1_confluent)+
+
+lemma cancel1_semiconfluent:
+  assumes "cancel1 xs ys"
+    and "cancel zs ys"
+  shows "\<exists>us. cancel us xs \<and> cancel us zs"
+  using pcancel1_cancel_confluent[OF cancel1_into_pcancel1, OF assms]
+  by(blast intro: pcancel_into_cancel)
+
+lemma semiconfluentp_cancel1: "semiconfluentp cancel1\<inverse>\<inverse>"
+  by(auto simp add: semiconfluentp_def rtranclp_conversep dest: cancel1_semiconfluent)
+
+lemma retract_cancel1_aux:
+  assumes "cancel1 ys (map f xs)"
+  shows "\<exists>zs. cancel1 zs xs \<and> ys = map f zs"
+  using assms
+  by cases(fastforce simp add: map_eq_append_conv append_eq_map_conv intro: cancel1.intros)
+
+lemma retract_cancel1:
+  assumes "cancel1 ys (map f xs)"
+  shows "\<exists>zs. eq xs zs \<and> ys = map f zs"
+  using retract_cancel1_aux[OF assms] by(blast intro: symclpI)
+
+lemma cancel1_set_eq:
+  assumes "cancel1 ys xs"
+  shows "set ys = set xs"
+  using assms by cases auto
+
+lemma eq_set_eq: "set xs = set ys" if "eq xs ys"
+  using that by(induction)(auto dest!: cancel1_set_eq elim!: symclpE)
+
+context includes lifting_syntax begin
+lemma map_respect_cancel1: "((=) ===> cancel1 ===> eq) map map"
+  by(auto 4 4 simp add: rel_fun_def cancel1.simps intro: symclpI cancel1.intros)
+
+lemma map_respect_eq: "((=) ===> eq ===> eq) map map"
+  apply(intro rel_funI; hypsubst)
+  subgoal for _ f x y
+    by(induction rule: equivclp_induct)
+      (auto dest: map_respect_cancel1[THEN rel_funD, THEN rel_funD, OF refl] intro: eq_sym equivclp_trans)
+  done
+end
+
+lemma confluent_quotient_fim:
+  "confluent_quotient cancel1\<inverse>\<inverse> eq eq eq eq eq (map fst) (map snd) (map fst) (map snd) list_all2 list_all2 list_all2 set set"
+  by(unfold_locales)(auto dest: retract_cancel1 eq_set_eq simp add: list.in_rel list.rel_compp map_respect_eq[THEN rel_funD, OF refl] semiconfluentp_imp_confluentp semiconfluentp_cancel1)+
+
+lift_bnf 'a fim [wits: "[]"]
+  subgoal for A B by(rule confluent_quotient.subdistributivity[OF confluent_quotient_fim])
+  subgoal by(force dest: eq_set_eq)
+  subgoal by(auto elim: allE[where x="[]"])
+  done
+
+end
diff --git a/src/HOL/Datatype_Examples/LDL.thy b/src/HOL/Datatype_Examples/LDL.thy
new file mode 100644
--- /dev/null
+++ b/src/HOL/Datatype_Examples/LDL.thy
@@ -0,0 +1,339 @@
+theory LDL imports
+  "HOL-Library.Confluent_Quotient"
+begin
+
+datatype 'a rexp = Atom 'a | Alt "'a rexp" "'a rexp" | Conc "'a rexp" "'a rexp" | Star "'a rexp"
+
+inductive ACI (infix "~" 64) where
+  a1: "Alt (Alt r s) t ~ Alt r (Alt s t)"
+| a2: "Alt r (Alt s t) ~ Alt (Alt r s) t"
+| c: "Alt r s ~ Alt s r"
+| i: "r ~ Alt r r"
+| R: "r ~ r"
+| A: "r ~ r' \<Longrightarrow> s ~ s' \<Longrightarrow> Alt r s ~ Alt r' s'"
+| C: "r ~ r' \<Longrightarrow> s ~ s' \<Longrightarrow> Conc r s ~ Conc r' s'"
+| S: "r ~ r' \<Longrightarrow> Star r ~ Star r'"
+
+declare ACI.intros[intro]
+
+abbreviation ACIcl (infix "~~" 64) where "(~~) \<equiv> equivclp (~)"
+
+lemma eq_set_preserves_inter:
+  fixes eq set
+  assumes "\<And>r s. eq r s \<Longrightarrow> set r = set s" and "Ss \<noteq> {}"
+  shows "(\<Inter>As\<in>Ss. {(x, x'). eq x x'} `` {x. set x \<subseteq> As}) \<subseteq> {(x, x'). eq x x'} `` {x. set x \<subseteq> \<Inter> Ss}"
+  using assms by (auto simp: subset_eq) metis
+
+lemma ACI_map_respects:
+  fixes f :: "'a \<Rightarrow> 'b" and r s :: "'a rexp"
+  assumes "r ~ s"
+  shows "map_rexp f r ~ map_rexp f s"
+  using assms by (induct r s rule: ACI.induct) auto
+
+lemma ACIcl_map_respects:
+  fixes f :: "'a \<Rightarrow> 'b" and r s :: "'a rexp"
+  assumes "r ~~ s"
+  shows "map_rexp f r ~~ map_rexp f s"
+  using assms by (induct rule: equivclp_induct) (auto intro: ACI_map_respects equivclp_trans)
+
+lemma ACI_set_eq:
+  fixes r s :: "'a rexp"
+  assumes "r ~ s"
+  shows "set_rexp r = set_rexp s"
+  using assms by (induct r s rule: ACI.induct) auto
+
+lemma ACIcl_set_eq:
+  fixes r s :: "'a rexp"
+  assumes "r ~~ s"
+  shows "set_rexp r = set_rexp s"
+  using assms by (induct rule: equivclp_induct) (auto dest: ACI_set_eq)
+
+lemma Alt_eq_map_rexp_iff:
+  "Alt r s = map_rexp f x \<longleftrightarrow> (\<exists>r' s'. x = Alt r' s' \<and> map_rexp f r' = r \<and> map_rexp f s' = s)"
+  "map_rexp f x = Alt r s \<longleftrightarrow> (\<exists>r' s'. x = Alt r' s' \<and> map_rexp f r' = r \<and> map_rexp f s' = s)"
+  by (cases x; auto)+
+
+lemma Conc_eq_map_rexp_iff:
+  "Conc r s = map_rexp f x \<longleftrightarrow> (\<exists>r' s'. x = Conc r' s' \<and> map_rexp f r' = r \<and> map_rexp f s' = s)"
+  "map_rexp f x = Conc r s \<longleftrightarrow> (\<exists>r' s'. x = Conc r' s' \<and> map_rexp f r' = r \<and> map_rexp f s' = s)"
+  by (cases x; auto)+
+
+lemma Star_eq_map_rexp_iff:
+  "Star r = map_rexp f x \<longleftrightarrow> (\<exists>r'. x = Star r' \<and> map_rexp f r' = r)"
+  "map_rexp f x = Star r \<longleftrightarrow> (\<exists>r'. x = Star r' \<and> map_rexp f r' = r)"
+  by (cases x; auto)+
+
+lemma AA: "r ~~ r' \<Longrightarrow> s ~~ s' \<Longrightarrow> Alt r s ~~ Alt r' s'"
+proof (induct rule: equivclp_induct)
+  case base
+  then show ?case
+    by (induct rule: equivclp_induct) (auto elim!: equivclp_trans)
+next
+  case (step s t)
+  then show ?case
+    by (auto elim!: equivclp_trans)
+qed
+
+lemma AAA: "(~)\<^sup>*\<^sup>* r  r' \<Longrightarrow> (~)\<^sup>*\<^sup>* s s' \<Longrightarrow> (~)\<^sup>*\<^sup>* (Alt r s) (Alt r' s')"
+proof (induct r r' rule: rtranclp.induct)
+  case (rtrancl_refl r)
+  then show ?case
+    by (induct s s' rule: rtranclp.induct)
+      (auto elim!: rtranclp.rtrancl_into_rtrancl)
+next
+  case (rtrancl_into_rtrancl a b c)
+  then show ?case
+    by (auto elim!: rtranclp.rtrancl_into_rtrancl)
+qed
+
+lemma CC: "r ~~ r' \<Longrightarrow> s ~~ s' \<Longrightarrow> Conc r s ~~ Conc r' s'"
+proof (induct rule: equivclp_induct)
+  case base
+  then show ?case
+    by (induct rule: equivclp_induct) (auto elim!: equivclp_trans)
+next
+  case (step s t)
+  then show ?case
+    by (auto elim!: equivclp_trans)
+qed
+
+lemma CCC: "(~)\<^sup>*\<^sup>* r r' \<Longrightarrow> (~)\<^sup>*\<^sup>* s s' \<Longrightarrow> (~)\<^sup>*\<^sup>* (Conc r s) (Conc r' s')"
+proof (induct r r' rule: rtranclp.induct)
+  case (rtrancl_refl r)
+  then show ?case
+    by (induct s s' rule: rtranclp.induct)
+      (auto elim!: rtranclp.rtrancl_into_rtrancl)
+next
+  case (rtrancl_into_rtrancl a b c)
+  then show ?case
+    by (auto elim!: rtranclp.rtrancl_into_rtrancl)
+qed
+
+lemma SS: "r ~~ r' \<Longrightarrow> Star r ~~ Star r'"
+proof (induct rule: equivclp_induct)
+  case (step s t)
+  then show ?case
+    by (auto elim!: equivclp_trans)
+qed auto
+
+lemma SSS: "(~)\<^sup>*\<^sup>* r r' \<Longrightarrow> (~)\<^sup>*\<^sup>* (Star r) (Star r')"
+proof (induct r r' rule: rtranclp.induct)
+  case (rtrancl_into_rtrancl a b c)
+  then show ?case
+    by (auto elim!: rtranclp.rtrancl_into_rtrancl)
+qed auto
+
+lemma map_rexp_ACI_inv: "map_rexp f x ~ y \<Longrightarrow> \<exists>z. x ~~ z \<and> y = map_rexp f z"
+proof (induct "map_rexp f x" y arbitrary: x rule: ACI.induct)
+  case (a1 r s t)
+  then obtain r' s' t' where "x = Alt (Alt r' s') t'"
+    "map_rexp f r' = r" "map_rexp f s' = s" "map_rexp f t' = t"
+    by (auto simp: Alt_eq_map_rexp_iff)
+  then show ?case
+    by (intro exI[of _ "Alt r' (Alt s' t')"]) auto
+next
+  case (a2 r s t)
+  then obtain r' s' t' where "x = Alt r' (Alt s' t')"
+    "map_rexp f r' = r" "map_rexp f s' = s" "map_rexp f t' = t"
+    by (auto simp: Alt_eq_map_rexp_iff)
+  then show ?case
+    by (intro exI[of _ "Alt (Alt r' s') t'"]) auto
+next
+  case (c r s)
+  then obtain r' s' where "x = Alt r' s'"
+    "map_rexp f r' = r" "map_rexp f s' = s"
+    by (auto simp: Alt_eq_map_rexp_iff)
+  then show ?case
+    by (intro exI[of _ "Alt s' r'"]) auto
+next
+  case (i r)
+  then show ?case
+    by (intro exI[of _ "Alt r r"]) auto
+next
+  case (R r)
+  then show ?case by (auto intro: exI[of _ r])
+next
+  case (A r rr s ss)
+  then obtain r' s' where "x = Alt r' s'"
+    "map_rexp f r' = r" "map_rexp f s' = s"
+    by (auto simp: Alt_eq_map_rexp_iff)
+  moreover from A(2)[OF this(2)[symmetric]] A(4)[OF this(3)[symmetric]] obtain rr' ss' where
+    "r' ~~ rr'" "rr = map_rexp f rr'" "s' ~~ ss'" "ss = map_rexp f ss'"
+    by blast
+  ultimately show ?case using A(1,3)
+    by (intro exI[of _ "Alt rr' ss'"]) (auto intro!: AA)
+next
+  case (C r rr s ss)
+  then obtain r' s' where "x = Conc r' s'"
+    "map_rexp f r' = r" "map_rexp f s' = s"
+    by (auto simp: Conc_eq_map_rexp_iff)
+  moreover from C(2)[OF this(2)[symmetric]] C(4)[OF this(3)[symmetric]] obtain rr' ss' where
+    "r' ~~ rr'" "rr = map_rexp f rr'" "s' ~~ ss'" "ss = map_rexp f ss'"
+    by blast
+  ultimately show ?case using C(1,3)
+    by (intro exI[of _ "Conc rr' ss'"]) (auto intro!: CC)
+next
+  case (S r rr)
+  then obtain r' where "x = Star r'" "map_rexp f r' = r"
+    by (auto simp: Star_eq_map_rexp_iff)
+  moreover from S(2)[OF this(2)[symmetric]] obtain rr' where "r' ~~ rr'" "rr = map_rexp f rr'"
+    by blast
+  ultimately show ?case
+    by (intro exI[of _ "Star rr'"]) (auto intro!: SS)
+qed
+
+lemma reflclp_ACI: "(~)\<^sup>=\<^sup>= = (~)"
+  unfolding fun_eq_iff
+  by auto
+
+lemma strong_confluentp_ACI: "strong_confluentp (~)"
+  apply (rule strong_confluentpI, unfold reflclp_ACI)
+  subgoal for x y z
+  proof (induct x y arbitrary: z rule: ACI.induct)
+    case (a1 r s t)
+    then show ?case
+      by (auto intro: AAA converse_rtranclp_into_rtranclp)
+  next
+    case (a2 r s t)
+    then show ?case
+      by (auto intro: AAA converse_rtranclp_into_rtranclp)
+  next
+    case (c r s)
+    then show ?case
+      by (cases rule: ACI.cases) (auto intro: AAA)
+  next
+    case (i r)
+    then show ?case
+      by (auto intro: AAA)
+  next
+    case (R r)
+    then show ?case
+      by auto
+  next
+    note A1 = ACI.A[OF _ R]
+    note A2 = ACI.A[OF R]
+    case (A r r' s s')
+    from A(5,1-4) show ?case
+    proof (cases rule: ACI.cases)
+      case inner: (a1 r'' s'')
+      from A(1,3) show ?thesis
+        unfolding inner
+      proof (elim ACI.cases[of _ r'], goal_cases Xa1 Xa2 XC XI XR XP XT XS)
+        case (Xa1 rr ss tt)
+        with A(3) show ?case
+          by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A2[OF A2]], rotated])
+            (metis a1 a2 A1 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
+      next
+        case (Xa2 r s t)
+        then show ?case
+          by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A2[OF A2]], rotated])
+            (metis a1 A1 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
+      next
+        case (XC r s)
+        then show ?case
+          by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A2[OF A2]], rotated])
+            (metis a1 c A1 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
+      next
+        case (XI r)
+        then show ?case
+          apply (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ ACI.A[OF i ACI.A[OF i]]], rotated])
+          apply hypsubst
+          apply (rule converse_rtranclp_into_rtranclp, rule a1)
+          apply (rule converse_rtranclp_into_rtranclp, rule a1)
+          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a2)
+          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule A1, rule c)
+          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a1)
+          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a1)
+          apply (rule converse_rtranclp_into_rtranclp, rule a2)
+          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a2)
+          apply blast
+          done
+      qed auto
+    next
+      case inner: (a2 s'' t'')
+      with A(1,3) show ?thesis
+        unfolding inner
+      proof (elim ACI.cases[of _ s'], goal_cases Xa1 Xa2 XC XI XR XP XT XS)
+        case (Xa1 rr ss tt)
+        with A(3) show ?case
+          by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A1[OF A1]], rotated])
+            (metis a2 A2 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
+      next
+        case (Xa2 r s t)
+        then show ?case
+          by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A1[OF A1]], rotated])
+            (metis a1 a2 A2 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
+      next
+        case (XC r s)
+        then show ?case
+          by (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ A1[OF A1]], rotated])
+            (metis a2 c A2 r_into_rtranclp rtranclp.rtrancl_into_rtrancl)
+      next
+        case (XI r)
+        then show ?case
+          apply (elim exI[where P = "\<lambda>x. _ x \<and> _ ~ x", OF conjI[OF _ ACI.A[OF ACI.A[OF _ i] i]], rotated])
+          apply hypsubst
+          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a2)
+          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule A1, rule c)
+          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a1)
+          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule A2, rule a1)
+          apply (rule converse_rtranclp_into_rtranclp, rule A2, rule a2)
+          apply (rule converse_rtranclp_into_rtranclp, rule a2)
+          apply blast
+          done
+      qed auto
+    qed (auto 5 0 intro: AAA)
+  next
+    case (C r r' s s')
+    from C(5,1-4) show ?case
+      by (cases rule: ACI.cases) (auto 5 0 intro: CCC)
+  next
+    case (S r r')
+    from S(3,1,2) show ?case
+      by (cases rule: ACI.cases) (auto intro: SSS)
+  qed
+  done
+
+lemma confluent_quotient_ACI:
+  "confluent_quotient (~) (~~) (~~) (~~) (~~) (~~)
+     (map_rexp fst) (map_rexp snd) (map_rexp fst) (map_rexp snd)
+     rel_rexp rel_rexp rel_rexp set_rexp set_rexp"
+  by unfold_locales (auto dest: ACIcl_set_eq simp: rexp.in_rel rexp.rel_compp map_rexp_ACI_inv
+      intro: equivpI reflpI sympI transpI ACIcl_map_respects
+      strong_confluentp_imp_confluentp[OF strong_confluentp_ACI])
+
+inductive ACIEQ (infix "\<approx>" 64) where
+  a: "Alt (Alt r s) t \<approx> Alt r (Alt s t)"
+| c: "Alt r s \<approx> Alt s r"
+| i: "Alt r r \<approx> r"
+| A: "r \<approx> r' \<Longrightarrow> s \<approx> s' \<Longrightarrow> Alt r s \<approx> Alt r' s'"
+| C: "r \<approx> r' \<Longrightarrow> s \<approx> s' \<Longrightarrow> Conc r s \<approx> Conc r' s'"
+| S: "r \<approx> r' \<Longrightarrow> Star r \<approx> Star r'"
+| r: "r \<approx> r"
+| s: "r \<approx> s \<Longrightarrow> s \<approx> r"
+| t: "r \<approx> s \<Longrightarrow> s \<approx> t \<Longrightarrow> r \<approx> t"
+
+lemma ACIEQ_le_ACIcl: "r \<approx> s \<Longrightarrow> r ~~ s"
+  by (induct r s rule: ACIEQ.induct) (auto intro: AA CC SS equivclp_sym equivclp_trans)
+
+lemma ACI_le_ACIEQ: "r ~ s \<Longrightarrow> r \<approx> s"
+  by (induct r s rule: ACI.induct) (auto intro: ACIEQ.intros)
+
+lemma ACIcl_le_ACIEQ: "r ~~ s \<Longrightarrow> r \<approx> s"
+  by (induct rule: equivclp_induct) (auto 0 3 intro: ACIEQ.intros ACI_le_ACIEQ)
+
+lemma ACIEQ_alt: "(\<approx>) = (~~)"
+  by (simp add: ACIEQ_le_ACIcl ACIcl_le_ACIEQ antisym predicate2I)
+
+quotient_type 'a ACI_rexp = "'a rexp" / "(\<approx>)"
+  unfolding ACIEQ_alt by (auto intro!: equivpI reflpI sympI transpI)
+
+lift_bnf (no_warn_wits) 'a ACI_rexp
+  unfolding ACIEQ_alt
+  subgoal for A Q by (rule confluent_quotient.subdistributivity[OF confluent_quotient_ACI])
+  subgoal for Ss by (intro eq_set_preserves_inter[rotated] ACIcl_set_eq; auto)
+  done
+
+datatype ldl = Prop string | And ldl ldl | Not ldl | Match "ldl ACI_rexp"
+
+end
\ No newline at end of file
diff --git a/src/HOL/Equiv_Relations.thy b/src/HOL/Equiv_Relations.thy
--- a/src/HOL/Equiv_Relations.thy
+++ b/src/HOL/Equiv_Relations.thy
@@ -1,489 +1,588 @@
 (*  Title:      HOL/Equiv_Relations.thy
     Author:     Lawrence C Paulson, 1996 Cambridge University Computer Laboratory
 *)
 
 section \<open>Equivalence Relations in Higher-Order Set Theory\<close>
 
 theory Equiv_Relations
   imports Groups_Big
 begin
 
 subsection \<open>Equivalence relations -- set version\<close>
 
 definition equiv :: "'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> bool"
   where "equiv A r \<longleftrightarrow> refl_on A r \<and> sym r \<and> trans r"
 
 lemma equivI: "refl_on A r \<Longrightarrow> sym r \<Longrightarrow> trans r \<Longrightarrow> equiv A r"
   by (simp add: equiv_def)
 
 lemma equivE:
   assumes "equiv A r"
   obtains "refl_on A r" and "sym r" and "trans r"
   using assms by (simp add: equiv_def)
 
 text \<open>
   Suppes, Theorem 70: \<open>r\<close> is an equiv relation iff \<open>r\<inverse> O r = r\<close>.
 
   First half: \<open>equiv A r \<Longrightarrow> r\<inverse> O r = r\<close>.
 \<close>
 
 lemma sym_trans_comp_subset: "sym r \<Longrightarrow> trans r \<Longrightarrow> r\<inverse> O r \<subseteq> r"
   unfolding trans_def sym_def converse_unfold by blast
 
 lemma refl_on_comp_subset: "refl_on A r \<Longrightarrow> r \<subseteq> r\<inverse> O r"
   unfolding refl_on_def by blast
 
 lemma equiv_comp_eq: "equiv A r \<Longrightarrow> r\<inverse> O r = r"
   apply (unfold equiv_def)
   apply clarify
   apply (rule equalityI)
    apply (iprover intro: sym_trans_comp_subset refl_on_comp_subset)+
   done
 
 text \<open>Second half.\<close>
 
 lemma comp_equivI: "r\<inverse> O r = r \<Longrightarrow> Domain r = A \<Longrightarrow> equiv A r"
   apply (unfold equiv_def refl_on_def sym_def trans_def)
   apply (erule equalityE)
   apply (subgoal_tac "\<forall>x y. (x, y) \<in> r \<longrightarrow> (y, x) \<in> r")
    apply fast
   apply fast
   done
 
 
 subsection \<open>Equivalence classes\<close>
 
 lemma equiv_class_subset: "equiv A r \<Longrightarrow> (a, b) \<in> r \<Longrightarrow> r``{a} \<subseteq> r``{b}"
   \<comment> \<open>lemma for the next result\<close>
   unfolding equiv_def trans_def sym_def by blast
 
 theorem equiv_class_eq: "equiv A r \<Longrightarrow> (a, b) \<in> r \<Longrightarrow> r``{a} = r``{b}"
   apply (assumption | rule equalityI equiv_class_subset)+
   apply (unfold equiv_def sym_def)
   apply blast
   done
 
 lemma equiv_class_self: "equiv A r \<Longrightarrow> a \<in> A \<Longrightarrow> a \<in> r``{a}"
   unfolding equiv_def refl_on_def by blast
 
 lemma subset_equiv_class: "equiv A r \<Longrightarrow> r``{b} \<subseteq> r``{a} \<Longrightarrow> b \<in> A \<Longrightarrow> (a, b) \<in> r"
   \<comment> \<open>lemma for the next result\<close>
   unfolding equiv_def refl_on_def by blast
 
 lemma eq_equiv_class: "r``{a} = r``{b} \<Longrightarrow> equiv A r \<Longrightarrow> b \<in> A \<Longrightarrow> (a, b) \<in> r"
   by (iprover intro: equalityD2 subset_equiv_class)
 
 lemma equiv_class_nondisjoint: "equiv A r \<Longrightarrow> x \<in> (r``{a} \<inter> r``{b}) \<Longrightarrow> (a, b) \<in> r"
   unfolding equiv_def trans_def sym_def by blast
 
 lemma equiv_type: "equiv A r \<Longrightarrow> r \<subseteq> A \<times> A"
   unfolding equiv_def refl_on_def by blast
 
 lemma equiv_class_eq_iff: "equiv A r \<Longrightarrow> (x, y) \<in> r \<longleftrightarrow> r``{x} = r``{y} \<and> x \<in> A \<and> y \<in> A"
   by (blast intro!: equiv_class_eq dest: eq_equiv_class equiv_type)
 
 lemma eq_equiv_class_iff: "equiv A r \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> r``{x} = r``{y} \<longleftrightarrow> (x, y) \<in> r"
   by (blast intro!: equiv_class_eq dest: eq_equiv_class equiv_type)
 
 
 subsection \<open>Quotients\<close>
 
 definition quotient :: "'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> 'a set set"  (infixl "'/'/" 90)
   where "A//r = (\<Union>x \<in> A. {r``{x}})"  \<comment> \<open>set of equiv classes\<close>
 
 lemma quotientI: "x \<in> A ==> r``{x} \<in> A//r"
   unfolding quotient_def by blast
 
 lemma quotientE: "X \<in> A//r \<Longrightarrow> (\<And>x. X = r``{x} \<Longrightarrow> x \<in> A \<Longrightarrow> P) \<Longrightarrow> P"
   unfolding quotient_def by blast
 
 lemma Union_quotient: "equiv A r \<Longrightarrow> \<Union>(A//r) = A"
   unfolding equiv_def refl_on_def quotient_def by blast
 
 lemma quotient_disj: "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> Y \<in> A//r \<Longrightarrow> X = Y \<or> X \<inter> Y = {}"
   apply (unfold quotient_def)
   apply clarify
   apply (rule equiv_class_eq)
    apply assumption
   apply (unfold equiv_def trans_def sym_def)
   apply blast
   done
 
 lemma quotient_eqI:
   "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> Y \<in> A//r \<Longrightarrow> x \<in> X \<Longrightarrow> y \<in> Y \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> X = Y"
   apply (clarify elim!: quotientE)
   apply (rule equiv_class_eq)
    apply assumption
   apply (unfold equiv_def sym_def trans_def)
   apply blast
   done
 
 lemma quotient_eq_iff:
   "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> Y \<in> A//r \<Longrightarrow> x \<in> X \<Longrightarrow> y \<in> Y \<Longrightarrow> X = Y \<longleftrightarrow> (x, y) \<in> r"
   apply (rule iffI)
    prefer 2
    apply (blast del: equalityI intro: quotient_eqI)
   apply (clarify elim!: quotientE)
   apply (unfold equiv_def sym_def trans_def)
   apply blast
   done
 
 lemma eq_equiv_class_iff2: "equiv A r \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> {x}//r = {y}//r \<longleftrightarrow> (x, y) \<in> r"
   by (simp add: quotient_def eq_equiv_class_iff)
 
 lemma quotient_empty [simp]: "{}//r = {}"
   by (simp add: quotient_def)
 
 lemma quotient_is_empty [iff]: "A//r = {} \<longleftrightarrow> A = {}"
   by (simp add: quotient_def)
 
 lemma quotient_is_empty2 [iff]: "{} = A//r \<longleftrightarrow> A = {}"
   by (simp add: quotient_def)
 
 lemma singleton_quotient: "{x}//r = {r `` {x}}"
   by (simp add: quotient_def)
 
 lemma quotient_diff1: "inj_on (\<lambda>a. {a}//r) A \<Longrightarrow> a \<in> A \<Longrightarrow> (A - {a})//r = A//r - {a}//r"
   unfolding quotient_def inj_on_def by blast
 
 
 subsection \<open>Refinement of one equivalence relation WRT another\<close>
 
 lemma refines_equiv_class_eq: "R \<subseteq> S \<Longrightarrow> equiv A R \<Longrightarrow> equiv A S \<Longrightarrow> R``(S``{a}) = S``{a}"
   by (auto simp: equiv_class_eq_iff)
 
 lemma refines_equiv_class_eq2: "R \<subseteq> S \<Longrightarrow> equiv A R \<Longrightarrow> equiv A S \<Longrightarrow> S``(R``{a}) = S``{a}"
   by (auto simp: equiv_class_eq_iff)
 
 lemma refines_equiv_image_eq: "R \<subseteq> S \<Longrightarrow> equiv A R \<Longrightarrow> equiv A S \<Longrightarrow> (\<lambda>X. S``X) ` (A//R) = A//S"
    by (auto simp: quotient_def image_UN refines_equiv_class_eq2)
 
 lemma finite_refines_finite:
   "finite (A//R) \<Longrightarrow> R \<subseteq> S \<Longrightarrow> equiv A R \<Longrightarrow> equiv A S \<Longrightarrow> finite (A//S)"
   by (erule finite_surj [where f = "\<lambda>X. S``X"]) (simp add: refines_equiv_image_eq)
 
 lemma finite_refines_card_le:
   "finite (A//R) \<Longrightarrow> R \<subseteq> S \<Longrightarrow> equiv A R \<Longrightarrow> equiv A S \<Longrightarrow> card (A//S) \<le> card (A//R)"
   by (subst refines_equiv_image_eq [of R S A, symmetric])
     (auto simp: card_image_le [where f = "\<lambda>X. S``X"])
 
 
 subsection \<open>Defining unary operations upon equivalence classes\<close>
 
 text \<open>A congruence-preserving function.\<close>
 
 definition congruent :: "('a \<times> 'a) set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
   where "congruent r f \<longleftrightarrow> (\<forall>(y, z) \<in> r. f y = f z)"
 
 lemma congruentI: "(\<And>y z. (y, z) \<in> r \<Longrightarrow> f y = f z) \<Longrightarrow> congruent r f"
   by (auto simp add: congruent_def)
 
 lemma congruentD: "congruent r f \<Longrightarrow> (y, z) \<in> r \<Longrightarrow> f y = f z"
   by (auto simp add: congruent_def)
 
 abbreviation RESPECTS :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> bool"  (infixr "respects" 80)
   where "f respects r \<equiv> congruent r f"
 
 
 lemma UN_constant_eq: "a \<in> A \<Longrightarrow> \<forall>y \<in> A. f y = c \<Longrightarrow> (\<Union>y \<in> A. f y) = c"
   \<comment> \<open>lemma required to prove \<open>UN_equiv_class\<close>\<close>
   by auto
 
 lemma UN_equiv_class: "equiv A r \<Longrightarrow> f respects r \<Longrightarrow> a \<in> A \<Longrightarrow> (\<Union>x \<in> r``{a}. f x) = f a"
   \<comment> \<open>Conversion rule\<close>
   apply (rule equiv_class_self [THEN UN_constant_eq])
     apply assumption
    apply assumption
   apply (unfold equiv_def congruent_def sym_def)
   apply (blast del: equalityI)
   done
 
 lemma UN_equiv_class_type:
   "equiv A r \<Longrightarrow> f respects r \<Longrightarrow> X \<in> A//r \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> f x \<in> B) \<Longrightarrow> (\<Union>x \<in> X. f x) \<in> B"
   apply (unfold quotient_def)
   apply clarify
   apply (subst UN_equiv_class)
      apply auto
   done
 
 text \<open>
   Sufficient conditions for injectiveness.  Could weaken premises!
   major premise could be an inclusion; \<open>bcong\<close> could be
   \<open>\<And>y. y \<in> A \<Longrightarrow> f y \<in> B\<close>.
 \<close>
 
 lemma UN_equiv_class_inject:
   "equiv A r \<Longrightarrow> f respects r \<Longrightarrow>
     (\<Union>x \<in> X. f x) = (\<Union>y \<in> Y. f y) \<Longrightarrow> X \<in> A//r ==> Y \<in> A//r
     \<Longrightarrow> (\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> f x = f y \<Longrightarrow> (x, y) \<in> r)
     \<Longrightarrow> X = Y"
   apply (unfold quotient_def)
   apply clarify
   apply (rule equiv_class_eq)
    apply assumption
   apply (subgoal_tac "f x = f xa")
    apply blast
   apply (erule box_equals)
    apply (assumption | rule UN_equiv_class)+
   done
 
 
 subsection \<open>Defining binary operations upon equivalence classes\<close>
 
 text \<open>A congruence-preserving function of two arguments.\<close>
 
 definition congruent2 :: "('a \<times> 'a) set \<Rightarrow> ('b \<times> 'b) set \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> bool"
   where "congruent2 r1 r2 f \<longleftrightarrow> (\<forall>(y1, z1) \<in> r1. \<forall>(y2, z2) \<in> r2. f y1 y2 = f z1 z2)"
 
 lemma congruent2I':
   assumes "\<And>y1 z1 y2 z2. (y1, z1) \<in> r1 \<Longrightarrow> (y2, z2) \<in> r2 \<Longrightarrow> f y1 y2 = f z1 z2"
   shows "congruent2 r1 r2 f"
   using assms by (auto simp add: congruent2_def)
 
 lemma congruent2D: "congruent2 r1 r2 f \<Longrightarrow> (y1, z1) \<in> r1 \<Longrightarrow> (y2, z2) \<in> r2 \<Longrightarrow> f y1 y2 = f z1 z2"
   by (auto simp add: congruent2_def)
 
 text \<open>Abbreviation for the common case where the relations are identical.\<close>
 abbreviation RESPECTS2:: "('a \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> bool"  (infixr "respects2" 80)
   where "f respects2 r \<equiv> congruent2 r r f"
 
 
 lemma congruent2_implies_congruent:
   "equiv A r1 \<Longrightarrow> congruent2 r1 r2 f \<Longrightarrow> a \<in> A \<Longrightarrow> congruent r2 (f a)"
   unfolding congruent_def congruent2_def equiv_def refl_on_def by blast
 
 lemma congruent2_implies_congruent_UN:
   "equiv A1 r1 \<Longrightarrow> equiv A2 r2 \<Longrightarrow> congruent2 r1 r2 f \<Longrightarrow> a \<in> A2 \<Longrightarrow>
     congruent r1 (\<lambda>x1. \<Union>x2 \<in> r2``{a}. f x1 x2)"
   apply (unfold congruent_def)
   apply clarify
   apply (rule equiv_type [THEN subsetD, THEN SigmaE2], assumption+)
   apply (simp add: UN_equiv_class congruent2_implies_congruent)
   apply (unfold congruent2_def equiv_def refl_on_def)
   apply (blast del: equalityI)
   done
 
 lemma UN_equiv_class2:
   "equiv A1 r1 \<Longrightarrow> equiv A2 r2 \<Longrightarrow> congruent2 r1 r2 f \<Longrightarrow> a1 \<in> A1 \<Longrightarrow> a2 \<in> A2 \<Longrightarrow>
     (\<Union>x1 \<in> r1``{a1}. \<Union>x2 \<in> r2``{a2}. f x1 x2) = f a1 a2"
   by (simp add: UN_equiv_class congruent2_implies_congruent congruent2_implies_congruent_UN)
 
 lemma UN_equiv_class_type2:
   "equiv A1 r1 \<Longrightarrow> equiv A2 r2 \<Longrightarrow> congruent2 r1 r2 f
     \<Longrightarrow> X1 \<in> A1//r1 \<Longrightarrow> X2 \<in> A2//r2
     \<Longrightarrow> (\<And>x1 x2. x1 \<in> A1 \<Longrightarrow> x2 \<in> A2 \<Longrightarrow> f x1 x2 \<in> B)
     \<Longrightarrow> (\<Union>x1 \<in> X1. \<Union>x2 \<in> X2. f x1 x2) \<in> B"
   apply (unfold quotient_def)
   apply clarify
   apply (blast intro: UN_equiv_class_type congruent2_implies_congruent_UN
       congruent2_implies_congruent quotientI)
   done
 
 lemma UN_UN_split_split_eq:
   "(\<Union>(x1, x2) \<in> X. \<Union>(y1, y2) \<in> Y. A x1 x2 y1 y2) =
     (\<Union>x \<in> X. \<Union>y \<in> Y. (\<lambda>(x1, x2). (\<lambda>(y1, y2). A x1 x2 y1 y2) y) x)"
   \<comment> \<open>Allows a natural expression of binary operators,\<close>
   \<comment> \<open>without explicit calls to \<open>split\<close>\<close>
   by auto
 
 lemma congruent2I:
   "equiv A1 r1 \<Longrightarrow> equiv A2 r2
     \<Longrightarrow> (\<And>y z w. w \<in> A2 \<Longrightarrow> (y,z) \<in> r1 \<Longrightarrow> f y w = f z w)
     \<Longrightarrow> (\<And>y z w. w \<in> A1 \<Longrightarrow> (y,z) \<in> r2 \<Longrightarrow> f w y = f w z)
     \<Longrightarrow> congruent2 r1 r2 f"
   \<comment> \<open>Suggested by John Harrison -- the two subproofs may be\<close>
   \<comment> \<open>\<^emph>\<open>much\<close> simpler than the direct proof.\<close>
   apply (unfold congruent2_def equiv_def refl_on_def)
   apply clarify
   apply (blast intro: trans)
   done
 
 lemma congruent2_commuteI:
   assumes equivA: "equiv A r"
     and commute: "\<And>y z. y \<in> A \<Longrightarrow> z \<in> A \<Longrightarrow> f y z = f z y"
     and congt: "\<And>y z w. w \<in> A \<Longrightarrow> (y,z) \<in> r \<Longrightarrow> f w y = f w z"
   shows "f respects2 r"
   apply (rule congruent2I [OF equivA equivA])
    apply (rule commute [THEN trans])
      apply (rule_tac [3] commute [THEN trans, symmetric])
        apply (rule_tac [5] sym)
        apply (rule congt | assumption |
          erule equivA [THEN equiv_type, THEN subsetD, THEN SigmaE2])+
   done
 
 
 subsection \<open>Quotients and finiteness\<close>
 
 text \<open>Suggested by Florian Kammüller\<close>
 
 lemma finite_quotient: "finite A \<Longrightarrow> r \<subseteq> A \<times> A \<Longrightarrow> finite (A//r)"
   \<comment> \<open>recall @{thm equiv_type}\<close>
   apply (rule finite_subset)
    apply (erule_tac [2] finite_Pow_iff [THEN iffD2])
   apply (unfold quotient_def)
   apply blast
   done
 
 lemma finite_equiv_class: "finite A \<Longrightarrow> r \<subseteq> A \<times> A \<Longrightarrow> X \<in> A//r \<Longrightarrow> finite X"
   apply (unfold quotient_def)
   apply (rule finite_subset)
    prefer 2 apply assumption
   apply blast
   done
 
 lemma equiv_imp_dvd_card: "finite A \<Longrightarrow> equiv A r \<Longrightarrow> \<forall>X \<in> A//r. k dvd card X \<Longrightarrow> k dvd card A"
   apply (rule Union_quotient [THEN subst [where P="\<lambda>A. k dvd card A"]])
    apply assumption
   apply (rule dvd_partition)
     prefer 3 apply (blast dest: quotient_disj)
    apply (simp_all add: Union_quotient equiv_type)
   done
 
 lemma card_quotient_disjoint: "finite A \<Longrightarrow> inj_on (\<lambda>x. {x} // r) A \<Longrightarrow> card (A//r) = card A"
   apply (simp add:quotient_def)
   apply (subst card_UN_disjoint)
      apply assumption
     apply simp
    apply (fastforce simp add:inj_on_def)
   apply simp
   done
 
 
 subsection \<open>Projection\<close>
 
 definition proj :: "('b \<times> 'a) set \<Rightarrow> 'b \<Rightarrow> 'a set"
   where "proj r x = r `` {x}"
 
 lemma proj_preserves: "x \<in> A \<Longrightarrow> proj r x \<in> A//r"
   unfolding proj_def by (rule quotientI)
 
 lemma proj_in_iff:
   assumes "equiv A r"
   shows "proj r x \<in> A//r \<longleftrightarrow> x \<in> A"
     (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume ?rhs
   then show ?lhs by (simp add: proj_preserves)
 next
   assume ?lhs
   then show ?rhs
     unfolding proj_def quotient_def
   proof clarsimp
     fix y
     assume y: "y \<in> A" and "r `` {x} = r `` {y}"
     moreover have "y \<in> r `` {y}"
       using assms y unfolding equiv_def refl_on_def by blast
     ultimately have "(x, y) \<in> r" by blast
     then show "x \<in> A"
       using assms unfolding equiv_def refl_on_def by blast
   qed
 qed
 
 lemma proj_iff: "equiv A r \<Longrightarrow> {x, y} \<subseteq> A \<Longrightarrow> proj r x = proj r y \<longleftrightarrow> (x, y) \<in> r"
   by (simp add: proj_def eq_equiv_class_iff)
 
 (*
 lemma in_proj: "\<lbrakk>equiv A r; x \<in> A\<rbrakk> \<Longrightarrow> x \<in> proj r x"
 unfolding proj_def equiv_def refl_on_def by blast
 *)
 
 lemma proj_image: "proj r ` A = A//r"
   unfolding proj_def[abs_def] quotient_def by blast
 
 lemma in_quotient_imp_non_empty: "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> X \<noteq> {}"
   unfolding quotient_def using equiv_class_self by fast
 
 lemma in_quotient_imp_in_rel: "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> {x, y} \<subseteq> X \<Longrightarrow> (x, y) \<in> r"
   using quotient_eq_iff[THEN iffD1] by fastforce
 
 lemma in_quotient_imp_closed: "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> x \<in> X \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> y \<in> X"
   unfolding quotient_def equiv_def trans_def by blast
 
 lemma in_quotient_imp_subset: "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> X \<subseteq> A"
   using in_quotient_imp_in_rel equiv_type by fastforce
 
 
 subsection \<open>Equivalence relations -- predicate version\<close>
 
 text \<open>Partial equivalences.\<close>
 
 definition part_equivp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
   where "part_equivp R \<longleftrightarrow> (\<exists>x. R x x) \<and> (\<forall>x y. R x y \<longleftrightarrow> R x x \<and> R y y \<and> R x = R y)"
     \<comment> \<open>John-Harrison-style characterization\<close>
 
 lemma part_equivpI: "\<exists>x. R x x \<Longrightarrow> symp R \<Longrightarrow> transp R \<Longrightarrow> part_equivp R"
   by (auto simp add: part_equivp_def) (auto elim: sympE transpE)
 
 lemma part_equivpE:
   assumes "part_equivp R"
   obtains x where "R x x" and "symp R" and "transp R"
 proof -
   from assms have 1: "\<exists>x. R x x"
     and 2: "\<And>x y. R x y \<longleftrightarrow> R x x \<and> R y y \<and> R x = R y"
     unfolding part_equivp_def by blast+
   from 1 obtain x where "R x x" ..
   moreover have "symp R"
   proof (rule sympI)
     fix x y
     assume "R x y"
     with 2 [of x y] show "R y x" by auto
   qed
   moreover have "transp R"
   proof (rule transpI)
     fix x y z
     assume "R x y" and "R y z"
     with 2 [of x y] 2 [of y z] show "R x z" by auto
   qed
   ultimately show thesis by (rule that)
 qed
 
 lemma part_equivp_refl_symp_transp: "part_equivp R \<longleftrightarrow> (\<exists>x. R x x) \<and> symp R \<and> transp R"
   by (auto intro: part_equivpI elim: part_equivpE)
 
 lemma part_equivp_symp: "part_equivp R \<Longrightarrow> R x y \<Longrightarrow> R y x"
   by (erule part_equivpE, erule sympE)
 
 lemma part_equivp_transp: "part_equivp R \<Longrightarrow> R x y \<Longrightarrow> R y z \<Longrightarrow> R x z"
   by (erule part_equivpE, erule transpE)
 
 lemma part_equivp_typedef: "part_equivp R \<Longrightarrow> \<exists>d. d \<in> {c. \<exists>x. R x x \<and> c = Collect (R x)}"
   by (auto elim: part_equivpE)
 
 
 text \<open>Total equivalences.\<close>
 
 definition equivp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
   where "equivp R \<longleftrightarrow> (\<forall>x y. R x y = (R x = R y))" \<comment> \<open>John-Harrison-style characterization\<close>
 
 lemma equivpI: "reflp R \<Longrightarrow> symp R \<Longrightarrow> transp R \<Longrightarrow> equivp R"
   by (auto elim: reflpE sympE transpE simp add: equivp_def)
 
 lemma equivpE:
   assumes "equivp R"
   obtains "reflp R" and "symp R" and "transp R"
   using assms by (auto intro!: that reflpI sympI transpI simp add: equivp_def)
 
 lemma equivp_implies_part_equivp: "equivp R \<Longrightarrow> part_equivp R"
   by (auto intro: part_equivpI elim: equivpE reflpE)
 
 lemma equivp_equiv: "equiv UNIV A \<longleftrightarrow> equivp (\<lambda>x y. (x, y) \<in> A)"
   by (auto intro!: equivI equivpI [to_set] elim!: equivE equivpE [to_set])
 
 lemma equivp_reflp_symp_transp: "equivp R \<longleftrightarrow> reflp R \<and> symp R \<and> transp R"
   by (auto intro: equivpI elim: equivpE)
 
 lemma identity_equivp: "equivp (=)"
   by (auto intro: equivpI reflpI sympI transpI)
 
 lemma equivp_reflp: "equivp R \<Longrightarrow> R x x"
   by (erule equivpE, erule reflpE)
 
 lemma equivp_symp: "equivp R \<Longrightarrow> R x y \<Longrightarrow> R y x"
   by (erule equivpE, erule sympE)
 
 lemma equivp_transp: "equivp R \<Longrightarrow> R x y \<Longrightarrow> R y z \<Longrightarrow> R x z"
   by (erule equivpE, erule transpE)
 
+lemma equivp_rtranclp: "symp r \<Longrightarrow> equivp r\<^sup>*\<^sup>*"
+  by(intro equivpI reflpI sympI transpI)(auto dest: sympD[OF symp_rtranclp])
+
+lemmas equivp_rtranclp_symclp [simp] = equivp_rtranclp[OF symp_symclp]
+
+lemma equivp_vimage2p: "equivp R \<Longrightarrow> equivp (vimage2p f f R)"
+  by(auto simp add: equivp_def vimage2p_def dest: fun_cong)
+
+lemma equivp_imp_transp: "equivp R \<Longrightarrow> transp R"
+  by(simp add: equivp_reflp_symp_transp)
+
+
+subsection \<open>Equivalence closure\<close>
+
+definition equivclp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
+  "equivclp r = (symclp r)\<^sup>*\<^sup>*"
+
+lemma transp_equivclp [simp]: "transp (equivclp r)"
+  by(simp add: equivclp_def)
+
+lemma reflp_equivclp [simp]: "reflp (equivclp r)"
+  by(simp add: equivclp_def)
+
+lemma symp_equivclp [simp]: "symp (equivclp r)"
+  by(simp add: equivclp_def)
+
+lemma equivp_evquivclp [simp]: "equivp (equivclp r)"
+  by(simp add: equivpI)
+
+lemma tranclp_equivclp [simp]: "(equivclp r)\<^sup>+\<^sup>+ = equivclp r"
+  by(simp add: equivclp_def)
+
+lemma rtranclp_equivclp [simp]: "(equivclp r)\<^sup>*\<^sup>* = equivclp r"
+  by(simp add: equivclp_def)
+
+lemma symclp_equivclp [simp]: "symclp (equivclp r) = equivclp r"
+  by(simp add: equivclp_def symp_symclp_eq)
+
+lemma equivclp_symclp [simp]: "equivclp (symclp r) = equivclp r"
+  by(simp add: equivclp_def)
+
+lemma equivclp_conversep [simp]: "equivclp (conversep r) = equivclp r"
+  by(simp add: equivclp_def)
+
+lemma equivclp_sym [sym]: "equivclp r x y \<Longrightarrow> equivclp r y x"
+  by(rule sympD[OF symp_equivclp])
+
+lemma equivclp_OO_equivclp_le_equivclp: "equivclp r OO equivclp r \<le> equivclp r"
+  by(rule transp_relcompp_less_eq transp_equivclp)+
+
+lemma rtranlcp_le_equivclp: "r\<^sup>*\<^sup>* \<le> equivclp r"
+  unfolding equivclp_def by(rule rtranclp_mono)(simp add: symclp_pointfree)
+
+lemma rtranclp_conversep_le_equivclp: "r\<inverse>\<inverse>\<^sup>*\<^sup>* \<le> equivclp r"
+  unfolding equivclp_def by(rule rtranclp_mono)(simp add: symclp_pointfree)
+
+lemma symclp_rtranclp_le_equivclp: "symclp r\<^sup>*\<^sup>* \<le> equivclp r"
+  unfolding symclp_pointfree
+  by(rule le_supI)(simp_all add: rtranclp_conversep[symmetric] rtranlcp_le_equivclp rtranclp_conversep_le_equivclp)
+
+lemma r_OO_conversep_into_equivclp:
+  "r\<^sup>*\<^sup>* OO r\<inverse>\<inverse>\<^sup>*\<^sup>* \<le> equivclp r"
+  by(blast intro: order_trans[OF _ equivclp_OO_equivclp_le_equivclp] relcompp_mono rtranlcp_le_equivclp rtranclp_conversep_le_equivclp del: predicate2I)
+
+lemma equivclp_induct [consumes 1, case_names base step, induct pred: equivclp]:
+  assumes a: "equivclp r a b"
+    and cases: "P a" "\<And>y z. equivclp r a y \<Longrightarrow> r y z \<or> r z y \<Longrightarrow> P y \<Longrightarrow> P z"
+  shows "P b"
+  using a unfolding equivclp_def
+  by(induction rule: rtranclp_induct; fold equivclp_def; blast intro: cases elim: symclpE)
+
+lemma converse_equivclp_induct [consumes 1, case_names base step]:
+  assumes major: "equivclp r a b"
+    and cases: "P b" "\<And>y z. r y z \<or> r z y \<Longrightarrow> equivclp r z b \<Longrightarrow> P z \<Longrightarrow> P y"
+  shows "P a"
+  using major unfolding equivclp_def
+  by(induction rule: converse_rtranclp_induct; fold equivclp_def; blast intro: cases elim: symclpE)
+
+lemma equivclp_refl [simp]: "equivclp r x x"
+  by(rule reflpD[OF reflp_equivclp])
+
+lemma r_into_equivclp [intro]: "r x y \<Longrightarrow> equivclp r x y"
+  unfolding equivclp_def by(blast intro: symclpI)
+
+lemma converse_r_into_equivclp [intro]: "r y x \<Longrightarrow> equivclp r x y"
+  unfolding equivclp_def by(blast intro: symclpI)
+
+lemma rtranclp_into_equivclp: "r\<^sup>*\<^sup>* x y \<Longrightarrow> equivclp r x y"
+  using rtranlcp_le_equivclp[of r] by blast
+
+lemma converse_rtranclp_into_equivclp: "r\<^sup>*\<^sup>* y x \<Longrightarrow> equivclp r x y"
+  by(blast intro: equivclp_sym rtranclp_into_equivclp)
+
+lemma equivclp_into_equivclp: "\<lbrakk> equivclp r a b; r b c \<or> r c b \<rbrakk> \<Longrightarrow> equivclp r a c"
+  unfolding equivclp_def by(erule rtranclp.rtrancl_into_rtrancl)(auto intro: symclpI)
+
+lemma equivclp_trans [trans]: "\<lbrakk> equivclp r a b; equivclp r b c \<rbrakk> \<Longrightarrow> equivclp r a c"
+  using equivclp_OO_equivclp_le_equivclp[of r] by blast
+
 hide_const (open) proj
 
 end
diff --git a/src/HOL/Library/Confluence.thy b/src/HOL/Library/Confluence.thy
new file mode 100644
--- /dev/null
+++ b/src/HOL/Library/Confluence.thy
@@ -0,0 +1,77 @@
+theory Confluence imports
+  Main
+begin
+
+section \<open>Confluence\<close>
+
+definition semiconfluentp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
+  "semiconfluentp r \<longleftrightarrow> r\<inverse>\<inverse> OO r\<^sup>*\<^sup>* \<le> r\<^sup>*\<^sup>* OO r\<inverse>\<inverse>\<^sup>*\<^sup>*"
+
+definition confluentp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
+  "confluentp r \<longleftrightarrow> r\<inverse>\<inverse>\<^sup>*\<^sup>* OO r\<^sup>*\<^sup>* \<le> r\<^sup>*\<^sup>* OO r\<inverse>\<inverse>\<^sup>*\<^sup>*"
+
+definition strong_confluentp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
+  "strong_confluentp r \<longleftrightarrow> r\<inverse>\<inverse> OO r \<le> r\<^sup>*\<^sup>* OO (r\<inverse>\<inverse>)\<^sup>=\<^sup>="
+
+lemma semiconfluentpI [intro?]:
+  "semiconfluentp r" if "\<And>x y z. \<lbrakk> r x y; r\<^sup>*\<^sup>* x z \<rbrakk> \<Longrightarrow> \<exists>u. r\<^sup>*\<^sup>* y u \<and> r\<^sup>*\<^sup>* z u"
+  using that unfolding semiconfluentp_def rtranclp_conversep by blast
+
+lemma semiconfluentpD: "\<exists>u. r\<^sup>*\<^sup>* y u \<and> r\<^sup>*\<^sup>* z u" if "semiconfluentp r" "r x y" "r\<^sup>*\<^sup>* x z"
+  using that unfolding semiconfluentp_def rtranclp_conversep by blast
+
+lemma confluentpI:
+  "confluentp r" if "\<And>x y z. \<lbrakk> r\<^sup>*\<^sup>* x y; r\<^sup>*\<^sup>* x z \<rbrakk> \<Longrightarrow> \<exists>u. r\<^sup>*\<^sup>* y u \<and> r\<^sup>*\<^sup>* z u"
+  using that unfolding confluentp_def rtranclp_conversep by blast
+
+lemma confluentpD: "\<exists>u. r\<^sup>*\<^sup>* y u \<and> r\<^sup>*\<^sup>* z u" if "confluentp r" "r\<^sup>*\<^sup>* x y" "r\<^sup>*\<^sup>* x z"
+  using that unfolding confluentp_def rtranclp_conversep by blast
+
+lemma strong_confluentpI [intro?]:
+  "strong_confluentp r" if "\<And>x y z. \<lbrakk> r x y; r x z \<rbrakk> \<Longrightarrow> \<exists>u. r\<^sup>*\<^sup>* y u \<and> r\<^sup>=\<^sup>= z u"
+  using that unfolding strong_confluentp_def by blast
+
+lemma strong_confluentpD: "\<exists>u. r\<^sup>*\<^sup>* y u \<and> r\<^sup>=\<^sup>= z u" if "strong_confluentp r" "r x y" "r x z"
+  using that unfolding strong_confluentp_def by blast
+
+lemma semiconfluentp_imp_confluentp: "confluentp r" if r: "semiconfluentp r"
+proof(rule confluentpI)
+  show "\<exists>u. r\<^sup>*\<^sup>* y u \<and> r\<^sup>*\<^sup>* z u" if "r\<^sup>*\<^sup>* x y" "r\<^sup>*\<^sup>* x z" for x y z
+    using that(2,1)
+    by(induction arbitrary: y rule: converse_rtranclp_induct)
+      (blast intro: rtranclp_trans dest:  r[THEN semiconfluentpD])+
+qed
+
+lemma confluentp_imp_semiconfluentp: "semiconfluentp r" if "confluentp r"
+  using that by(auto intro!: semiconfluentpI dest: confluentpD[OF that])
+
+lemma confluentp_eq_semiconfluentp: "confluentp r \<longleftrightarrow> semiconfluentp r"
+  by(blast intro: semiconfluentp_imp_confluentp confluentp_imp_semiconfluentp)
+
+lemma confluentp_conv_strong_confluentp_rtranclp:
+  "confluentp r \<longleftrightarrow> strong_confluentp (r\<^sup>*\<^sup>*)"
+  by(auto simp add: confluentp_def strong_confluentp_def rtranclp_conversep)
+
+lemma strong_confluentp_into_semiconfluentp:
+  "semiconfluentp r" if r: "strong_confluentp r"
+proof
+  show "\<exists>u. r\<^sup>*\<^sup>* y u \<and> r\<^sup>*\<^sup>* z u" if "r x y" "r\<^sup>*\<^sup>* x z" for x y z
+    using that(2,1)
+    apply(induction arbitrary: y rule: converse_rtranclp_induct)
+    subgoal by blast
+    subgoal for a b c
+      by (drule (1) strong_confluentpD[OF r, of a c])(auto 10 0 intro: rtranclp_trans)
+    done
+qed
+
+lemma strong_confluentp_imp_confluentp: "confluentp r" if "strong_confluentp r"
+  unfolding confluentp_eq_semiconfluentp using that by(rule strong_confluentp_into_semiconfluentp)
+
+lemma semiconfluentp_equivclp: "equivclp r = r\<^sup>*\<^sup>* OO r\<inverse>\<inverse>\<^sup>*\<^sup>*" if r: "semiconfluentp r"
+proof(rule antisym[rotated] r_OO_conversep_into_equivclp predicate2I)+
+  show "(r\<^sup>*\<^sup>* OO r\<inverse>\<inverse>\<^sup>*\<^sup>*) x y" if "equivclp r x y" for x y using that unfolding equivclp_def rtranclp_conversep
+    by(induction rule: converse_rtranclp_induct)
+      (blast elim!: symclpE intro: converse_rtranclp_into_rtranclp rtranclp_trans dest: semiconfluentpD[OF r])+
+qed
+
+end
\ No newline at end of file
diff --git a/src/HOL/Library/Confluent_Quotient.thy b/src/HOL/Library/Confluent_Quotient.thy
new file mode 100644
--- /dev/null
+++ b/src/HOL/Library/Confluent_Quotient.thy
@@ -0,0 +1,74 @@
+theory Confluent_Quotient imports 
+  Confluence
+begin
+
+section \<open>Subdistributivity for quotients via confluence\<close>
+
+locale confluent_quotient =
+  fixes R :: "'Fb \<Rightarrow> 'Fb \<Rightarrow> bool"
+    and Ea :: "'Fa \<Rightarrow> 'Fa \<Rightarrow> bool"
+    and Eb :: "'Fb \<Rightarrow> 'Fb \<Rightarrow> bool"
+    and Ec :: "'Fc \<Rightarrow> 'Fc \<Rightarrow> bool"
+    and Eab :: "'Fab \<Rightarrow> 'Fab \<Rightarrow> bool"
+    and Ebc :: "'Fbc \<Rightarrow> 'Fbc \<Rightarrow> bool"
+    and \<pi>_Faba :: "'Fab \<Rightarrow> 'Fa"
+    and \<pi>_Fabb :: "'Fab \<Rightarrow> 'Fb"
+    and \<pi>_Fbcb :: "'Fbc \<Rightarrow> 'Fb"
+    and \<pi>_Fbcc :: "'Fbc \<Rightarrow> 'Fc"
+    and rel_Fab :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'Fa \<Rightarrow> 'Fb \<Rightarrow> bool"
+    and rel_Fbc :: "('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> 'Fb \<Rightarrow> 'Fc \<Rightarrow> bool"
+    and rel_Fac :: "('a \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> 'Fa \<Rightarrow> 'Fc \<Rightarrow> bool"
+    and set_Fab :: "'Fab \<Rightarrow> ('a \<times> 'b) set"
+    and set_Fbc :: "'Fbc \<Rightarrow> ('b \<times> 'c) set"
+  assumes confluent: "confluentp R"
+    and retract1_ab: "\<And>x y. R (\<pi>_Fabb x) y \<Longrightarrow> \<exists>z. Eab x z \<and> y = \<pi>_Fabb z"
+    and retract1_bc: "\<And>x y. R (\<pi>_Fbcb x) y \<Longrightarrow> \<exists>z. Ebc x z \<and> y = \<pi>_Fbcb z"
+    and generated: "Eb \<le> equivclp R"
+    and set_ab: "\<And>x y. Eab x y \<Longrightarrow> set_Fab x = set_Fab y"
+    and set_bc: "\<And>x y. Ebc x y \<Longrightarrow> set_Fbc x = set_Fbc y"
+    and transp_a: "transp Ea"
+    and transp_c: "transp Ec"
+    and equivp_ab: "equivp Eab"
+    and equivp_bc: "equivp Ebc"
+    and in_rel_Fab: "\<And>A x y. rel_Fab A x y \<longleftrightarrow> (\<exists>z. z \<in> {x. set_Fab x \<subseteq> {(x, y). A x y}} \<and> \<pi>_Faba z = x \<and> \<pi>_Fabb z = y)"
+    and in_rel_Fbc: "\<And>B x y. rel_Fbc B x y \<longleftrightarrow> (\<exists>z. z \<in> {x. set_Fbc x \<subseteq> {(x, y). B x y}} \<and> \<pi>_Fbcb z = x \<and> \<pi>_Fbcc z = y)"
+    and rel_compp: "\<And>A B. rel_Fac (A OO B) = rel_Fab A OO rel_Fbc B"
+    and \<pi>_Faba_respect: "rel_fun Eab Ea \<pi>_Faba \<pi>_Faba"
+    and \<pi>_Fbcc_respect: "rel_fun Ebc Ec \<pi>_Fbcc \<pi>_Fbcc"
+begin
+
+lemma retract_ab: "R\<^sup>*\<^sup>* (\<pi>_Fabb x) y \<Longrightarrow> \<exists>z. Eab x z \<and> y = \<pi>_Fabb z"
+  by(induction rule: rtranclp_induct)(blast dest: retract1_ab intro: equivp_transp[OF equivp_ab] equivp_reflp[OF equivp_ab])+
+
+lemma retract_bc: "R\<^sup>*\<^sup>* (\<pi>_Fbcb x) y \<Longrightarrow> \<exists>z. Ebc x z \<and> y = \<pi>_Fbcb z"
+  by(induction rule: rtranclp_induct)(blast dest: retract1_bc intro: equivp_transp[OF equivp_bc] equivp_reflp[OF equivp_bc])+
+
+lemma subdistributivity: "rel_Fab A OO Eb OO rel_Fbc B \<le> Ea OO rel_Fac (A OO B) OO Ec"
+proof(rule predicate2I; elim relcomppE)
+  fix x y y' z
+  assume "rel_Fab A x y" and "Eb y y'" and "rel_Fbc B y' z"
+  then obtain xy y'z
+    where xy: "set_Fab xy \<subseteq> {(a, b). A a b}" "x = \<pi>_Faba xy" "y = \<pi>_Fabb xy"
+      and y'z: "set_Fbc y'z \<subseteq> {(a, b). B a b}" "y' = \<pi>_Fbcb y'z" "z = \<pi>_Fbcc y'z"
+    by(auto simp add: in_rel_Fab in_rel_Fbc)
+  from \<open>Eb y y'\<close> have "equivclp R y y'" using generated by blast
+  then obtain u where u: "R\<^sup>*\<^sup>* y u" "R\<^sup>*\<^sup>* y' u"
+    unfolding semiconfluentp_equivclp[OF confluent[THEN confluentp_imp_semiconfluentp]]
+    by(auto simp add: rtranclp_conversep)
+  with xy y'z obtain xy' y'z'
+    where retract1: "Eab xy xy'" "\<pi>_Fabb xy' = u"
+      and retract2: "Ebc y'z y'z'" "\<pi>_Fbcb y'z' = u"
+    by(auto dest!: retract_ab retract_bc)
+  from retract1(1) xy have "Ea x (\<pi>_Faba xy')" by(auto dest: \<pi>_Faba_respect[THEN rel_funD])
+  moreover have "rel_Fab A (\<pi>_Faba xy') u" using xy retract1
+    by(auto simp add: in_rel_Fab dest: set_ab)
+  moreover have "rel_Fbc B u (\<pi>_Fbcc y'z')" using y'z retract2
+    by(auto simp add: in_rel_Fbc dest: set_bc)
+  moreover have "Ec (\<pi>_Fbcc y'z') z" using retract2 y'z equivp_symp[OF equivp_bc]
+    by(auto dest: \<pi>_Fbcc_respect[THEN rel_funD])
+  ultimately show "(Ea OO rel_Fac (A OO B) OO Ec) x z" unfolding rel_compp by blast
+qed
+
+end
+
+end
\ No newline at end of file
diff --git a/src/HOL/Library/Library.thy b/src/HOL/Library/Library.thy
--- a/src/HOL/Library/Library.thy
+++ b/src/HOL/Library/Library.thy
@@ -1,101 +1,103 @@
 (*<*)
 theory Library
 imports
   AList
   Adhoc_Overloading
   BigO
   BNF_Axiomatization
   BNF_Corec
   Boolean_Algebra
   Bourbaki_Witt_Fixpoint
   Char_ord
   Code_Lazy
   Code_Test
   Combine_PER
   Complete_Partial_Order2
   Conditional_Parametricity
+  Confluence
+  Confluent_Quotient
   Countable
   Countable_Complete_Lattices
   Countable_Set_Type
   Debug
   Diagonal_Subsequence
   Discrete
   Disjoint_Sets
   Dlist
   Dual_Ordered_Lattice
   Equipollence
   Extended
   Extended_Nat
   Extended_Nonnegative_Real
   Extended_Real
   Finite_Map
   Float
   FSet
   FuncSet
   Function_Division
   Fun_Lexorder
   Going_To_Filter
   Groups_Big_Fun
   Indicator_Function
   Infinite_Set
   Interval
   Interval_Float
   IArray
   Landau_Symbols
   Lattice_Algebras
   Lattice_Syntax
   Lattice_Constructions
   Linear_Temporal_Logic_on_Streams
   ListVector
   Lub_Glb
   Mapping
   Monad_Syntax
   More_List
   Multiset_Order
   Multiset_Permutations
   Nonpos_Ints
   Numeral_Type
   Omega_Words_Fun
   Open_State_Syntax
   Option_ord
   Order_Continuity
   Parallel
   Pattern_Aliases
   Periodic_Fun
   Perm
   Permutation
   Permutations
   Poly_Mapping
   Power_By_Squaring
   Preorder
   Product_Plus
   Quadratic_Discriminant
   Quotient_List
   Quotient_Option
   Quotient_Product
   Quotient_Set
   Quotient_Sum
   Quotient_Syntax
   Quotient_Type
   Ramsey
   Reflection
   Rewrite
   Saturated
   Set_Algebras
   Set_Idioms
   State_Monad
   Stirling
   Stream
   Sorting_Algorithms
   Sublist
   Sum_of_Squares
   Transitive_Closure_Table
   Tree_Multiset
   Tree_Real
   Type_Length
   Uprod
   While_Combinator
   Z2
 begin
 end
 (*>*)
diff --git a/src/HOL/List.thy b/src/HOL/List.thy
--- a/src/HOL/List.thy
+++ b/src/HOL/List.thy
@@ -1,7521 +1,7566 @@
 (*  Title:      HOL/List.thy
     Author:     Tobias Nipkow; proofs tidied by LCP
 *)
 
 section \<open>The datatype of finite lists\<close>
 
 theory List
 imports Sledgehammer Code_Numeral 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"
 
 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 "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 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)"
 
 (* FIXME: define sorted in terms of sorted_wrt *)
 
 text \<open>A class-based sorted predicate:\<close>
 
 context linorder
 begin
 
 fun sorted :: "'a list \<Rightarrow> bool" where
 "sorted [] = True" |
 "sorted (x # ys) = ((\<forall>y \<in> set ys. x \<le> y) \<and> sorted ys)"
 
 lemma sorted_sorted_wrt: "sorted = sorted_wrt (\<le>)"
 proof (rule ext)
   fix xs show "sorted xs = sorted_wrt (\<le>) xs"
     by(induction xs rule: sorted.induct) auto
 qed
 
 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)"
 
 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
 
 lemma Nil_tl: "[] = tl xs \<longleftrightarrow> xs = [] \<or> (\<exists>x. xs = [x])"
 by (cases xs) auto
 
 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
 
 lemma Suc_length_conv:
   "(Suc n = length xs) = (\<exists>y ys. xs = y # ys \<and> length ys = n)"
   by (induct xs; simp; blast)
 
 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 ==> 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
 
 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 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>\<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
 
 lemma Nil_is_append_conv [iff]: "([] = xs @ ys) = (xs = [] \<and> ys = [])"
 by (induct xs) auto
 
 lemma append_self_conv [iff]: "(xs @ ys = xs) = (ys = [])"
 by (induct xs) auto
 
 lemma self_append_conv [iff]: "(xs = xs @ ys) = (ys = [])"
 by (induct xs) auto
 
 lemma append_eq_append_conv [simp]:
   "length xs = length ys \<or> length us = length vs
   ==> (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
 
 lemma self_append_conv2 [iff]: "(ys = xs @ ys) = (xs = [])"
 using append_same_eq [of "[]"] by auto
 
 lemma hd_Cons_tl: "xs \<noteq> [] ==> 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> [] ==> 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> [] ==> tl (xs @ ys) = tl xs @ ys"
 by (simp add: tl_append split: list.split)
 
 
 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, hide_lams) append_Cons append_Nil list.sel(1))
 
 text \<open>Trivial rules for solving \<open>@\<close>-equations automatically.\<close>
 
 lemma eq_Nil_appendI: "xs = ys ==> xs = [] @ ys"
 by simp
 
 lemma Cons_eq_appendI:
 "[| x # xs1 = ys; xs = xs1 @ zs |] ==> x # xs = ys @ zs"
 by (drule sym) simp
 
 lemma append_eq_appendI:
 "[| xs @ xs1 = zs; ys = xs1 @ us |] ==> xs @ ys = zs @ us"
 by (drule sym) simp
 
 
 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
 \<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) ==> 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 (cases xs) auto
 
 lemma Nil_is_map_conv [iff]: "([] = map f xs) = (xs = [])"
 by (cases xs) auto
 
 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 ==> inj f ==> 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 ==> inj (map f)"
 by (iprover dest: map_injective injD intro: inj_onI)
 
 lemma inj_mapD: "inj (map f) ==> inj f"
   by (metis (no_types, hide_lams) 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
 
 lemma Nil_is_rev_conv [iff]: "([] = rev xs) = (xs = [])"
 by (induct xs) auto
 
 lemma rev_singleton_conv [simp]: "(rev xs = [x]) = (xs = [x])"
 by (cases xs) auto
 
 lemma singleton_rev_conv [simp]: "([x] = rev xs) = (xs = [x])"
 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]:
   "[| P []; !!x xs. P xs ==> P (xs @ [x]) |] ==> P xs"
 apply(simplesubst rev_rev_ident[symmetric])
 apply(rule_tac list = "rev xs" in list.induct, simp_all)
 done
 
 lemma rev_exhaust [case_names Nil snoc]:
   "(xs = [] ==> P) ==>(!!ys y. xs = ys @ [y] ==> P) ==> 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
 
 
 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
 
 lemma set_empty2[iff]: "({} = set xs) = (xs = [])"
 by(induct xs) auto
 
 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>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 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 ==> filter P xs = xs"
 by (induct xs) auto
 
 lemma filter_False [simp]: "\<forall>x \<in> set xs. \<not> P x ==> 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
 
 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) 
+      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)
 
 lemma Cons_eq_filter_iff:
   "(x#xs = filter P ys) =
   (\<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:Cons_eq_filterD)
 
 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>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
 
 lemma Nil_eq_concat_conv [simp]: "([] = concat xss) = (\<forall>xs \<in> set xss. xs = [])"
   by (induct xss) auto
 
 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 filter_concat: "filter p (concat xs) = concat (map (filter p) xs)"
   by (induct xs) auto
 
 lemma rev_concat: "rev (concat xs) = concat (map rev (rev xs))"
   by (induct xs) auto
 
 lemma concat_eq_concat_iff: "\<forall>(x, y) \<in> set (zip xs ys). length x = length y ==> length xs = length ys ==> (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 ==> length xs = length ys ==> \<forall>(x, y) \<in> set (zip xs ys). length x = length y ==> 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)
+
 
 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 ==> (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 
+  show ?case
   proof (cases ys)
     case (Cons y ys)
     then show ?thesis
       using Cons.hyps by fastforce
   qed simp
 qed force
 
 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==> (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 ==> (xs[i:=x])!i = x"
   by (simp add: nth_list_update)
 
 lemma nth_list_update_neq [simp]: "i \<noteq> j ==> 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 ==> (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 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: "xs \<noteq> [] \<Longrightarrow> hd(rev xs) = last xs"
   by(rule rev_exhaust[of xs]) simp_all
 
 lemma last_rev: "xs \<noteq> [] \<Longrightarrow> last(rev xs) = hd xs"
   by(cases xs) simp_all
 
 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 ==> take n xs = xs"
   by (induct n arbitrary: xs) (auto, case_tac xs, auto)
 
 lemma drop_all [simp]: "length xs \<le> n ==> drop n xs = []"
   by (induct n arbitrary: xs) (auto, case_tac xs, auto)
 
 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_eq_Nil[simp]: "(take n xs = []) = (n = 0 \<or> xs = [])"
   by(induct xs arbitrary: n)(auto simp: take_Cons split:nat.split)
 
 lemma drop_eq_Nil[simp]: "(drop n xs = []) = (length xs \<le> n)"
   by (induct xs arbitrary: n) (auto simp: drop_Cons split:nat.split)
 
 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 ==> (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 ==> (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 ==> butlast (take n xs) = take (n - 1) xs"
   by (simp add: butlast_conv_take min.absorb1 min.absorb2)
 
 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 ==> take n (butlast xs) = take n xs"
   by (simp add: butlast_conv_take min.absorb1)
 
 lemma drop_butlast: "drop n (butlast xs) = butlast (drop n xs)"
   by (simp add: butlast_conv_take drop_take ac_simps)
 
 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
+
+lemma append_eq_map_conv:
+  "ys @ zs = map f xs \<longleftrightarrow> (\<exists>us vs. xs = us @ vs \<and> ys = map f us \<and> zs = map f vs)"
+by (metis map_eq_append_conv)
+
 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: 
+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(auto simp: set_conv_nth image_def) (metis Suc_le_eq nth_take order_trans)
 
 
 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_tail: "\<not> P x \<Longrightarrow> takeWhile P (xs @ (x#l)) = takeWhile P xs"
   by (induct 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 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)) ==> 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_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 distinct_takeWhile[simp]: "distinct xs ==> distinct (takeWhile P xs)"
   by (induct xs) (auto dest: set_takeWhileD)
 
 lemma distinct_dropWhile[simp]: "distinct xs ==> 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]:
   "[| length xs = length us |] ==>
   zip (xs@ys) (us@vs) = zip xs us @ zip ys vs"
   by (simp add: zip_append1)
 
 lemma zip_rev:
   "length xs = length ys ==> 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]:
   "[| i < length xs; i < length ys|] ==> (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:
   "zip xs ys = [] \<longleftrightarrow> xs = [] \<or> ys = []"
   by (cases xs; cases ys) simp_all
 
 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 simp add: zip_eq_Nil_iff)
     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 simp add: zip_eq_Nil_iff dest: sym)
     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
 
 
 subsubsection \<open>\<^const>\<open>list_all2\<close>\<close>
 
 lemma list_all2_lengthD [intro?]:
   "list_all2 P xs ys ==> 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 ==> P2 b c ==> P3 a c"
   shows "!!bs cs. list_all2 P1 as bs ==> list_all2 P2 bs cs ==> 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) fold_set_fold_remdups:
   "Finite_Set.fold f y (set xs) = fold f (remdups xs) y"
   by (rule sym, induct xs arbitrary: y) (simp_all add: fold_fun_left_comm insert_absorb)
 
 lemma (in comp_fun_idem) fold_set_fold:
   "Finite_Set.fold f y (set xs) = fold f xs y"
   by (rule sym, induct xs arbitrary: y) (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 ==> [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 ==> [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 ==> [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 ==> [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 ==> [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 ==> 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 ==> (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) ==> 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')
 
 
 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)
 
 lemma upto_Nil2[simp]: "[] = [i..j] \<longleftrightarrow> j < i"
 by (simp add: upto.simps)
 
 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"
   apply(induction i j arbitrary: k rule: upto.induct)
 apply(subst upto_rec1)
 apply(auto simp add: nth_Cons')
 done
 
-lemma upto_split1: 
+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: 
+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>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 ==> 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)
 
 lemma remdups_eq_nil_right_iff [simp]: "([] = remdups x) = (x = [])"
 by (induct x, auto)
 
 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 ==> 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]"
 apply(induct i j rule:upto.induct)
 apply(subst upto.simps)
 apply(simp)
 done
 
 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
     then show ?thesis
-      using d anot \<open>i < length xs\<close> 
+      using d anot \<open>i < length xs\<close>
       apply (simp add: upd_conv_take_nth_drop)
       by (metis disjoint_insert(1) distinct_append id_take_nth_drop set_simps(2))
   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>It is best to avoid this 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 split: nat.split_asm)
     apply (metis Suc_less_eq2 in_set_conv_nth less_not_refl zero_less_Suc)+
     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
 apply 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 ==> card (set xs) = size xs"
 by (induct xs) auto
 
 lemma card_distinct: "card (set xs) = size xs ==> 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)}"
           apply safe
            apply fastforce
           subgoal for \<dots> x by (cases x) auto
           done
         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
             apply safe
              apply fastforce
             subgoal for \<dots> x by (cases x) auto
             done
         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 "2 \<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 \<open>2 \<le> length ys\<close> by auto
       qed
       obtain ys' where "ys = x1 # x2 # ys'"
         using \<open>2 \<le> length ys\<close> f_nth[of 0] f_nth[of 1]
         apply (cases ys)
          apply (rename_tac [2] ys', case_tac [2] ys')
           apply (auto simp: \<open>f 0 = 0\<close> \<open>f (Suc 0) = Suc 0\<close>)
         done
 
       define f' where "f' x = f (Suc x) - 1" for x
 
       { fix i
         have "Suc 0 \<le> f (Suc 0)" using f_nth[of 0] \<open>x1 \<noteq> x2\<close> \<open>f 0 = 0\<close>  by auto
         also have "\<dots> \<le> f (Suc i)" using f_mono by (rule monoD) arith
         finally have "Suc 0 \<le> f (Suc i)" .
       } note Suc0_le_f_Suc = this
 
       { fix i have "f (Suc i) = Suc (f' i)"
           using Suc0_le_f_Suc[of i] by (auto simp: f'_def)
       } note f_Suc = this
 
       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 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
 
 
 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
 
 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
 
 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>
 
 lemma count_notin[simp]: "x \<notin> set xs \<Longrightarrow> count_list xs x = 0"
 by (induction xs) auto
 
 lemma count_le_length: "count_list xs x \<le> length xs"
 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
     apply (auto simp: sum.If_cases sum.remove)
     by (metis (no_types) Cons.IH Cons.prems(2) diff_eq sum.remove)
 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
 
 
 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)
 
 
 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 ==> 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 ==> last (replicate n x) = x"
 by (atomize (full), induct n) auto
 
 lemma nth_replicate[simp]: "i < n ==> (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 ==> 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 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
 
 lemma empty_replicate[simp]: "([] = replicate n x) \<longleftrightarrow> n=0"
 by (induct n) auto
 
 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 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:
   "\<lbrakk> xs \<noteq> []; ys \<noteq> []; xs @ ys = ys @ xs \<rbrakk>
   \<Longrightarrow> \<exists>m n zs. concat (replicate m zs) = xs \<and> concat (replicate n zs) = ys"
 proof (induction "length (xs @ ys)" arbitrary: xs ys rule: less_induct)
   case less
 
   define xs' ys' where "xs' = (if (length xs \<le> length ys) then xs else ys)"
     and "ys' = (if (length xs \<le> length ys) then ys else xs)"
   then have
     prems': "length xs' \<le> length ys'"
             "xs' @ ys' = ys' @ xs'"
       and "xs' \<noteq> []"
       and len: "length (xs @ ys) = length (xs' @ ys')"
     using less by (auto intro: less.hyps)
 
   from prems'
   obtain ws where "ys' = xs' @ ws"
     by (auto simp: append_eq_append_conv2)
 
   have "\<exists>m n zs. concat (replicate m zs) = xs' \<and> concat (replicate n zs) = ys'"
   proof (cases "ws = []")
     case True
     then have "concat (replicate 1 xs') = xs'"
       and "concat (replicate 1 xs') = ys'"
       using \<open>ys' = xs' @ ws\<close> by auto
     then show ?thesis by blast
   next
     case False
     from \<open>ys' = xs' @ ws\<close> and \<open>xs' @ ys' = ys' @ xs'\<close>
     have "xs' @ ws = ws @ xs'" by simp
     then have "\<exists>m n zs. concat (replicate m zs) = xs' \<and> concat (replicate n zs) = ws"
       using False and \<open>xs' \<noteq> []\<close> and \<open>ys' = xs' @ ws\<close> and len
       by (intro less.hyps) auto
     then obtain m n zs where *: "concat (replicate m zs) = xs'"
       and "concat (replicate n zs) = ws" by blast
     then have "concat (replicate (m + n) zs) = ys'"
       using \<open>ys' = xs' @ ws\<close>
       by (simp add: replicate_add)
     with * show ?thesis by blast
   qed
   then show ?case
     using xs'_def ys'_def by meson
 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 xs ys, OF assms] 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
         apply (simp add: mod_Suc)
         by (simp add: False Suc.hyps drop_Suc rotate1_hd_tl take_Suc)
     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_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)
 
 
 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 (clarsimp simp: in_set_zip subset_iff)
 apply simp
 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}"
 apply(induction xs arbitrary: A B)
 apply(auto simp add: nths_Cons card_less_Suc card_less_Suc2)
 done
 
 lemma drop_eq_nths: "drop n xs = nths xs {i. i \<ge> n}"
 apply(induction xs arbitrary: n)
 apply (auto simp add: nths_Cons nths_all drop_Cons' intro: arg_cong2[where f=nths, OF refl])
 done
 
 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))"
 proof (rule card_distinct)
   have "finite (set xs)" ..
   then have "card (Pow (set xs)) = 2 ^ card (set xs)"
     by (rule card_Pow)
   with assms distinct_card [of xs] have "card (Pow (set xs)) = 2 ^ length xs"
     by simp
   then show "card (set (map set (subseqs xs))) = length (map set (subseqs xs))"
     by (simp add: subseqs_powset length_subseqs)
 qed
 
 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"
 apply(induction "replicate m x" "replicate n x" arbitrary: m n rule: splice.induct)
 apply (auto simp add: Cons_replicate_eq dest: gr0_implies_Suc)
 done
 
 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 x have "Suc j < length x \<longleftrightarrow> x \<noteq> [] \<and> j < length x - Suc 0"
       by (cases x) 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)
 
 
 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 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_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 (auto simp: 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 sorted1: "sorted [x] = True"
 by simp
 
 lemma sorted2: "sorted (x # y # zs) = (x \<le> y \<and> sorted (y # zs))"
 by(induction zs) auto
 
 lemmas sorted2_simps = sorted1 sorted2
 
 lemmas [code] = sorted.simps(1) sorted2_simps
 
 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_sorted_wrt 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_sorted_wrt sorted_wrt_map)
 
 lemma sorted01: "length xs \<le> 1 \<Longrightarrow> sorted xs"
 by (simp add: sorted_sorted_wrt 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_sorted_wrt 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_rev_nth_mono:
   "sorted (rev xs) \<Longrightarrow> i \<le> j \<Longrightarrow> j < length xs \<Longrightarrow> xs!j \<le> xs!i"
 using sorted_nth_mono[ of "rev xs" "length xs - j - 1" "length xs - i - 1"]
       rev_nth[of "length xs - i - 1" "xs"] rev_nth[of "length xs - j - 1" "xs"]
 by auto
 
 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 "xs \<noteq> []" and "sorted xs"
   shows "sorted (butlast xs)"
 proof -
   from \<open>xs \<noteq> []\<close> obtain ys y where "xs = ys @ [y]"
     by (cases xs rule: rev_cases) auto
   with \<open>sorted xs\<close> show ?thesis by (simp add: sorted_append)
 qed
 
 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 thus ?case by simp (metis Diff_insert_absorb antisym insertE insert_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"
 proof -
   from assms have "map f xs = map f ys"
     by (simp add: sorted_distinct_set_unique)
   with \<open>inj_on f (set xs \<union> set ys)\<close> show "xs = ys"
     by (blast intro: map_inj_on)
 qed
 
 lemma
   assumes "sorted xs"
   shows sorted_take: "sorted (take n xs)"
   and sorted_drop: "sorted (drop n xs)"
 proof -
   from assms have "sorted (take n xs @ drop n xs)" by simp
   then show "sorted (take n xs)" and "sorted (drop n xs)"
     unfolding sorted_append by simp_all
 qed
 
 lemma sorted_dropWhile: "sorted xs \<Longrightarrow> sorted (dropWhile P xs)"
   by (auto dest: sorted_drop simp add: dropWhile_eq_drop)
 
 lemma sorted_takeWhile: "sorted xs \<Longrightarrow> sorted (takeWhile P xs)"
   by (subst takeWhile_eq_take) (auto dest: sorted_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 \<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"
     using hd_dropWhile[of "?P" xs] le0[THEN preorder_class.le_less_trans, OF i]
     using hd_conv_nth[of "?dW"] by simp
   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_sorted_wrt sorted_wrt_mono_rel[OF _ sorted_wrt_upt])
 
 lemma sorted_upto[simp]: "sorted [m..n]"
 by(simp add: sorted_sorted_wrt 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: 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_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 sorted_sort_id: "sorted xs \<Longrightarrow> sort xs = xs"
 by (induct xs) (auto simp add: insort_is_Cons)
 
 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 [simp]:
   "remove1 x (insort x xs) = xs"
   by (induct xs) simp_all
 
 end
 
 lemma sort_upt [simp]: "sort [m..<n] = [m..<n]"
 by (rule sorted_sort_id) simp
 
 lemma sort_upto [simp]: "sort [i..j] = [i..j]"
 by (rule sorted_sort_id) 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)
 
 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_list_of_set\<close>\<close>
 
 text\<open>This function maps (finite) linearly ordered sets to sorted
 lists. 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>).\<close>
 
 context linorder
 begin
 
 definition sorted_list_of_set :: "'a set \<Rightarrow> 'a list" where
   "sorted_list_of_set = folding.F insort []"
 
 sublocale sorted_list_of_set: folding insort Nil
 rewrites
   "folding.F insort [] = sorted_list_of_set"
 proof -
   interpret comp_fun_commute insort by (fact comp_fun_commute_insort)
   show "folding insort" by standard (fact comp_fun_commute)
   show "folding.F insort [] = sorted_list_of_set" by (simp only: sorted_list_of_set_def)
 qed
 
 lemma sorted_list_of_set_empty:
   "sorted_list_of_set {} = []"
 by (fact sorted_list_of_set.empty)
 
 lemma sorted_list_of_set_insert [simp]:
   "finite A \<Longrightarrow> sorted_list_of_set (insert x A) = insort x (sorted_list_of_set (A - {x}))"
 by (fact sorted_list_of_set.insert_remove)
 
 lemma sorted_list_of_set_eq_Nil_iff [simp]:
   "finite A \<Longrightarrow> sorted_list_of_set A = [] \<longleftrightarrow> A = {}"
 by (auto simp: sorted_list_of_set.remove)
 
 lemma set_sorted_list_of_set [simp]:
   "finite A \<Longrightarrow> set (sorted_list_of_set A) = A"
 by(induct A rule: finite_induct) (simp_all add: set_insort_key)
 
 lemma sorted_sorted_list_of_set [simp]: "sorted (sorted_list_of_set A)"
 proof (cases "finite A")
   case True thus ?thesis by(induction A) (simp_all add: sorted_insort)
 next
   case False thus ?thesis by simp
 qed
 
 lemma distinct_sorted_list_of_set [simp]: "distinct (sorted_list_of_set A)"
 proof (cases "finite A")
   case True thus ?thesis by(induction A) (simp_all add: distinct_insort)
 next
   case False thus ?thesis by simp
 qed
 
 lemmas sorted_list_of_set = set_sorted_list_of_set sorted_sorted_list_of_set distinct_sorted_list_of_set
 
 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.eq_fold sort_conv_fold fold_set_fold_remdups)
 qed
 
 lemma sorted_list_of_set_remove:
   assumes "finite A"
   shows "sorted_list_of_set (A - {x}) = remove1 x (sorted_list_of_set A)"
 proof (cases "x \<in> A")
   case False with assms have "x \<notin> set (sorted_list_of_set 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
 
 end
 
 lemma sorted_list_of_set_range [simp]:
   "sorted_list_of_set {m..<n} = [m..<n]"
 by (rule sorted_distinct_set_unique) simp_all
 
 
 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 ==> 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 ==> 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 ==> \<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 ==> 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!]: "wf r ==> wf (lex r)"
   unfolding lex_def
   apply (rule wf_UN)
    apply (simp add: wf_lexn)
   apply (metis DomainE Int_emptyI RangeE lexn_length)
   done
 
 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)}"
 apply (induct n, simp)
 apply (simp add: image_Collect lex_prod_def, safe, blast)
  apply (rule_tac x = "ab # xys" in exI, simp)
 apply (case_tac xys, simp_all, blast)
 done
 
 text\<open>By Mathias Fleury:\<close>
 lemma 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
 
 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 ==> 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 (simp add: lenlex_def Id_on_def lex_prod_def inv_image_def)
 
 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) =
       ((x, y) \<in> r \<and> length xs = length ys \<or> x = y \<and> (xs, ys) \<in> lex r)"
   apply (simp add: lex_conv)
   apply (rule iffI)
    prefer 2 apply (blast intro: Cons_eq_appendI, clarify)
   by (metis hd_append append_Nil list.sel(1) list.sel(3) tl_append2)
 
 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
 
 
 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) = ((a,b)\<in> r \<or> (a = b \<and> (x,y)\<in> lexord r))"
   unfolding lexord_def
   apply (safe, simp_all)
      apply (metis hd_append list.sel(1))
     apply (metis hd_append list.sel(1) list.sel(3) tl_append2)
    apply blast
   by (meson Cons_eq_appendI)
 
 lemmas lexord_simps = lexord_Nil_left lexord_Nil_right lexord_cons_cons
 
 lemma lexord_append_rightI: "\<exists> b z. y = b # z \<Longrightarrow> (x, x @ y) \<in> lexord r"
 by (induct_tac x, auto)
 
 lemma lexord_append_left_rightI:
      "(a,b) \<in> r \<Longrightarrow> (u @ a # x, u @ b # y) \<in> lexord r"
 by (induct_tac u, auto)
 
 lemma lexord_append_leftI: " (u,v) \<in> lexord r \<Longrightarrow> (x @ u, x @ v) \<in> lexord r"
 by (induct x, auto)
 
 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 (erule rev_mp, induct_tac x, auto)
 
 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))"
   apply (unfold lexord_def Let_def, clarsimp)
   apply (rule_tac f = "(% a b. a \<or> b)" in arg_cong2)
   apply (metis Cons_nth_drop_Suc append_eq_conv_conj drop_all list.simps(3) not_le)
   apply auto
   apply (rule_tac x ="length u" in exI, simp)
   by (metis id_take_nth_drop)
 
 \<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_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 (rule transI, drule lexord_trans, blast)
 
 lemma 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"
 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
 
 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
   from assms obtain "irrefl R" by (blast elim: asym.cases)
   then show "irrefl (lexord R)" by (rule lexord_irrefl)
 next
   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 elim: asym.cases)
   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 (rule asym.cases) (auto simp add: hyp)
 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]:
   "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]:
   "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:
   assumes "lexordp xs ys"
   shows "lexordp_eq xs ys"
 using assms by induct simp_all
 
 end
 
 declare ord.lexordp_simps [simp, code]
 declare ord.lexordp_eq_simps [code, simp]
 
 lemma lexord_code [code, code_unfold]: "lexordp = ord.lexordp less"
 unfolding lexordp_def ord.lexordp_def ..
 
 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
 
 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)
 
 
 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 ==> (x, y) \<in> measures (f#fs)"
 by simp
 
 lemma measures_lesseq: "f x \<le> f y ==> (x, y) \<in> measures fs ==> (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)"
 apply (induct arbitrary: xs set: Wellfounded.acc)
 apply (erule thin_rl)
 apply (erule acc_induct)
   apply (rule accI)
 apply (blast)
 done
 
 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)"
 apply (induct set: Wellfounded.acc)
 apply clarify
 apply (rule accI)
 apply (fastforce dest!: in_set_conv_decomp[THEN iffD1] simp: listrel1_def)
 done
 
 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: "[| (x,y) \<in> r; (xs,ys) \<in> listrel r |] ==> (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: "r \<subseteq> A \<times> A \<Longrightarrow> listrel r \<subseteq> lists A \<times> lists A"
 apply clarify
 apply (erule listrel.induct, auto)
 done
 
 lemma listrel_refl_on: "refl_on A r \<Longrightarrow> refl_on (lists A) (listrel r)"
 apply (simp add: refl_on_def listrel_subset Ball_def)
 apply (rule allI)
 apply (induct_tac x)
 apply (auto intro: listrel.intros)
 done
 
 lemma listrel_sym: "sym r \<Longrightarrow> sym (listrel r)"
   by (simp add: listrel_iff_nth sym_def)
 
 lemma listrel_trans: "trans r \<Longrightarrow> trans (listrel r)"
 apply (simp add: trans_def)
 apply (intro allI)
 apply (rule impI)
 apply (erule listrel.induct)
 apply (blast intro: listrel.intros)+
 done
 
 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>*"
 apply(induct rule: rtrancl.induct)
  apply simp
 by (metis listrel1I2 rtrancl.rtrancl_into_rtrancl)
 
 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 (blast intro: rtrancl_trans rtrancl_listrel1_ConsI1
     subsetD[OF listrel1_rtrancl_subset_rtrancl_listrel1 listrel1I1])
 
 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.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"
   proof -
     fix n
     assume "P i" "\<forall>n\<in>{Suc i..<j}. P n" "i \<le> n" "n < j"
     then show "P n" by (cases "n = i") simp_all
   qed
   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"
   proof -
     fix k
     assume "P i" "\<forall>k\<in>{i+1..j}. P k" "i \<le> k" "k \<le> j"
     then show "P k" by (cases "k = i") simp_all
   qed
   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)"
 proof -
   have "card (set (remdups xs)) = length (remdups xs)"
     by (rule distinct_card) simp
   then show ?thesis by simp
 qed
 
 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 distinct_transfer [transfer_rule]:
   assumes [transfer_rule]: "bi_unique A"
   shows "(list_all2 A ===> (=)) distinct distinct"
   unfolding distinct_def by transfer_prover
 
 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"
   apply (rule rel_funI, rule rel_setI)
   apply (erule lists.induct, simp)
   apply (simp only: rel_set_def list_all2_Cons1, metis lists.Cons)
   apply (erule lists.induct, simp)
   apply (simp only: rel_set_def list_all2_Cons2, metis lists.Cons)
   done
 
 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/Quotient.thy b/src/HOL/Quotient.thy
--- a/src/HOL/Quotient.thy
+++ b/src/HOL/Quotient.thy
@@ -1,852 +1,859 @@
 (*  Title:      HOL/Quotient.thy
     Author:     Cezary Kaliszyk and Christian Urban
 *)
 
 section \<open>Definition of Quotient Types\<close>
 
 theory Quotient
 imports Lifting
 keywords
   "print_quotmapsQ3" "print_quotientsQ3" "print_quotconsts" :: diag and
   "quotient_type" :: thy_goal_defn and "/" and
   "quotient_definition" :: thy_goal_defn and
   "copy_bnf" :: thy_defn and
   "lift_bnf" :: thy_goal_defn
 begin
 
 text \<open>
   Basic definition for equivalence relations
   that are represented by predicates.
 \<close>
 
 text \<open>Composition of Relations\<close>
 
 abbreviation
   rel_conj :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool" (infixr "OOO" 75)
 where
   "r1 OOO r2 \<equiv> r1 OO r2 OO r1"
 
 lemma eq_comp_r:
   shows "((=) OOO R) = R"
   by (auto simp add: fun_eq_iff)
 
 context includes lifting_syntax
 begin
 
 subsection \<open>Quotient Predicate\<close>
 
 definition
   "Quotient3 R Abs Rep \<longleftrightarrow>
      (\<forall>a. Abs (Rep a) = a) \<and> (\<forall>a. R (Rep a) (Rep a)) \<and>
      (\<forall>r s. R r s \<longleftrightarrow> R r r \<and> R s s \<and> Abs r = Abs s)"
 
 lemma Quotient3I:
   assumes "\<And>a. Abs (Rep a) = a"
     and "\<And>a. R (Rep a) (Rep a)"
     and "\<And>r s. R r s \<longleftrightarrow> R r r \<and> R s s \<and> Abs r = Abs s"
   shows "Quotient3 R Abs Rep"
   using assms unfolding Quotient3_def by blast
 
 context
   fixes R Abs Rep
   assumes a: "Quotient3 R Abs Rep"
 begin
 
 lemma Quotient3_abs_rep:
   "Abs (Rep a) = a"
   using a
   unfolding Quotient3_def
   by simp
 
 lemma Quotient3_rep_reflp:
   "R (Rep a) (Rep a)"
   using a
   unfolding Quotient3_def
   by blast
 
 lemma Quotient3_rel:
   "R r r \<and> R s s \<and> Abs r = Abs s \<longleftrightarrow> R r s" \<comment> \<open>orientation does not loop on rewriting\<close>
   using a
   unfolding Quotient3_def
   by blast
 
 lemma Quotient3_refl1:
   "R r s \<Longrightarrow> R r r"
   using a unfolding Quotient3_def
   by fast
 
 lemma Quotient3_refl2:
   "R r s \<Longrightarrow> R s s"
   using a unfolding Quotient3_def
   by fast
 
 lemma Quotient3_rel_rep:
   "R (Rep a) (Rep b) \<longleftrightarrow> a = b"
   using a
   unfolding Quotient3_def
   by metis
 
 lemma Quotient3_rep_abs:
   "R r r \<Longrightarrow> R (Rep (Abs r)) r"
   using a unfolding Quotient3_def
   by blast
 
 lemma Quotient3_rel_abs:
   "R r s \<Longrightarrow> Abs r = Abs s"
   using a unfolding Quotient3_def
   by blast
 
 lemma Quotient3_symp:
   "symp R"
   using a unfolding Quotient3_def using sympI by metis
 
 lemma Quotient3_transp:
   "transp R"
   using a unfolding Quotient3_def using transpI by (metis (full_types))
 
 lemma Quotient3_part_equivp:
   "part_equivp R"
   by (metis Quotient3_rep_reflp Quotient3_symp Quotient3_transp part_equivpI)
 
 lemma abs_o_rep:
   "Abs \<circ> Rep = id"
   unfolding fun_eq_iff
   by (simp add: Quotient3_abs_rep)
 
 lemma equals_rsp:
   assumes b: "R xa xb" "R ya yb"
   shows "R xa ya = R xb yb"
   using b Quotient3_symp Quotient3_transp
   by (blast elim: sympE transpE)
 
 lemma rep_abs_rsp:
   assumes b: "R x1 x2"
   shows "R x1 (Rep (Abs x2))"
   using b Quotient3_rel Quotient3_abs_rep Quotient3_rep_reflp
   by metis
 
 lemma rep_abs_rsp_left:
   assumes b: "R x1 x2"
   shows "R (Rep (Abs x1)) x2"
   using b Quotient3_rel Quotient3_abs_rep Quotient3_rep_reflp
   by metis
 
 end
 
 lemma identity_quotient3:
   "Quotient3 (=) id id"
   unfolding Quotient3_def id_def
   by blast
 
 lemma fun_quotient3:
   assumes q1: "Quotient3 R1 abs1 rep1"
   and     q2: "Quotient3 R2 abs2 rep2"
   shows "Quotient3 (R1 ===> R2) (rep1 ---> abs2) (abs1 ---> rep2)"
 proof -
   have "(rep1 ---> abs2) ((abs1 ---> rep2) a) = a" for a
     using q1 q2 by (simp add: Quotient3_def fun_eq_iff)
   moreover
   have "(R1 ===> R2) ((abs1 ---> rep2) a) ((abs1 ---> rep2) a)" for a
     by (rule rel_funI)
       (insert q1 q2 Quotient3_rel_abs [of R1 abs1 rep1] Quotient3_rel_rep [of R2 abs2 rep2],
         simp (no_asm) add: Quotient3_def, simp)
   moreover
   have "(R1 ===> R2) r s = ((R1 ===> R2) r r \<and> (R1 ===> R2) s s \<and>
         (rep1 ---> abs2) r  = (rep1 ---> abs2) s)" for r s
   proof -
     have "(R1 ===> R2) r s \<Longrightarrow> (R1 ===> R2) r r" unfolding rel_fun_def
       using Quotient3_part_equivp[OF q1] Quotient3_part_equivp[OF q2]
       by (metis (full_types) part_equivp_def)
     moreover have "(R1 ===> R2) r s \<Longrightarrow> (R1 ===> R2) s s" unfolding rel_fun_def
       using Quotient3_part_equivp[OF q1] Quotient3_part_equivp[OF q2]
       by (metis (full_types) part_equivp_def)
     moreover have "(R1 ===> R2) r s \<Longrightarrow> (rep1 ---> abs2) r  = (rep1 ---> abs2) s"
       by (auto simp add: rel_fun_def fun_eq_iff)
         (use q1 q2 in \<open>unfold Quotient3_def, metis\<close>)
     moreover have "((R1 ===> R2) r r \<and> (R1 ===> R2) s s \<and>
         (rep1 ---> abs2) r  = (rep1 ---> abs2) s) \<Longrightarrow> (R1 ===> R2) r s"
       by (auto simp add: rel_fun_def fun_eq_iff)
         (use q1 q2 in \<open>unfold Quotient3_def, metis map_fun_apply\<close>)
     ultimately show ?thesis by blast
   qed
   ultimately show ?thesis by (intro Quotient3I) (assumption+)
 qed
 
 lemma lambda_prs:
   assumes q1: "Quotient3 R1 Abs1 Rep1"
   and     q2: "Quotient3 R2 Abs2 Rep2"
   shows "(Rep1 ---> Abs2) (\<lambda>x. Rep2 (f (Abs1 x))) = (\<lambda>x. f x)"
   unfolding fun_eq_iff
   using Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2]
   by simp
 
 lemma lambda_prs1:
   assumes q1: "Quotient3 R1 Abs1 Rep1"
   and     q2: "Quotient3 R2 Abs2 Rep2"
   shows "(Rep1 ---> Abs2) (\<lambda>x. (Abs1 ---> Rep2) f x) = (\<lambda>x. f x)"
   unfolding fun_eq_iff
   using Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2]
   by simp
 
 text\<open>
   In the following theorem R1 can be instantiated with anything,
   but we know some of the types of the Rep and Abs functions;
   so by solving Quotient assumptions we can get a unique R1 that
   will be provable; which is why we need to use \<open>apply_rsp\<close> and
   not the primed version\<close>
 
 lemma apply_rspQ3:
   fixes f g::"'a \<Rightarrow> 'c"
   assumes q: "Quotient3 R1 Abs1 Rep1"
   and     a: "(R1 ===> R2) f g" "R1 x y"
   shows "R2 (f x) (g y)"
   using a by (auto elim: rel_funE)
 
 lemma apply_rspQ3'':
   assumes "Quotient3 R Abs Rep"
   and "(R ===> S) f f"
   shows "S (f (Rep x)) (f (Rep x))"
 proof -
   from assms(1) have "R (Rep x) (Rep x)" by (rule Quotient3_rep_reflp)
   then show ?thesis using assms(2) by (auto intro: apply_rsp')
 qed
 
 subsection \<open>lemmas for regularisation of ball and bex\<close>
 
 lemma ball_reg_eqv:
   fixes P :: "'a \<Rightarrow> bool"
   assumes a: "equivp R"
   shows "Ball (Respects R) P = (All P)"
   using a
   unfolding equivp_def
   by (auto simp add: in_respects)
 
 lemma bex_reg_eqv:
   fixes P :: "'a \<Rightarrow> bool"
   assumes a: "equivp R"
   shows "Bex (Respects R) P = (Ex P)"
   using a
   unfolding equivp_def
   by (auto simp add: in_respects)
 
 lemma ball_reg_right:
   assumes a: "\<And>x. x \<in> R \<Longrightarrow> P x \<longrightarrow> Q x"
   shows "All P \<longrightarrow> Ball R Q"
   using a by fast
 
 lemma bex_reg_left:
   assumes a: "\<And>x. x \<in> R \<Longrightarrow> Q x \<longrightarrow> P x"
   shows "Bex R Q \<longrightarrow> Ex P"
   using a by fast
 
 lemma ball_reg_left:
   assumes a: "equivp R"
   shows "(\<And>x. (Q x \<longrightarrow> P x)) \<Longrightarrow> Ball (Respects R) Q \<longrightarrow> All P"
   using a by (metis equivp_reflp in_respects)
 
 lemma bex_reg_right:
   assumes a: "equivp R"
   shows "(\<And>x. (Q x \<longrightarrow> P x)) \<Longrightarrow> Ex Q \<longrightarrow> Bex (Respects R) P"
   using a by (metis equivp_reflp in_respects)
 
 lemma ball_reg_eqv_range:
   fixes P::"'a \<Rightarrow> bool"
   and x::"'a"
   assumes a: "equivp R2"
   shows   "(Ball (Respects (R1 ===> R2)) (\<lambda>f. P (f x)) = All (\<lambda>f. P (f x)))"
   apply(rule iffI)
   apply(rule allI)
   apply(drule_tac x="\<lambda>y. f x" in bspec)
   apply(simp add: in_respects rel_fun_def)
   apply(rule impI)
   using a equivp_reflp_symp_transp[of "R2"]
   apply (auto elim: equivpE reflpE)
   done
 
 lemma bex_reg_eqv_range:
   assumes a: "equivp R2"
   shows   "(Bex (Respects (R1 ===> R2)) (\<lambda>f. P (f x)) = Ex (\<lambda>f. P (f x)))"
   apply(auto)
   apply(rule_tac x="\<lambda>y. f x" in bexI)
   apply(simp)
   apply(simp add: Respects_def in_respects rel_fun_def)
   apply(rule impI)
   using a equivp_reflp_symp_transp[of "R2"]
   apply (auto elim: equivpE reflpE)
   done
 
 (* Next four lemmas are unused *)
 lemma all_reg:
   assumes a: "\<forall>x :: 'a. (P x \<longrightarrow> Q x)"
   and     b: "All P"
   shows "All Q"
   using a b by fast
 
 lemma ex_reg:
   assumes a: "\<forall>x :: 'a. (P x \<longrightarrow> Q x)"
   and     b: "Ex P"
   shows "Ex Q"
   using a b by fast
 
 lemma ball_reg:
   assumes a: "\<forall>x :: 'a. (x \<in> R \<longrightarrow> P x \<longrightarrow> Q x)"
   and     b: "Ball R P"
   shows "Ball R Q"
   using a b by fast
 
 lemma bex_reg:
   assumes a: "\<forall>x :: 'a. (x \<in> R \<longrightarrow> P x \<longrightarrow> Q x)"
   and     b: "Bex R P"
   shows "Bex R Q"
   using a b by fast
 
 
 lemma ball_all_comm:
   assumes "\<And>y. (\<forall>x\<in>P. A x y) \<longrightarrow> (\<forall>x. B x y)"
   shows "(\<forall>x\<in>P. \<forall>y. A x y) \<longrightarrow> (\<forall>x. \<forall>y. B x y)"
   using assms by auto
 
 lemma bex_ex_comm:
   assumes "(\<exists>y. \<exists>x. A x y) \<longrightarrow> (\<exists>y. \<exists>x\<in>P. B x y)"
   shows "(\<exists>x. \<exists>y. A x y) \<longrightarrow> (\<exists>x\<in>P. \<exists>y. B x y)"
   using assms by auto
 
 subsection \<open>Bounded abstraction\<close>
 
 definition
   Babs :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
 where
   "x \<in> p \<Longrightarrow> Babs p m x = m x"
 
 lemma babs_rsp:
   assumes q: "Quotient3 R1 Abs1 Rep1"
   and     a: "(R1 ===> R2) f g"
   shows      "(R1 ===> R2) (Babs (Respects R1) f) (Babs (Respects R1) g)"
   apply (auto simp add: Babs_def in_respects rel_fun_def)
   apply (subgoal_tac "x \<in> Respects R1 \<and> y \<in> Respects R1")
   using a apply (simp add: Babs_def rel_fun_def)
   apply (simp add: in_respects rel_fun_def)
   using Quotient3_rel[OF q]
   by metis
 
 lemma babs_prs:
   assumes q1: "Quotient3 R1 Abs1 Rep1"
   and     q2: "Quotient3 R2 Abs2 Rep2"
   shows "((Rep1 ---> Abs2) (Babs (Respects R1) ((Abs1 ---> Rep2) f))) = f"
   apply (rule ext)
   apply (simp add:)
   apply (subgoal_tac "Rep1 x \<in> Respects R1")
   apply (simp add: Babs_def Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2])
   apply (simp add: in_respects Quotient3_rel_rep[OF q1])
   done
 
 lemma babs_simp:
   assumes q: "Quotient3 R1 Abs Rep"
   shows "((R1 ===> R2) (Babs (Respects R1) f) (Babs (Respects R1) g)) = ((R1 ===> R2) f g)"
   apply(rule iffI)
   apply(simp_all only: babs_rsp[OF q])
   apply(auto simp add: Babs_def rel_fun_def)
   apply(metis Babs_def in_respects  Quotient3_rel[OF q])
   done
 
 (* If a user proves that a particular functional relation
    is an equivalence this may be useful in regularising *)
 lemma babs_reg_eqv:
   shows "equivp R \<Longrightarrow> Babs (Respects R) P = P"
   by (simp add: fun_eq_iff Babs_def in_respects equivp_reflp)
 
 
 (* 3 lemmas needed for proving repabs_inj *)
 lemma ball_rsp:
   assumes a: "(R ===> (=)) f g"
   shows "Ball (Respects R) f = Ball (Respects R) g"
   using a by (auto simp add: Ball_def in_respects elim: rel_funE)
 
 lemma bex_rsp:
   assumes a: "(R ===> (=)) f g"
   shows "(Bex (Respects R) f = Bex (Respects R) g)"
   using a by (auto simp add: Bex_def in_respects elim: rel_funE)
 
 lemma bex1_rsp:
   assumes a: "(R ===> (=)) f g"
   shows "Ex1 (\<lambda>x. x \<in> Respects R \<and> f x) = Ex1 (\<lambda>x. x \<in> Respects R \<and> g x)"
   using a by (auto elim: rel_funE simp add: Ex1_def in_respects)
 
 (* 2 lemmas needed for cleaning of quantifiers *)
 lemma all_prs:
   assumes a: "Quotient3 R absf repf"
   shows "Ball (Respects R) ((absf ---> id) f) = All f"
   using a unfolding Quotient3_def Ball_def in_respects id_apply comp_def map_fun_def
   by metis
 
 lemma ex_prs:
   assumes a: "Quotient3 R absf repf"
   shows "Bex (Respects R) ((absf ---> id) f) = Ex f"
   using a unfolding Quotient3_def Bex_def in_respects id_apply comp_def map_fun_def
   by metis
 
 subsection \<open>\<open>Bex1_rel\<close> quantifier\<close>
 
 definition
   Bex1_rel :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
 where
   "Bex1_rel R P \<longleftrightarrow> (\<exists>x \<in> Respects R. P x) \<and> (\<forall>x \<in> Respects R. \<forall>y \<in> Respects R. ((P x \<and> P y) \<longrightarrow> (R x y)))"
 
 lemma bex1_rel_aux:
   "\<lbrakk>\<forall>xa ya. R xa ya \<longrightarrow> x xa = y ya; Bex1_rel R x\<rbrakk> \<Longrightarrow> Bex1_rel R y"
   unfolding Bex1_rel_def
   by (metis in_respects)
 
 lemma bex1_rel_aux2:
   "\<lbrakk>\<forall>xa ya. R xa ya \<longrightarrow> x xa = y ya; Bex1_rel R y\<rbrakk> \<Longrightarrow> Bex1_rel R x"
   unfolding Bex1_rel_def
   by (metis in_respects)
 
 lemma bex1_rel_rsp:
   assumes a: "Quotient3 R absf repf"
   shows "((R ===> (=)) ===> (=)) (Bex1_rel R) (Bex1_rel R)"
   unfolding rel_fun_def by (metis bex1_rel_aux bex1_rel_aux2)
 
 lemma ex1_prs:
   assumes "Quotient3 R absf repf"
   shows "((absf ---> id) ---> id) (Bex1_rel R) f = Ex1 f"
   apply (auto simp: Bex1_rel_def Respects_def)
   apply (metis Quotient3_def assms)
   apply (metis (full_types) Quotient3_def assms)
   by (meson Quotient3_rel assms)
 
 lemma bex1_bexeq_reg:
   shows "(\<exists>!x\<in>Respects R. P x) \<longrightarrow> (Bex1_rel R (\<lambda>x. P x))"
   by (auto simp add: Ex1_def Bex1_rel_def Bex_def Ball_def in_respects)
 
 lemma bex1_bexeq_reg_eqv:
   assumes a: "equivp R"
   shows "(\<exists>!x. P x) \<longrightarrow> Bex1_rel R P"
   using equivp_reflp[OF a]
   by (metis (full_types) Bex1_rel_def in_respects)
 
 subsection \<open>Various respects and preserve lemmas\<close>
 
 lemma quot_rel_rsp:
   assumes a: "Quotient3 R Abs Rep"
   shows "(R ===> R ===> (=)) R R"
   apply(rule rel_funI)+
   by (meson assms equals_rsp)
 
 lemma o_prs:
   assumes q1: "Quotient3 R1 Abs1 Rep1"
   and     q2: "Quotient3 R2 Abs2 Rep2"
   and     q3: "Quotient3 R3 Abs3 Rep3"
   shows "((Abs2 ---> Rep3) ---> (Abs1 ---> Rep2) ---> (Rep1 ---> Abs3)) (\<circ>) = (\<circ>)"
   and   "(id ---> (Abs1 ---> id) ---> Rep1 ---> id) (\<circ>) = (\<circ>)"
   using Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2] Quotient3_abs_rep[OF q3]
   by (simp_all add: fun_eq_iff)
 
 lemma o_rsp:
   "((R2 ===> R3) ===> (R1 ===> R2) ===> (R1 ===> R3)) (\<circ>) (\<circ>)"
   "((=) ===> (R1 ===> (=)) ===> R1 ===> (=)) (\<circ>) (\<circ>)"
   by (force elim: rel_funE)+
 
 lemma cond_prs:
   assumes a: "Quotient3 R absf repf"
   shows "absf (if a then repf b else repf c) = (if a then b else c)"
   using a unfolding Quotient3_def by auto
 
 lemma if_prs:
   assumes q: "Quotient3 R Abs Rep"
   shows "(id ---> Rep ---> Rep ---> Abs) If = If"
   using Quotient3_abs_rep[OF q]
   by (auto simp add: fun_eq_iff)
 
 lemma if_rsp:
   assumes q: "Quotient3 R Abs Rep"
   shows "((=) ===> R ===> R ===> R) If If"
   by force
 
 lemma let_prs:
   assumes q1: "Quotient3 R1 Abs1 Rep1"
   and     q2: "Quotient3 R2 Abs2 Rep2"
   shows "(Rep2 ---> (Abs2 ---> Rep1) ---> Abs1) Let = Let"
   using Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2]
   by (auto simp add: fun_eq_iff)
 
 lemma let_rsp:
   shows "(R1 ===> (R1 ===> R2) ===> R2) Let Let"
   by (force elim: rel_funE)
 
 lemma id_rsp:
   shows "(R ===> R) id id"
   by auto
 
 lemma id_prs:
   assumes a: "Quotient3 R Abs Rep"
   shows "(Rep ---> Abs) id = id"
   by (simp add: fun_eq_iff Quotient3_abs_rep [OF a])
 
 end
 
 locale quot_type =
   fixes R :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
   and   Abs :: "'a set \<Rightarrow> 'b"
   and   Rep :: "'b \<Rightarrow> 'a set"
   assumes equivp: "part_equivp R"
   and     rep_prop: "\<And>y. \<exists>x. R x x \<and> Rep y = Collect (R x)"
   and     rep_inverse: "\<And>x. Abs (Rep x) = x"
   and     abs_inverse: "\<And>c. (\<exists>x. ((R x x) \<and> (c = Collect (R x)))) \<Longrightarrow> (Rep (Abs c)) = c"
   and     rep_inject: "\<And>x y. (Rep x = Rep y) = (x = y)"
 begin
 
 definition
   abs :: "'a \<Rightarrow> 'b"
 where
   "abs x = Abs (Collect (R x))"
 
 definition
   rep :: "'b \<Rightarrow> 'a"
 where
   "rep a = (SOME x. x \<in> Rep a)"
 
 lemma some_collect:
   assumes "R r r"
   shows "R (SOME x. x \<in> Collect (R r)) = R r"
   apply simp
   by (metis assms exE_some equivp[simplified part_equivp_def])
 
 lemma Quotient:
   shows "Quotient3 R abs rep"
   unfolding Quotient3_def abs_def rep_def
   proof (intro conjI allI)
     fix a r s
     show x: "R (SOME x. x \<in> Rep a) (SOME x. x \<in> Rep a)" proof -
       obtain x where r: "R x x" and rep: "Rep a = Collect (R x)" using rep_prop[of a] by auto
       have "R (SOME x. x \<in> Rep a) x"  using r rep some_collect by metis
       then have "R x (SOME x. x \<in> Rep a)" using part_equivp_symp[OF equivp] by fast
       then show "R (SOME x. x \<in> Rep a) (SOME x. x \<in> Rep a)"
         using part_equivp_transp[OF equivp] by (metis \<open>R (SOME x. x \<in> Rep a) x\<close>)
     qed
     have "Collect (R (SOME x. x \<in> Rep a)) = (Rep a)" by (metis some_collect rep_prop)
     then show "Abs (Collect (R (SOME x. x \<in> Rep a))) = a" using rep_inverse by auto
     have "R r r \<Longrightarrow> R s s \<Longrightarrow> Abs (Collect (R r)) = Abs (Collect (R s)) \<longleftrightarrow> R r = R s"
     proof -
       assume "R r r" and "R s s"
       then have "Abs (Collect (R r)) = Abs (Collect (R s)) \<longleftrightarrow> Collect (R r) = Collect (R s)"
         by (metis abs_inverse)
       also have "Collect (R r) = Collect (R s) \<longleftrightarrow> (\<lambda>A x. x \<in> A) (Collect (R r)) = (\<lambda>A x. x \<in> A) (Collect (R s))"
         by rule simp_all
       finally show "Abs (Collect (R r)) = Abs (Collect (R s)) \<longleftrightarrow> R r = R s" by simp
     qed
     then show "R r s \<longleftrightarrow> R r r \<and> R s s \<and> (Abs (Collect (R r)) = Abs (Collect (R s)))"
       using equivp[simplified part_equivp_def] by metis
     qed
 
 end
 
 subsection \<open>Quotient composition\<close>
 
 
 lemma OOO_quotient3:
   fixes R1 :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
   fixes Abs1 :: "'a \<Rightarrow> 'b" and Rep1 :: "'b \<Rightarrow> 'a"
   fixes Abs2 :: "'b \<Rightarrow> 'c" and Rep2 :: "'c \<Rightarrow> 'b"
   fixes R2' :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
   fixes R2 :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
   assumes R1: "Quotient3 R1 Abs1 Rep1"
   assumes R2: "Quotient3 R2 Abs2 Rep2"
   assumes Abs1: "\<And>x y. R2' x y \<Longrightarrow> R1 x x \<Longrightarrow> R1 y y \<Longrightarrow> R2 (Abs1 x) (Abs1 y)"
   assumes Rep1: "\<And>x y. R2 x y \<Longrightarrow> R2' (Rep1 x) (Rep1 y)"
   shows "Quotient3 (R1 OO R2' OO R1) (Abs2 \<circ> Abs1) (Rep1 \<circ> Rep2)"
 proof -
   have *: "(R1 OOO R2') r r \<and> (R1 OOO R2') s s \<and> (Abs2 \<circ> Abs1) r = (Abs2 \<circ> Abs1) s
            \<longleftrightarrow> (R1 OOO R2') r s" for r s
     apply safe
     subgoal for a b c d
       apply simp
       apply (rule_tac b="Rep1 (Abs1 r)" in relcomppI)
       using Quotient3_refl1 R1 rep_abs_rsp apply fastforce
       apply (rule_tac b="Rep1 (Abs1 s)" in relcomppI)
        apply (metis (full_types) Rep1 Abs1 Quotient3_rel R2  Quotient3_refl1 [OF R1] Quotient3_refl2 [OF R1] Quotient3_rel_abs [OF R1])
       by (metis Quotient3_rel R1 rep_abs_rsp_left)
     subgoal for x y
       apply (drule Abs1)
         apply (erule Quotient3_refl2 [OF R1])
        apply (erule Quotient3_refl1 [OF R1])
       apply (drule Quotient3_refl1 [OF R2], drule Rep1)
       by (metis (full_types) Quotient3_def R1 relcompp.relcompI)
     subgoal for x y
       apply (drule Abs1)
         apply (erule Quotient3_refl2 [OF R1])
        apply (erule Quotient3_refl1 [OF R1])
       apply (drule Quotient3_refl2 [OF R2], drule Rep1)
       by (metis (full_types) Quotient3_def R1 relcompp.relcompI)
     subgoal for x y
       by simp (metis (full_types) Abs1 Quotient3_rel R1 R2)
     done
   show ?thesis
     apply (rule Quotient3I)
     using * apply (simp_all add: o_def Quotient3_abs_rep [OF R2] Quotient3_abs_rep [OF R1])
     apply (metis Quotient3_rep_reflp R1 R2 Rep1 relcompp.relcompI)
     done
 qed
 
 lemma OOO_eq_quotient3:
   fixes R1 :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
   fixes Abs1 :: "'a \<Rightarrow> 'b" and Rep1 :: "'b \<Rightarrow> 'a"
   fixes Abs2 :: "'b \<Rightarrow> 'c" and Rep2 :: "'c \<Rightarrow> 'b"
   assumes R1: "Quotient3 R1 Abs1 Rep1"
   assumes R2: "Quotient3 (=) Abs2 Rep2"
   shows "Quotient3 (R1 OOO (=)) (Abs2 \<circ> Abs1) (Rep1 \<circ> Rep2)"
 using assms
 by (rule OOO_quotient3) auto
 
 subsection \<open>Quotient3 to Quotient\<close>
 
 lemma Quotient3_to_Quotient:
 assumes "Quotient3 R Abs Rep"
 and "T \<equiv> \<lambda>x y. R x x \<and> Abs x = y"
 shows "Quotient R Abs Rep T"
 using assms unfolding Quotient3_def by (intro QuotientI) blast+
 
 lemma Quotient3_to_Quotient_equivp:
 assumes q: "Quotient3 R Abs Rep"
 and T_def: "T \<equiv> \<lambda>x y. Abs x = y"
 and eR: "equivp R"
 shows "Quotient R Abs Rep T"
 proof (intro QuotientI)
   fix a
   show "Abs (Rep a) = a" using q by(rule Quotient3_abs_rep)
 next
   fix a
   show "R (Rep a) (Rep a)" using q by(rule Quotient3_rep_reflp)
 next
   fix r s
   show "R r s = (R r r \<and> R s s \<and> Abs r = Abs s)" using q by(rule Quotient3_rel[symmetric])
 next
   show "T = (\<lambda>x y. R x x \<and> Abs x = y)" using T_def equivp_reflp[OF eR] by simp
 qed
 
 subsection \<open>ML setup\<close>
 
 text \<open>Auxiliary data for the quotient package\<close>
 
 named_theorems quot_equiv "equivalence relation theorems"
   and quot_respect "respectfulness theorems"
   and quot_preserve "preservation theorems"
   and id_simps "identity simp rules for maps"
   and quot_thm "quotient theorems"
 ML_file \<open>Tools/Quotient/quotient_info.ML\<close>
 
 declare [[mapQ3 "fun" = (rel_fun, fun_quotient3)]]
 
 lemmas [quot_thm] = fun_quotient3
 lemmas [quot_respect] = quot_rel_rsp if_rsp o_rsp let_rsp id_rsp
 lemmas [quot_preserve] = if_prs o_prs let_prs id_prs
 lemmas [quot_equiv] = identity_equivp
 
 
 text \<open>Lemmas about simplifying id's.\<close>
 lemmas [id_simps] =
   id_def[symmetric]
   map_fun_id
   id_apply
   id_o
   o_id
   eq_comp_r
   vimage_id
 
 text \<open>Translation functions for the lifting process.\<close>
 ML_file \<open>Tools/Quotient/quotient_term.ML\<close>
 
 
 text \<open>Definitions of the quotient types.\<close>
 ML_file \<open>Tools/Quotient/quotient_type.ML\<close>
 
 
 text \<open>Definitions for quotient constants.\<close>
 ML_file \<open>Tools/Quotient/quotient_def.ML\<close>
 
 
 text \<open>
   An auxiliary constant for recording some information
   about the lifted theorem in a tactic.
 \<close>
 definition
   Quot_True :: "'a \<Rightarrow> bool"
 where
   "Quot_True x \<longleftrightarrow> True"
 
 lemma
   shows QT_all: "Quot_True (All P) \<Longrightarrow> Quot_True P"
   and   QT_ex:  "Quot_True (Ex P) \<Longrightarrow> Quot_True P"
   and   QT_ex1: "Quot_True (Ex1 P) \<Longrightarrow> Quot_True P"
   and   QT_lam: "Quot_True (\<lambda>x. P x) \<Longrightarrow> (\<And>x. Quot_True (P x))"
   and   QT_ext: "(\<And>x. Quot_True (a x) \<Longrightarrow> f x = g x) \<Longrightarrow> (Quot_True a \<Longrightarrow> f = g)"
   by (simp_all add: Quot_True_def ext)
 
 lemma QT_imp: "Quot_True a \<equiv> Quot_True b"
   by (simp add: Quot_True_def)
 
 context includes lifting_syntax
 begin
 
 text \<open>Tactics for proving the lifted theorems\<close>
 ML_file \<open>Tools/Quotient/quotient_tacs.ML\<close>
 
 end
 
 subsection \<open>Methods / Interface\<close>
 
 method_setup lifting =
   \<open>Attrib.thms >> (fn thms => fn ctxt =>
        SIMPLE_METHOD' (Quotient_Tacs.lift_tac ctxt [] thms))\<close>
   \<open>lift theorems to quotient types\<close>
 
 method_setup lifting_setup =
   \<open>Attrib.thm >> (fn thm => fn ctxt =>
        SIMPLE_METHOD' (Quotient_Tacs.lift_procedure_tac ctxt [] thm))\<close>
   \<open>set up the three goals for the quotient lifting procedure\<close>
 
 method_setup descending =
   \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (Quotient_Tacs.descend_tac ctxt []))\<close>
   \<open>decend theorems to the raw level\<close>
 
 method_setup descending_setup =
   \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (Quotient_Tacs.descend_procedure_tac ctxt []))\<close>
   \<open>set up the three goals for the decending theorems\<close>
 
 method_setup partiality_descending =
   \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (Quotient_Tacs.partiality_descend_tac ctxt []))\<close>
   \<open>decend theorems to the raw level\<close>
 
 method_setup partiality_descending_setup =
   \<open>Scan.succeed (fn ctxt =>
        SIMPLE_METHOD' (Quotient_Tacs.partiality_descend_procedure_tac ctxt []))\<close>
   \<open>set up the three goals for the decending theorems\<close>
 
 method_setup regularize =
   \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (Quotient_Tacs.regularize_tac ctxt))\<close>
   \<open>prove the regularization goals from the quotient lifting procedure\<close>
 
 method_setup injection =
   \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (Quotient_Tacs.all_injection_tac ctxt))\<close>
   \<open>prove the rep/abs injection goals from the quotient lifting procedure\<close>
 
 method_setup cleaning =
   \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (Quotient_Tacs.clean_tac ctxt))\<close>
   \<open>prove the cleaning goals from the quotient lifting procedure\<close>
 
 attribute_setup quot_lifted =
   \<open>Scan.succeed Quotient_Tacs.lifted_attrib\<close>
   \<open>lift theorems to quotient types\<close>
 
 no_notation
   rel_conj (infixr "OOO" 75)
 
 section \<open>Lifting of BNFs\<close>
 
 lemma sum_insert_Inl_unit: "x \<in> A \<Longrightarrow> (\<And>y. x = Inr y \<Longrightarrow> Inr y \<in> B) \<Longrightarrow> x \<in> insert (Inl ()) B"
   by (cases x) (simp_all)
 
 lemma lift_sum_unit_vimage_commute:
   "insert (Inl ()) (Inr ` f -` A) = map_sum id f -` insert (Inl ()) (Inr ` A)"
   by (auto simp: map_sum_def split: sum.splits)
 
 lemma insert_Inl_int_map_sum_unit: "insert (Inl ()) A \<inter> range (map_sum id f) \<noteq> {}"
   by (auto simp: map_sum_def split: sum.splits)
 
 lemma image_map_sum_unit_subset:
   "A \<subseteq> insert (Inl ()) (Inr ` B) \<Longrightarrow> map_sum id f ` A \<subseteq> insert (Inl ()) (Inr ` f ` B)"
   by auto
 
 lemma subset_lift_sum_unitD: "A \<subseteq> insert (Inl ()) (Inr ` B) \<Longrightarrow> Inr x \<in> A \<Longrightarrow> x \<in> B"
   unfolding insert_def by auto
 
 lemma UNIV_sum_unit_conv: "insert (Inl ()) (range Inr) = UNIV"
   unfolding UNIV_sum UNIV_unit image_insert image_empty Un_insert_left sup_bot.left_neutral..
 
 lemma subset_vimage_image_subset: "A \<subseteq> f -` B \<Longrightarrow> f ` A \<subseteq> B"
   by auto
 
 lemma relcompp_mem_Grp_neq_bot:
   "A \<inter> range f \<noteq> {} \<Longrightarrow> (\<lambda>x y. x \<in> A \<and> y \<in> A) OO (Grp UNIV f)\<inverse>\<inverse> \<noteq> bot"
   unfolding Grp_def relcompp_apply fun_eq_iff by blast
 
 lemma comp_projr_Inr: "projr \<circ> Inr = id"
   by auto
 
 lemma in_rel_sum_in_image_projr:
   "B \<subseteq> {(x,y). rel_sum ((=) :: unit \<Rightarrow> unit \<Rightarrow> bool) A x y} \<Longrightarrow>
    Inr ` C = fst ` B \<Longrightarrow> snd ` B = Inr ` D \<Longrightarrow> map_prod projr projr ` B \<subseteq> {(x,y). A x y}"
   by (force simp: projr_def image_iff dest!: spec[of _ "Inl ()"]  split: sum.splits)
 
 lemma subset_rel_sumI: "B \<subseteq> {(x,y). A x y} \<Longrightarrow> rel_sum ((=) :: unit => unit => bool) A
     (if x \<in> B then Inr (fst x) else Inl ())
     (if x \<in> B then Inr (snd x) else Inl ())"
   by auto
 
 lemma relcompp_eq_Grp_neq_bot: "(=) OO (Grp UNIV f)\<inverse>\<inverse> \<noteq> bot"
   unfolding Grp_def relcompp_apply fun_eq_iff by blast
 
 lemma rel_fun_rel_OO1: "(rel_fun Q (rel_fun R (=))) A B \<Longrightarrow> conversep Q OO A OO R \<le> B"
   by (auto simp: rel_fun_def)
 
 lemma rel_fun_rel_OO2: "(rel_fun Q (rel_fun R (=))) A B \<Longrightarrow> Q OO B OO conversep R \<le> A"
   by (auto simp: rel_fun_def)
 
 lemma rel_sum_eq2_nonempty: "rel_sum (=) A OO rel_sum (=) B \<noteq> bot"
   by (auto simp: fun_eq_iff relcompp_apply intro!: exI[of _ "Inl _"])
 
 lemma rel_sum_eq3_nonempty: "rel_sum (=) A OO (rel_sum (=) B OO rel_sum (=) C) \<noteq> bot"
   by (auto simp: fun_eq_iff relcompp_apply intro!: exI[of _ "Inl _"])
 
 lemma hypsubst: "A = B \<Longrightarrow> x \<in> B \<Longrightarrow> (x \<in> A \<Longrightarrow> P) \<Longrightarrow> P" by simp
 
 lemma Quotient_crel_quotient: "Quotient R Abs Rep T \<Longrightarrow> equivp R \<Longrightarrow> T \<equiv> (\<lambda>x y. Abs x = y)"
   by (drule Quotient_cr_rel) (auto simp: fun_eq_iff equivp_reflp intro!: eq_reflection)
 
 lemma Quotient_crel_typedef: "Quotient (eq_onp P) Abs Rep T \<Longrightarrow> T \<equiv> (\<lambda>x y. x = Rep y)"
   unfolding Quotient_def
   by (auto 0 4 simp: fun_eq_iff eq_onp_def intro: sym intro!: eq_reflection)
 
 lemma Quotient_crel_typecopy: "Quotient (=) Abs Rep T \<Longrightarrow> T \<equiv> (\<lambda>x y. x = Rep y)"
   by (subst (asm) eq_onp_True[symmetric]) (rule Quotient_crel_typedef)
 
 lemma equivp_add_relconj:
   assumes equiv: "equivp R" "equivp R'" and le: "S OO T OO U \<le> R OO STU OO R'"
   shows "R OO S OO T OO U OO R' \<le> R OO STU OO R'"
 proof -
   have trans: "R OO R \<le> R" "R' OO R' \<le> R'"
     using equiv unfolding equivp_reflp_symp_transp transp_relcompp by blast+
   have "R OO S OO T OO U OO R' = R OO (S OO T OO U) OO R'"
     unfolding relcompp_assoc ..
   also have "\<dots> \<le> R OO (R OO STU OO R') OO R'"
     by (intro le relcompp_mono order_refl)
   also have "\<dots> \<le> (R OO R) OO STU OO (R' OO R')"
     unfolding relcompp_assoc ..
   also have "\<dots> \<le> R OO STU OO R'"
     by (intro trans relcompp_mono order_refl)
   finally show ?thesis .
 qed
 
 lemma Grp_conversep_eq_onp: "((BNF_Def.Grp UNIV f)\<inverse>\<inverse> OO BNF_Def.Grp UNIV f) = eq_onp (\<lambda>x. x \<in> range f)"
   by (auto simp: fun_eq_iff Grp_def eq_onp_def image_iff)
 
 lemma Grp_conversep_nonempty: "(BNF_Def.Grp UNIV f)\<inverse>\<inverse> OO BNF_Def.Grp UNIV f \<noteq> bot"
   by (auto simp: fun_eq_iff Grp_def)
 
 lemma relcomppI2: "r a b \<Longrightarrow> s b c \<Longrightarrow> t c d \<Longrightarrow> (r OO s OO t) a d"
   by (auto)
 
 lemma rel_conj_eq_onp: "equivp R \<Longrightarrow> rel_conj R (eq_onp P) \<le> R"
   by (auto simp: eq_onp_def transp_def equivp_def)
 
+lemma Quotient_Quotient3: "Quotient R Abs Rep T \<Longrightarrow> Quotient3 R Abs Rep"
+  unfolding Quotient_def Quotient3_def by blast
+
+lemma bnf_lift_Quotient_equivp: "Quotient R Abs Rep T \<and> equivp R \<Longrightarrow> True"
+  by auto
+
 ML_file "Tools/BNF/bnf_lift.ML"
 
 hide_fact
   sum_insert_Inl_unit lift_sum_unit_vimage_commute insert_Inl_int_map_sum_unit
   image_map_sum_unit_subset subset_lift_sum_unitD UNIV_sum_unit_conv subset_vimage_image_subset
   relcompp_mem_Grp_neq_bot comp_projr_Inr in_rel_sum_in_image_projr subset_rel_sumI
   relcompp_eq_Grp_neq_bot rel_fun_rel_OO1 rel_fun_rel_OO2 rel_sum_eq2_nonempty rel_sum_eq3_nonempty
   hypsubst equivp_add_relconj Grp_conversep_eq_onp Grp_conversep_nonempty relcomppI2 rel_conj_eq_onp
+  bnf_lift_Quotient_equivp Quotient_Quotient3
 
 end
 
diff --git a/src/HOL/ROOT b/src/HOL/ROOT
--- a/src/HOL/ROOT
+++ b/src/HOL/ROOT
@@ -1,1127 +1,1131 @@
 chapter HOL
 
 session HOL (main) = Pure +
   description "
     Classical Higher-order Logic.
   "
   options [strict_facts]
   sessions Tools
   theories
     Main (global)
     Complex_Main (global)
   document_files
     "root.bib"
     "root.tex"
 
 session "HOL-Proofs" (timing) in Proofs = Pure +
   description "
     HOL-Main with explicit proof terms.
   "
   options [quick_and_dirty = false, record_proofs = 2, parallel_limit = 500]
   sessions
     "HOL-Library"
   theories
     "HOL-Library.Realizers"
 
 session "HOL-Library" (main timing) in Library = HOL +
   description "
     Classical Higher-order Logic -- batteries included.
   "
   theories
     Library
     (*conflicting type class instantiations and dependent applications*)
     Finite_Lattice
     List_Lexorder
     Prefix_Order
     Product_Lexorder
     Product_Order
     Subseq_Order
     (*conflicting syntax*)
     Datatype_Records
     (*data refinements and dependent applications*)
     AList_Mapping
     Code_Binary_Nat
     Code_Prolog
     Code_Real_Approx_By_Float
     Code_Target_Numeral
     DAList
     DAList_Multiset
     RBT_Mapping
     RBT_Set
     (*printing modifications*)
     OptionalSugar
     (*prototypic tools*)
     Predicate_Compile_Quickcheck
     (*legacy tools*)
     Old_Datatype
     Old_Recdef
     Realizers
     Refute
   document_files "root.bib" "root.tex"
 
 session "HOL-Analysis" (main timing) in Analysis = HOL +
   options [document_tags = "theorem%important,corollary%important,proposition%important,class%important,instantiation%important,subsubsection%unimportant,%unimportant",
     document_variants = "document:manual=-proof,-ML,-unimportant"]
   sessions
     "HOL-Library"
     "HOL-Computational_Algebra"
   theories
     Analysis
   document_files
     "root.tex"
     "root.bib"
 
 session "HOL-Complex_Analysis" (main timing) in Complex_Analysis = "HOL-Analysis" +
   options [document_tags = "theorem%important,corollary%important,proposition%important,class%important,instantiation%important,subsubsection%unimportant,%unimportant",
     document_variants = "document:manual=-proof,-ML,-unimportant"]
   theories
     Complex_Analysis
   document_files
     "root.tex"
     "root.bib"
 
 session "HOL-Analysis-ex" in "Analysis/ex" = "HOL-Analysis" +
   theories
     Approximations
     Metric_Arith_Examples
 
 session "HOL-Homology" (timing) in Homology = "HOL-Analysis" +
   options [document_tags = "theorem%important,corollary%important,proposition%important,class%important,instantiation%important,subsubsection%unimportant,%unimportant",
     document_variants = "document:manual=-proof,-ML,-unimportant"]
   sessions
     "HOL-Algebra"
   theories
     Homology
   document_files
     "root.tex"
 
 session "HOL-Computational_Algebra" (main timing) in "Computational_Algebra" = "HOL-Library" +
   theories
     Computational_Algebra
     (*conflicting type class instantiations and dependent applications*)
     Field_as_Ring
 
 session "HOL-Real_Asymp" in Real_Asymp = HOL +
   sessions
     "HOL-Decision_Procs"
   theories
     Real_Asymp
     Real_Asymp_Approx
     Real_Asymp_Examples
 
 session "HOL-Real_Asymp-Manual" in "Real_Asymp/Manual" = "HOL-Real_Asymp" +
   theories
     Real_Asymp_Doc
   document_files (in "~~/src/Doc")
     "iman.sty"
     "extra.sty"
     "isar.sty"
   document_files
     "root.tex"
     "style.sty"
 
 session "HOL-Hahn_Banach" in Hahn_Banach = "HOL-Library" +
   description "
     Author:     Gertrud Bauer, TU Munich
 
     The Hahn-Banach theorem for real vector spaces.
 
     This is the proof of the Hahn-Banach theorem for real vectorspaces,
     following H. Heuser, Funktionalanalysis, p. 228 -232. The Hahn-Banach
     theorem is one of the fundamental theorems of functional analysis. It is a
     conclusion of Zorn's lemma.
 
     Two different formaulations of the theorem are presented, one for general
     real vectorspaces and its application to normed vectorspaces.
 
     The theorem says, that every continous linearform, defined on arbitrary
     subspaces (not only one-dimensional subspaces), can be extended to a
     continous linearform on the whole vectorspace.
   "
   sessions
     "HOL-Analysis"
   theories
     Hahn_Banach
   document_files "root.bib" "root.tex"
 
 session "HOL-Induct" in Induct = "HOL-Library" +
   description "
     Examples of (Co)Inductive Definitions.
 
     Comb proves the Church-Rosser theorem for combinators (see
     http://www.cl.cam.ac.uk/ftp/papers/reports/TR396-lcp-generic-automatic-proof-tools.ps.gz).
 
     Mutil is the famous Mutilated Chess Board problem (see
     http://www.cl.cam.ac.uk/ftp/papers/reports/TR394-lcp-mutilated-chess-board.dvi.gz).
 
     PropLog proves the completeness of a formalization of propositional logic
     (see
     http://www.cl.cam.ac.uk/Research/Reports/TR312-lcp-set-II.ps.gz).
 
     Exp demonstrates the use of iterated inductive definitions to reason about
     mutually recursive relations.
   "
   theories [quick_and_dirty]
     Common_Patterns
   theories
     Nested_Datatype
     QuoDataType
     QuoNestedDataType
     Term
     SList
     ABexp
     Infinitely_Branching_Tree
     Ordinals
     Sigma_Algebra
     Comb
     PropLog
     Com
   document_files "root.tex"
 
 session "HOL-IMP" (timing) in IMP = "HOL-Library" +
   options [document_variants = document]
   theories
     BExp
     ASM
     Finite_Reachable
     Denotational
     Compiler2
     Poly_Types
     Sec_Typing
     Sec_TypingT
     Def_Init_Big
     Def_Init_Small
     Fold
     Live
     Live_True
     Hoare_Examples
     Hoare_Sound_Complete
     VCG
     Hoare_Total
     VCG_Total_EX
     VCG_Total_EX2
     Collecting1
     Collecting_Examples
     Abs_Int_Tests
     Abs_Int1_parity
     Abs_Int1_const
     Abs_Int3
     Procs_Dyn_Vars_Dyn
     Procs_Stat_Vars_Dyn
     Procs_Stat_Vars_Stat
     C_like
     OO
   document_files "root.bib" "root.tex"
 
 session "HOL-IMPP" in IMPP = HOL +
   description \<open>
     Author:     David von Oheimb
     Copyright   1999 TUM
 
     IMPP -- An imperative language with procedures.
 
     This is an extension of IMP with local variables and mutually recursive
     procedures. For documentation see "Hoare Logic for Mutual Recursion and
     Local Variables" (https://isabelle.in.tum.de/Bali/papers/FSTTCS99.html).
   \<close>
   theories EvenOdd
 
 session "HOL-Data_Structures" (timing) in Data_Structures = HOL +
   options [document_variants = document]
   sessions
     "HOL-Number_Theory"
   theories [document = false]
     Less_False
   theories
     Sorting
     Balance
     Tree_Map
     AVL_Map
     RBT_Set2
     RBT_Map
     Tree23_Map
     Tree234_Map
     Brother12_Map
     AA_Map
     Set2_Join_RBT
     Array_Braun
     Trie_Fun
     Trie_Map
     Tries_Binary
     Leftist_Heap
     Binomial_Heap
   document_files "root.tex" "root.bib"
 
 session "HOL-Import" in Import = HOL +
   theories HOL_Light_Maps
   theories [condition = HOL_LIGHT_BUNDLE] HOL_Light_Import
 
 session "HOL-Number_Theory" (main timing) in Number_Theory = "HOL-Computational_Algebra" +
   description "
     Fundamental Theorem of Arithmetic, Chinese Remainder Theorem, Fermat/Euler
     Theorem, Wilson's Theorem, some lemmas for Quadratic Reciprocity.
   "
   sessions
     "HOL-Algebra"
   theories
     Number_Theory
   document_files
     "root.tex"
 
 session "HOL-Hoare" in Hoare = HOL +
   description "
     Verification of imperative programs (verification conditions are generated
     automatically from pre/post conditions and loop invariants).
   "
   theories Hoare
   document_files "root.bib" "root.tex"
 
 session "HOL-Hoare_Parallel" (timing) in Hoare_Parallel = HOL +
   description "
     Verification of shared-variable imperative programs a la Owicki-Gries.
     (verification conditions are generated automatically).
   "
   theories Hoare_Parallel
   document_files "root.bib" "root.tex"
 
 session "HOL-Codegenerator_Test" in Codegenerator_Test = "HOL-Number_Theory" +
   sessions
     "HOL-Data_Structures"
     "HOL-ex"
   theories
     Generate
     Generate_Binary_Nat
     Generate_Target_Nat
     Generate_Efficient_Datastructures
     Code_Lazy_Test
     Code_Test_PolyML
     Code_Test_Scala
   theories [condition = ISABELLE_GHC]
     Code_Test_GHC
   theories [condition = ISABELLE_MLTON]
     Code_Test_MLton
   theories [condition = ISABELLE_OCAMLFIND]
     Code_Test_OCaml
   theories [condition = ISABELLE_SMLNJ]
     Code_Test_SMLNJ
 
 session "HOL-Metis_Examples" (timing) in Metis_Examples = "HOL-Library" +
   description "
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Author:     Jasmin Blanchette, TU Muenchen
 
     Testing Metis and Sledgehammer.
   "
   sessions
     "HOL-Decision_Procs"
   theories
     Abstraction
     Big_O
     Binary_Tree
     Clausification
     Message
     Proxies
     Tarski
     Trans_Closure
     Sets
 
 session "HOL-Nitpick_Examples" in Nitpick_Examples = "HOL-Library" +
   description "
     Author:     Jasmin Blanchette, TU Muenchen
     Copyright   2009
   "
   theories [quick_and_dirty] Nitpick_Examples
 
 session "HOL-Algebra" (main timing) in Algebra = "HOL-Computational_Algebra" +
   description "
     Author: Clemens Ballarin, started 24 September 1999, and many others
 
     The Isabelle Algebraic Library.
   "
   sessions
     "HOL-Cardinals"
   theories
     (* Orders and Lattices *)
     Galois_Connection    (* Knaster-Tarski theorem and Galois connections *)
     (* Groups *)
     FiniteProduct        (* Product operator for commutative groups *)
     Sylow                (* Sylow's theorem *)
     Bij                  (* Automorphism Groups *)
     Multiplicative_Group
     Zassenhaus            (* The Zassenhaus lemma *)
     (* Rings *)
     Divisibility         (* Rings *)
     IntRing              (* Ideals and residue classes *)
     UnivPoly             (* Polynomials *)
     (* Main theory *)
     Algebra
   document_files "root.bib" "root.tex"
 
 session "HOL-Auth" (timing) in Auth = "HOL-Library" +
   description "
     A new approach to verifying authentication protocols.
   "
   directories "Smartcard" "Guard"
   theories
     Auth_Shared
     Auth_Public
     "Smartcard/Auth_Smartcard"
     "Guard/Auth_Guard_Shared"
     "Guard/Auth_Guard_Public"
   document_files "root.tex"
 
 session "HOL-UNITY" (timing) in UNITY = "HOL-Auth" +
   description "
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1998  University of Cambridge
 
     Verifying security protocols using Chandy and Misra's UNITY formalism.
   "
   directories "Simple" "Comp"
   theories
     (*Basic meta-theory*)
     UNITY_Main
 
     (*Simple examples: no composition*)
     "Simple/Deadlock"
     "Simple/Common"
     "Simple/Network"
     "Simple/Token"
     "Simple/Channel"
     "Simple/Lift"
     "Simple/Mutex"
     "Simple/Reach"
     "Simple/Reachability"
 
     (*Verifying security protocols using UNITY*)
     "Simple/NSP_Bad"
 
     (*Example of composition*)
     "Comp/Handshake"
 
     (*Universal properties examples*)
     "Comp/Counter"
     "Comp/Counterc"
     "Comp/Priority"
 
     "Comp/TimerArray"
     "Comp/Progress"
 
     "Comp/Alloc"
     "Comp/AllocImpl"
     "Comp/Client"
 
     (*obsolete*)
     ELT
   document_files "root.tex"
 
 session "HOL-Unix" in Unix = "HOL-Library" +
   options [print_mode = "no_brackets,no_type_brackets"]
   theories Unix
   document_files "root.bib" "root.tex"
 
 session "HOL-ZF" in ZF = "HOL-Library" +
   theories
     MainZF
     Games
   document_files "root.tex"
 
 session "HOL-Imperative_HOL" (timing) in Imperative_HOL = "HOL-Library" +
   options [print_mode = "iff,no_brackets"]
   directories "ex"
   theories Imperative_HOL_ex
   document_files "root.bib" "root.tex"
 
 session "HOL-Decision_Procs" (timing) in Decision_Procs = "HOL-Algebra" +
   description "
     Various decision procedures, typically involving reflection.
   "
   directories "ex"
   theories
     Decision_Procs
 
 session "HOL-Proofs-ex" in "Proofs/ex" = "HOL-Proofs" +
   sessions
     "HOL-Isar_Examples"
   theories
     Hilbert_Classical
     Proof_Terms
     XML_Data
 
 session "HOL-Proofs-Extraction" (timing) in "Proofs/Extraction" = "HOL-Proofs" +
   description "
     Examples for program extraction in Higher-Order Logic.
   "
   options [quick_and_dirty = false]
   sessions
     "HOL-Computational_Algebra"
   theories
     Greatest_Common_Divisor
     Warshall
     Higman_Extraction
     Pigeonhole
     Euclid
   document_files "root.bib" "root.tex"
 
 session "HOL-Proofs-Lambda" (timing) in "Proofs/Lambda" = "HOL-Proofs" +
   description \<open>
     Lambda Calculus in de Bruijn's Notation.
 
     This session defines lambda-calculus terms with de Bruijn indixes and
     proves confluence of beta, eta and beta+eta.
 
     The paper "More Church-Rosser Proofs (in Isabelle/HOL)" describes the whole
     theory (see http://www.in.tum.de/~nipkow/pubs/jar2001.html).
   \<close>
   options [print_mode = "no_brackets", quick_and_dirty = false]
   sessions
     "HOL-Library"
   theories
     Eta
     StrongNorm
     Standardization
     WeakNorm
   document_files "root.bib" "root.tex"
 
 session "HOL-Prolog" in Prolog = HOL +
   description "
     Author:   David von Oheimb (based on a lecture on Lambda Prolog by Nadathur)
 
     A bare-bones implementation of Lambda-Prolog.
 
     This is a simple exploratory implementation of Lambda-Prolog in HOL,
     including some minimal examples (in Test.thy) and a more typical example of
     a little functional language and its type system.
   "
   theories Test Type
 
 session "HOL-MicroJava" (timing) in MicroJava = "HOL-Library" +
   description "
     Formalization of a fragment of Java, together with a corresponding virtual
     machine and a specification of its bytecode verifier and a lightweight
     bytecode verifier, including proofs of type-safety.
   "
   sessions
     "HOL-Eisbach"
   directories "BV" "Comp" "DFA" "J" "JVM"
   theories
     MicroJava
   document_files
     "introduction.tex"
     "root.bib"
     "root.tex"
 
 session "HOL-NanoJava" in NanoJava = HOL +
   description "
     Hoare Logic for a tiny fragment of Java.
   "
   theories Example
   document_files "root.bib" "root.tex"
 
 session "HOL-Bali" (timing) in Bali = "HOL-Library" +
   theories
     AxExample
     AxSound
     AxCompl
     Trans
     TypeSafe
   document_files "root.tex"
 
 session "HOL-IOA" in IOA = HOL +
   description \<open>
     Author:     Tobias Nipkow and Konrad Slind and Olaf Müller
     Copyright   1994--1996  TU Muenchen
 
     The meta-theory of I/O-Automata in HOL. This formalization has been
     significantly changed and extended, see HOLCF/IOA. There are also the
     proofs of two communication protocols which formerly have been here.
 
     @inproceedings{Nipkow-Slind-IOA,
     author={Tobias Nipkow and Konrad Slind},
     title={{I/O} Automata in {Isabelle/HOL}},
     booktitle={Proc.\ TYPES Workshop 1994},
     publisher=Springer,
     series=LNCS,
     note={To appear}}
     ftp://ftp.informatik.tu-muenchen.de/local/lehrstuhl/nipkow/ioa.ps.gz
 
     and
 
     @inproceedings{Mueller-Nipkow,
     author={Olaf M\"uller and Tobias Nipkow},
     title={Combining Model Checking and Deduction for {I/O}-Automata},
     booktitle={Proc.\ TACAS Workshop},
     organization={Aarhus University, BRICS report},
     year=1995}
     ftp://ftp.informatik.tu-muenchen.de/local/lehrstuhl/nipkow/tacas.dvi.gz
   \<close>
   theories Solve
 
 session "HOL-Lattice" in Lattice = HOL +
   description "
     Author:     Markus Wenzel, TU Muenchen
 
     Basic theory of lattices and orders.
   "
   theories CompleteLattice
   document_files "root.tex"
 
 session "HOL-ex" (timing) in ex = "HOL-Number_Theory" +
   description "
     Miscellaneous examples for Higher-Order Logic.
   "
   theories
     Adhoc_Overloading_Examples
     Antiquote
     Argo_Examples
     Arith_Examples
     Ballot
     BinEx
     Birthday_Paradox
     Bit_Lists
     Bubblesort
     CTL
     Cartouche_Examples
     Case_Product
     Chinese
     Classical
     Code_Binary_Nat_examples
     Code_Lazy_Demo
     Code_Timing
     Coercion_Examples
     Coherent
     Commands
     Computations
     Conditional_Parametricity_Examples
     Cubic_Quartic
     Datatype_Record_Examples
     Dedekind_Real
     Erdoes_Szekeres
     Eval_Examples
     Executable_Relation
     Execute_Choice
     Functions
     Function_Growth
     Gauge_Integration
     Groebner_Examples
     Guess
     HarmonicSeries
     Hebrew
     Hex_Bin_Examples
     IArray_Examples
     Iff_Oracle
     Induction_Schema
     Intuitionistic
     Join_Theory
     Lagrange
     List_to_Set_Comprehension_Examples
     LocaleTest2
     "ML"
     MergeSort
     MonoidGroup
     Multiquote
     NatSum
     Normalization_by_Evaluation
     PER
     Parallel_Example
     Peano_Axioms
     Perm_Fragments
     PresburgerEx
     Primrec
     Pythagoras
     Quicksort
     Radix_Sort
     Records
     Reflection_Examples
     Refute_Examples
     Residue_Ring
     Rewrite_Examples
     SOS
     SOS_Cert
     Seq
     Serbian
     Set_Comprehension_Pointfree_Examples
     Set_Theory
     Simproc_Tests
     Simps_Case_Conv_Examples
     Sketch_and_Explore
     Sorting_Algorithms_Examples
     Sqrt
     Sqrt_Script
     Sudoku
     Sum_of_Powers
     Tarski
     Termination
     ThreeDivides
     Transfer_Debug
     Transfer_Int_Nat
     Transitive_Closure_Table_Ex
     Tree23
     Triangular_Numbers
     Unification
     While_Combinator_Example
     Word
     veriT_Preprocessing
   theories [skip_proofs = false]
     SAT_Examples
     Meson_Test
 
 session "HOL-Isar_Examples" in Isar_Examples = "HOL-Computational_Algebra" +
   description "
     Miscellaneous Isabelle/Isar examples.
   "
   options [quick_and_dirty]
   theories
     Knaster_Tarski
     Peirce
     Drinker
     Cantor
     Structured_Statements
     Basic_Logic
     Expr_Compiler
     Fibonacci
     Group
     Group_Context
     Group_Notepad
     Hoare_Ex
     Mutilated_Checkerboard
     Puzzle
     Summation
     First_Order_Logic
     Higher_Order_Logic
   document_files
     "root.bib"
     "root.tex"
 
 session "HOL-Eisbach" in Eisbach = HOL +
   description \<open>
     The Eisbach proof method language and "match" method.
   \<close>
   sessions
     FOL
     "HOL-Analysis"
   theories
     Eisbach
     Tests
     Examples
     Examples_FOL
     Example_Metric
 
 session "HOL-SET_Protocol" (timing) in SET_Protocol = "HOL-Library" +
   description "
     Verification of the SET Protocol.
   "
   theories
     SET_Protocol
   document_files "root.tex"
 
 session "HOL-Matrix_LP" in Matrix_LP = "HOL-Library" +
   description "
     Two-dimensional matrices and linear programming.
   "
   directories "Compute_Oracle"
   theories Cplex
   document_files "root.tex"
 
 session "HOL-TLA" in TLA = HOL +
   description "
     Lamport's Temporal Logic of Actions.
   "
   theories TLA
 
 session "HOL-TLA-Inc" in "TLA/Inc" = "HOL-TLA" +
   theories Inc
 
 session "HOL-TLA-Buffer" in "TLA/Buffer" = "HOL-TLA" +
   theories DBuffer
 
 session "HOL-TLA-Memory" in "TLA/Memory" = "HOL-TLA" +
   theories MemoryImplementation
 
 session "HOL-TPTP" in TPTP = "HOL-Library" +
   description "
     Author:     Jasmin Blanchette, TU Muenchen
     Author:     Nik Sultana, University of Cambridge
     Copyright   2011
 
     TPTP-related extensions.
   "
   theories
     ATP_Theory_Export
     MaSh_Eval
     TPTP_Interpret
     THF_Arith
     TPTP_Proof_Reconstruction
   theories
     ATP_Problem_Import
 
 session "HOL-Probability" (main timing) in "Probability" = "HOL-Analysis" +
   theories
     Probability
   document_files "root.tex"
 
 session "HOL-Probability-ex" (timing) in "Probability/ex" = "HOL-Probability" +
   theories
     Dining_Cryptographers
     Koepf_Duermuth_Countermeasure
     Measure_Not_CCC
 
 session "HOL-Nominal" in Nominal = "HOL-Library" +
   theories
     Nominal
 
 session "HOL-Nominal-Examples" (timing) in "Nominal/Examples" = "HOL-Nominal" +
   theories
     Class3
     CK_Machine
     Compile
     Contexts
     Crary
     CR_Takahashi
     CR
     Fsub
     Height
     Lambda_mu
     Lam_Funs
     LocalWeakening
     Pattern
     SN
     SOS
     Standardization
     Support
     Type_Preservation
     Weakening
     W
   theories [quick_and_dirty]
     VC_Condition
 
 session "HOL-Cardinals" (timing) in Cardinals = HOL +
   description "
     Ordinals and Cardinals, Full Theories.
   "
   theories
     Cardinals
     Bounded_Set
   document_files
     "intro.tex"
     "root.tex"
     "root.bib"
 
 session "HOL-Datatype_Examples" (timing) in Datatype_Examples = "HOL-Library" +
   description "
     (Co)datatype Examples.
   "
   directories "Derivation_Trees"
   theories
     Compat
     Lambda_Term
     Process
     TreeFsetI
     "Derivation_Trees/Gram_Lang"
     "Derivation_Trees/Parallel_Composition"
     Koenig
     Lift_BNF
     Milner_Tofte
     Stream_Processor
+    Cyclic_List
+    Dlist
+    Free_Idempotent_Monoid
+    LDL
     TLList
     Misc_Codatatype
     Misc_Datatype
     Misc_Primcorec
     Misc_Primrec
 
 session "HOL-Corec_Examples" (timing) in Corec_Examples = "HOL-Library" +
   description "
     Corecursion Examples.
   "
   directories "Tests"
   theories
     LFilter
     Paper_Examples
     Stream_Processor
     "Tests/Simple_Nesting"
     "Tests/Iterate_GPV"
   theories [quick_and_dirty]
     "Tests/GPV_Bare_Bones"
     "Tests/Merge_D"
     "Tests/Merge_Poly"
     "Tests/Misc_Mono"
     "Tests/Misc_Poly"
     "Tests/Small_Concrete"
     "Tests/Stream_Friends"
     "Tests/TLList_Friends"
     "Tests/Type_Class"
 
 session "HOL-Word" (main timing) in Word = HOL +
   sessions
     "HOL-Library"
   theories
     Word
     More_Word
     Word_Examples
   document_files "root.bib" "root.tex"
 
 session "HOL-Statespace" in Statespace = HOL +
   theories [skip_proofs = false]
     StateSpaceEx
   document_files "root.tex"
 
 session "HOL-Nonstandard_Analysis" (timing) in Nonstandard_Analysis = "HOL-Computational_Algebra" +
   description "
     Nonstandard analysis.
   "
   theories
     Nonstandard_Analysis
   document_files "root.tex"
 
 session "HOL-Nonstandard_Analysis-Examples" (timing) in "Nonstandard_Analysis/Examples" = "HOL-Nonstandard_Analysis" +
   theories
     NSPrimes
 
 session "HOL-Mirabelle" in Mirabelle = HOL +
   theories Mirabelle_Test
 
 session "HOL-Mirabelle-ex" in "Mirabelle/ex" = "HOL-Mirabelle" +
   options [timeout = 60]
   theories Ex
 
 session "HOL-Word-SMT_Examples" (timing) in SMT_Examples = "HOL-Word" +
   options [quick_and_dirty]
   theories
     Boogie
     SMT_Examples
     SMT_Word_Examples
     SMT_Tests
 
 session "HOL-SPARK" in "SPARK" = "HOL-Word" +
   theories
     SPARK
 
 session "HOL-SPARK-Examples" in "SPARK/Examples" = "HOL-SPARK" +
   directories "Gcd" "Liseq" "RIPEMD-160" "Sqrt"
   theories
     "Gcd/Greatest_Common_Divisor"
     "Liseq/Longest_Increasing_Subsequence"
     "RIPEMD-160/F"
     "RIPEMD-160/Hash"
     "RIPEMD-160/K_L"
     "RIPEMD-160/K_R"
     "RIPEMD-160/R_L"
     "RIPEMD-160/Round"
     "RIPEMD-160/R_R"
     "RIPEMD-160/S_L"
     "RIPEMD-160/S_R"
     "Sqrt/Sqrt"
   export_files (in ".") "*:**.prv"
 
 session "HOL-SPARK-Manual" in "SPARK/Manual" = "HOL-SPARK" +
   options [show_question_marks = false]
   sessions
     "HOL-SPARK-Examples"
   theories
     Example_Verification
     VC_Principles
     Reference
     Complex_Types
   document_files
     "complex_types.ads"
     "complex_types_app.adb"
     "complex_types_app.ads"
     "Gcd.adb"
     "Gcd.ads"
     "intro.tex"
     "loop_invariant.adb"
     "loop_invariant.ads"
     "root.bib"
     "root.tex"
     "Simple_Gcd.adb"
     "Simple_Gcd.ads"
 
 session "HOL-Mutabelle" in Mutabelle = "HOL-Library" +
   theories MutabelleExtra
 
 session "HOL-Quickcheck_Examples" (timing) in Quickcheck_Examples = "HOL-Library" +
   theories
     Quickcheck_Examples
     Quickcheck_Lattice_Examples
     Completeness
     Quickcheck_Interfaces
     Quickcheck_Nesting_Example
   theories [condition = ISABELLE_GHC]
     Hotel_Example
     Quickcheck_Narrowing_Examples
 
 session "HOL-Quotient_Examples" (timing) in Quotient_Examples = "HOL-Algebra" +
   description "
     Author:     Cezary Kaliszyk and Christian Urban
   "
   theories
     DList
     Quotient_FSet
     Quotient_Int
     Quotient_Message
     Lift_FSet
     Lift_Set
     Lift_Fun
     Quotient_Rat
     Lift_DList
     Int_Pow
     Lifting_Code_Dt_Test
 
 session "HOL-Predicate_Compile_Examples" (timing) in Predicate_Compile_Examples = "HOL-Library" +
   theories
     Examples
     Predicate_Compile_Tests
     Predicate_Compile_Quickcheck_Examples
     Specialisation_Examples
     IMP_1
     IMP_2
     (* FIXME since 21-Jul-2011
     Hotel_Example_Small_Generator *)
     IMP_3
     IMP_4
   theories [condition = ISABELLE_SWIPL]
     Code_Prolog_Examples
     Context_Free_Grammar_Example
     Hotel_Example_Prolog
     Lambda_Example
     List_Examples
   theories [condition = ISABELLE_SWIPL, quick_and_dirty]
     Reg_Exp_Example
 
 session "HOL-Types_To_Sets" in Types_To_Sets = HOL +
   description "
     Experimental extension of Higher-Order Logic to allow translation of types to sets.
   "
   directories "Examples"
   theories
     Types_To_Sets
     "Examples/Prerequisites"
     "Examples/Finite"
     "Examples/T2_Spaces"
     "Examples/Unoverload_Def"
     "Examples/Linear_Algebra_On"
 
 session HOLCF (main timing) in HOLCF = HOL +
   description "
     Author:     Franz Regensburger
     Author:     Brian Huffman
 
     HOLCF -- a semantic extension of HOL by the LCF logic.
   "
   sessions
     "HOL-Library"
   theories
     HOLCF (global)
   document_files "root.tex"
 
 session "HOLCF-Tutorial" in "HOLCF/Tutorial" = HOLCF +
   theories
     Domain_ex
     Fixrec_ex
     New_Domain
   document_files "root.tex"
 
 session "HOLCF-Library" in "HOLCF/Library" = HOLCF +
   theories
     HOLCF_Library
     HOL_Cpo
 
 session "HOLCF-IMP" in "HOLCF/IMP" = HOLCF +
   description "
     IMP -- A WHILE-language and its Semantics.
 
     This is the HOLCF-based denotational semantics of a simple WHILE-language.
   "
   sessions
     "HOL-IMP"
   theories
     HoareEx
   document_files
     "isaverbatimwrite.sty"
     "root.tex"
     "root.bib"
 
 session "HOLCF-ex" in "HOLCF/ex" = "HOLCF-Library" +
   description "
     Miscellaneous examples for HOLCF.
   "
   theories
     Dnat
     Dagstuhl
     Focus_ex
     Fix2
     Hoare
     Concurrency_Monad
     Loop
     Powerdomain_ex
     Domain_Proofs
     Letrec
     Pattern_Match
 
 session "HOLCF-FOCUS" in "HOLCF/FOCUS" = "HOLCF-Library" +
   description \<open>
     FOCUS: a theory of stream-processing functions Isabelle/HOLCF.
 
     For introductions to FOCUS, see
 
     "The Design of Distributed Systems - An Introduction to FOCUS"
     http://www4.in.tum.de/publ/html.php?e=2
 
     "Specification and Refinement of a Buffer of Length One"
     http://www4.in.tum.de/publ/html.php?e=15
 
     "Specification and Development of Interactive Systems: Focus on Streams,
     Interfaces, and Refinement" http://www4.in.tum.de/publ/html.php?e=321
   \<close>
   theories
     Fstreams
     FOCUS
     Buffer_adm
 
 session IOA (timing) in "HOLCF/IOA" = HOLCF +
   description "
     Author:     Olaf Mueller
     Copyright   1997 TU München
 
     A formalization of I/O automata in HOLCF.
 
     The distribution contains simulation relations, temporal logic, and an
     abstraction theory. Everything is based upon a domain-theoretic model of
     finite and infinite sequences.
   "
   theories Abstraction
 
 session "IOA-ABP" in "HOLCF/IOA/ABP" = IOA +
   description "
     Author:     Olaf Mueller
 
     The Alternating Bit Protocol performed in I/O-Automata.
   "
   theories
     Correctness
     Spec
 
 session "IOA-NTP" in "HOLCF/IOA/NTP" = IOA +
   description "
     Author:     Tobias Nipkow & Konrad Slind
 
     A network transmission protocol, performed in the
     I/O automata formalization by Olaf Mueller.
   "
   theories Correctness
 
 session "IOA-Storage" in "HOLCF/IOA/Storage" = IOA +
   description "
     Author:     Olaf Mueller
 
     Memory storage case study.
   "
   theories Correctness
 
 session "IOA-ex" in "HOLCF/IOA/ex" = IOA +
   description "
     Author:     Olaf Mueller
   "
   theories
     TrivEx
     TrivEx2
diff --git a/src/HOL/Tools/BNF/bnf_lift.ML b/src/HOL/Tools/BNF/bnf_lift.ML
--- a/src/HOL/Tools/BNF/bnf_lift.ML
+++ b/src/HOL/Tools/BNF/bnf_lift.ML
@@ -1,2043 +1,2054 @@
 (*  Title:      HOL/Tools/BNF/bnf_lift.ML
     Author:     Julian Biendarra, TU Muenchen
     Author:     Basil Fürer, ETH Zurich
     Author:     Joshua Schneider, ETH Zurich
     Author:     Dmitriy Traytel, ETH Zurich
     Copyright   2015, 2019
 
 Lifting of BNFs through typedefs.
 *)
 
 signature BNF_LIFT =
 sig
   datatype lift_bnf_option =
     Plugins_Option of Proof.context -> Plugin_Name.filter
   | No_Warn_Wits
   | No_Warn_Transfer
   val copy_bnf:
     (((lift_bnf_option list * (binding option * (string * sort option)) list) *
       string) * thm option) * (binding * binding * binding) ->
       local_theory -> local_theory
   val copy_bnf_cmd:
     (((lift_bnf_option list * (binding option * (string * string option)) list) *
       string) * (Facts.ref * Token.src list) option) * (binding * binding * binding) ->
       local_theory -> local_theory
   val lift_bnf:
     ((((lift_bnf_option list * (binding option * (string * sort option)) list) *
       string) * term list option) * thm option) * (binding * binding * binding) ->
       ({context: Proof.context, prems: thm list} -> tactic) list ->
       local_theory -> local_theory
   val lift_bnf_cmd:
      ((((lift_bnf_option list * (binding option * (string * string option)) list) *
        string) * string list) * (Facts.ref * Token.src list) option) *
        (binding * binding * binding) -> local_theory -> Proof.state
 end
 
 structure BNF_Lift : BNF_LIFT =
 struct
 
 open Ctr_Sugar_Tactics
 open BNF_Util
 open BNF_Comp
 open BNF_Def
 
 
 datatype lift_bnf_option =
   Plugins_Option of Proof.context -> Plugin_Name.filter
 | No_Warn_Wits
 | No_Warn_Transfer;
 
 datatype lift_thm = Typedef of thm | Quotient of thm
 
 (** Util **)
 
 fun last2 [x, y] = ([], (x, y))
   | last2 (x :: xs) = last2 xs |>> (fn y => x :: y)
   | last2 [] = raise Match;
 
 fun strip3 thm = (case Term.strip_comb (HOLogic.dest_Trueprop (Thm.prop_of thm)) of
     (_, [x1, x2, x3]) => (x1, x2, x3)
   | _ => error "strip3: wrong number of arguments");
 
 val mk_Free = yield_singleton o mk_Frees;
 
 fun TWICE t = t THEN' t;
 
 fun prove lthy fvars tm tac =
   Goal.prove_sorry lthy (map (fst o dest_Free) fvars) [] tm (fn {context, ...} => tac context);
 
 (** Term construction **)
 
 fun mk_relT aT bT = aT --> bT --> HOLogic.boolT;
 fun mk_relcompp r s = let
     val (rT, sT) = apply2 fastype_of (r, s);
     val ((xT, _), (_, zTs)) = apply2 dest_funT (rT, sT);
     val T = rT --> sT --> mk_relT xT (fst (dest_funT zTs));
   in Const (@{const_name relcompp}, T) $ r $ s end;
 val mk_OO = fold_rev mk_relcompp;
 
 (* option from sum *)
 fun mk_MaybeT T = mk_sumT (HOLogic.unitT, T);
 fun mk_Nothing T = BNF_FP_Util.mk_Inl T HOLogic.unit;
 val Just_const = BNF_FP_Util.Inr_const HOLogic.unitT;
 fun mk_Just tm = Just_const (fastype_of tm) $ tm;
 fun Maybe_map_const T =
   let val (xT, yT) = dest_funT T in
     Const (@{const_name map_sum}, (HOLogic.unitT --> HOLogic.unitT) --> T --> mk_MaybeT xT --> mk_MaybeT yT) $
       HOLogic.id_const HOLogic.unitT
   end;
 fun mk_Maybe_map tm = Maybe_map_const (fastype_of tm) $ tm;
 fun fromJust_const T = Const (@{const_name sum.projr}, mk_MaybeT T --> T)
 
 fun rel_Maybe_const T U =
   Const (@{const_name rel_sum}, (HOLogic.unitT --> HOLogic.unitT --> HOLogic.boolT) -->
     (T --> U --> HOLogic.boolT) --> mk_MaybeT T --> mk_MaybeT U --> HOLogic.boolT) $
   HOLogic.eq_const HOLogic.unitT
 fun set_Maybe_const T = Const (@{const_name Basic_BNFs.setr}, mk_MaybeT T --> HOLogic.mk_setT T)
 
 fun Inf_const T = Const (@{const_name Inf}, HOLogic.mk_setT T --> T);
 
 fun Image_const T =
   let
     val relT = HOLogic.mk_setT (HOLogic.mk_prodT (T, T));
     val setT = HOLogic.mk_setT T;
   in Const (@{const_name Image}, relT --> setT --> setT) end;
 
 fun bot_const T = Const (@{const_name bot}, T);
 
 fun mk_insert x S =
   Const (@{const_name Set.insert}, fastype_of x --> fastype_of S --> fastype_of S) $ x $ S;
 
 fun mk_vimage f s =
   let val (xT, yT) = dest_funT (fastype_of f) in
     Const (@{const_name vimage}, (xT --> yT) --> HOLogic.mk_setT yT --> HOLogic.mk_setT xT) $ f $ s
   end;
 
 fun mk_case_prod (x, y) tm = let
      val ((x, xT), (y, yT)) = apply2 dest_Free (x, y);
      val prodT = HOLogic.mk_prodT (xT, yT);
    in HOLogic.Collect_const prodT $ (Const (@{const_name case_prod},
        (xT --> yT --> HOLogic.boolT) --> prodT --> HOLogic.boolT) $ absfree (x, xT)
        (absfree (y, yT) tm)) end;
 
 fun mk_Trueprop_implies (ps, c) =
   Logic.list_implies (map HOLogic.mk_Trueprop ps, HOLogic.mk_Trueprop c);
 
 fun mk_Collect (v, tm) = let val (n, T) = dest_Free v in
   HOLogic.mk_Collect (n, T, tm) end;
 
 
 (** witnesses **)
 fun prepare_wits is_quotient RepT wits opts alphas wits_F var_as var_as' sets lthy =
   let
     fun binder_types_until_eq V T =
       let
         fun strip (TU as Type ("fun", [T, U])) = if V = TU then [] else T :: strip U
           | strip T = if V = T then [] else
               error ("Bad type for witness: " ^ quote (Syntax.string_of_typ lthy T));
       in strip T end;
 
     val Iwits = the_default wits_F (Option.map (map (`(map (fn T =>
       find_index (fn U => T = U) alphas) o binder_types_until_eq RepT o fastype_of))) wits);
 
     val wit_goals = maps (BNF_Def.mk_wit_goals var_as var_as' sets) Iwits;
 
     val lost_wits = filter_out (fn (J, _) => exists (fn (I, _) => subset (op =) (I, J)) Iwits) wits_F;
 
     val _ =
       if null lost_wits orelse exists (fn No_Warn_Wits => true | _ => false) opts then ()
       else
         let
           val what = (if is_quotient then "quotient type" else "typedef");
           val (suffix1, suffix2, be) =
             (if length lost_wits = 1 then ("", "", "was") else ("s", "es", "were"))
         in
           lost_wits
           |> map (Syntax.pretty_typ lthy o fastype_of o snd)
           |> Pretty.big_list
             ("The following type" ^ suffix1 ^ " of nonemptiness witness" ^ suffix2 ^
               " of the raw type's BNF " ^ be ^ " lost:")
           |> (fn pt => Pretty.chunks [pt,
             Pretty.para ("You can specify a liftable witness (e.g., a term of one of the above types\
               \ that satisfies the " ^ what ^ "'s invariant)\
               \ using the annotation [wits: <term>].")])
           |> Pretty.string_of
           |> warning
         end;
   in (Iwits, wit_goals) end;
 
 
 (** transfer theorems **)
 
 fun mk_transfer_thms' bnf_F bnf_G name consts Tss crel_def pcrel_def defs lthy = let
 
     val live = length (#alphas Tss);
 
     val (pcrel_tm, crel_tm) = apply2 (Thm.prop_of #> Logic.dest_equals #> fst #> head_of)
       (pcrel_def, crel_def);
 
     val (var_Qs, var_Rs) = fold Variable.declare_typ (#alphas Tss @ #deads Tss) lthy
       |> mk_Frees "Q" (map2 mk_relT (#alphas Tss) (#betas Tss))
       ||>> mk_Frees "R" (map2 mk_relT (#gammas Tss) (#deltas Tss))
       |> fst;
 
     (* get the "pcrel :: args_raw => rep => abs \<Rightarrow> bool" term and instantiate types *)
     val (args_raw, (rep, abs)) = pcrel_tm
       |> fastype_of
       |> binder_types
       |> last2;
     val thy = Proof_Context.theory_of lthy;
     val tyenv_match = Vartab.empty
       |> Sign.typ_match thy ((rep, #rep Tss))
       |> Sign.typ_match thy ((abs, #abs Tss));
     val args = map (Envir.subst_type tyenv_match) args_raw;
     val (pcrel_a, pcrel_b) = Envir.subst_term (tyenv_match, Vartab.empty) pcrel_tm
       |> `(subst_atomic_types (#alphas Tss @ #betas Tss ~~ #gammas Tss @ #deltas Tss));
 
     (* match "crel :: {?a F} \<Rightarrow> a G" with "rep_G :: {a F}" *)
     val tyenv_match = Vartab.empty |> Sign.typ_match thy
       (crel_tm |> fastype_of |> binder_types |> hd, #rep Tss);
     val crel_b = Envir.subst_term (tyenv_match, Vartab.empty) crel_tm
       |> subst_atomic_types (#alphas Tss ~~ #betas Tss)
     val crel_d = subst_atomic_types (#betas Tss ~~ #deltas Tss) crel_b;
 
     (* instantiate pcrel with Qs and Rs*)
     val dead_args = map binder_types args
       |> map (fn [T,U] => if T = U then SOME T else NONE | _ => NONE);
     val parametrize = let
         fun go (SOME T :: dTs) tms = HOLogic.eq_const T :: go dTs tms
           | go (_ :: dTs) (tm :: tms) = tm :: go dTs tms
           | go (_ :: dTs) tms = go dTs tms
           | go _ _ = [];
       in go dead_args end;
 
     val pcrel_Qs = list_comb (pcrel_b, parametrize var_Qs);
     val pcrel_Rs = list_comb (pcrel_a, parametrize var_Rs);
 
     (* get the order of the dead variables right *)
     val Ds0 = maps the_list dead_args;
     val permute_Ds = (mk_T_of_bnf Ds0 (#betas Tss) bnf_G, nth (binder_types (type_of pcrel_Qs)) 1)
       |> apply2 (fn Type (_, Ts) => Ts | _ => []) |> op~~ |> typ_subst_atomic;
     val Ds0 = map permute_Ds Ds0;
 
     (* terms for sets of the set_transfer thms *)
     val rel_sets_Q = @{map 3} (fn aT => fn bT => fn Q =>
       mk_rel 1 [aT] [bT] @{term rel_set} $ Q) (#alphas Tss) (#betas Tss) var_Qs;
 
     (* rewrite rules for pcrel and BNF's relator: "pcrel Q = rel_F OO crel" *)
     fun mk_pcr_rel_F_eq Ts Us pcrel vs crel =
       let
         val thm = HOLogic.mk_Trueprop (HOLogic.mk_eq (pcrel, mk_relcompp (list_comb
           (mk_rel_of_bnf (#deads Tss) (Ts Tss) (Us Tss) bnf_F, vs)) crel));
         fun tac ctxt = unfold_thms_tac ctxt (pcrel_def :: defs @ @{thm id_bnf_apply} ::
           Transfer.get_relator_eq ctxt) THEN (HEADGOAL (rtac ctxt refl))
       in prove lthy vs thm tac |> mk_abs_def end;
 
     val pcr_rel_F_eqs =
       [mk_pcr_rel_F_eq #alphas #betas pcrel_Qs var_Qs crel_b,
        mk_pcr_rel_F_eq #gammas #deltas pcrel_Rs var_Rs crel_d];
 
     (* create transfer-relations from term('s type) *)
     fun mk_transfer_rel' i tm =
       let
         fun go T' (n, q) = case T' of
             Type ("fun", [T as Type ("fun", _), U]) =>
               go U (n+1, q) |>> mk_rel_fun (fst (go T (n, q)))
           | Type ("fun", [T, U]) =>
               go T (n, q) |-> (fn x => fn st => go U st |>> mk_rel_fun x)
           | Type (@{type_name bool}, _) => (HOLogic.eq_const HOLogic.boolT, (n, q))
           | Type (@{type_name set}, _) => (nth rel_sets_Q n, (n, q))
           | Type _ => (if q then pcrel_Qs else pcrel_Rs, (n, not q))
           | TFree _ => (nth (if q then var_Qs else var_Rs) n, (n, not q))
           | _ => raise Match
       in go (fastype_of tm) (i, true) |> fst end;
 
     (* prove transfer rules *)
     fun prove_transfer_thm' i vars new_tm const =
       let
         val tm = HOLogic.mk_Trueprop (mk_transfer_rel' i new_tm $ #raw const $ new_tm);
         val tac = (fn ctxt => unfold_thms_tac ctxt (pcr_rel_F_eqs @ [crel_def]) THEN
           #tac const {Rs=var_Rs,Qs=var_Qs} ctxt);
       in prove lthy vars tm tac end;
     val prove_transfer_thm = prove_transfer_thm' 0;
 
     (* map transfer: "((Q ===> R) ===> pcr_G Q ===> pcr_G R) map_F' map_G" *)
     val map_G = mk_map_of_bnf Ds0 (#betas Tss) (#deltas Tss) bnf_G;
     val map_transfer = prove_transfer_thm (var_Qs @ var_Rs) map_G (#map consts);
 
     (* pred_transfer: "((Q ===> (=)) ===> pcr_G Q ===> (=)) pred_F' pred_G" *)
     val pred_G = mk_pred_of_bnf Ds0 (#betas Tss) bnf_G;
     val pred_transfer = #pred consts |> Option.map (fn p =>
       ("pred", [prove_transfer_thm (var_Qs @ var_Rs) pred_G p]));
 
     (* rel_transfer: "((Q ===> R ===> (=)) ===> pcr_G Q ===> pcr_G R ===> (=)) rel_F' rel_G" *)
     val rel_G = mk_rel_of_bnf Ds0 (#betas Tss) (#deltas Tss) bnf_G;
     val rel_transfer = prove_transfer_thm (var_Qs @ var_Rs) rel_G (#rel consts);
 
     (* set_transfer: "(pcr_G Q ===> rel_set Q) set_F' set_G" *)
     val sets_G = mk_sets_of_bnf (replicate live Ds0) (replicate live (#betas Tss)) bnf_G;
     fun mk_set_transfer i set_G raw tac = prove_transfer_thm' i var_Qs set_G {raw=raw, tac=tac};
     val sets_transfer = @{map 4} mk_set_transfer
       (0 upto (live-1)) sets_G (#raws (#sets consts)) (#tacs (#sets consts));
 
     (* export transfer theorems *)
     val transform = Morphism.thm (Morphism.thm_morphism "BNF" (unfold_thms lthy defs)) |> map;
     val b = Binding.qualified_name name;
     val qualify =
       let val qs = Binding.path_of b;
       in fold_rev (fn (s, mand) => Binding.qualify mand s) qs end;
     fun mk_binding n = Binding.name (n ^ "_transfer_raw")
       |> Binding.qualify true (Binding.name_of b) |> qualify;
     val notes = [("map", [map_transfer]), ("rel", [rel_transfer])] @ the_list pred_transfer @
       [("set", sets_transfer)] |> map (fn (n, thms) =>
         ((mk_binding n, []), [(transform thms, @{attributes [transfer_rule]})]));
 
   in lthy |> Local_Theory.notes notes |> snd end;
 
 (* transfer theorems for map, pred (in case of a typedef), rel and sets *)
 fun mk_transfer_thms quiet bnf_F bnf_G name consts thm Tss defs lthy = let
 
     fun mk_crel_def quot_thm =
       (case thm of
         Quotient equiv => @{thm Quotient_crel_quotient} OF [quot_thm, equiv]
       | Typedef _ => hd ([quot_thm] RL @{thms Quotient_crel_typedef Quotient_crel_typecopy}));
     fun no_quotient _ = [Pretty.para ("No quotient theorem has been registered for " ^
         Binding.name_of (name_of_bnf bnf_G) ^ "."),
       Pretty.para "Use setup_lifting to register a quotient or type definition theorem."];
     fun wrong_quotient T lthy = [Pretty.para ("A wrong quotient theorem has been registered for " ^
         Binding.name_of (name_of_bnf bnf_G) ^ "."),
       Pretty.para ("Expected raw type " ^
         Pretty.string_of (Syntax.pretty_typ lthy (T_of_bnf bnf_F)) ^
         " but the quotient theorem has raw type " ^
         Pretty.string_of (Syntax.pretty_typ lthy T) ^ "."),
       Pretty.para "Use setup_lifting to register a different quotient or type definition theorem."];
     fun pcr_why _ = [Pretty.para ("The pcr_" ^ Binding.name_of (name_of_bnf bnf_G) ^
       " relator has not been defined.")];
     fun warn_transfer why lthy =
       (Pretty.para "The transfer theorems can't be generated:" ::  why lthy)
       |> Pretty.chunks |> Pretty.string_of |> warning |> K lthy;
     fun maybe_warn_transfer why = not quiet ? warn_transfer why;
   in
     case Lifting_Info.lookup_quotients lthy name of
       SOME {pcr_info, quot_thm} =>
         (let
           val crel_def = mk_crel_def quot_thm;
           val rty = Lifting_Util.quot_thm_rty_qty quot_thm |> fst;
           val thy = Proof_Context.theory_of lthy;
         in
           if Sign.typ_instance thy (rty, T_of_bnf bnf_F) then
           (case pcr_info of
             SOME {pcrel_def, ...} =>
               mk_transfer_thms' bnf_F bnf_G name consts Tss crel_def pcrel_def defs lthy
           | _ => maybe_warn_transfer pcr_why lthy)
           else maybe_warn_transfer (wrong_quotient rty) lthy
         end)
     | _ => maybe_warn_transfer no_quotient lthy
   end;
 
 
 (** typedef_bnf **)
 
 fun mk_typedef_transfer_tacs bnf_F bnf_G thms old_defs
   map_raw rel_raw pred_raw sets_raw = let
 
     val live = live_of_bnf bnf_G;
     val Abs_G_inverse = @{thm type_definition.Abs_inverse} OF [#typedef thms];
     val Rep_G = @{thm type_definition.Rep} OF [#typedef thms];
 
     fun common_tac addefs tac = (fn _ => fn ctxt =>
       HEADGOAL (EVERY' [SELECT_GOAL (unfold_thms_tac ctxt addefs),
         REPEAT_DETERM o rtac ctxt rel_funI,
         SELECT_GOAL (unfold_thms_tac ctxt @{thms o_apply}),
         REPEAT_DETERM o eresolve_tac ctxt @{thms relcomppE exE conjE},
         hyp_subst_tac ctxt]) THEN tac ctxt)
 
     fun map_tac ctxt = (HEADGOAL o EVERY')
       [rtac ctxt @{thm relcomppI},
       etac ctxt (mk_rel_funDN (live+1) (map_transfer_of_bnf bnf_F)),
       REPEAT_DETERM_N live o assume_tac ctxt,
       SELECT_GOAL (unfold_thms_tac ctxt [Abs_G_inverse OF [#map_closed thms] OF [Rep_G]]),
       REPEAT_DETERM o rtac ctxt refl];
     val map_tac = common_tac [#map old_defs] map_tac;
 
     fun rel_tac ctxt =
       HEADGOAL (etac ctxt (mk_rel_funDN (live+2) (rel_transfer_of_bnf bnf_F)) THEN'
         REPEAT_DETERM_N (live+1) o assume_tac ctxt);
     val rel_tac = common_tac (#rel old_defs :: @{thms vimage2p_def}) rel_tac;
 
     fun pred_tac ctxt =
       HEADGOAL (etac ctxt (mk_rel_funDN (live+1) (pred_transfer_of_bnf bnf_F)) THEN'
         REPEAT_DETERM_N live o (assume_tac ctxt));
     val pred_tac = common_tac [#pred old_defs] pred_tac;
 
     fun set_tac set_transfer_thm ctxt =
       HEADGOAL (etac ctxt (rel_funD OF [set_transfer_thm]));
     fun mk_set_tac set_def set_transfer = common_tac [set_def] (set_tac set_transfer);
     val set_tacs = map2 mk_set_tac (#sets old_defs) (set_transfer_of_bnf bnf_F);
 
   in {map={raw=map_raw,tac=map_tac},rel={raw=rel_raw,tac=rel_tac},
       sets={raws=sets_raw,tacs=set_tacs},pred=SOME{raw=pred_raw,tac=pred_tac}} end;
 
 fun typedef_bnf thm wits specs map_b rel_b pred_b opts lthy =
   let
     val plugins =
       get_first (fn Plugins_Option f => SOME (f lthy) | _ => NONE) (rev opts)
         |> the_default Plugin_Name.default_filter;
 
     (* extract Rep Abs F RepT AbsT *)
     val (Rep_G, Abs_G, F) = strip3 thm;
     val typ_Abs_G = dest_funT (fastype_of Abs_G);
     val RepT = fst typ_Abs_G; (* F *)
     val AbsT = snd typ_Abs_G; (* G *)
     val AbsT_name = fst (dest_Type AbsT);
     val tvs = AbsT |> dest_Type |> snd |> map (fst o dest_TVar);
     val alpha0s = map (TFree o snd) specs;
 
     val _ = length tvs = length alpha0s orelse
       error ("Expected " ^ string_of_int (length tvs) ^ " type argument(s) to " ^ quote AbsT_name);
 
     (* instantiate the new type variables newtvs to oldtvs *)
     val subst = subst_TVars (tvs ~~ alpha0s);
     val typ_subst = typ_subst_TVars (tvs ~~ alpha0s);
 
     val Rep_G = subst Rep_G;
     val Abs_G = subst Abs_G;
     val F = subst F;
     val RepT = typ_subst RepT;
     val AbsT = typ_subst AbsT;
 
     fun flatten_tyargs Ass =
       map dest_TFree alpha0s
       |> filter (fn T => exists (fn Ts => member op= Ts T) Ass);
 
     val Ds0 = filter (is_none o fst) specs |> map snd;
 
     (* get the bnf for RepT *)
     val ((bnf_F, (deads, alphas)), ((_, unfolds), lthy)) =
       bnf_of_typ true Dont_Inline (Binding.qualify true AbsT_name) flatten_tyargs []
         Ds0 RepT ((empty_comp_cache, empty_unfolds), lthy);
 
     val set_bs =
       map (fn T => find_index (fn U => T = U) alpha0s) alphas
       |> map (the_default Binding.empty o fst o nth specs);
 
     val _ = (case alphas of [] => error "No live variables" | _ => ());
 
     val defs = #map_unfolds unfolds @ flat (#set_unfoldss unfolds) @ #rel_unfolds unfolds @ #pred_unfolds unfolds;
 
     (* number of live variables *)
     val live = length alphas;
 
     (* state the three required properties *)
     val sorts = map Type.sort_of_atyp alphas;
     val names_lthy = fold Variable.declare_typ (alphas @ deads) lthy;
     val (((alphas', betas), betas'), names_lthy) = names_lthy
       |> mk_TFrees' sorts
       ||>> mk_TFrees' sorts
       ||>> mk_TFrees' sorts;
 
     val map_F = mk_map_of_bnf deads alphas betas bnf_F;
 
     val (typ_fs, typ_aF) = fastype_of map_F |> strip_typeN live ||> domain_type;
     val typ_pairs = map HOLogic.mk_prodT (alphas ~~ alphas');
     val typ_subst_pair = typ_subst_atomic (alphas ~~ typ_pairs);
     val typ_pair = typ_subst_pair RepT;
     val subst_b = subst_atomic_types (alphas ~~ betas);
     val subst_a' = subst_atomic_types (alphas ~~ alphas');
     val subst_pair = subst_atomic_types (alphas ~~ typ_pairs);
     val aF_set = F;
     val aF_set' = subst_a' F;
     val pairF_set = subst_pair F;
     val bF_set = subst_b F;
     val map_F_fst = mk_map_of_bnf deads typ_pairs alphas bnf_F;
     val map_F_snd = mk_map_of_bnf deads typ_pairs alphas' bnf_F
     val sets_F_pairs = mk_sets_of_bnf (replicate live deads) (replicate live typ_pairs) bnf_F
     val wits_F = mk_wits_of_bnf
       (replicate (nwits_of_bnf bnf_F) deads)
       (replicate (nwits_of_bnf bnf_F) alphas) bnf_F;
 
     (* val map_closed_F = @{term "\<And>f x. x \<in> F \<Longrightarrow> map_F f x \<in> F"}; *)
     val (var_fs, names_lthy) = mk_Frees "f" typ_fs names_lthy;
     val (var_x, names_lthy) = mk_Frees "x" [typ_aF] names_lthy |>> the_single;
     val mem_x = HOLogic.mk_Trueprop (HOLogic.mk_mem (var_x, aF_set));
     val map_f = list_comb (map_F, var_fs);
     val mem_map = HOLogic.mk_Trueprop (HOLogic.mk_mem (map_f $ var_x, bF_set));
     val imp_map = Logic.mk_implies (mem_x, mem_map);
     val map_closed_F = fold_rev Logic.all var_fs (Logic.all var_x imp_map);
 
     (* val zip_closed_F =
       @{term "\<And>z. \<lbrakk>map_F fst z \<in> F; map_F snd z \<in> F\<rbrakk> \<Longrightarrow>
         \<exists>z' \<in> F. set_F z' \<subseteq> set_F z \<and> map_F fst z' = map_F fst z \<and> map_F snd z' = map_F snd z"}; *)
     val (var_z, names_lthy) = mk_Free "z" typ_pair names_lthy;
     val (var_z', names_lthy) = mk_Free "z'" typ_pair names_lthy;
     val (pairs, names_lthy) = mk_Frees "tmp" typ_pairs names_lthy;
 
     fun mk_map mfs f z = Term.list_comb (mfs, map (fst o Term.strip_comb o f) pairs) $ z;
     fun mk_set var = map (fn t => t $ var) sets_F_pairs;
 
     val (map_fst', map_fst) = apply2 (mk_map map_F_fst HOLogic.mk_fst) (var_z', var_z);
     val (map_snd', map_snd) = apply2 (mk_map map_F_snd HOLogic.mk_snd) (var_z', var_z);
     val mem_map_fst = HOLogic.mk_Trueprop (HOLogic.mk_mem (map_fst, aF_set));
     val mem_map_snd = HOLogic.mk_Trueprop (HOLogic.mk_mem (map_snd, aF_set'));
     val ex_conj = foldr1 HOLogic.mk_conj (map2 mk_leq (mk_set var_z') (mk_set var_z) @
       [HOLogic.mk_eq (map_fst', map_fst), HOLogic.mk_eq (map_snd', map_snd)]);
     val zip_concl = HOLogic.mk_Trueprop (mk_Bex pairF_set (absfree (dest_Free var_z') ex_conj));
     val zip_closed_F = Logic.all var_z (Logic.list_implies ([mem_map_fst, mem_map_snd], zip_concl));
 
     (* val wit_closed_F = @{term "wit_F a \<in> F"}; *)
     val (var_as, names_lthy) = mk_Frees "a" alphas names_lthy;
     val (var_bs, _) = mk_Frees "a" alphas names_lthy;
     val sets = mk_sets_of_bnf (replicate live deads) (replicate live alphas) bnf_F;
     val (Iwits, wit_goals) =
       prepare_wits false RepT wits opts alphas wits_F var_as var_bs sets lthy;
     val wit_closed_Fs =
       Iwits |> map (fn (I, wit_F) =>
         let
           val vars = map (nth var_as) I;
           val wit_a = list_comb (wit_F, vars);
         in fold_rev Logic.all vars (HOLogic.mk_Trueprop (HOLogic.mk_mem (wit_a, aF_set))) end);
 
     val goals = [map_closed_F, zip_closed_F] @ wit_closed_Fs @
       (case wits of NONE => [] | _ => wit_goals);
 
     fun after_qed ([map_closed_thm] :: [zip_closed_thm] :: wit_thmss) lthy =
           let
             val (wit_closed_thms, wit_thms) =
               (case wits of
                 NONE => (map the_single wit_thmss, wit_thms_of_bnf bnf_F)
               | _ => chop (length wit_closed_Fs) (map the_single wit_thmss))
 
             (*  construct map set bd rel wit *)
             (* val map_G = @{term "\<lambda>f. Abs_G o map_F f o Rep_G"}; *)
             val Abs_Gb = subst_b Abs_G;
             val map_G = fold_rev lambda var_fs
                 (HOLogic.mk_comp (HOLogic.mk_comp (Abs_Gb, map_f), Rep_G));
             val map_raw = fold_rev lambda var_fs map_f;
 
             (* val sets_G = [@{term "set_F o Rep_G"}]; *)
             val sets_F = mk_sets_of_bnf (replicate live deads) (replicate live alphas) bnf_F;
             val sets_G = map (fn set_F => HOLogic.mk_comp (set_F, Rep_G)) sets_F;
 
             (* val bd_G = @{term "bd_F"}; *)
             val bd_F = mk_bd_of_bnf deads alphas bnf_F;
             val bd_G = bd_F;
 
             (* val rel_G = @{term "\<lambda>R. BNF_Def.vimage2p Rep_G Rep_G (rel_F R)"}; *)
             val rel_F = mk_rel_of_bnf deads alphas betas bnf_F;
             val (typ_Rs, _) = strip_typeN live (fastype_of rel_F);
 
             val (var_Rs, names_lthy) = mk_Frees "R" typ_Rs lthy;
             val Rep_Gb = subst_b Rep_G;
             val rel_G = fold_rev absfree (map dest_Free var_Rs)
               (mk_vimage2p Rep_G Rep_Gb $ list_comb (rel_F, var_Rs));
             val rel_raw = fold_rev absfree (map dest_Free var_Rs) (list_comb (rel_F, var_Rs));
 
             (* val pred_G = @{term "\<lambda>P. pred_F P o Rep_G"}; *)
             val pred_F = mk_pred_of_bnf deads alphas bnf_F;
             val (typ_Ps, _) = strip_typeN live (fastype_of pred_F);
 
             val (var_Ps, names_lthy) = mk_Frees "P" typ_Ps names_lthy;
             val pred_G = fold_rev absfree (map dest_Free var_Ps)
               (HOLogic.mk_comp (list_comb (pred_F, var_Ps), Rep_G));
             val pred_raw = fold_rev absfree (map dest_Free var_Ps) (list_comb (pred_F, var_Ps));
 
             (* val wits_G = [@{term "Abs_G o wit_F"}]; *)
             val (var_as, _) = mk_Frees "a" alphas names_lthy;
             val wits_G =
               map (fn (I, wit_F) =>
                 let
                   val vs = map (nth var_as) I;
                 in fold_rev absfree (map dest_Free vs) (Abs_G $ (list_comb (wit_F, vs))) end)
               Iwits;
 
             (* tactics *)
             val Rep_thm = thm RS @{thm type_definition.Rep};
             val Abs_inverse_thm = thm RS @{thm type_definition.Abs_inverse};
             val Abs_inject_thm = thm RS @{thm type_definition.Abs_inject};
             val Rep_cases_thm = thm RS @{thm type_definition.Rep_cases};
             val Rep_inverse_thm = thm RS @{thm type_definition.Rep_inverse};
 
             fun map_id0_tac ctxt =
               HEADGOAL (EVERY' [rtac ctxt ext,
                 SELECT_GOAL (unfold_thms_tac ctxt [map_id0_of_bnf bnf_F, id_apply, o_apply,
                   Rep_inverse_thm]),
                 rtac ctxt refl]);
 
             fun map_comp0_tac ctxt =
               HEADGOAL (EVERY' [rtac ctxt ext,
                 SELECT_GOAL (unfold_thms_tac ctxt [map_comp0_of_bnf bnf_F, o_apply,
                   Rep_thm RS (map_closed_thm RS Abs_inverse_thm)]),
                 rtac ctxt refl]);
 
             fun map_cong0_tac ctxt =
               HEADGOAL (EVERY' ([SELECT_GOAL (unfold_thms_tac ctxt [o_apply]),
                 rtac ctxt (([Rep_thm RS map_closed_thm, Rep_thm RS map_closed_thm] MRS
                   Abs_inject_thm) RS iffD2),
                 rtac ctxt (map_cong0_of_bnf bnf_F)] @ replicate live (Goal.assume_rule_tac ctxt)));
 
             val set_map0s_tac =
               map (fn set_map => fn ctxt =>
                 HEADGOAL (EVERY' [rtac ctxt ext,
                   SELECT_GOAL (unfold_thms_tac ctxt [set_map, o_apply,
                     Rep_thm RS (map_closed_thm RS Abs_inverse_thm)]),
                   rtac ctxt refl]))
               (set_map_of_bnf bnf_F);
 
             fun card_order_bd_tac ctxt = HEADGOAL (rtac ctxt (bd_card_order_of_bnf bnf_F));
 
             fun cinfinite_bd_tac ctxt = HEADGOAL (rtac ctxt (bd_cinfinite_of_bnf bnf_F));
 
             val set_bds_tac =
               map (fn set_bd => fn ctxt =>
                 HEADGOAL (EVERY' [SELECT_GOAL (unfold_thms_tac ctxt [o_apply]), rtac ctxt set_bd]))
               (set_bd_of_bnf bnf_F);
 
             fun le_rel_OO_tac ctxt =
               HEADGOAL (EVERY' [rtac ctxt @{thm vimage2p_relcompp_mono},
                 rtac ctxt ((rel_OO_of_bnf bnf_F RS sym) RS @{thm ord_eq_le_trans}),
                 rtac ctxt @{thm order_refl}]);
 
             fun rel_OO_Grp_tac ctxt =
               HEADGOAL (EVERY' ([SELECT_GOAL (REPEAT_DETERM (HEADGOAL (rtac ctxt ext))),
                 SELECT_GOAL (unfold_thms_tac ctxt [@{thm OO_Grp_alt}, mem_Collect_eq,
                   o_apply, @{thm vimage2p_def}, in_rel_of_bnf bnf_F, Bex_def, mem_Collect_eq]),
                 rtac ctxt iffI,
                 SELECT_GOAL (REPEAT_DETERM (HEADGOAL (eresolve_tac ctxt [exE, conjE]))),
                 forward_tac ctxt
                   [zip_closed_thm OF (replicate 2 (Rep_thm RSN (2, @{thm ssubst_mem})))],
                 assume_tac ctxt,
                 SELECT_GOAL (REPEAT_DETERM (HEADGOAL (eresolve_tac ctxt [bexE, conjE]))),
                 etac ctxt Rep_cases_thm,
                 hyp_subst_tac ctxt,
                 SELECT_GOAL (REPEAT_DETERM (HEADGOAL (rtac ctxt exI))),
                 rtac ctxt conjI] @
                 replicate live
                   (EVERY' [TRY o rtac ctxt conjI, etac ctxt @{thm order_trans}, assume_tac ctxt]) @
                 [SELECT_GOAL (REPEAT_DETERM (HEADGOAL (rtac ctxt conjI))),
                 REPEAT_DETERM_N 2 o EVERY'
                   [rtac ctxt (trans OF [iffD2 OF [Abs_inject_thm OF
                       [map_closed_thm OF [Rep_thm], Rep_thm]], Rep_inverse_thm]),
                   etac ctxt trans, assume_tac ctxt],
                 SELECT_GOAL (REPEAT_DETERM (HEADGOAL (eresolve_tac ctxt [exE, conjE]))),
                 rtac ctxt exI,
                 rtac ctxt conjI] @
                 replicate (live-1) (rtac ctxt conjI THEN' assume_tac ctxt) @
                 [assume_tac ctxt,
                 rtac ctxt conjI,
                 REPEAT_DETERM_N 2 o EVERY'
                   [rtac ctxt (iffD1 OF [Abs_inject_thm OF [map_closed_thm OF [Rep_thm], Rep_thm]]),
                   etac ctxt (Rep_inverse_thm RS sym RSN (2, trans))]]));
 
             fun pred_set_tac ctxt =
               HEADGOAL (EVERY'
                 [rtac ctxt (pred_set_of_bnf bnf_F RS @{thm arg_cong[of _ _ "\<lambda>f. f \<circ> _"]} RS trans),
                 SELECT_GOAL (unfold_thms_tac ctxt (@{thms Ball_comp_iff conj_comp_iff})),
                 rtac ctxt refl]);
 
             fun wit_tac ctxt =
               HEADGOAL (EVERY'
                 (map (fn thm => (EVERY'
                   [SELECT_GOAL (unfold_thms_tac ctxt (o_apply ::
                     (wit_closed_thms RL [Abs_inverse_thm]))),
                   dtac ctxt thm, assume_tac ctxt]))
                 wit_thms));
 
             val tactics = [map_id0_tac, map_comp0_tac, map_cong0_tac] @ set_map0s_tac @
               [card_order_bd_tac, cinfinite_bd_tac] @ set_bds_tac @
               [le_rel_OO_tac, rel_OO_Grp_tac, pred_set_tac];
 
             val (bnf_G, lthy) = bnf_def Dont_Inline (user_policy Note_Some) true I
               tactics wit_tac NONE map_b rel_b pred_b set_bs
               (((((((Binding.empty, AbsT), map_G), sets_G), bd_G), wits_G), SOME rel_G), SOME pred_G)
               lthy;
 
             val old_defs =
               {sets = set_defs_of_bnf bnf_G, map = map_def_of_bnf bnf_G, rel = rel_def_of_bnf bnf_G,
                pred = pred_def_of_bnf bnf_G};
 
             val unfold_morphism = Morphism.thm_morphism "BNF" (unfold_thms lthy defs);
             val (bnf_G, lthy) = morph_bnf_defs unfold_morphism bnf_G
               |> (fn bnf => note_bnf_defs bnf lthy);
 
             val setup_lifting_thm = Typedef thm;
             val quiet = exists (fn No_Warn_Transfer => true | _ => false) opts;
 
             val transfer_consts = mk_typedef_transfer_tacs bnf_F bnf_G
               {map_closed=map_closed_thm,typedef=thm} old_defs map_raw rel_raw pred_raw sets_F;
           in
             lthy |> BNF_Def.register_bnf plugins AbsT_name bnf_G |>
               mk_transfer_thms quiet bnf_F bnf_G AbsT_name transfer_consts setup_lifting_thm
               {abs=typ_subst_atomic (alphas ~~ alphas') AbsT, rep=RepT, Ds0=map TFree Ds0,
                deads = deads, alphas=alphas, betas=alphas', gammas=betas, deltas=betas'} defs
           end
       | after_qed _ _ = raise Match;
   in
     (goals, after_qed, defs, lthy)
   end;
 
 
 (** quotient_bnf **)
 
 fun mk_quotient_transfer_tacs bnf_F Tss live qthms thms set_F'_thmss old_defs
   inst_REL_pos_distrI map_raw rel_raw sets_raw = let
 
     fun common_tac ctxt addefs = unfold_thms_tac ctxt (#REL qthms :: addefs) THEN
       (REPEAT_DETERM o HEADGOAL) (rtac ctxt rel_funI);
 
     (* quotient.map_transfer tactic *)
     val map_F_transfer = map_transfer_of_bnf bnf_F |> mk_rel_funDN (live+1);
     fun map_transfer_q _ ctxt =
       common_tac ctxt (#map old_defs :: @{thms o_def}) THEN
       (HEADGOAL o EVERY') [REPEAT_DETERM o eresolve_tac ctxt @{thms relcomppE},
         rtac ctxt @{thm relcomppI[rotated]}, hyp_subst_tac ctxt THEN' EVERY'
         (map (rtac ctxt) [#rel_abs qthms, #map_F_rsp thms, (#rep_abs_rsp qthms), (#reflp qthms)]),
         hyp_subst_tac ctxt, rtac ctxt map_F_transfer, REPEAT_DETERM_N (live+1) o assume_tac ctxt];
 
     (* quotient.rel_transfer tactic *)
     val rel_F_maps = rel_map_of_bnf bnf_F;
     val rel_F_map_iffD2s = map (fn thm => thm RS @{thm iffD2}) rel_F_maps;
     fun inst_REL_pos_distrI_order_refls vs aTs bTs ctxt = inst_REL_pos_distrI live vs aTs bTs ctxt
       OF (replicate (live+1) asm_rl @ replicate live @{thm order_refl});
     fun rel_transfer_q {Qs, Rs} ctxt = EVERY
       [common_tac ctxt [#rel old_defs, @{thm vimage2p_def}],
       HEADGOAL (rtac ctxt iffI),
       (REPEAT_DETERM o ALLGOALS)
         (eresolve_tac ctxt @{thms exE conjE relcomppE} ORELSE' hyp_subst_tac ctxt),
       (HEADGOAL o EVERY')
         [REPEAT_DETERM o dtac ctxt @{thm rel_fun_rel_OO1},
         rtac ctxt (inst_REL_pos_distrI 0 (map mk_conversep Qs) (#betas Tss) (#alphas Tss) ctxt),
         rtac ctxt @{thm relcomppI},
         rtac ctxt (#symp qthms),
         rtac ctxt (#map_F_rsp thms),
         rtac ctxt (#rep_abs_rsp qthms),
         rtac ctxt (#reflp qthms),
         rtac ctxt @{thm relcomppI},
         rtac ctxt (rel_flip_of_bnf bnf_F RS @{thm iffD1}),
         rtac ctxt (nth rel_F_map_iffD2s 0),
         rtac ctxt (nth rel_F_map_iffD2s 1),
         etac ctxt (#rel_monoD_rotated thms)],
       (REPEAT_DETERM_N live o HEADGOAL o EVERY')
         [rtac ctxt @{thm predicate2I},
         rtac ctxt @{thm conversepI},
         rtac ctxt @{thm Basic_BNFs.rel_sum_simps(4)[THEN iffD2]},
         etac ctxt @{thm conversepI}],
       (HEADGOAL o EVERY')
         [rtac ctxt (inst_REL_pos_distrI_order_refls Rs (#gammas Tss) (#deltas Tss) ctxt),
         (SELECT_GOAL o REPEAT_DETERM o HEADGOAL) (etac ctxt @{thm relcomppI}),
         rtac ctxt @{thm relcomppI[rotated]},
         rtac ctxt (#map_F_rsp thms),
         rtac ctxt (#rep_abs_rsp qthms OF [#reflp qthms]),
         SELECT_GOAL (unfold_thms_tac ctxt (@{thms rel_sum_simps} @ rel_F_maps)),
         assume_tac ctxt],
       (REPEAT_DETERM_N (2*live) o HEADGOAL)
         (rtac ctxt @{thm rel_sum_eq2_nonempty} ORELSE' rtac ctxt @{thm rel_sum_eq3_nonempty}),
       (REPEAT_DETERM_N live)
         (unfold_thms_tac ctxt @{thms sum.rel_compp[symmetric] eq_OO} THEN
         HEADGOAL (etac ctxt @{thm sum.rel_mono[OF order_refl]})),
       (HEADGOAL o EVERY')
         [(SELECT_GOAL o REPEAT_DETERM o HEADGOAL) (dtac ctxt @{thm rel_fun_rel_OO2}),
         rtac ctxt (inst_REL_pos_distrI 0 Qs (#alphas Tss) (#betas Tss) ctxt),
         rtac ctxt @{thm relcomppI},
         rtac ctxt (#reflp qthms),
         rtac ctxt @{thm relcomppI},
         rtac ctxt (nth rel_F_map_iffD2s 0),
         rtac ctxt (nth rel_F_map_iffD2s 1),
         etac ctxt (#rel_monoD_rotated thms)],
       (REPEAT_DETERM_N live o HEADGOAL o EVERY')
         [rtac ctxt @{thm predicate2I}, rtac ctxt @{thm rel_sum.intros(2)}, assume_tac ctxt],
       (HEADGOAL o EVERY')
         [rtac ctxt
           (inst_REL_pos_distrI_order_refls (map mk_conversep Rs) (#deltas Tss) (#gammas Tss) ctxt),
         rtac ctxt @{thm relcomppI},
         etac ctxt (rotate_prems 1 (#transp qthms)),
         rtac ctxt (#map_F_rsp thms),
         rtac ctxt (#rep_abs_rsp qthms OF [#reflp qthms]),
         etac ctxt @{thm relcomppI},
         rtac ctxt @{thm relcomppI},
         etac ctxt (#transp qthms),
         rtac ctxt (#symp qthms),
         rtac ctxt (#map_F_rsp thms),
         rtac ctxt (#rep_abs_rsp qthms),
         rtac ctxt (#reflp qthms),
         rtac ctxt @{thm relcomppI[rotated]},
         rtac ctxt (#reflp qthms),
         rtac ctxt (rel_flip_of_bnf bnf_F RS @{thm iffD1}),
         rtac ctxt (nth rel_F_map_iffD2s 0),
         rtac ctxt (nth rel_F_map_iffD2s 1),
         etac ctxt (#rel_monoD_rotated thms)],
       (REPEAT_DETERM_N live o HEADGOAL o EVERY')
         [rtac ctxt @{thm predicate2I},
         rtac ctxt @{thm conversepI},
         rtac ctxt @{thm rel_sum.intros(2)},
         etac ctxt @{thm conversepI}],
       (REPEAT_DETERM_N (2*live) o HEADGOAL)
         (rtac ctxt @{thm rel_sum_eq2_nonempty} ORELSE' rtac ctxt @{thm rel_sum_eq3_nonempty}),
       (REPEAT_DETERM_N live o EVERY)
         [unfold_thms_tac ctxt @{thms sum.rel_compp[symmetric] eq_OO},
         HEADGOAL (etac ctxt @{thm sum.rel_mono[OF order_refl]})]];
 
     (* quotient.set_transfer tactics *)
     fun set_transfer_q set_G_def set_F'_thms _ ctxt =
       let val set_F'_rsp = mk_rel_funDN 1 (#set_F'_respect set_F'_thms) in
         common_tac ctxt (set_G_def :: @{thms o_def}) THEN
         (HEADGOAL o EVERY')
           [etac ctxt @{thm relcomppE}, hyp_subst_tac ctxt,
           SELECT_GOAL (unfold_thms_tac ctxt
             [set_F'_rsp OF [#rep_abs qthms] OF [#reflp qthms], @{thm rel_set_def}]),
           dtac ctxt (#rel_F_rel_F' thms), rtac ctxt conjI] THEN
         (REPEAT_DETERM_N 2 o HEADGOAL o EVERY')
           [SELECT_GOAL (unfold_thms_tac ctxt [#rel_F'_set thms]),
           REPEAT_DETERM o eresolve_tac ctxt [exE, conjE],
           REPEAT_DETERM o dtac ctxt (mk_sym set_F'_rsp),
           SELECT_GOAL (unfold_thms_tac ctxt [#set_map_F' set_F'_thms]),
           rtac ctxt ballI, dtac ctxt @{thm equalityD1[THEN subsetD]}, assume_tac ctxt,
           SELECT_GOAL (unfold_thms_tac ctxt @{thms image_iff}),
           etac ctxt bexE, dtac ctxt set_mp, assume_tac ctxt,
           SELECT_GOAL (unfold_thms_tac ctxt @{thms mem_Collect_eq case_prod_beta}),
           rtac ctxt bexI, hyp_subst_tac ctxt, assume_tac ctxt, etac ctxt @{thm hypsubst},
           etac ctxt @{thm imageI}, assume_tac ctxt]
       end;
   in
      {map={raw=map_raw, tac=map_transfer_q},
       rel={raw=rel_raw, tac=rel_transfer_q},
       sets={raws=sets_raw,tacs=map2 set_transfer_q (#sets old_defs) set_F'_thmss},
       pred=NONE}
   end;
 
 
-fun quotient_bnf {equiv_rel, equiv_thm, quot_thm, ...} _ wits specs map_b rel_b pred_b opts lthy =
+fun quotient_bnf (equiv_thm, quot_thm) _ wits specs map_b rel_b pred_b opts lthy =
   let
     (* extract rep_G and abs_G *)
-    val (_, abs_G, rep_G) = strip3 quot_thm;
+    val (equiv_rel, abs_G, rep_G) = strip3 quot_thm;
     val (repT, absT) = dest_funT (fastype_of abs_G); (* ("?'a F", "?'a G") *)
     val absT_name = fst (dest_Type absT);
 
     val tvs = map (fst o dest_TVar) (snd (dest_Type absT));
     val _ = length tvs = length specs orelse
       error ("Expected " ^ string_of_int (length tvs) ^
         " type argument" ^ (if (length tvs) = 1 then "" else "s") ^ " to " ^ quote absT_name);
 
     (* instantiate TVars *)
     val alpha0s = map (TFree o snd) specs;
     val typ_subst = typ_subst_TVars (tvs ~~ alpha0s);
     val (repT, absT) = apply2 typ_subst (repT, absT);
 
     (* get the bnf for RepT *)
     val Ds0 = filter (is_none o fst) specs |> map snd;
 
     fun flatten_tyargs Ass =
       map dest_TFree alpha0s |> filter (fn T => exists (fn Ts => member op= Ts T) Ass);
 
     val ((bnf_F, (deads, alphas)), ((_, unfolds), lthy)) =
       bnf_of_typ true Dont_Inline (Binding.qualify true absT_name) flatten_tyargs
         [] Ds0 repT ((empty_comp_cache, empty_unfolds), lthy);
     val live = length alphas;
     val _ = (if live = 0 then error "No live variables" else ());
 
     val defs = #map_unfolds unfolds @ flat (#set_unfoldss unfolds) @ #rel_unfolds unfolds;
     val set_bs =
       map (fn T => find_index (fn U => T = U) alpha0s) alphas
       |> map (the_default Binding.empty o fst o nth specs);
 
     (* create and instantiate all the needed type variables *)
     val subst = subst_TVars (tvs ~~ alpha0s);
     val (abs_G, rep_G) = apply2 subst (abs_G, rep_G);
 
     val sorts = map Type.sort_of_atyp alphas;
     val (((betas, gammas), deltas), names_lthy) = fold Variable.declare_typ (alphas @ deads) lthy
       |> mk_TFrees' sorts
       ||>> mk_TFrees' sorts
       ||>> mk_TFrees' sorts;
 
     fun subst_Ts tm Ts = subst_atomic_types (alphas ~~ Ts) tm;
     val subst_b = subst_atomic_types (alphas ~~ betas);
     val subst_Maybe = subst_atomic_types o map (swap o `mk_MaybeT);
     val equiv_rel_a = subst equiv_rel;
     val map_F = mk_map_of_bnf deads alphas betas bnf_F;
     val rel_F_ab = mk_rel_of_bnf deads alphas betas bnf_F;
     val rel_F_bc = mk_rel_of_bnf deads betas gammas bnf_F;
     val rel_F_ac = mk_rel_of_bnf deads alphas gammas bnf_F;
     val rel_F_option = mk_rel_of_bnf deads (map mk_MaybeT alphas) (map mk_MaybeT betas) bnf_F;
     val sets_F = mk_sets_of_bnf (replicate live deads) (replicate live alphas) bnf_F;
     val wits_F = mk_wits_of_bnf
       (replicate (nwits_of_bnf bnf_F) deads) (replicate (nwits_of_bnf bnf_F) alphas) bnf_F;
 
     val (typ_fs, (typ_aF, typ_bF)) = strip_typeN live (fastype_of map_F) ||> dest_funT;
     val typ_MaybeF = typ_subst_atomic (alphas ~~ map mk_MaybeT alphas) typ_aF;
     val typ_a_sets = map HOLogic.mk_setT alphas;
     val typ_pairs = map HOLogic.mk_prodT (alphas ~~ betas);
     val typ_fs' = map (typ_subst_atomic (map (swap o `mk_MaybeT) betas)) typ_fs;
 
     (* create all the needed variables *)
     val ((((((((((((((((((((((var_Ps, var_Qs), var_Rs), var_x), var_x'), var_y), var_y'), var_mx),
       var_As), var_As'), var_Ss), var_Bs), var_as), var_as'), var_bs), var_bs'), var_R), var_fs),
       var_fs'), var_gs), var_gs'), var_z), var_ts) = names_lthy
         |> mk_Frees "Ps" (map2 mk_relT alphas betas)
         ||>> mk_Frees "Qs" (map2 mk_relT betas gammas)
         ||>> mk_Frees "Rs" (map2 mk_relT alphas gammas)
         ||>> mk_Free "x" typ_aF
         ||>> mk_Free "x'" typ_aF
         ||>> mk_Free "y" typ_bF
         ||>> mk_Free "y'" (typ_subst_atomic (alphas ~~ gammas) typ_aF)
         ||>> mk_Free "mx" typ_MaybeF
         ||>> mk_Frees "As" typ_a_sets
         ||>> mk_Frees "As'" typ_a_sets
         ||>> mk_Frees "Ss" (map HOLogic.mk_setT typ_a_sets)
         ||>> mk_Frees "Bs" (map HOLogic.mk_setT betas)
         ||>> mk_Frees "as" alphas
         ||>> mk_Frees "as'" alphas
         ||>> mk_Frees "bs" betas
         ||>> mk_Frees "bs'" betas
         ||>> mk_Free "R" (typ_aF --> typ_bF --> HOLogic.boolT)
         ||>> mk_Frees "fs" typ_fs
         ||>> mk_Frees "fs'" typ_fs'
         ||>> mk_Frees "gs" typ_fs
         ||>> mk_Frees "gs'" typ_fs'
         ||>> mk_Free "z" (typ_subst_atomic (alphas ~~ typ_pairs) typ_aF)
         ||>> mk_Frees "ts" typ_pairs
         |> fst;
 
     (* create local definitions `b = tm` with n arguments *)
     fun suffix tm s = (dest_Const tm |> fst |> Long_Name.base_name) ^ s;
     fun define lthy b n tm =
       let
         val b = Binding.qualify true absT_name (Binding.qualified_name b);
         val ((tm, (_, def)), (lthy, lthy_old)) = lthy
           |> Local_Theory.open_target |> snd
           |> Local_Theory.define_internal (((Binding.concealed b, NoSyn), (Binding.empty_atts, tm)))
           ||> `Local_Theory.close_target;
         val phi = Proof_Context.export_morphism lthy_old lthy;
         val tm = Term.subst_atomic_types
           (map (`(Morphism.typ phi)) (alphas @ betas @ gammas @ map TFree Ds0))
           (Morphism.term phi tm);
         val def = mk_unabs_def n (HOLogic.mk_obj_eq (Morphism.thm phi def));
       in ({def=def, tm=tm}, lthy) end;
 
     (* internally use REL, not the user-provided definition *)
     val (REL, lthy) = define lthy "REL" 0 equiv_rel_a;
     val REL_def = sym RS eq_reflection OF [#def REL];
     fun REL_rewr_all ctxt thm = Conv.fconv_rule
       (Conv.top_conv (fn _ => Conv.try_conv (Conv.rewr_conv REL_def)) ctxt) thm;
 
     val equiv_rel_a' = equiv_rel_a;
     val equiv_rel_a  = #tm REL;
     val (equiv_rel_b, equiv_rel_c) = apply2 (subst_Ts equiv_rel_a) (betas, gammas);
 
     (* rel_pos_distr: @{term "\<And>A B.
       A \<circ>\<circ> B \<noteq> bot \<Longrightarrow> REL \<circ>\<circ> rel_F A \<circ>\<circ> REL \<circ>\<circ> rel_F B \<circ>\<circ> REL \<le> REL \<circ>\<circ> rel_F (A \<circ>\<circ> B) \<circ>\<circ> REL"} *)
     fun compp_not_bot comp aT cT = let
         val T = mk_relT aT cT;
         val mk_eq = HOLogic.eq_const T;
       in HOLogic.mk_not (mk_eq $ comp $ bot_const T) end;
     val ab_comps = map2 mk_relcompp var_Ps var_Qs;
     val ne_comps = (@{map 3} compp_not_bot ab_comps alphas gammas);
     val ab_prem = foldr1 HOLogic.mk_conj ne_comps;
 
     val REL_pos_distrI_tm = let
         val le_relcomps = map2 mk_leq ab_comps var_Rs;
         val assm = mk_OO [equiv_rel_a, list_comb (rel_F_ab, var_Ps),
                     equiv_rel_b, list_comb (rel_F_bc, var_Qs)] equiv_rel_c;
         val concl = mk_OO [equiv_rel_a, list_comb (rel_F_ac, var_Rs)] equiv_rel_c;
       in
         mk_Trueprop_implies
           ([assm $ var_x $ var_y'] @ ne_comps @ le_relcomps, concl $ var_x $ var_y')
       end;
 
     val ab_concl = mk_leq
       (mk_OO [list_comb (rel_F_ab, var_Ps), equiv_rel_b] (list_comb (rel_F_bc, var_Qs)))
       (mk_OO [equiv_rel_a, list_comb (rel_F_ac, ab_comps)] (equiv_rel_c));
     val ab_imp = Logic.mk_implies (apply2 HOLogic.mk_Trueprop (ab_prem, ab_concl));
     val rel_pos_distr = fold_rev Logic.all (var_Ps @ var_Qs) ab_imp;
 
     (* {(x, y) . REL x y} *)
     fun mk_rel_pairs rel = mk_case_prod (var_x, var_x') (rel $ var_x $ var_x')
     val rel_pairs = mk_rel_pairs equiv_rel_a;
 
     (* rel_Inter: \<And>S. \<lbrakk> S \<noteq> {}; \<Inter>S \<noteq> {} \<rbrakk> \<Longrightarrow>
       (\<Inter>A\<in>S. {(x, y). REL x y} `` {x. set_F x \<subseteq> A}) \<subseteq> {(x, y). REL x y} `` {x. set_F x \<subseteq> \<Inter>S} *)
     fun rel_Inter_from_set_F (var_A, var_S) set_F = let
 
       val typ_aset = fastype_of var_A;
 
       (* \<Inter>S *)
       val inter_S = Inf_const typ_aset $ var_S;
 
       (* [S \<noteq> {}, \<Inter>S \<noteq> {}] *)
       fun not_empty x = let val ty = fastype_of x
         in HOLogic.mk_not (HOLogic.mk_eq (x, bot_const ty)) end;
       val prems = map (HOLogic.mk_Trueprop o not_empty) [var_S, inter_S];
 
       (* {x. set_F x \<subseteq> A} *)
       val setF_sub_A = mk_in [var_A] [set_F] typ_aF;
 
       (* {x. set_F x \<subseteq> \<Inter>S} *)
       val setF_sub_S = mk_in [inter_S] [set_F] typ_aF;
 
       val lhs = Inf_const (HOLogic.mk_setT typ_aF) $ (mk_image
         (absfree (dest_Free var_A) (Image_const typ_aF $ rel_pairs $ setF_sub_A)) $ var_S);
       val rhs = Image_const typ_aF $ rel_pairs $ setF_sub_S;
       val concl = HOLogic.mk_Trueprop (mk_leq lhs rhs);
 
      in Logic.all var_S (Logic.list_implies (prems, concl)) end;
 
     val rel_Inters = map2 rel_Inter_from_set_F (var_As ~~ var_Ss) sets_F;
 
     (* map_F_Just = map_F Just *)
     val map_F_Just = let
         val option_tys = map mk_MaybeT alphas;
         val somes = map Just_const alphas;
       in list_comb (subst_atomic_types (betas ~~ option_tys) map_F, somes) end;
 
     fun mk_set_F'_tm typ_a set_F =
       let
         val typ_aset = HOLogic.mk_setT typ_a;
 
         (* set_F' x = (\<Inter>y\<in>{y. REL (map_F Just x) y}. UNION (set_F y) set_Maybe) *)
         val sbind = mk_UNION (subst_Maybe alphas set_F $ var_mx) (set_Maybe_const typ_a);
         val collection = HOLogic.Collect_const typ_MaybeF $ absfree (dest_Free var_mx)
           (subst_Maybe alphas equiv_rel_a $ (map_F_Just $ var_x) $ var_mx);
         val set_F'_tm = lambda var_x
           (Inf_const typ_aset $ (mk_image (absfree (dest_Free var_mx) sbind) $ collection));
       in
         set_F'_tm
       end
 
     val sets = mk_sets_of_bnf (replicate live deads) (replicate live alphas) bnf_F;
     val sets' = map2 mk_set_F'_tm alphas sets;
 
     val (Iwits, wit_goals) =
       prepare_wits true repT wits opts alphas wits_F var_as var_as' sets' lthy;
 
     val goals = rel_pos_distr :: rel_Inters @
       (case wits of NONE => [] | _ => wit_goals);
 
     val plugins =
       get_first (fn Plugins_Option f => SOME (f lthy) | _ => NONE) (rev opts) |>
       the_default Plugin_Name.default_filter;
 
     fun after_qed thmss lthy =
       (case thmss of [rel_pos_distr_thm0] :: thmss =>
         let
           val equiv_thm' = REL_rewr_all lthy equiv_thm;
           val rel_pos_distr_thm =
             @{thm equivp_add_relconj} OF [equiv_thm', equiv_thm', rel_pos_distr_thm0];
 
           val (rel_Inter_thms, wit_thmss) = apply2 (fn f => flat (f live thmss)) (take, drop);
           val wit_thms = (case wit_thmss of
               [] => wit_thms_of_bnf bnf_F
             | _ => wit_thmss);
 
           (* construct map_G, sets_G, bd_G, rel_G and wits_G *)
 
           (* map_G f = abs_G o map_F f o rep_G *)
           val map_G = fold_rev lambda var_fs (HOLogic.mk_comp (HOLogic.mk_comp
             (subst_Ts abs_G betas, list_comb (map_F, var_fs)), rep_G));
           val map_raw = fold_rev lambda var_fs (list_comb (map_F, var_fs))
             |> subst_atomic_types (betas ~~ gammas);
 
           (* Define set_G and the three auxiliary definitions (set_F', F_in, F_in') *)
           fun mk_set_G var_A set_F lthy = let
               val typ_a = HOLogic.dest_setT (fastype_of var_A);
               val set_F'_tm = mk_set_F'_tm typ_a set_F
 
               val (set_F', lthy) = define lthy (suffix set_F "'") 1 set_F'_tm;
 
               (* set_G = set_F' o rep_G *)
               val set_G = HOLogic.mk_comp (#tm set_F', rep_G);
 
               (* F_in A = {x. set_F x \<subseteq> A} *)
               val F_in_tm = lambda var_A (mk_in [var_A] [set_F] typ_aF);
               val (F_in, lthy) = define lthy (suffix set_F "_in") 1 F_in_tm;
 
               (* F_in' A = map_F Inr -` ({(x, y). REL x y} `` F_in (insert (Inl ()) (Inr ` A))) *)
               val F_in' = lambda var_A (mk_vimage map_F_Just (Image_const typ_MaybeF $
                 subst_Maybe alphas rel_pairs $ (subst_Maybe alphas (#tm F_in) $ mk_insert
                   (mk_Nothing typ_a) (mk_image (Just_const typ_a) $ var_A))));
               val (F_in', lthy) = define lthy (suffix set_F "_in'") 1 F_in';
 
             in ((set_G, {set_F'=set_F', F_in=F_in, F_in'=F_in'}), lthy) end;
 
           val ((sets_G, set_F'_aux_defs), lthy) =
             @{fold_map 2} mk_set_G var_As sets_F lthy |>> split_list;
 
           (* bd_G = bd_F *)
           val bd_G = mk_bd_of_bnf deads alphas bnf_F;
 
           (* rel_F' A =
                BNF_Def.vimage2p (map_F Just) (map_F Just) ((\<cong>) OO rel_F (rel_Maybe A) OO (\<cong>)) *)
           val rel_Maybes = @{map 3} (fn v => fn aT => fn bT => rel_Maybe_const aT bT $ v);
           val rel_F'_tm = let val equiv_equiv_rel_option = subst_Ts equiv_rel_a' o map mk_MaybeT in
             mk_vimage2p map_F_Just (subst_atomic_types (alphas ~~ betas) map_F_Just) $
               mk_OO [equiv_equiv_rel_option alphas, list_comb (rel_F_option, rel_Maybes var_Ps alphas betas)]
               (equiv_equiv_rel_option betas) end;
 
           val (rel_F', lthy) =
             define lthy (suffix rel_F_ab "'") (live+2) (fold_rev lambda var_Ps rel_F'_tm);
 
           (* rel_G A = vimage2p rep_G rep_G (rel_F' A) *)
           val rel_G = fold_rev lambda var_Ps (mk_vimage2p rep_G (subst_Ts rep_G betas) $ rel_F'_tm);
           val rel_raw = fold_rev lambda var_Ps rel_F'_tm
             |> subst_atomic_types (betas ~~ gammas);
 
           (* val wits_G = [abs_G o wit_F] *)
           val wits_G = map (fn (I, wit) => let val vars = (map (fn n => nth var_as n) I)
               in fold_rev lambda vars (abs_G $ list_comb (wit, vars)) end) Iwits;
 
           (* auxiliary lemmas *)
           val bd_card_order = bd_card_order_of_bnf bnf_F;
           val bd_cinfinite = bd_cinfinite_of_bnf bnf_F;
           val in_rel = in_rel_of_bnf bnf_F;
           val map_F_comp = map_comp_of_bnf bnf_F;
           val map_F_comp0 = map_comp0_of_bnf bnf_F;
           val map_F_cong = map_cong_of_bnf bnf_F;
           val map_F_id0 = map_id0_of_bnf bnf_F;
           val map_F_id = map_id_of_bnf bnf_F;
           val rel_conversep = rel_conversep_of_bnf bnf_F;
           val rel_flip = rel_flip_of_bnf bnf_F;
           val rel_eq_onp = rel_eq_onp_of_bnf bnf_F;
           val rel_Grp = rel_Grp_of_bnf bnf_F;
           val rel_OO = rel_OO_of_bnf bnf_F;
           val rel_map = rel_map_of_bnf bnf_F;
           val rel_refl_strong = rel_refl_strong_of_bnf bnf_F;
           val set_bd_thms = set_bd_of_bnf bnf_F;
           val set_map_thms = set_map_of_bnf bnf_F;
 
 
 
           (* map_F_respect: @{term "((=) ===> REL ===> REL) map_F map_F"} *)
           val map_F_respect = HOLogic.mk_Trueprop (fold_rev mk_rel_fun (map2 (fn xT => fn yT =>
             HOLogic.eq_const (xT --> yT)) alphas betas @ [equiv_rel_a]) (equiv_rel_b) $ map_F $ map_F);
 
           fun map_F_respect_tac ctxt =
             HEADGOAL (EVERY'
              [REPEAT_DETERM_N (live + 1) o rtac ctxt @{thm rel_funI}, hyp_subst_tac ctxt,
               rtac ctxt (BNF_FP_Util.split_conj_prems live rel_pos_distr_thm0 OF
                 replicate live @{thm Grp_conversep_nonempty} RS rev_mp),
               rtac ctxt impI, dtac ctxt @{thm predicate2D}, etac ctxt @{thm relcomppI2[rotated]},
               rtac ctxt (rel_Grp RS @{thm predicate2_eqD} RS iffD2), rtac ctxt @{thm GrpI[OF refl]},
               REPEAT_DETERM o resolve_tac ctxt [CollectI, conjI, subset_UNIV],
               rtac ctxt (rel_flip RS iffD2),
               rtac ctxt (rel_Grp RS @{thm predicate2_eqD} RS iffD2), rtac ctxt @{thm GrpI[OF refl]},
               REPEAT_DETERM o resolve_tac ctxt [CollectI, conjI, subset_UNIV],
               SELECT_GOAL (unfold_thms_tac ctxt (rel_eq_onp :: @{thms Grp_conversep_eq_onp})),
               etac ctxt @{thm predicate2D[OF rel_conj_eq_onp, rotated]},
               rtac ctxt equiv_thm']);
 
           val map_F_respect_thm = prove lthy [] map_F_respect map_F_respect_tac;
 
           val rel_funD = mk_rel_funDN (live+1);
           val map_F_rsp = (rel_funD map_F_respect_thm) OF (replicate live refl);
           fun map_F_rsp_of tms ctxt = (infer_instantiate' ctxt (NONE :: NONE
             :: map (SOME o Thm.cterm_of ctxt) tms) map_F_rsp)
 
           val qthms = let
               fun equivp_THEN thm = REL_rewr_all lthy equiv_thm RS thm;
               fun Quotient3_THEN thm = REL_rewr_all lthy quot_thm RS thm;
             in
               {abs_rep = Quotient3_THEN @{thm Quotient3_abs_rep},
                rel_abs = Quotient3_THEN @{thm Quotient3_rel_abs},
                rep_abs = Quotient3_THEN @{thm Quotient3_rep_abs},
                rep_reflp = Quotient3_THEN @{thm Quotient3_rep_reflp},
                rep_abs_rsp = Quotient3_THEN @{thm rep_abs_rsp},
                reflp = equivp_THEN @{thm equivp_reflp},
                symp = equivp_THEN @{thm equivp_symp},
                transp = equivp_THEN @{thm equivp_transp},
                REL = REL_def}
             end;
 
           (* lemma REL_OO_REL_left: REL OO REL OO R = REL OO R *)
           val REL_OO_REL_left_thm = let
               val tm = mk_Trueprop_eq
                 (mk_OO [equiv_rel_a, equiv_rel_a] var_R, mk_relcompp equiv_rel_a var_R)
               fun tac ctxt = HEADGOAL (EVERY'
                 [rtac ctxt ext,
                 rtac ctxt ext,
                 rtac ctxt iffI,
                 TWICE (etac ctxt @{thm relcomppE}),
                 rtac ctxt @{thm relcomppI},
                 etac ctxt (#transp qthms),
                 TWICE (assume_tac ctxt),
                 etac ctxt @{thm relcomppE},
                 etac ctxt @{thm relcomppI},
                 rtac ctxt @{thm relcomppI},
                 rtac ctxt (#reflp qthms),
                 assume_tac ctxt]);
             in prove lthy [var_R] tm tac end;
 
           (* Generate theorems related to the setters *)
           val map_F_fs = list_comb (map_F, var_fs);
 
           (* aset aset asetset bset typ_b typ_b *)
           fun mk_set_F'_thmss (((((var_A, var_A'), var_S), var_B), var_b), var_b')
                 set_F {set_F', F_in, F_in'} rel_Inter_thm set_map_F_thm (idx, vf) =
             let
               val (var_f, var_fs') = case vf of
                 (f :: fs) => (f, fs)
                 | _ => error "won't happen";
 
               val typ_a = fastype_of var_f |> dest_funT |> fst;
               val typ_b = fastype_of var_b;
               val (typ_asetset, typ_aset) = `HOLogic.mk_setT (fastype_of var_A);
 
               val map_F_fs_x = map_F_fs $ var_x;
 
               (* F_in'_mono: A \<subseteq> B \<Longrightarrow> F_in' A \<subseteq> F_in' B *)
               val F_in'_mono_tm = mk_Trueprop_implies
                 ([mk_leq var_A var_A'], mk_leq (#tm F_in' $ var_A) (#tm F_in' $ var_A'));
               fun F_in'_mono_tac ctxt =
                 unfold_thms_tac ctxt [#def F_in', #def F_in] THEN
                 HEADGOAL (EVERY'
                   [rtac ctxt subsetI,
                   etac ctxt vimageE,
                   etac ctxt @{thm ImageE},
                   etac ctxt CollectE,
                   etac ctxt CollectE,
                   dtac ctxt @{thm case_prodD},
                   hyp_subst_tac ctxt,
                   rtac ctxt (vimageI OF [refl]),
                   rtac ctxt @{thm ImageI},
                   rtac ctxt CollectI,
                   rtac ctxt @{thm case_prodI},
                   assume_tac ctxt ORELSE' rtac ctxt refl,
                   rtac ctxt CollectI,
                   etac ctxt subset_trans,
                   etac ctxt (@{thm insert_mono} OF [@{thm image_mono}])]);
               val F_in'_mono_thm = prove lthy [var_A, var_A'] F_in'_mono_tm F_in'_mono_tac;
 
               (* F_in'_Inter: F_in' (\<Inter>S) = (\<Inter>A\<in>S. F_in' A) *)
               val F_in'_Inter_tm = mk_Trueprop_eq ((#tm F_in' $ (Inf_const typ_aset $ var_S)),
                 (Inf_const (HOLogic.mk_setT typ_aF) $ (mk_image (#tm F_in') $ var_S)));
               fun F_in'_Inter_tac ctxt =
                 Local_Defs.unfold_tac ctxt [#def F_in', #def F_in]
                 THEN HEADGOAL (rtac ctxt (infer_instantiate' ctxt
                   [SOME (Thm.cterm_of ctxt (HOLogic.mk_eq (var_S, bot_const typ_asetset)))] @{thm case_split})
                   THEN' EVERY' [
                     hyp_subst_tac ctxt,
                     SELECT_GOAL
                       (unfold_thms_tac ctxt @{thms Inter_empty INT_empty UNIV_sum_unit_conv}),
                     rtac ctxt @{thm set_eqI},
                     rtac ctxt iffI,
                     rtac ctxt UNIV_I,
                     rtac ctxt (vimageI OF [refl]),
                     rtac ctxt @{thm ImageI},
                     rtac ctxt CollectI,
                     rtac ctxt @{thm case_prodI},
                     rtac ctxt (#reflp qthms),
                     rtac ctxt CollectI,
                     rtac ctxt subset_UNIV,
                     etac ctxt @{thm exE[OF ex_in_conv[THEN iffD2]]},
                     EqSubst.eqsubst_tac ctxt [0] @{thms image_INT[of _ UNIV _ id, simplified]},
                     rtac ctxt @{thm inj_Inr},
                     assume_tac ctxt,
                     SELECT_GOAL (unfold_thms_tac ctxt @{thms INT_extend_simps vimage_INT[symmetric]}),
                     rtac ctxt @{thm arg_cong2[where f=vimage, OF refl]},
                     rtac ctxt equalityI,
                     rtac ctxt subsetI,
                     rtac ctxt @{thm InterI},
                     etac ctxt imageE,
                     etac ctxt @{thm ImageE},
                     etac ctxt CollectE,
                     etac ctxt CollectE,
                     dtac ctxt @{thm case_prodD},
                     hyp_subst_tac ctxt,
                     rtac ctxt @{thm ImageI[OF CollectI]},
                     etac ctxt @{thm case_prodI} ORELSE' (SELECT_GOAL
                       (unfold_thms_tac ctxt @{thms prod.case}) THEN' rtac ctxt @{thm refl}),
                     rtac ctxt CollectI,
                     etac ctxt subset_trans,
                     etac ctxt @{thm INT_lower[OF imageI]},
                     rtac ctxt (@{thm subset_trans} OF [asm_rl, rel_Inter_thm]),
                     K (unfold_thms_tac ctxt @{thms image_image}),
                     rtac ctxt subset_refl,
                     K (unfold_thms_tac ctxt @{thms INT_extend_simps ex_in_conv[symmetric]}),
                     rtac ctxt exI,
                     rtac ctxt imageI,
                     assume_tac ctxt,
                     rtac ctxt exI,
                     rtac ctxt @{thm InterI},
                     etac ctxt imageE,
                     hyp_subst_tac ctxt,
                     rtac ctxt @{thm insertI1}]);
 
               val F_in'_Inter_thm = prove lthy [var_S] F_in'_Inter_tm F_in'_Inter_tac;
 
               (* set_F'_respect: (REL ===> (=)) set_F' set_F' *)
               val set_F'_respect_tm = HOLogic.mk_Trueprop (mk_rel_fun equiv_rel_a
                 (HOLogic.eq_const typ_aset) $ #tm set_F' $ #tm set_F');
               fun set_F'_respect_tac ctxt = unfold_thms_tac ctxt (#def set_F' :: @{thms rel_fun_def})
                 THEN HEADGOAL (EVERY'
                   [TWICE (rtac ctxt allI),
                   rtac ctxt impI,
                   dtac ctxt (map_F_rsp_of (map Just_const alphas) ctxt),
                   rtac ctxt @{thm INF_cong},
                   rtac ctxt @{thm Collect_eqI},
                   rtac ctxt iffI,
                   etac ctxt (#transp qthms OF [#symp qthms]),
                   assume_tac ctxt,
                   etac ctxt (#transp qthms),
                   assume_tac ctxt,
                   rtac ctxt refl]);
 
               (* F_in'_alt2: F_in' A = {x. set_F' x \<subseteq> A} *)
               val F_in'_alt2_tm = mk_Trueprop_eq
                 (#tm F_in' $ var_A, mk_in [var_A] [#tm set_F'] typ_aF);
               fun F_in'_alt2_tac ctxt = HEADGOAL (rtac ctxt equalityI THEN'
                 (Subgoal.FOCUS o K) (unfold_thms_tac ctxt (map #def [set_F', F_in', F_in])) ctxt
                 THEN' EVERY'
                   [rtac ctxt subsetI,
                   rtac ctxt CollectI,
                   rtac ctxt subsetI,
                   dtac ctxt vimageD,
                   etac ctxt @{thm ImageE},
                   etac ctxt CollectE,
                   etac ctxt CollectE,
                   dtac ctxt @{thm case_prodD},
                   dtac ctxt @{thm InterD},
                   rtac ctxt @{thm imageI[OF CollectI]},
                   etac ctxt (#symp qthms),
                   etac ctxt @{thm UnionE},
                   etac ctxt imageE,
                   hyp_subst_tac ctxt,
                   etac ctxt @{thm subset_lift_sum_unitD},
                   etac ctxt @{thm setr.cases},
                   hyp_subst_tac ctxt,
                   assume_tac ctxt])
                 THEN unfold_thms_tac ctxt [#def set_F'] THEN
                 (HEADGOAL o EVERY')
                   [rtac ctxt subsetI,
                   etac ctxt CollectE,
                   etac ctxt (subsetD OF [F_in'_mono_thm]),
                   EqSubst.eqsubst_tac ctxt [0] [F_in'_Inter_thm],
                   rtac ctxt @{thm InterI}] THEN
                 REPEAT_DETERM (HEADGOAL (etac ctxt @{thm imageE} THEN' hyp_subst_tac ctxt)) THEN
                 (HEADGOAL o EVERY')
                   [etac ctxt CollectE,
                   SELECT_GOAL (unfold_thms_tac ctxt (map #def [F_in', F_in])),
                   rtac ctxt @{thm vimageI[OF refl]},
                   rtac ctxt @{thm ImageI},
                   rtac ctxt CollectI,
                   rtac ctxt @{thm case_prodI},
                   etac ctxt (#symp qthms),
                   rtac ctxt CollectI,
                   rtac ctxt subsetI,
                   rtac ctxt @{thm sum_insert_Inl_unit},
                   assume_tac ctxt,
                   hyp_subst_tac ctxt,
                   rtac ctxt imageI,
                   rtac ctxt @{thm UnionI},
                   rtac ctxt imageI,
                   assume_tac ctxt,
                   rtac ctxt @{thm setr.intros[OF refl]}];
               val F_in'_alt2_thm = prove lthy [var_A] F_in'_alt2_tm F_in'_alt2_tac;
 
               (* set_F'_alt: set_F' x = \<Inter>{A. x \<in> F_in' A} *)
               val set_F'_alt_tm = mk_Trueprop_eq (#tm set_F' $ var_x,
                 Inf_const typ_aset $ mk_Collect (var_A, HOLogic.mk_mem (var_x, #tm F_in' $ var_A)));
               fun set_F'_alt_tac ctxt = unfold_thms_tac ctxt [F_in'_alt2_thm]
                 THEN HEADGOAL (EVERY'
                   [rtac ctxt @{thm set_eqI},
                   rtac ctxt iffI,
                   rtac ctxt @{thm InterI},
                   etac ctxt CollectE,
                   etac ctxt CollectE,
                   dtac ctxt subsetD,
                   assume_tac ctxt,
                   assume_tac ctxt,
                   etac ctxt @{thm InterD},
                   rtac ctxt CollectI,
                   rtac ctxt CollectI,
                   rtac ctxt subset_refl]);
               val set_F'_alt_thm = prove lthy [var_x] set_F'_alt_tm set_F'_alt_tac;
 
               (* map_F_in_F_in'I: x \<in> F_in' B \<Longrightarrow> map_F f x \<in> F_in' (f ` B) *)
               val map_F_in_F_in'I_tm = mk_Trueprop_implies ([HOLogic.mk_mem (var_x, #tm F_in' $ var_A')],
                 HOLogic.mk_mem (map_F_fs_x, subst_b (#tm F_in') $ (mk_image var_f $ var_A')));
               fun map_F_in_F_in'I_tac ctxt =
                 Local_Defs.unfold_tac ctxt ([#def F_in', #def F_in, Bex_def] @ @{thms vimage_def Image_iff}) THEN
                 HEADGOAL (EVERY'
                   [etac ctxt @{thm CollectE},
                   etac ctxt exE,
                   etac ctxt conjE,
                   etac ctxt @{thm CollectE},
                   etac ctxt @{thm CollectE},
                   dtac ctxt @{thm case_prodD},
                   rtac ctxt @{thm CollectI},
                   rtac ctxt exI,
                   rtac ctxt @{thm conjI[rotated]},
                   rtac ctxt @{thm CollectI},
                   rtac ctxt @{thm case_prodI},
                   dtac ctxt (map_F_rsp_of (map mk_Maybe_map var_fs) ctxt),
                   SELECT_GOAL (unfold_thms_tac ctxt (map_F_comp :: @{thms o_def map_sum.simps})),
                   assume_tac ctxt,
                   rtac ctxt CollectI,
                   SELECT_GOAL (unfold_thms_tac ctxt set_map_thms),
                   etac ctxt @{thm image_map_sum_unit_subset}]);
               val map_F_in_F_in'I_thm =
                 prove lthy (var_A' :: var_x :: var_fs) map_F_in_F_in'I_tm map_F_in_F_in'I_tac;
 
               (* REL_preimage_eq: C \<inter> range f \<noteq> {} \<Longrightarrow>
                     {(a, b). REL a b} `` {x. set_F x \<subseteq> f -` C} =
                         map_F f -` {(a, b). REL a b} `` {x. set_F x \<subseteq> C} *)
               val REL_preimage_eq_tm = mk_Trueprop_implies ([HOLogic.mk_not (HOLogic.mk_eq
                   (HOLogic.mk_binop @{const_name inf} (var_B, mk_image var_f $ HOLogic.mk_UNIV typ_a),
                     bot_const (HOLogic.mk_setT typ_b)))], HOLogic.mk_eq (Image_const typ_aF $
                     rel_pairs $ mk_in [mk_vimage var_f var_B] [set_F] typ_aF, mk_vimage map_F_fs
                     (Image_const typ_bF $ subst_b rel_pairs $ mk_in [var_B] [subst_b set_F] typ_bF)));
 
               (* Bs \<inter> range fs \<noteq> {} \<Longrightarrow> set_F xb \<subseteq> Bs \<Longrightarrow> REL xb (map_F fs x)
                     \<Longrightarrow> x \<in> {(x, x'). REL x x'} `` {x. set_F x \<subseteq> fs -` Bs}              *)
               fun subgoal_tac {context = ctxt, params, ...} = let
                   val (x, y) = case params of
                     [(_, x), _, (_, y)] => (x, y)
                     | _ => error "won't happen";
                   val cond = HOLogic.mk_conj (apply2 HOLogic.mk_mem ((var_b, var_B), (var_b', var_B)));
 
                   (* ["\<lambda>x y. x \<in> B \<and> y \<in> B", "(Grp UNIV f_1)\<inverse>\<inverse>"] *)
                   val cvars = var_fs |> maps (fn f => let val fT = fastype_of f in
                     map (SOME o Thm.cterm_of ctxt)
                       [if f = var_f then
                         fold_rev lambda [var_b, var_b'] cond else HOLogic.eq_const (range_type fT),
                       mk_conversep (mk_Grp (HOLogic.mk_UNIV (domain_type fT)) f)] end);
                   val rel_pos_distr_thm_inst = infer_instantiate' ctxt (cvars @ [SOME y,SOME x])
                     (@{thm predicate2D} OF [rel_pos_distr_thm]);
 
                   (* GrpI[of "map_F f1 .. fN" x, OF refl CollectI, OF "B1 \<subseteq> UNIV \<and> ... \<and> Bn \<subseteq> UNIV"] *)
                   fun subset_UNIVs n = fold (fn a => fn b => conjI OF [a, b]) (replicate (n-1)
                     @{thm subset_UNIV}) @{thm subset_UNIV};
                   val GrpI_inst = infer_instantiate' ctxt (map SOME [Thm.cterm_of ctxt map_F_fs, x])
                     @{thm GrpI} OF [refl, CollectI] OF [subset_UNIVs live];
 
                 in EVERY [
                   HEADGOAL (Method.insert_tac ctxt [rel_pos_distr_thm_inst]),
                   unfold_thms_tac ctxt [rel_conversep, rel_OO, rel_Grp],
                   HEADGOAL (etac ctxt @{thm meta_impE}),
                   REPEAT_DETERM_N (live-1) (HEADGOAL (rtac ctxt @{thm conjI[rotated]})),
                   REPEAT_DETERM_N live (HEADGOAL (etac ctxt @{thm relcompp_mem_Grp_neq_bot} ORELSE'
                       rtac ctxt @{thm relcompp_eq_Grp_neq_bot})),
                   HEADGOAL (EVERY' [etac ctxt @{thm meta_impE},
                     rtac ctxt @{thm relcomppI},
                     rtac ctxt (#reflp qthms),
                     rtac ctxt @{thm relcomppI},
                     rtac ctxt rel_refl_strong]),
                   REPEAT_DETERM_N idx (HEADGOAL (rtac ctxt refl)),
                   HEADGOAL (rtac ctxt conjI THEN' TWICE (etac ctxt subsetD THEN' assume_tac ctxt)),
                   REPEAT_DETERM_N (live-idx-1) (HEADGOAL (rtac ctxt refl)),
                   HEADGOAL (EVERY'
                     [rtac ctxt @{thm relcomppI},
                     assume_tac ctxt,
                     rtac ctxt @{thm relcomppI},
                     rtac ctxt @{thm conversepI},
                     rtac ctxt GrpI_inst,
                     rtac ctxt (#reflp qthms),
                     etac ctxt @{thm relcomppE},
                     etac ctxt @{thm relcomppE},
                     etac ctxt @{thm relcomppE},
                     etac ctxt @{thm conversepE},
                     etac ctxt @{thm GrpE},
                     hyp_subst_tac ctxt,
                     rtac ctxt @{thm ImageI},
                     rtac ctxt CollectI,
                     rtac ctxt @{thm case_prodI},
                     assume_tac ctxt,
                     EqSubst.eqsubst_asm_tac ctxt [1] rel_map,
                     EqSubst.eqsubst_asm_tac ctxt [1] [in_rel_of_bnf bnf_F],
                     etac ctxt exE,
                     etac ctxt CollectE,
                     etac ctxt conjE,
                     etac ctxt conjE,
                     etac ctxt CollectE,
                     hyp_subst_tac ctxt,
                     rtac ctxt CollectI]),
                   unfold_thms_tac ctxt set_map_thms,
                   HEADGOAL (rtac ctxt (subsetI OF [vimageI] OF [refl]) THEN'
                             etac ctxt @{thm imageE} THEN' hyp_subst_tac ctxt),
                   REPEAT_DETERM_N 6 (HEADGOAL (etac ctxt Drule.thin_rl)),
                   REPEAT_DETERM_N (live-1) (HEADGOAL (etac ctxt conjE)),
                   HEADGOAL (EVERY' [dtac ctxt subsetD, assume_tac ctxt, etac ctxt CollectE]),
                   unfold_thms_tac ctxt @{thms split_beta},
                   HEADGOAL (etac ctxt conjunct2)] end;
 
               fun REL_preimage_eq_tac ctxt = HEADGOAL (EVERY'
                 [rtac ctxt @{thm set_eqI},
                 rtac ctxt iffI,
                 etac ctxt @{thm ImageE},
                 etac ctxt CollectE,
                 etac ctxt CollectE,
                 dtac ctxt @{thm case_prodD},
                 rtac ctxt (vimageI OF [refl]),
                 rtac ctxt @{thm ImageI},
                 rtac ctxt CollectI,
                 rtac ctxt @{thm case_prodI},
                 etac ctxt map_F_rsp,
                 rtac ctxt CollectI,
                 EqSubst.eqsubst_tac ctxt [0] [set_map_F_thm],
                 etac ctxt @{thm subset_vimage_image_subset},
                 etac ctxt vimageE,
                 etac ctxt @{thm ImageE},
                 TWICE (etac ctxt CollectE),
                 dtac ctxt @{thm case_prodD},
                 hyp_subst_tac ctxt,
                 Subgoal.FOCUS_PARAMS subgoal_tac ctxt]);
 
               val REL_preimage_eq_thm = prove lthy (var_B :: var_fs) REL_preimage_eq_tm REL_preimage_eq_tac;
 
               (* set_map_F': set_F' (map_F f x) = f ` set_F' x *)
               val set_map_F'_tm = mk_Trueprop_eq (subst_b (#tm set_F')
                 $ map_F_fs_x, mk_image var_f $ (#tm set_F' $ var_x));
               fun set_map_F'_tac ctxt = HEADGOAL (EVERY'
                   [rtac ctxt @{thm set_eqI},
                   rtac ctxt iffI,
                   EqSubst.eqsubst_asm_tac ctxt [0] [set_F'_alt_thm],
                   etac ctxt @{thm InterD},
                   rtac ctxt CollectI,
                   rtac ctxt map_F_in_F_in'I_thm,
                   SELECT_GOAL (unfold_thms_tac ctxt [F_in'_alt2_thm]),
                   rtac ctxt CollectI,
                   rtac ctxt subset_refl,
                   SELECT_GOAL (unfold_thms_tac ctxt [set_F'_alt_thm]),
                   rtac ctxt @{thm InterI},
                   etac ctxt imageE,
                   etac ctxt CollectE,
                   hyp_subst_tac ctxt,
                   etac ctxt @{thm vimageD[OF InterD]},
                   rtac ctxt CollectI]) THEN
                   (* map_F f x \<in> F_in' X \<Longrightarrow> x \<in> F_in' (f -` X) *)
                   HEADGOAL (Subgoal.FOCUS_PARAMS (fn {context = ctxt, params, ...} =>
                     let
                       val X = nth params 1 |> snd |> Thm.term_of;
                       val Inr_img = mk_image (Just_const (HOLogic.dest_setT (fastype_of X))) $ X;
                       fun cvars_of ctxt = map (SOME o Thm.cterm_of ctxt);
                       val cut_thm = infer_instantiate' ctxt (cvars_of ctxt [Inr_img, var_f])
                         @{thm insert_Inl_int_map_sum_unit};
                       val preimage_thm = infer_instantiate' ctxt (cvars_of ctxt
                           (filter (fn f => var_f <> f) var_fs |> map mk_Maybe_map))
                         (cut_thm RS REL_preimage_eq_thm);
                     in EVERY [
                       unfold_thms_tac ctxt (map #def [F_in', F_in] @ preimage_thm :: map_F_comp ::
                           @{thms lift_sum_unit_vimage_commute vimage_comp o_def map_sum.simps}),
                       unfold_thms_tac ctxt [@{thm o_def[symmetric]}, map_F_comp0],
                       Local_Defs.fold_tac ctxt @{thms vimage_comp},
                       HEADGOAL (etac ctxt (vimageI OF [refl]))] end) ctxt);
 
               (* set_F'_subset: set_F' x \<subseteq> set_F x *)
               val set_F'_subset_tm = HOLogic.mk_Trueprop (mk_leq (#tm set_F' $ var_x) (set_F $ var_x));
               fun set_F'_subset_tac ctxt =
                 let val int_e_thm = infer_instantiate' ctxt
                   (replicate 3 NONE @ [SOME (Thm.cterm_of ctxt (map_F_Just $ var_x))]) @{thm INT_E};
                 in HEADGOAL (EVERY' [SELECT_GOAL (Local_Defs.unfold_tac ctxt [#def set_F']),
                   rtac ctxt subsetI,
                   etac ctxt int_e_thm,
                   SELECT_GOAL (unfold_thms_tac ctxt [set_map_F_thm]),
                   etac ctxt @{thm UN_E},
                   etac ctxt imageE,
                   hyp_subst_tac ctxt,
                   SELECT_GOAL (unfold_thms_tac ctxt @{thms sum_set_simps singleton_iff}),
                   hyp_subst_tac ctxt,
                   assume_tac ctxt,
                   etac ctxt notE,
                   rtac ctxt CollectI,
                   rtac ctxt (#reflp qthms)])
                 end;
             in
               ({F_in'_mono = F_in'_mono_thm,
                 F_in'_Inter = F_in'_Inter_thm,
                 set_F'_respect = prove lthy [] set_F'_respect_tm set_F'_respect_tac,
                 F_in'_alt2 = F_in'_alt2_thm,
                 set_F'_alt = set_F'_alt_thm,
                 map_F_in_F_in'I = map_F_in_F_in'I_thm,
                 set_map_F' = prove lthy (var_x :: var_fs) set_map_F'_tm set_map_F'_tac,
                 set_F'_subset = prove lthy [var_x] set_F'_subset_tm set_F'_subset_tac,
                 set_F'_def = #def set_F',
                 F_in_def = #def F_in,
                 F_in'_def = #def F_in'}, (idx + 1, var_fs'))
             end;
 
           val set_F'_thmss = @{fold_map 5} mk_set_F'_thmss
             (var_As ~~ var_As' ~~ var_Ss ~~ var_Bs ~~ var_bs ~~ var_bs') sets_F set_F'_aux_defs
             rel_Inter_thms set_map_thms (0, var_fs)
             |> fst;
 
           (* F_in'D: x \<in> F_in' A \<Longrightarrow> \<forall>a\<in>A. f a = g a \<Longrightarrow> REL (map_F f x) (map_F g x) *)
           fun rel_map_F_fs_map_F_gs subst fs gs = subst equiv_rel_b $
             (list_comb (subst map_F, fs) $ var_x) $ (list_comb (subst map_F, gs) $ var_x);
           val F_in'D_thm = let
               fun mk_prem var_a var_Aset {F_in', ...} var_f var_g =
                 [HOLogic.mk_mem (var_x, #tm F_in' $ var_Aset), mk_Ball var_Aset
                   ((absfree (dest_Free var_a)) (HOLogic.mk_eq (var_f $ var_a, var_g $ var_a)))];
               val prems = @{map 5} mk_prem var_as var_As set_F'_aux_defs var_fs' var_gs';
               val F_in'D_tm = mk_Trueprop_implies (flat prems,
                 rel_map_F_fs_map_F_gs (subst_Maybe betas) var_fs' var_gs');
 
               fun map_F_rsp_of_case_sums fs ctxt = map_F_rsp_of
                 (@{map 2} (fn f => fn T => BNF_FP_Util.mk_case_sum
                   (Term.absdummy HOLogic.unitT (mk_Nothing T), f)) fs betas) ctxt;
 
               fun mk_var_fgs n = take n var_gs' @ drop n var_fs';
               fun F_in'D_tac ctxt = EVERY
                 (unfold_thms_tac ctxt
                   (maps (fn {F_in'_def, F_in_def, ...} => [F_in'_def, F_in_def]) set_F'_thmss) ::
                 map (REPEAT_DETERM_N live o HEADGOAL)
                   [etac ctxt vimageE,
                   etac ctxt @{thm ImageE},
                   etac ctxt CollectE THEN' etac ctxt CollectE,
                   dtac ctxt @{thm case_prodD}] @
                 HEADGOAL (hyp_subst_tac ctxt THEN' rotate_tac (~live)) ::
                 map (fn i => (HEADGOAL o EVERY')
                   [if i < live then rtac ctxt (#transp qthms) else K all_tac,
                   Ctr_Sugar_Tactics.select_prem_tac ctxt live (dresolve_tac ctxt [asm_rl]) i,
                   rtac ctxt (#transp qthms),
                   dtac ctxt (map_F_rsp_of_case_sums (mk_var_fgs (i-1)) ctxt),
                   SELECT_GOAL (unfold_thms_tac ctxt (map_F_comp :: @{thms case_sum_o_inj(2)})),
                   etac ctxt (#symp qthms),
                   dtac ctxt (map_F_rsp_of_case_sums (mk_var_fgs i) ctxt),
                   SELECT_GOAL (unfold_thms_tac ctxt (map_F_comp :: @{thms case_sum_o_inj(2)})),
                   EqSubst.eqsubst_tac ctxt [0] [map_F_cong OF replicate i refl @ asm_rl :: replicate (live-i) refl],
                   rtac ctxt @{thm sum.case_cong[OF refl refl]},
                   etac ctxt bspec,
                   hyp_subst_tac ctxt,
                   etac ctxt @{thm subset_lift_sum_unitD},
                   assume_tac ctxt,
                   assume_tac ctxt]) (1 upto live));
 
             in prove lthy (var_x :: var_As @ var_fs' @ var_gs') F_in'D_tm F_in'D_tac end;
 
           (* map_F_cong': (\<And>a. a \<in> set_F' x \<Longrightarrow> f a = g a) \<Longrightarrow> REL (map_F f x) (map_F g x) *)
           val map_F_cong'_thm = let
               fun mk_prem {set_F', ...} var_a var_f var_g = Logic.all var_a
                 (mk_Trueprop_implies ([HOLogic.mk_mem (var_a, #tm set_F' $ var_x)],
                   HOLogic.mk_eq (var_f $ var_a, var_g $ var_a)));
               val map_F_cong'_tm = Logic.list_implies
                 (@{map 4} mk_prem set_F'_aux_defs var_as var_fs var_gs, HOLogic.mk_Trueprop
                   (rel_map_F_fs_map_F_gs I var_fs var_gs));
               fun Just_o_fun bT f = HOLogic.mk_comp (Just_const bT, f);
               fun map_F_Just_o_funs fs = list_comb
                 (subst_Maybe betas map_F, map2 Just_o_fun betas fs) $ var_x;
               fun map_F_cong'_tac ctxt = let
                   val map_F_respect_inst = map_F_rsp
                     |> infer_instantiate' ctxt (map (SOME o Thm.cterm_of ctxt)
                       (map map_F_Just_o_funs [var_fs, var_gs] @ map fromJust_const betas))
                     |> Local_Defs.unfold ctxt (map_F_comp :: @{thms o_assoc
                       Fun.o_apply[where f=projr and g=Inr, unfolded sum.sel] id_def[symmetric]})
                     |> Local_Defs.unfold ctxt @{thms id_comp};
                 in
                   HEADGOAL (rtac ctxt map_F_respect_inst THEN' rtac ctxt F_in'D_thm) THEN
                   EVERY (map (fn {F_in'_alt2, ...} =>
                     unfold_thms_tac ctxt [F_in'_alt2] THEN
                     HEADGOAL (EVERY'
                       [rtac ctxt CollectI,
                       rtac ctxt subset_refl,
                       rtac ctxt ballI,
                       SELECT_GOAL (unfold_thms_tac ctxt [o_apply]),
                       rtac ctxt @{thm arg_cong[where f=Inr]},
                       asm_full_simp_tac ctxt])) set_F'_thmss) end;
                 in prove lthy (var_x :: var_fs @ var_gs) map_F_cong'_tm map_F_cong'_tac end;
 
           (* rel_F'_set: "rel_F' P x y \<longleftrightarrow>
             (\<exists>z. set_F' z \<subseteq> {(x, y). P x y} \<and> REL (map_F fst z) x \<and> REL (map_F snd z) y)" *)
           val rel_F'_set_thm = let
             val lhs = list_comb (#tm rel_F', var_Ps) $ var_x $ var_y;
             fun mk_subset_A var_a var_b var_P {set_F', ...} = let
                 val collect_A = mk_case_prod (var_a, var_b) (var_P $ var_a $ var_b);
               in mk_leq (subst_atomic_types (alphas ~~ typ_pairs) (#tm set_F') $ var_z) collect_A end;
             val subset_As = @{map 4} mk_subset_A var_as var_bs var_Ps set_F'_aux_defs;
             fun mk_map mfs f z =
               Term.list_comb (mfs, map (fst o Term.strip_comb o f) var_ts) $ z;
             val map_F_fst = mk_map_of_bnf deads typ_pairs alphas bnf_F;
             val map_F_snd = mk_map_of_bnf deads typ_pairs betas bnf_F;
             val map_fst = equiv_rel_a $ (mk_map map_F_fst HOLogic.mk_fst var_z) $ var_x;
             val map_snd = equiv_rel_b $ (mk_map map_F_snd HOLogic.mk_snd var_z) $ var_y;
             val rhs = let val (z, T) = dest_Free var_z in
               HOLogic.mk_exists (z, T, fold_rev (fn a => fn b => HOLogic.mk_conj (a, b))
                 (subset_As @ [map_fst]) map_snd) end;
             val rel_F'_set_tm = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs));
 
             val maybePairsTs = map HOLogic.mk_prodT (map mk_MaybeT alphas ~~ map mk_MaybeT betas)
             fun mk_map_prod_projr aT bT = let
                 val (mabT, (maT, mbT)) = `HOLogic.mk_prodT (apply2 mk_MaybeT (aT, bT));
                 val map_prod_const = Const (@{const_name map_prod},
                   (maT --> aT) --> (mbT --> bT) --> mabT --> HOLogic.mk_prodT (aT, bT));
               in map_prod_const $ fromJust_const aT $ fromJust_const bT end;
 
             fun exI_OF_tac ctxt tm = rtac ctxt
               (infer_instantiate' ctxt (NONE :: [SOME (Thm.cterm_of ctxt tm)]) exI);
 
             (* REL (map_F Inr x) (map_F fst z) \<Longrightarrow> REL (map_F snd z) (map_F Inr y) \<Longrightarrow>
                  set_F z \<subseteq> {(x, y). rel_sum (=) P x y} \<Longrightarrow>
                  \<exists>z. set_F' z \<subseteq> {(x, y). P x y} \<and> REL (map_F fst z) x \<and> REL (map_F snd z) y *)
             fun subgoal1_tac {context = ctxt, params, ...} =
               let
                 val z = (case params of
                     (_ :: _ :: (_, ct) :: _) => Thm.term_of ct
                   | _ => error "won't happen");
                 val map_F_projr_z = list_comb (mk_map_of_bnf deads maybePairsTs typ_pairs bnf_F,
                   map2 mk_map_prod_projr alphas betas) $ z;
               in
                 HEADGOAL (exI_OF_tac ctxt map_F_projr_z) THEN
                 HEADGOAL (EVERY' (maps (fn {set_F'_subset, set_F'_respect, set_map_F', ...} =>
                   [rtac ctxt conjI,
                   dtac ctxt (set_F'_subset RS @{thm order_trans}),
                   TWICE (dtac ctxt (set_F'_respect RS @{thm rel_funD})),
                   SELECT_GOAL (unfold_thms_tac ctxt [set_map_F']),
                   etac ctxt @{thm in_rel_sum_in_image_projr},
                   TWICE (assume_tac ctxt)]) set_F'_thmss)) THEN
                 HEADGOAL (EVERY' (map (fn Ts => FIRST'
                   [dtac ctxt (map_F_rsp_of (map fromJust_const Ts) ctxt),
                   etac ctxt sym , assume_tac ctxt]) [alphas, betas])) THEN
                 unfold_thms_tac ctxt (map_F_comp ::
                   @{thms fst_comp_map_prod snd_comp_map_prod comp_projr_Inr} @ [map_F_id]) THEN
                 HEADGOAL (rtac ctxt conjI) THEN
                 HEADGOAL (etac ctxt (#symp qthms) THEN' assume_tac ctxt
                   ORELSE' (EVERY' (maps (fn Ts =>
                     [dtac ctxt (map_F_rsp_of (map fromJust_const Ts) ctxt),
                     SELECT_GOAL (unfold_thms_tac ctxt (map_F_comp ::
                       @{thms fst_comp_map_prod snd_comp_map_prod comp_projr_Inr} @ [map_F_id])),
                     assume_tac ctxt]) [alphas, betas]))) end;
 
             (* set_F' z \<subseteq> {(x, y). P x y} \<Longrightarrow> REL (map_F fst z) x \<Longrightarrow> REL (map_F snd z) y \<Longrightarrow>
                  \<exists>b. REL (map_F Inr x) b \<and> (\<exists>ba. rel_F (rel_sum (=) P) b ba \<and> REL ba (map_F Inr y)) *)
             fun subgoal2_tac {context = ctxt, params, ...} = let
                 val z = (case params of
                   ((_, ct) :: _) => Thm.term_of ct
                 | _ => error "won't happen");
 
                 fun exI_map_Ifs_tac mk_proj Ts = exI_OF_tac ctxt (list_comb
                   (mk_map_of_bnf deads typ_pairs (map mk_MaybeT Ts) bnf_F, @{map 3}
                     (fn var_t => fn {set_F', ...} => fn T => lambda var_t (BNF_FP_Util.mk_If
                       (HOLogic.mk_mem (var_t, subst_Ts (#tm set_F') typ_pairs $ z))
                       (mk_Just (mk_proj var_t)) (mk_Nothing T))) var_ts set_F'_aux_defs Ts) $ z)
 
                 fun mk_REL_trans_map_F n = (rotate_prems n (#transp qthms) OF
                   [rel_funD map_F_respect_thm] OF (replicate live refl @ [#symp qthms]));
               in
                 HEADGOAL (EVERY'
                   [exI_map_Ifs_tac HOLogic.mk_fst alphas,
                   rtac ctxt conjI,
                   etac ctxt (mk_REL_trans_map_F 0)]) THEN
                 unfold_thms_tac ctxt [map_F_comp, @{thm o_def}] THEN
                 HEADGOAL (rtac ctxt map_F_cong'_thm) THEN
                 REPEAT_DETERM_N live (HEADGOAL (etac ctxt @{thm if_P[symmetric]})) THEN
                 HEADGOAL (EVERY' [exI_map_Ifs_tac HOLogic.mk_snd betas, rtac ctxt conjI]) THEN
                 unfold_thms_tac ctxt rel_map THEN
                 HEADGOAL (rtac ctxt rel_refl_strong) THEN
                 REPEAT_DETERM_N live (HEADGOAL (etac ctxt @{thm subset_rel_sumI})) THEN
                 HEADGOAL (etac ctxt (mk_REL_trans_map_F 1 OF [#symp qthms])) THEN
                 unfold_thms_tac ctxt [map_F_comp, @{thm o_def}] THEN
                 HEADGOAL (rtac ctxt map_F_cong'_thm) THEN
                 REPEAT_DETERM_N live (HEADGOAL (etac ctxt @{thm if_P})) end;
 
             fun rel_F'_set_tac ctxt = EVERY
               ([unfold_thms_tac ctxt (#def rel_F' :: #REL qthms :: @{thms vimage2p_def relcompp_apply}),
               HEADGOAL (rtac ctxt iffI),
               (HEADGOAL o TWICE) (etac ctxt exE THEN' etac ctxt conjE),
               HEADGOAL (EVERY'
                 [dtac ctxt (in_rel RS iffD1),
                 etac ctxt exE,
                 TWICE (etac ctxt conjE),
                 etac ctxt CollectE,
                 hyp_subst_tac ctxt]),
               (REPEAT_DETERM_N (live-1) o HEADGOAL) (etac ctxt conjE),
               HEADGOAL (Subgoal.FOCUS_PARAMS subgoal1_tac ctxt THEN' etac ctxt exE),
               (REPEAT_DETERM_N (live+1) o HEADGOAL) (etac ctxt conjE),
               HEADGOAL (Subgoal.FOCUS_PARAMS subgoal2_tac ctxt)]);
 
             in prove lthy (var_x :: var_y :: var_Ps) rel_F'_set_tm rel_F'_set_tac end;
 
           (* tactics *)
 
           (* map_G_id0: abs_G \<circ> map_F id \<circ> rep_G = id *)
           fun map_G_id0_tac ctxt = HEADGOAL (EVERY' [SELECT_GOAL (unfold_thms_tac ctxt
             [@{thm fun_eq_iff}, o_apply, map_F_id0, id_apply, #abs_rep qthms]),
             rtac ctxt allI, rtac ctxt refl]);
 
           (* map_G (g \<circ> f) = map_G g \<circ> map_G f *)
           fun map_G_comp0_tac ctxt = HEADGOAL (EVERY' [rtac ctxt ext, rtac ctxt sym,
             SELECT_GOAL (unfold_thms_tac ctxt [o_apply, map_F_comp0]), rtac ctxt (#rel_abs qthms),
             rtac ctxt map_F_rsp, rtac ctxt (#rep_abs qthms), rtac ctxt (#reflp qthms)]);
 
           (* map_G_cong: (\<And>z. z \<in> set_G x \<Longrightarrow> f z = g z) \<Longrightarrow> map_G f x = map_G g x *)
           fun map_G_cong_tac ctxt = EVERY
             [Local_Defs.fold_tac ctxt (map #set_F'_def set_F'_thmss),
             unfold_thms_tac ctxt [o_apply],
             HEADGOAL (rtac ctxt (#rel_abs qthms) THEN' rtac ctxt map_F_cong'_thm),
             REPEAT_DETERM_N live (HEADGOAL (asm_full_simp_tac ctxt))];
 
           (* set_G_map0_G: set_G \<circ> map_G f = f ` set_G *)
           fun mk_set_G_map0_G_tac thms ctxt =
             HEADGOAL (rtac ctxt ext) THEN
             EVERY [unfold_thms_tac ctxt [o_apply],
               Local_Defs.fold_tac ctxt [#set_F'_def thms]] THEN
             HEADGOAL (EVERY' (map (rtac ctxt)
               [trans OF [#set_map_F' thms RS sym, sym] RS sym,
                @{thm rel_funD} OF [#set_F'_respect thms],
                #rep_abs qthms,
                map_F_rsp,
                #rep_reflp qthms]));
 
           (* bd_card_order: card_order bd_F *)
           fun bd_card_order_tac ctxt = HEADGOAL (rtac ctxt bd_card_order);
 
           (* bd_cinfinite: BNF_Cardinal_Arithmetic.cinfinite bd_F *)
           fun bd_cinfinite_tac ctxt = HEADGOAL (rtac ctxt bd_cinfinite);
 
           (*target: ordLeq3 (card_of (set_F' (rep_G x_))) bd_F*)
           fun mk_set_G_bd_tac thms set_bd_thm ctxt = EVERY
             [Local_Defs.fold_tac ctxt [#set_F'_def thms],
             unfold_thms_tac ctxt [o_apply],
             HEADGOAL (rtac ctxt (@{thm ordLeq_transitive} OF
               [@{thm card_of_mono1} OF [#set_F'_subset thms], set_bd_thm]))];
 
           (* rel_compp: rel_G R OO rel_G S \<le> rel_G (R OO S) *)
           fun rel_compp_tac ctxt = EVERY
             [unfold_thms_tac ctxt [#REL qthms],
             HEADGOAL (TWICE (rtac ctxt @{thm vimage2p_relcompp_mono})),
             (unfold_thms_tac ctxt (REL_OO_REL_left_thm :: @{thms relcompp_assoc})),
             (unfold_thms_tac ctxt [Local_Defs.unfold ctxt @{thms eq_OO}
               (infer_instantiate' ctxt [HOLogic.eq_const HOLogic.unitT |> Thm.cterm_of ctxt |> SOME]
                 @{thm sum.rel_compp})]),
             HEADGOAL (rtac ctxt rel_pos_distr_thm),
             unfold_thms_tac ctxt
               @{thms fun_eq_iff bot_apply bot_bool_def not_all eq_False not_not OO_def},
             REPEAT_DETERM (HEADGOAL (resolve_tac ctxt [exI, conjI, @{thm rel_sum.intros(1)}, refl]))];
 
           (* rel_G R_ = (\<lambda>x y. \<exists>z. set_G z \<subseteq> {(x, y). R x y} \<and> map_G fst z = x \<and> map_G snd z = y) *)
           fun rel_compp_Grp_tac ctxt = let
               val _ = ()
             in EVERY [Local_Defs.fold_tac ctxt (@{thm Grp_def} :: map #set_F'_def set_F'_thmss),
               unfold_thms_tac ctxt
                 [o_apply, @{thm mem_Collect_eq}, @{thm OO_Grp_alt}, @{thm vimage2p_def}],
               Local_Defs.fold_tac ctxt [Local_Defs.unfold ctxt @{thms vimage2p_def} (#def rel_F')],
               unfold_thms_tac ctxt [rel_F'_set_thm],
               HEADGOAL (TWICE (rtac ctxt ext)),
               HEADGOAL (rtac ctxt iffI),
               REPEAT_DETERM (ALLGOALS (eresolve_tac ctxt [exE, conjE])),
               HEADGOAL (rtac ctxt exI),
               REPEAT_FIRST (resolve_tac ctxt [conjI]),
               HEADGOAL (EVERY' (maps (fn {set_F'_respect, ...} =>
                 [etac ctxt @{thm subset_trans[rotated]},
                 rtac ctxt equalityD1,
                 rtac ctxt (@{thm rel_funD} OF [set_F'_respect]),
                 rtac ctxt (#rep_abs qthms),
                 rtac ctxt (#reflp qthms)]) set_F'_thmss)),
               (HEADGOAL o TWICE o EVERY')
                 [rtac ctxt (trans OF [asm_rl, #abs_rep qthms]),
                 rtac ctxt (#rel_abs qthms),
                 etac ctxt (rotate_prems 1 (#transp qthms)),
                 rtac ctxt map_F_rsp,
                 rtac ctxt (#rep_abs qthms),
                 rtac ctxt (#reflp qthms)
                 ],
               HEADGOAL (rtac ctxt exI THEN' rtac ctxt conjI),
               (REPEAT_DETERM_N live o HEADGOAL o EVERY')
                 [assume_tac ctxt, rtac ctxt conjI],
               (HEADGOAL o TWICE o EVERY') [
                 hyp_subst_tac ctxt,
                 rtac ctxt (#rep_abs_rsp qthms),
                 rtac ctxt map_F_rsp,
                 rtac ctxt (#rep_reflp qthms)]]
             end;
 
           fun pred_G_set_G_tac ctxt = HEADGOAL (rtac ctxt refl);
 
           val tactics = map_G_id0_tac :: map_G_comp0_tac :: map_G_cong_tac ::
             map mk_set_G_map0_G_tac set_F'_thmss @
             bd_card_order_tac :: bd_cinfinite_tac ::
             map2 mk_set_G_bd_tac set_F'_thmss set_bd_thms @
             rel_compp_tac :: rel_compp_Grp_tac :: [pred_G_set_G_tac];
 
           fun mk_wit_tacs ({set_F'_def, set_F'_respect, ...} :: set_F'_thmss) (w :: ws) ctxt =
                 EVERY [unfold_thms_tac ctxt [@{thm o_def},
                     set_F'_respect RS @{thm rel_funD} OF [#rep_abs qthms OF [(#reflp qthms)]]],
                   unfold_thms_tac ctxt [set_F'_def],
                   HEADGOAL (etac ctxt w)]
                 THEN mk_wit_tacs set_F'_thmss ws ctxt
             | mk_wit_tacs [] ws ctxt = mk_wit_tacs set_F'_thmss ws ctxt
             | mk_wit_tacs _ _ _ = all_tac;
 
           val (bnf_G, lthy) = bnf_def Dont_Inline (user_policy Note_Some) true I
             tactics (mk_wit_tacs [] wit_thms) NONE map_b rel_b pred_b set_bs
             (((((((Binding.empty, absT), map_G), sets_G), bd_G), wits_G), SOME rel_G), NONE) lthy;
 
           val old_defs =
             {sets = set_defs_of_bnf bnf_G, map = map_def_of_bnf bnf_G, rel = rel_def_of_bnf bnf_G};
 
           val set_F'_defs = map (mk_abs_def o #set_F'_def) set_F'_thmss;
           val unfold_morphism = Morphism.thm_morphism "BNF"
             (unfold_thms lthy (defs @ #def REL :: set_F'_defs));
           val (bnf_G, lthy) = morph_bnf_defs unfold_morphism bnf_G
             |> (fn bnf => note_bnf_defs bnf lthy);
 
           (* auxiliary lemmas transfer for transfer *)
           val rel_monoD_rotated = rotate_prems ~1 (rel_mono_of_bnf bnf_F RS @{thm predicate2D});
 
           val REL_pos_distrI = let
               fun tac ctxt = EVERY
                 [HEADGOAL (dtac ctxt (rotate_prems ~1 (rel_pos_distr_thm RS @{thm predicate2D}))),
                 (REPEAT_DETERM o HEADGOAL) (rtac ctxt conjI ORELSE' assume_tac ctxt),
                 (REPEAT_DETERM o HEADGOAL) (etac ctxt @{thm relcomppE}),
                 HEADGOAL (dtac ctxt rel_monoD_rotated),
                 (REPEAT_DETERM o HEADGOAL)
                   (assume_tac ctxt ORELSE' rtac ctxt @{thm relcomppI})];
             in prove lthy (var_x :: var_y' :: var_Ps @ var_Qs @ var_Rs) REL_pos_distrI_tm tac end;
 
           val rel_F_rel_F' = let
               val rel_F = mk_rel_of_bnf deads alphas betas bnf_F;
               val rel_F_rel_F'_tm = (rel_F, #tm rel_F')
                 |> apply2 (fn R => HOLogic.mk_Trueprop (list_comb (R, var_Ps) $ var_x $ var_y))
                 |> Logic.mk_implies;
               fun rel_F_rel_F'_tac ctxt = EVERY
                 [HEADGOAL (dtac ctxt (in_rel_of_bnf bnf_F RS iffD1)),
                 unfold_thms_tac ctxt (rel_F'_set_thm :: @{thms mem_Collect_eq}),
                 (REPEAT_DETERM o HEADGOAL) (eresolve_tac ctxt [exE, conjE]),
                 HEADGOAL (rtac ctxt exI),
                 HEADGOAL (EVERY' (maps (fn thms =>
                   [rtac ctxt conjI,
                   rtac ctxt subsetI,
                   dtac ctxt (set_mp OF [#set_F'_subset thms]),
                   dtac ctxt subsetD,
                   assume_tac ctxt, assume_tac ctxt]) set_F'_thmss)),
                 (REPEAT_DETERM o HEADGOAL)
                   (rtac ctxt conjI ORELSE' hyp_subst_tac ctxt THEN' rtac ctxt (#reflp qthms))]
             in prove lthy (var_x :: var_y :: var_Ps) rel_F_rel_F'_tm rel_F_rel_F'_tac end;
 
           fun inst_REL_pos_distrI n vs aTs bTs ctxt =
             infer_instantiate' ctxt (replicate n NONE @ (rel_Maybes vs aTs bTs
               |> map (SOME o Thm.cterm_of ctxt))) REL_pos_distrI;
 
           val Tss = {abs = typ_subst_atomic (alphas ~~ betas) absT, rep = repT, Ds0 = map TFree Ds0,
             deads = deads, alphas = alphas, betas = betas, gammas = gammas, deltas = deltas};
 
           val thms =
             {map_F_rsp = map_F_rsp,
              rel_F'_def = #def rel_F',
              rel_F_rel_F' = rel_F_rel_F',
              rel_F'_set = rel_F'_set_thm,
              rel_monoD_rotated = rel_monoD_rotated}
 
           val transfer_consts = mk_quotient_transfer_tacs bnf_F Tss live
             qthms thms set_F'_thmss old_defs inst_REL_pos_distrI
             map_raw rel_raw (map (#tm o #set_F') set_F'_aux_defs);
           val quiet = exists (fn No_Warn_Transfer => true | _ => false) opts;
         in
           lthy |> BNF_Def.register_bnf plugins absT_name bnf_G |>
             mk_transfer_thms quiet bnf_F bnf_G absT_name transfer_consts (Quotient equiv_thm) Tss
               (defs @ #def REL :: set_F'_defs)
         end
       | _ => raise Match);
 
   in (goals, after_qed, #def REL :: defs, lthy) end;
 
 
 (** main commands **)
 
 local
 
 fun prepare_common prepare_name prepare_sort prepare_term prepare_thm
     (((((plugins, raw_specs), raw_absT_name), raw_wits), xthm_opt), (map_b, rel_b, pred_b)) lthy =
   let
     val absT_name = prepare_name lthy raw_absT_name;
 
     val input_thm =
       (case xthm_opt of
         SOME xthm => prepare_thm lthy xthm
       | NONE => Typedef.get_info lthy absT_name |> hd |> snd |> #type_definition);
     val wits = (Option.map o map) (prepare_term lthy) raw_wits;
     val specs =
       map (apsnd (apsnd (the_default @{sort type} o Option.map (prepare_sort lthy)))) raw_specs;
 
-    val which_bnf = (case Quotient_Info.lookup_quotients lthy absT_name of
-        SOME qs => quotient_bnf qs
+    val which_bnf = (case (xthm_opt, Quotient_Info.lookup_quotients lthy absT_name) of
+        (NONE, SOME qs) => quotient_bnf (#equiv_thm qs, #quot_thm qs)
+      | (SOME _, _) =>
+          if can (fn thm => thm RS @{thm bnf_lift_Quotient_equivp}) input_thm
+          then quotient_bnf (input_thm RS conjunct2, input_thm RS conjunct1 RS @{thm Quotient_Quotient3})
+          else if can (fn thm => thm RS @{thm type_definition.Rep}) input_thm
+            then typedef_bnf
+            else Pretty.chunks [Pretty.para ("Expected theorem of either form:"),
+                Pretty.item [Syntax.pretty_term lthy @{term "Quotient R Abs Rep T \<and> equivp R"}],
+                Pretty.item [Syntax.pretty_term lthy @{term "type_definition Rep Abs A"}],
+                Pretty.para ("Got"), Pretty.item [Thm.pretty_thm lthy input_thm]]
+              |> Pretty.string_of
+              |> error
       | _ => typedef_bnf);
 
   in
     which_bnf input_thm wits specs map_b rel_b pred_b plugins lthy
   end;
 
 fun prepare_lift_bnf prepare_name prepare_sort prepare_term prepare_thm =
   (fn (goals, after_qed, definitions, lthy) =>
     lthy
     |> Proof.theorem NONE after_qed (map (single o rpair []) goals)
     |> Proof.refine_singleton
         (Method.Basic (fn ctxt => SIMPLE_METHOD (unfold_thms_tac ctxt definitions)))
     |> Proof.refine_singleton (Method.primitive_text (K I))) oo
   prepare_common prepare_name prepare_sort prepare_term prepare_thm o apfst (apfst (apsnd SOME));
 
 fun prepare_solve prepare_name prepare_typ prepare_sort prepare_thm tacs =
   (fn (goals, after_qed, definitions, lthy) =>
     lthy
     |> after_qed (map2 (fn goal => fn tac => [Goal.prove_sorry lthy [] [] goal
         (fn (ctxtprems as {context = ctxt, prems = _}) =>
           unfold_thms_tac ctxt definitions THEN tac ctxtprems)])
       goals (tacs (length goals)))) oo
   prepare_common prepare_name prepare_typ prepare_sort prepare_thm;
 
 in
 
 val lift_bnf_cmd =
   prepare_lift_bnf
     (fst o dest_Type oo Proof_Context.read_type_name {proper = true, strict = false})
     Syntax.read_sort Syntax.read_term (singleton o Attrib.eval_thms);
 
 fun lift_bnf args tacs =
   prepare_solve (K I) (K I) (K I) (K I) (K tacs) args;
 
 fun copy_bnf_tac {context = ctxt, prems = _} =
   REPEAT_DETERM (resolve_tac ctxt [bexI, conjI, UNIV_I, refl, subset_refl] 1);
 
 val copy_bnf =
   apfst (apfst (rpair NONE))
   #> prepare_solve (K I) (K I) (K I) (K I)
     (fn n => replicate n copy_bnf_tac);
 
 val copy_bnf_cmd =
   apfst (apfst (rpair NONE))
   #> prepare_solve
     (fst o dest_Type oo Proof_Context.read_type_name {proper = true, strict = false})
     Syntax.read_sort Syntax.read_term (singleton o Attrib.eval_thms)
     (fn n => replicate n copy_bnf_tac);
 
 end;
 
 (** outer syntax **)
 
 local
 
 (* parsers *)
 
 val parse_wits =
   @{keyword "["} |-- (Parse.name --| @{keyword ":"} -- Scan.repeat Parse.term >>
     (fn ("wits", Ts) => Ts
       | (s, _) => error ("Unknown label " ^ quote s ^ " (expected \"wits\")"))) --|
   @{keyword "]"} || Scan.succeed [];
 
 fun parse_common_opts p =
   Scan.optional (@{keyword "("} |--
     Parse.list1 (Parse.group (K "option")
       (Scan.first (p :: [Plugin_Name.parse_filter >> Plugins_Option,
           Parse.reserved "no_warn_transfer" >> K No_Warn_Transfer])))
     --| @{keyword ")"}) [];
 
 val parse_lift_opts = Parse.reserved "no_warn_wits" >> K No_Warn_Wits |> parse_common_opts;
 
 val parse_copy_opts = parse_common_opts Scan.fail;
 
 val parse_xthm = Scan.option (Parse.reserved "via" |-- Parse.thm);
 
 in
 
 (* exposed commands *)
 
 val _ =
   Outer_Syntax.local_theory_to_proof @{command_keyword lift_bnf}
     "register a quotient type/subtype of a bounded natural functor (BNF) as a BNF"
     ((parse_lift_opts -- parse_type_args_named_constrained -- Parse.type_const -- parse_wits --
       parse_xthm -- parse_map_rel_pred_bindings) >> lift_bnf_cmd);
 
 val _ =
   Outer_Syntax.local_theory @{command_keyword copy_bnf}
     "register a type copy of a bounded natural functor (BNF) as a BNF"
     ((parse_copy_opts -- parse_type_args_named_constrained -- Parse.type_const --
       parse_xthm -- parse_map_rel_pred_bindings) >> copy_bnf_cmd);
 
 end;
 
 end;
diff --git a/src/HOL/Transitive_Closure.thy b/src/HOL/Transitive_Closure.thy
--- a/src/HOL/Transitive_Closure.thy
+++ b/src/HOL/Transitive_Closure.thy
@@ -1,1291 +1,1345 @@
 (*  Title:      HOL/Transitive_Closure.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1992  University of Cambridge
 *)
 
 section \<open>Reflexive and Transitive closure of a relation\<close>
 
 theory Transitive_Closure
   imports Relation
   abbrevs "^*" = "\<^sup>*" "\<^sup>*\<^sup>*"
     and "^+" = "\<^sup>+" "\<^sup>+\<^sup>+"
     and "^=" = "\<^sup>=" "\<^sup>=\<^sup>="
 begin
 
 ML_file \<open>~~/src/Provers/trancl.ML\<close>
 
 text \<open>
   \<open>rtrancl\<close> is reflexive/transitive closure,
   \<open>trancl\<close> is transitive closure,
   \<open>reflcl\<close> is reflexive closure.
 
   These postfix operators have \<^emph>\<open>maximum priority\<close>, forcing their
   operands to be atomic.
 \<close>
 
 context notes [[inductive_internals]]
 begin
 
 inductive_set rtrancl :: "('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set"  ("(_\<^sup>*)" [1000] 999)
   for r :: "('a \<times> 'a) set"
   where
     rtrancl_refl [intro!, Pure.intro!, simp]: "(a, a) \<in> r\<^sup>*"
   | rtrancl_into_rtrancl [Pure.intro]: "(a, b) \<in> r\<^sup>* \<Longrightarrow> (b, c) \<in> r \<Longrightarrow> (a, c) \<in> r\<^sup>*"
 
 inductive_set trancl :: "('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set"  ("(_\<^sup>+)" [1000] 999)
   for r :: "('a \<times> 'a) set"
   where
     r_into_trancl [intro, Pure.intro]: "(a, b) \<in> r \<Longrightarrow> (a, b) \<in> r\<^sup>+"
   | trancl_into_trancl [Pure.intro]: "(a, b) \<in> r\<^sup>+ \<Longrightarrow> (b, c) \<in> r \<Longrightarrow> (a, c) \<in> r\<^sup>+"
 
 notation
   rtranclp  ("(_\<^sup>*\<^sup>*)" [1000] 1000) and
   tranclp  ("(_\<^sup>+\<^sup>+)" [1000] 1000)
 
 declare
   rtrancl_def [nitpick_unfold del]
   rtranclp_def [nitpick_unfold del]
   trancl_def [nitpick_unfold del]
   tranclp_def [nitpick_unfold del]
 
 end
 
 abbreviation reflcl :: "('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set"  ("(_\<^sup>=)" [1000] 999)
   where "r\<^sup>= \<equiv> r \<union> Id"
 
 abbreviation reflclp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"  ("(_\<^sup>=\<^sup>=)" [1000] 1000)
   where "r\<^sup>=\<^sup>= \<equiv> sup r (=)"
 
 notation (ASCII)
   rtrancl  ("(_^*)" [1000] 999) and
   trancl  ("(_^+)" [1000] 999) and
   reflcl  ("(_^=)" [1000] 999) and
   rtranclp  ("(_^**)" [1000] 1000) and
   tranclp  ("(_^++)" [1000] 1000) and
   reflclp  ("(_^==)" [1000] 1000)
 
 
 subsection \<open>Reflexive closure\<close>
 
 lemma refl_reflcl[simp]: "refl (r\<^sup>=)"
   by (simp add: refl_on_def)
 
 lemma antisym_reflcl[simp]: "antisym (r\<^sup>=) = antisym r"
   by (simp add: antisym_def)
 
 lemma trans_reflclI[simp]: "trans r \<Longrightarrow> trans (r\<^sup>=)"
   unfolding trans_def by blast
 
 lemma reflclp_idemp [simp]: "(P\<^sup>=\<^sup>=)\<^sup>=\<^sup>= = P\<^sup>=\<^sup>="
   by blast
 
 
 subsection \<open>Reflexive-transitive closure\<close>
 
 lemma reflcl_set_eq [pred_set_conv]: "(sup (\<lambda>x y. (x, y) \<in> r) (=)) = (\<lambda>x y. (x, y) \<in> r \<union> Id)"
   by (auto simp: fun_eq_iff)
 
 lemma r_into_rtrancl [intro]: "\<And>p. p \<in> r \<Longrightarrow> p \<in> r\<^sup>*"
   \<comment> \<open>\<open>rtrancl\<close> of \<open>r\<close> contains \<open>r\<close>\<close>
   apply (simp only: split_tupled_all)
   apply (erule rtrancl_refl [THEN rtrancl_into_rtrancl])
   done
 
 lemma r_into_rtranclp [intro]: "r x y \<Longrightarrow> r\<^sup>*\<^sup>* x y"
   \<comment> \<open>\<open>rtrancl\<close> of \<open>r\<close> contains \<open>r\<close>\<close>
   by (erule rtranclp.rtrancl_refl [THEN rtranclp.rtrancl_into_rtrancl])
 
 lemma rtranclp_mono: "r \<le> s \<Longrightarrow> r\<^sup>*\<^sup>* \<le> s\<^sup>*\<^sup>*"
   \<comment> \<open>monotonicity of \<open>rtrancl\<close>\<close>
   apply (rule predicate2I)
   apply (erule rtranclp.induct)
    apply (rule_tac [2] rtranclp.rtrancl_into_rtrancl, blast+)
   done
 
 lemma mono_rtranclp[mono]: "(\<And>a b. x a b \<longrightarrow> y a b) \<Longrightarrow> x\<^sup>*\<^sup>* a b \<longrightarrow> y\<^sup>*\<^sup>* a b"
    using rtranclp_mono[of x y] by auto
 
 lemmas rtrancl_mono = rtranclp_mono [to_set]
 
 theorem rtranclp_induct [consumes 1, case_names base step, induct set: rtranclp]:
   assumes a: "r\<^sup>*\<^sup>* a b"
     and cases: "P a" "\<And>y z. r\<^sup>*\<^sup>* a y \<Longrightarrow> r y z \<Longrightarrow> P y \<Longrightarrow> P z"
   shows "P b"
   using a by (induct x\<equiv>a b) (rule cases)+
 
 lemmas rtrancl_induct [induct set: rtrancl] = rtranclp_induct [to_set]
 
 lemmas rtranclp_induct2 =
   rtranclp_induct[of _ "(ax,ay)" "(bx,by)", split_rule, consumes 1, case_names refl step]
 
 lemmas rtrancl_induct2 =
   rtrancl_induct[of "(ax,ay)" "(bx,by)", split_format (complete), consumes 1, case_names refl step]
 
 lemma refl_rtrancl: "refl (r\<^sup>*)"
   unfolding refl_on_def by fast
 
 text \<open>Transitivity of transitive closure.\<close>
 lemma trans_rtrancl: "trans (r\<^sup>*)"
 proof (rule transI)
   fix x y z
   assume "(x, y) \<in> r\<^sup>*"
   assume "(y, z) \<in> r\<^sup>*"
   then show "(x, z) \<in> r\<^sup>*"
   proof induct
     case base
     show "(x, y) \<in> r\<^sup>*" by fact
   next
     case (step u v)
     from \<open>(x, u) \<in> r\<^sup>*\<close> and \<open>(u, v) \<in> r\<close>
     show "(x, v) \<in> r\<^sup>*" ..
   qed
 qed
 
 lemmas rtrancl_trans = trans_rtrancl [THEN transD]
 
 lemma rtranclp_trans:
   assumes "r\<^sup>*\<^sup>* x y"
     and "r\<^sup>*\<^sup>* y z"
   shows "r\<^sup>*\<^sup>* x z"
   using assms(2,1) by induct iprover+
 
 lemma rtranclE [cases set: rtrancl]:
   fixes a b :: 'a
   assumes major: "(a, b) \<in> r\<^sup>*"
   obtains
     (base) "a = b"
   | (step) y where "(a, y) \<in> r\<^sup>*" and "(y, b) \<in> r"
   \<comment> \<open>elimination of \<open>rtrancl\<close> -- by induction on a special formula\<close>
 proof -
   have "a = b \<or> (\<exists>y. (a, y) \<in> r\<^sup>* \<and> (y, b) \<in> r)"
     by (rule major [THEN rtrancl_induct]) blast+
   then show ?thesis
     by (auto intro: base step)
 qed
 
 lemma rtrancl_Int_subset: "Id \<subseteq> s \<Longrightarrow> (r\<^sup>* \<inter> s) O r \<subseteq> s \<Longrightarrow> r\<^sup>* \<subseteq> s"
   apply clarify
   apply (erule rtrancl_induct, auto)
   done
 
 lemma converse_rtranclp_into_rtranclp: "r a b \<Longrightarrow> r\<^sup>*\<^sup>* b c \<Longrightarrow> r\<^sup>*\<^sup>* a c"
   by (rule rtranclp_trans) iprover+
 
 lemmas converse_rtrancl_into_rtrancl = converse_rtranclp_into_rtranclp [to_set]
 
 text \<open>\<^medskip> More \<^term>\<open>r\<^sup>*\<close> equations and inclusions.\<close>
 
 lemma rtranclp_idemp [simp]: "(r\<^sup>*\<^sup>*)\<^sup>*\<^sup>* = r\<^sup>*\<^sup>*"
   apply (auto intro!: order_antisym)
   apply (erule rtranclp_induct)
    apply (rule rtranclp.rtrancl_refl)
   apply (blast intro: rtranclp_trans)
   done
 
 lemmas rtrancl_idemp [simp] = rtranclp_idemp [to_set]
 
 lemma rtrancl_idemp_self_comp [simp]: "R\<^sup>* O R\<^sup>* = R\<^sup>*"
   apply (rule set_eqI)
   apply (simp only: split_tupled_all)
   apply (blast intro: rtrancl_trans)
   done
 
 lemma rtrancl_subset_rtrancl: "r \<subseteq> s\<^sup>* \<Longrightarrow> r\<^sup>* \<subseteq> s\<^sup>*"
 by (drule rtrancl_mono, simp)
 
 lemma rtranclp_subset: "R \<le> S \<Longrightarrow> S \<le> R\<^sup>*\<^sup>* \<Longrightarrow> S\<^sup>*\<^sup>* = R\<^sup>*\<^sup>*"
   apply (drule rtranclp_mono)
   apply (drule rtranclp_mono, simp)
   done
 
 lemmas rtrancl_subset = rtranclp_subset [to_set]
 
 lemma rtranclp_sup_rtranclp: "(sup (R\<^sup>*\<^sup>*) (S\<^sup>*\<^sup>*))\<^sup>*\<^sup>* = (sup R S)\<^sup>*\<^sup>*"
   by (blast intro!: rtranclp_subset intro: rtranclp_mono [THEN predicate2D])
 
 lemmas rtrancl_Un_rtrancl = rtranclp_sup_rtranclp [to_set]
 
 lemma rtranclp_reflclp [simp]: "(R\<^sup>=\<^sup>=)\<^sup>*\<^sup>* = R\<^sup>*\<^sup>*"
   by (blast intro!: rtranclp_subset)
 
 lemmas rtrancl_reflcl [simp] = rtranclp_reflclp [to_set]
 
 lemma rtrancl_r_diff_Id: "(r - Id)\<^sup>* = r\<^sup>*"
   by (rule rtrancl_subset [symmetric]) auto
 
 lemma rtranclp_r_diff_Id: "(inf r (\<noteq>))\<^sup>*\<^sup>* = r\<^sup>*\<^sup>*"
   by (rule rtranclp_subset [symmetric]) auto
 
 theorem rtranclp_converseD:
   assumes "(r\<inverse>\<inverse>)\<^sup>*\<^sup>* x y"
   shows "r\<^sup>*\<^sup>* y x"
   using assms by induct (iprover intro: rtranclp_trans dest!: conversepD)+
 
 lemmas rtrancl_converseD = rtranclp_converseD [to_set]
 
 theorem rtranclp_converseI:
   assumes "r\<^sup>*\<^sup>* y x"
   shows "(r\<inverse>\<inverse>)\<^sup>*\<^sup>* x y"
   using assms by induct (iprover intro: rtranclp_trans conversepI)+
 
 lemmas rtrancl_converseI = rtranclp_converseI [to_set]
 
 lemma rtrancl_converse: "(r\<inverse>)\<^sup>* = (r\<^sup>*)\<inverse>"
   by (fast dest!: rtrancl_converseD intro!: rtrancl_converseI)
 
 lemma sym_rtrancl: "sym r \<Longrightarrow> sym (r\<^sup>*)"
   by (simp only: sym_conv_converse_eq rtrancl_converse [symmetric])
 
 theorem converse_rtranclp_induct [consumes 1, case_names base step]:
   assumes major: "r\<^sup>*\<^sup>* a b"
     and cases: "P b" "\<And>y z. r y z \<Longrightarrow> r\<^sup>*\<^sup>* z b \<Longrightarrow> P z \<Longrightarrow> P y"
   shows "P a"
   using rtranclp_converseI [OF major]
   by induct (iprover intro: cases dest!: conversepD rtranclp_converseD)+
 
 lemmas converse_rtrancl_induct = converse_rtranclp_induct [to_set]
 
 lemmas converse_rtranclp_induct2 =
   converse_rtranclp_induct [of _ "(ax, ay)" "(bx, by)", split_rule, consumes 1, case_names refl step]
 
 lemmas converse_rtrancl_induct2 =
   converse_rtrancl_induct [of "(ax, ay)" "(bx, by)", split_format (complete),
     consumes 1, case_names refl step]
 
 lemma converse_rtranclpE [consumes 1, case_names base step]:
   assumes major: "r\<^sup>*\<^sup>* x z"
     and cases: "x = z \<Longrightarrow> P" "\<And>y. r x y \<Longrightarrow> r\<^sup>*\<^sup>* y z \<Longrightarrow> P"
   shows P
 proof -
   have "x = z \<or> (\<exists>y. r x y \<and> r\<^sup>*\<^sup>* y z)"
     by (rule_tac major [THEN converse_rtranclp_induct]) iprover+
   then show ?thesis
     by (auto intro: cases)
 qed
 
 lemmas converse_rtranclE = converse_rtranclpE [to_set]
 
 lemmas converse_rtranclpE2 = converse_rtranclpE [of _ "(xa,xb)" "(za,zb)", split_rule]
 
 lemmas converse_rtranclE2 = converse_rtranclE [of "(xa,xb)" "(za,zb)", split_rule]
 
 lemma r_comp_rtrancl_eq: "r O r\<^sup>* = r\<^sup>* O r"
   by (blast elim: rtranclE converse_rtranclE
       intro: rtrancl_into_rtrancl converse_rtrancl_into_rtrancl)
 
 lemma rtrancl_unfold: "r\<^sup>* = Id \<union> r\<^sup>* O r"
   by (auto intro: rtrancl_into_rtrancl elim: rtranclE)
 
 lemma rtrancl_Un_separatorE:
   "(a, b) \<in> (P \<union> Q)\<^sup>* \<Longrightarrow> \<forall>x y. (a, x) \<in> P\<^sup>* \<longrightarrow> (x, y) \<in> Q \<longrightarrow> x = y \<Longrightarrow> (a, b) \<in> P\<^sup>*"
 proof (induct rule: rtrancl.induct)
   case rtrancl_refl
   then show ?case by blast
 next
   case rtrancl_into_rtrancl
   then show ?case by (blast intro: rtrancl_trans)
 qed
 
 lemma rtrancl_Un_separator_converseE:
   "(a, b) \<in> (P \<union> Q)\<^sup>* \<Longrightarrow> \<forall>x y. (x, b) \<in> P\<^sup>* \<longrightarrow> (y, x) \<in> Q \<longrightarrow> y = x \<Longrightarrow> (a, b) \<in> P\<^sup>*"
 proof (induct rule: converse_rtrancl_induct)
   case base
   then show ?case by blast
 next
   case step
   then show ?case by (blast intro: rtrancl_trans)
 qed
 
 lemma Image_closed_trancl:
   assumes "r `` X \<subseteq> X"
   shows "r\<^sup>* `` X = X"
 proof -
   from assms have **: "{y. \<exists>x\<in>X. (x, y) \<in> r} \<subseteq> X"
     by auto
   have "x \<in> X" if 1: "(y, x) \<in> r\<^sup>*" and 2: "y \<in> X" for x y
   proof -
     from 1 show "x \<in> X"
     proof induct
       case base
       show ?case by (fact 2)
     next
       case step
       with ** show ?case by auto
     qed
   qed
   then show ?thesis by auto
 qed
 
 
 subsection \<open>Transitive closure\<close>
 
 lemma trancl_mono: "\<And>p. p \<in> r\<^sup>+ \<Longrightarrow> r \<subseteq> s \<Longrightarrow> p \<in> s\<^sup>+"
   apply (simp add: split_tupled_all)
   apply (erule trancl.induct)
    apply (iprover dest: subsetD)+
   done
 
 lemma r_into_trancl': "\<And>p. p \<in> r \<Longrightarrow> p \<in> r\<^sup>+"
   by (simp only: split_tupled_all) (erule r_into_trancl)
 
 text \<open>\<^medskip> Conversions between \<open>trancl\<close> and \<open>rtrancl\<close>.\<close>
 
 lemma tranclp_into_rtranclp: "r\<^sup>+\<^sup>+ a b \<Longrightarrow> r\<^sup>*\<^sup>* a b"
   by (erule tranclp.induct) iprover+
 
 lemmas trancl_into_rtrancl = tranclp_into_rtranclp [to_set]
 
 lemma rtranclp_into_tranclp1:
   assumes "r\<^sup>*\<^sup>* a b"
   shows "r b c \<Longrightarrow> r\<^sup>+\<^sup>+ a c"
   using assms by (induct arbitrary: c) iprover+
 
 lemmas rtrancl_into_trancl1 = rtranclp_into_tranclp1 [to_set]
 
 lemma rtranclp_into_tranclp2: "r a b \<Longrightarrow> r\<^sup>*\<^sup>* b c \<Longrightarrow> r\<^sup>+\<^sup>+ a c"
   \<comment> \<open>intro rule from \<open>r\<close> and \<open>rtrancl\<close>\<close>
   apply (erule rtranclp.cases, iprover)
   apply (rule rtranclp_trans [THEN rtranclp_into_tranclp1])
     apply (simp | rule r_into_rtranclp)+
   done
 
 lemmas rtrancl_into_trancl2 = rtranclp_into_tranclp2 [to_set]
 
 text \<open>Nice induction rule for \<open>trancl\<close>\<close>
 lemma tranclp_induct [consumes 1, case_names base step, induct pred: tranclp]:
   assumes a: "r\<^sup>+\<^sup>+ a b"
     and cases: "\<And>y. r a y \<Longrightarrow> P y" "\<And>y z. r\<^sup>+\<^sup>+ a y \<Longrightarrow> r y z \<Longrightarrow> P y \<Longrightarrow> P z"
   shows "P b"
   using a by (induct x\<equiv>a b) (iprover intro: cases)+
 
 lemmas trancl_induct [induct set: trancl] = tranclp_induct [to_set]
 
 lemmas tranclp_induct2 =
   tranclp_induct [of _ "(ax, ay)" "(bx, by)", split_rule, consumes 1, case_names base step]
 
 lemmas trancl_induct2 =
   trancl_induct [of "(ax, ay)" "(bx, by)", split_format (complete),
     consumes 1, case_names base step]
 
 lemma tranclp_trans_induct:
   assumes major: "r\<^sup>+\<^sup>+ x y"
     and cases: "\<And>x y. r x y \<Longrightarrow> P x y" "\<And>x y z. r\<^sup>+\<^sup>+ x y \<Longrightarrow> P x y \<Longrightarrow> r\<^sup>+\<^sup>+ y z \<Longrightarrow> P y z \<Longrightarrow> P x z"
   shows "P x y"
   \<comment> \<open>Another induction rule for trancl, incorporating transitivity\<close>
   by (iprover intro: major [THEN tranclp_induct] cases)
 
 lemmas trancl_trans_induct = tranclp_trans_induct [to_set]
 
 lemma tranclE [cases set: trancl]:
   assumes "(a, b) \<in> r\<^sup>+"
   obtains
     (base) "(a, b) \<in> r"
   | (step) c where "(a, c) \<in> r\<^sup>+" and "(c, b) \<in> r"
   using assms by cases simp_all
 
 lemma trancl_Int_subset: "r \<subseteq> s \<Longrightarrow> (r\<^sup>+ \<inter> s) O r \<subseteq> s \<Longrightarrow> r\<^sup>+ \<subseteq> s"
   apply clarify
   apply (erule trancl_induct, auto)
   done
 
 lemma trancl_unfold: "r\<^sup>+ = r \<union> r\<^sup>+ O r"
   by (auto intro: trancl_into_trancl elim: tranclE)
 
 text \<open>Transitivity of \<^term>\<open>r\<^sup>+\<close>\<close>
 lemma trans_trancl [simp]: "trans (r\<^sup>+)"
 proof (rule transI)
   fix x y z
   assume "(x, y) \<in> r\<^sup>+"
   assume "(y, z) \<in> r\<^sup>+"
   then show "(x, z) \<in> r\<^sup>+"
   proof induct
     case (base u)
     from \<open>(x, y) \<in> r\<^sup>+\<close> and \<open>(y, u) \<in> r\<close>
     show "(x, u) \<in> r\<^sup>+" ..
   next
     case (step u v)
     from \<open>(x, u) \<in> r\<^sup>+\<close> and \<open>(u, v) \<in> r\<close>
     show "(x, v) \<in> r\<^sup>+" ..
   qed
 qed
 
 lemmas trancl_trans = trans_trancl [THEN transD]
 
 lemma tranclp_trans:
   assumes "r\<^sup>+\<^sup>+ x y"
     and "r\<^sup>+\<^sup>+ y z"
   shows "r\<^sup>+\<^sup>+ x z"
   using assms(2,1) by induct iprover+
 
 lemma trancl_id [simp]: "trans r \<Longrightarrow> r\<^sup>+ = r"
   apply auto
   apply (erule trancl_induct, assumption)
   apply (unfold trans_def, blast)
   done
 
 lemma rtranclp_tranclp_tranclp:
   assumes "r\<^sup>*\<^sup>* x y"
   shows "\<And>z. r\<^sup>+\<^sup>+ y z \<Longrightarrow> r\<^sup>+\<^sup>+ x z"
   using assms by induct (iprover intro: tranclp_trans)+
 
 lemmas rtrancl_trancl_trancl = rtranclp_tranclp_tranclp [to_set]
 
 lemma tranclp_into_tranclp2: "r a b \<Longrightarrow> r\<^sup>+\<^sup>+ b c \<Longrightarrow> r\<^sup>+\<^sup>+ a c"
   by (erule tranclp_trans [OF tranclp.r_into_trancl])
 
 lemmas trancl_into_trancl2 = tranclp_into_tranclp2 [to_set]
 
 lemma tranclp_converseI: "(r\<^sup>+\<^sup>+)\<inverse>\<inverse> x y \<Longrightarrow> (r\<inverse>\<inverse>)\<^sup>+\<^sup>+ x y"
   apply (drule conversepD)
   apply (erule tranclp_induct)
    apply (iprover intro: conversepI tranclp_trans)+
   done
 
 lemmas trancl_converseI = tranclp_converseI [to_set]
 
 lemma tranclp_converseD: "(r\<inverse>\<inverse>)\<^sup>+\<^sup>+ x y \<Longrightarrow> (r\<^sup>+\<^sup>+)\<inverse>\<inverse> x y"
   apply (rule conversepI)
   apply (erule tranclp_induct)
    apply (iprover dest: conversepD intro: tranclp_trans)+
   done
 
 lemmas trancl_converseD = tranclp_converseD [to_set]
 
 lemma tranclp_converse: "(r\<inverse>\<inverse>)\<^sup>+\<^sup>+ = (r\<^sup>+\<^sup>+)\<inverse>\<inverse>"
   by (fastforce simp add: fun_eq_iff intro!: tranclp_converseI dest!: tranclp_converseD)
 
 lemmas trancl_converse = tranclp_converse [to_set]
 
 lemma sym_trancl: "sym r \<Longrightarrow> sym (r\<^sup>+)"
   by (simp only: sym_conv_converse_eq trancl_converse [symmetric])
 
 lemma converse_tranclp_induct [consumes 1, case_names base step]:
   assumes major: "r\<^sup>+\<^sup>+ a b"
     and cases: "\<And>y. r y b \<Longrightarrow> P y" "\<And>y z. r y z \<Longrightarrow> r\<^sup>+\<^sup>+ z b \<Longrightarrow> P z \<Longrightarrow> P y"
   shows "P a"
   apply (rule tranclp_induct [OF tranclp_converseI, OF conversepI, OF major])
    apply (blast intro: cases)
   apply (blast intro: assms dest!: tranclp_converseD)
   done
 
 lemmas converse_trancl_induct = converse_tranclp_induct [to_set]
 
 lemma tranclpD: "R\<^sup>+\<^sup>+ x y \<Longrightarrow> \<exists>z. R x z \<and> R\<^sup>*\<^sup>* z y"
   apply (erule converse_tranclp_induct, auto)
   apply (blast intro: rtranclp_trans)
   done
 
 lemmas tranclD = tranclpD [to_set]
 
 lemma converse_tranclpE:
   assumes major: "tranclp r x z"
     and base: "r x z \<Longrightarrow> P"
     and step: "\<And>y. r x y \<Longrightarrow> tranclp r y z \<Longrightarrow> P"
   shows P
 proof -
   from tranclpD [OF major] obtain y where "r x y" and "rtranclp r y z"
     by iprover
   from this(2) show P
   proof (cases rule: rtranclp.cases)
     case rtrancl_refl
     with \<open>r x y\<close> base show P
       by iprover
   next
     case rtrancl_into_rtrancl
     from this have "tranclp r y z"
       by (iprover intro: rtranclp_into_tranclp1)
     with \<open>r x y\<close> step show P
       by iprover
   qed
 qed
 
 lemmas converse_tranclE = converse_tranclpE [to_set]
 
 lemma tranclD2: "(x, y) \<in> R\<^sup>+ \<Longrightarrow> \<exists>z. (x, z) \<in> R\<^sup>* \<and> (z, y) \<in> R"
   by (blast elim: tranclE intro: trancl_into_rtrancl)
 
 lemma irrefl_tranclI: "r\<inverse> \<inter> r\<^sup>* = {} \<Longrightarrow> (x, x) \<notin> r\<^sup>+"
   by (blast elim: tranclE dest: trancl_into_rtrancl)
 
 lemma irrefl_trancl_rD: "\<forall>x. (x, x) \<notin> r\<^sup>+ \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> x \<noteq> y"
   by (blast dest: r_into_trancl)
 
 lemma trancl_subset_Sigma_aux: "(a, b) \<in> r\<^sup>* \<Longrightarrow> r \<subseteq> A \<times> A \<Longrightarrow> a = b \<or> a \<in> A"
   by (induct rule: rtrancl_induct) auto
 
 lemma trancl_subset_Sigma: "r \<subseteq> A \<times> A \<Longrightarrow> r\<^sup>+ \<subseteq> A \<times> A"
   apply (clarsimp simp:)
   apply (erule tranclE)
    apply (blast dest!: trancl_into_rtrancl trancl_subset_Sigma_aux)+
   done
 
 lemma reflclp_tranclp [simp]: "(r\<^sup>+\<^sup>+)\<^sup>=\<^sup>= = r\<^sup>*\<^sup>*"
   apply (safe intro!: order_antisym)
    apply (erule tranclp_into_rtranclp)
   apply (blast elim: rtranclp.cases dest: rtranclp_into_tranclp1)
   done
 
 lemmas reflcl_trancl [simp] = reflclp_tranclp [to_set]
 
 lemma trancl_reflcl [simp]: "(r\<^sup>=)\<^sup>+ = r\<^sup>*"
 proof -
   have "(a, b) \<in> (r\<^sup>=)\<^sup>+ \<Longrightarrow> (a, b) \<in> r\<^sup>*" for a b
     by (force dest: trancl_into_rtrancl)
   moreover have "(a, b) \<in> (r\<^sup>=)\<^sup>+" if "(a, b) \<in> r\<^sup>*" for a b
     using that
   proof (cases a b rule: rtranclE)
     case step
     show ?thesis
       by (rule rtrancl_into_trancl1) (use step in auto)
   qed auto
-  ultimately show ?thesis 
+  ultimately show ?thesis
     by auto
 qed
 
 lemma rtrancl_trancl_reflcl [code]: "r\<^sup>* = (r\<^sup>+)\<^sup>="
   by simp
 
 lemma trancl_empty [simp]: "{}\<^sup>+ = {}"
   by (auto elim: trancl_induct)
 
 lemma rtrancl_empty [simp]: "{}\<^sup>* = Id"
   by (rule subst [OF reflcl_trancl]) simp
 
 lemma rtranclpD: "R\<^sup>*\<^sup>* a b \<Longrightarrow> a = b \<or> a \<noteq> b \<and> R\<^sup>+\<^sup>+ a b"
   by (force simp: reflclp_tranclp [symmetric] simp del: reflclp_tranclp)
 
 lemmas rtranclD = rtranclpD [to_set]
 
 lemma rtrancl_eq_or_trancl: "(x,y) \<in> R\<^sup>* \<longleftrightarrow> x = y \<or> x \<noteq> y \<and> (x, y) \<in> R\<^sup>+"
   by (fast elim: trancl_into_rtrancl dest: rtranclD)
 
 lemma trancl_unfold_right: "r\<^sup>+ = r\<^sup>* O r"
   by (auto dest: tranclD2 intro: rtrancl_into_trancl1)
 
 lemma trancl_unfold_left: "r\<^sup>+ = r O r\<^sup>*"
   by (auto dest: tranclD intro: rtrancl_into_trancl2)
 
 lemma trancl_insert: "(insert (y, x) r)\<^sup>+ = r\<^sup>+ \<union> {(a, b). (a, y) \<in> r\<^sup>* \<and> (x, b) \<in> r\<^sup>*}"
   \<comment> \<open>primitive recursion for \<open>trancl\<close> over finite relations\<close>
 proof -
   have "\<And>a b. (a, b) \<in> (insert (y, x) r)\<^sup>+ \<Longrightarrow>
            (a, b) \<in> r\<^sup>+ \<union> {(a, b). (a, y) \<in> r\<^sup>* \<and> (x, b) \<in> r\<^sup>*}"
     by (erule trancl_induct) (blast intro: rtrancl_into_trancl1 trancl_into_rtrancl trancl_trans)+
   moreover have "r\<^sup>+ \<union> {(a, b). (a, y) \<in> r\<^sup>* \<and> (x, b) \<in> r\<^sup>*}  \<subseteq> (insert (y, x) r)\<^sup>+"
     by (blast intro: trancl_mono rtrancl_mono [THEN [2] rev_subsetD]
                      rtrancl_trancl_trancl rtrancl_into_trancl2)
   ultimately show ?thesis
     by auto
 qed
 
 lemma trancl_insert2:
   "(insert (a, b) r)\<^sup>+ = r\<^sup>+ \<union> {(x, y). ((x, a) \<in> r\<^sup>+ \<or> x = a) \<and> ((b, y) \<in> r\<^sup>+ \<or> y = b)}"
   by (auto simp: trancl_insert rtrancl_eq_or_trancl)
 
 lemma rtrancl_insert: "(insert (a,b) r)\<^sup>* = r\<^sup>* \<union> {(x, y). (x, a) \<in> r\<^sup>* \<and> (b, y) \<in> r\<^sup>*}"
   using trancl_insert[of a b r]
   by (simp add: rtrancl_trancl_reflcl del: reflcl_trancl) blast
 
 
 text \<open>Simplifying nested closures\<close>
 
 lemma rtrancl_trancl_absorb[simp]: "(R\<^sup>*)\<^sup>+ = R\<^sup>*"
   by (simp add: trans_rtrancl)
 
 lemma trancl_rtrancl_absorb[simp]: "(R\<^sup>+)\<^sup>* = R\<^sup>*"
   by (subst reflcl_trancl[symmetric]) simp
 
 lemma rtrancl_reflcl_absorb[simp]: "(R\<^sup>*)\<^sup>= = R\<^sup>*"
   by auto
 
 
 text \<open>\<open>Domain\<close> and \<open>Range\<close>\<close>
 
 lemma Domain_rtrancl [simp]: "Domain (R\<^sup>*) = UNIV"
   by blast
 
 lemma Range_rtrancl [simp]: "Range (R\<^sup>*) = UNIV"
   by blast
 
 lemma rtrancl_Un_subset: "(R\<^sup>* \<union> S\<^sup>*) \<subseteq> (R \<union> S)\<^sup>*"
   by (rule rtrancl_Un_rtrancl [THEN subst]) fast
 
 lemma in_rtrancl_UnI: "x \<in> R\<^sup>* \<or> x \<in> S\<^sup>* \<Longrightarrow> x \<in> (R \<union> S)\<^sup>*"
   by (blast intro: subsetD [OF rtrancl_Un_subset])
 
 lemma trancl_domain [simp]: "Domain (r\<^sup>+) = Domain r"
   by (unfold Domain_unfold) (blast dest: tranclD)
 
 lemma trancl_range [simp]: "Range (r\<^sup>+) = Range r"
   unfolding Domain_converse [symmetric] by (simp add: trancl_converse [symmetric])
 
-lemma Not_Domain_rtrancl: 
+lemma Not_Domain_rtrancl:
   assumes "x \<notin> Domain R" shows "(x, y) \<in> R\<^sup>* \<longleftrightarrow> x = y"
 proof -
 have "(x, y) \<in> R\<^sup>* \<Longrightarrow> x = y"
   by (erule rtrancl_induct) (use assms in auto)
   then show ?thesis
     by auto
 qed
 
 lemma trancl_subset_Field2: "r\<^sup>+ \<subseteq> Field r \<times> Field r"
   apply clarify
   apply (erule trancl_induct)
    apply (auto simp: Field_def)
   done
 
 lemma finite_trancl[simp]: "finite (r\<^sup>+) = finite r"
 proof
   show "finite (r\<^sup>+) \<Longrightarrow> finite r"
     by (blast intro: r_into_trancl' finite_subset)
   show "finite r \<Longrightarrow> finite (r\<^sup>+)"
    apply (rule trancl_subset_Field2 [THEN finite_subset])
    apply (auto simp: finite_Field)
   done
 qed
 
 lemma finite_rtrancl_Image[simp]: assumes "finite R" "finite A" shows "finite (R\<^sup>* `` A)"
 proof (rule ccontr)
   assume "infinite (R\<^sup>* `` A)"
   with assms show False
     by(simp add: rtrancl_trancl_reflcl Un_Image del: reflcl_trancl)
 qed
 
 text \<open>More about converse \<open>rtrancl\<close> and \<open>trancl\<close>, should
   be merged with main body.\<close>
 
 lemma single_valued_confluent:
   assumes "single_valued r" and xy: "(x, y) \<in> r\<^sup>*" and xz: "(x, z) \<in> r\<^sup>*"
   shows "(y, z) \<in> r\<^sup>* \<or> (z, y) \<in> r\<^sup>*"
   using xy
 proof (induction rule: rtrancl_induct)
   case base
   show ?case
-    by (simp add: assms)   
+    by (simp add: assms)
 next
   case (step y z)
   with xz \<open>single_valued r\<close> show ?case
     apply (auto simp: elim: converse_rtranclE dest: single_valuedD)
     apply (blast intro: rtrancl_trans)
     done
 qed
 
 lemma r_r_into_trancl: "(a, b) \<in> R \<Longrightarrow> (b, c) \<in> R \<Longrightarrow> (a, c) \<in> R\<^sup>+"
   by (fast intro: trancl_trans)
 
 lemma trancl_into_trancl: "(a, b) \<in> r\<^sup>+ \<Longrightarrow> (b, c) \<in> r \<Longrightarrow> (a, c) \<in> r\<^sup>+"
   by (induct rule: trancl_induct) (fast intro: r_r_into_trancl trancl_trans)+
 
 lemma tranclp_rtranclp_tranclp: "r\<^sup>+\<^sup>+ a b \<Longrightarrow> r\<^sup>*\<^sup>* b c \<Longrightarrow> r\<^sup>+\<^sup>+ a c"
   apply (drule tranclpD)
   apply (elim exE conjE)
   apply (drule rtranclp_trans, assumption)
   apply (drule (2) rtranclp_into_tranclp2)
   done
 
+lemma rtranclp_conversep: "r\<inverse>\<inverse>\<^sup>*\<^sup>* = r\<^sup>*\<^sup>*\<inverse>\<inverse>"
+  by(auto simp add: fun_eq_iff intro: rtranclp_converseI rtranclp_converseD)
+
+lemmas symp_rtranclp = sym_rtrancl[to_pred]
+
+lemmas symp_conv_conversep_eq = sym_conv_converse_eq[to_pred]
+
+lemmas rtranclp_tranclp_absorb [simp] = rtrancl_trancl_absorb[to_pred]
+lemmas tranclp_rtranclp_absorb [simp] = trancl_rtrancl_absorb[to_pred]
+lemmas rtranclp_reflclp_absorb [simp] = rtrancl_reflcl_absorb[to_pred]
+
 lemmas trancl_rtrancl_trancl = tranclp_rtranclp_tranclp [to_set]
 
 lemmas transitive_closure_trans [trans] =
   r_r_into_trancl trancl_trans rtrancl_trans
   trancl.trancl_into_trancl trancl_into_trancl2
   rtrancl.rtrancl_into_rtrancl converse_rtrancl_into_rtrancl
   rtrancl_trancl_trancl trancl_rtrancl_trancl
 
 lemmas transitive_closurep_trans' [trans] =
   tranclp_trans rtranclp_trans
   tranclp.trancl_into_trancl tranclp_into_tranclp2
   rtranclp.rtrancl_into_rtrancl converse_rtranclp_into_rtranclp
   rtranclp_tranclp_tranclp tranclp_rtranclp_tranclp
 
 declare trancl_into_rtrancl [elim]
 
+subsection \<open>Symmetric closure\<close>
+
+definition symclp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
+where "symclp r x y \<longleftrightarrow> r x y \<or> r y x"
+
+lemma symclpI [simp, intro?]:
+  shows symclpI1: "r x y \<Longrightarrow> symclp r x y"
+  and symclpI2: "r y x \<Longrightarrow> symclp r x y"
+by(simp_all add: symclp_def)
+
+lemma symclpE [consumes 1, cases pred]:
+  assumes "symclp r x y"
+  obtains (base) "r x y" | (sym) "r y x"
+using assms by(auto simp add: symclp_def)
+
+lemma symclp_pointfree: "symclp r = sup r r\<inverse>\<inverse>"
+  by(auto simp add: symclp_def fun_eq_iff)
+
+lemma symclp_greater: "r \<le> symclp r"
+  by(simp add: symclp_pointfree)
+
+lemma symclp_conversep [simp]: "symclp r\<inverse>\<inverse> = symclp r"
+  by(simp add: symclp_pointfree sup.commute)
+
+lemma symp_symclp [simp]: "symp (symclp r)"
+  by(auto simp add: symp_def elim: symclpE intro: symclpI)
+
+lemma symp_symclp_eq: "symp r \<Longrightarrow> symclp r = r"
+  by(simp add: symclp_pointfree symp_conv_conversep_eq)
+
+lemma symp_rtranclp_symclp [simp]: "symp (symclp r)\<^sup>*\<^sup>*"
+  by(simp add: symp_rtranclp)
+
+lemma rtranclp_symclp_sym [sym]: "(symclp r)\<^sup>*\<^sup>* x y \<Longrightarrow> (symclp r)\<^sup>*\<^sup>* y x"
+  by(rule sympD[OF symp_rtranclp_symclp])
+
+lemma symclp_idem [simp]: "symclp (symclp r) = symclp r"
+  by(simp add: symclp_pointfree sup_commute converse_join)
+
+lemma reflp_rtranclp [simp]: "reflp R\<^sup>*\<^sup>*"
+  using refl_rtrancl[to_pred, of R] reflp_refl_eq[of "{(x, y). R\<^sup>*\<^sup>* x y}"] by simp
 
 subsection \<open>The power operation on relations\<close>
 
 text \<open>\<open>R ^^ n = R O \<dots> O R\<close>, the n-fold composition of \<open>R\<close>\<close>
 
 overloading
   relpow \<equiv> "compow :: nat \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set"
   relpowp \<equiv> "compow :: nat \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool)"
 begin
 
 primrec relpow :: "nat \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set"
   where
     "relpow 0 R = Id"
   | "relpow (Suc n) R = (R ^^ n) O R"
 
 primrec relpowp :: "nat \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool)"
   where
     "relpowp 0 R = HOL.eq"
   | "relpowp (Suc n) R = (R ^^ n) OO R"
 
 end
 
 lemma relpowp_relpow_eq [pred_set_conv]:
   "(\<lambda>x y. (x, y) \<in> R) ^^ n = (\<lambda>x y. (x, y) \<in> R ^^ n)" for R :: "'a rel"
   by (induct n) (simp_all add: relcompp_relcomp_eq)
 
 text \<open>For code generation:\<close>
 
 definition relpow :: "nat \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set"
   where relpow_code_def [code_abbrev]: "relpow = compow"
 
 definition relpowp :: "nat \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool)"
   where relpowp_code_def [code_abbrev]: "relpowp = compow"
 
 lemma [code]:
   "relpow (Suc n) R = (relpow n R) O R"
   "relpow 0 R = Id"
   by (simp_all add: relpow_code_def)
 
 lemma [code]:
   "relpowp (Suc n) R = (R ^^ n) OO R"
   "relpowp 0 R = HOL.eq"
   by (simp_all add: relpowp_code_def)
 
 hide_const (open) relpow
 hide_const (open) relpowp
 
 lemma relpow_1 [simp]: "R ^^ 1 = R"
   for R :: "('a \<times> 'a) set"
   by simp
 
 lemma relpowp_1 [simp]: "P ^^ 1 = P"
   for P :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
   by (fact relpow_1 [to_pred])
 
 lemma relpow_0_I: "(x, x) \<in> R ^^ 0"
   by simp
 
 lemma relpowp_0_I: "(P ^^ 0) x x"
   by (fact relpow_0_I [to_pred])
 
 lemma relpow_Suc_I: "(x, y) \<in>  R ^^ n \<Longrightarrow> (y, z) \<in> R \<Longrightarrow> (x, z) \<in> R ^^ Suc n"
   by auto
 
 lemma relpowp_Suc_I: "(P ^^ n) x y \<Longrightarrow> P y z \<Longrightarrow> (P ^^ Suc n) x z"
   by (fact relpow_Suc_I [to_pred])
 
 lemma relpow_Suc_I2: "(x, y) \<in> R \<Longrightarrow> (y, z) \<in> R ^^ n \<Longrightarrow> (x, z) \<in> R ^^ Suc n"
   by (induct n arbitrary: z) (simp, fastforce)
 
 lemma relpowp_Suc_I2: "P x y \<Longrightarrow> (P ^^ n) y z \<Longrightarrow> (P ^^ Suc n) x z"
   by (fact relpow_Suc_I2 [to_pred])
 
 lemma relpow_0_E: "(x, y) \<in> R ^^ 0 \<Longrightarrow> (x = y \<Longrightarrow> P) \<Longrightarrow> P"
   by simp
 
 lemma relpowp_0_E: "(P ^^ 0) x y \<Longrightarrow> (x = y \<Longrightarrow> Q) \<Longrightarrow> Q"
   by (fact relpow_0_E [to_pred])
 
 lemma relpow_Suc_E: "(x, z) \<in> R ^^ Suc n \<Longrightarrow> (\<And>y. (x, y) \<in> R ^^ n \<Longrightarrow> (y, z) \<in> R \<Longrightarrow> P) \<Longrightarrow> P"
   by auto
 
 lemma relpowp_Suc_E: "(P ^^ Suc n) x z \<Longrightarrow> (\<And>y. (P ^^ n) x y \<Longrightarrow> P y z \<Longrightarrow> Q) \<Longrightarrow> Q"
   by (fact relpow_Suc_E [to_pred])
 
 lemma relpow_E:
   "(x, z) \<in>  R ^^ n \<Longrightarrow>
     (n = 0 \<Longrightarrow> x = z \<Longrightarrow> P) \<Longrightarrow>
     (\<And>y m. n = Suc m \<Longrightarrow> (x, y) \<in>  R ^^ m \<Longrightarrow> (y, z) \<in> R \<Longrightarrow> P) \<Longrightarrow> P"
   by (cases n) auto
 
 lemma relpowp_E:
   "(P ^^ n) x z \<Longrightarrow>
     (n = 0 \<Longrightarrow> x = z \<Longrightarrow> Q) \<Longrightarrow>
     (\<And>y m. n = Suc m \<Longrightarrow> (P ^^ m) x y \<Longrightarrow> P y z \<Longrightarrow> Q) \<Longrightarrow> Q"
   by (fact relpow_E [to_pred])
 
 lemma relpow_Suc_D2: "(x, z) \<in> R ^^ Suc n \<Longrightarrow> (\<exists>y. (x, y) \<in> R \<and> (y, z) \<in> R ^^ n)"
   by (induct n arbitrary: x z)
     (blast intro: relpow_0_I relpow_Suc_I elim: relpow_0_E relpow_Suc_E)+
 
 lemma relpowp_Suc_D2: "(P ^^ Suc n) x z \<Longrightarrow> \<exists>y. P x y \<and> (P ^^ n) y z"
   by (fact relpow_Suc_D2 [to_pred])
 
 lemma relpow_Suc_E2: "(x, z) \<in> R ^^ Suc n \<Longrightarrow> (\<And>y. (x, y) \<in> R \<Longrightarrow> (y, z) \<in> R ^^ n \<Longrightarrow> P) \<Longrightarrow> P"
   by (blast dest: relpow_Suc_D2)
 
 lemma relpowp_Suc_E2: "(P ^^ Suc n) x z \<Longrightarrow> (\<And>y. P x y \<Longrightarrow> (P ^^ n) y z \<Longrightarrow> Q) \<Longrightarrow> Q"
   by (fact relpow_Suc_E2 [to_pred])
 
 lemma relpow_Suc_D2': "\<forall>x y z. (x, y) \<in> R ^^ n \<and> (y, z) \<in> R \<longrightarrow> (\<exists>w. (x, w) \<in> R \<and> (w, z) \<in> R ^^ n)"
   by (induct n) (simp_all, blast)
 
 lemma relpowp_Suc_D2': "\<forall>x y z. (P ^^ n) x y \<and> P y z \<longrightarrow> (\<exists>w. P x w \<and> (P ^^ n) w z)"
   by (fact relpow_Suc_D2' [to_pred])
 
 lemma relpow_E2:
   assumes "(x, z) \<in> R ^^ n" "n = 0 \<Longrightarrow> x = z \<Longrightarrow> P"
           "\<And>y m. n = Suc m \<Longrightarrow> (x, y) \<in> R \<Longrightarrow> (y, z) \<in> R ^^ m \<Longrightarrow> P"
       shows "P"
 proof (cases n)
   case 0
   with assms show ?thesis
     by simp
 next
   case (Suc m)
   with assms relpow_Suc_D2' [of m R] show ?thesis
     by force
 qed
 
 lemma relpowp_E2:
   "(P ^^ n) x z \<Longrightarrow>
     (n = 0 \<Longrightarrow> x = z \<Longrightarrow> Q) \<Longrightarrow>
     (\<And>y m. n = Suc m \<Longrightarrow> P x y \<Longrightarrow> (P ^^ m) y z \<Longrightarrow> Q) \<Longrightarrow> Q"
   by (fact relpow_E2 [to_pred])
 
 lemma relpow_add: "R ^^ (m + n) = R^^m O R^^n"
   by (induct n) auto
 
 lemma relpowp_add: "P ^^ (m + n) = P ^^ m OO P ^^ n"
   by (fact relpow_add [to_pred])
 
 lemma relpow_commute: "R O R ^^ n = R ^^ n O R"
   by (induct n) (simp_all add: O_assoc [symmetric])
 
 lemma relpowp_commute: "P OO P ^^ n = P ^^ n OO P"
   by (fact relpow_commute [to_pred])
 
 lemma relpow_empty: "0 < n \<Longrightarrow> ({} :: ('a \<times> 'a) set) ^^ n = {}"
   by (cases n) auto
 
 lemma relpowp_bot: "0 < n \<Longrightarrow> (\<bottom> :: 'a \<Rightarrow> 'a \<Rightarrow> bool) ^^ n = \<bottom>"
   by (fact relpow_empty [to_pred])
 
 lemma rtrancl_imp_UN_relpow:
   assumes "p \<in> R\<^sup>*"
   shows "p \<in> (\<Union>n. R ^^ n)"
 proof (cases p)
   case (Pair x y)
   with assms have "(x, y) \<in> R\<^sup>*" by simp
   then have "(x, y) \<in> (\<Union>n. R ^^ n)"
   proof induct
     case base
     show ?case by (blast intro: relpow_0_I)
   next
     case step
     then show ?case by (blast intro: relpow_Suc_I)
   qed
   with Pair show ?thesis by simp
 qed
 
 lemma rtranclp_imp_Sup_relpowp:
   assumes "(P\<^sup>*\<^sup>*) x y"
   shows "(\<Squnion>n. P ^^ n) x y"
   using assms and rtrancl_imp_UN_relpow [of "(x, y)", to_pred] by simp
 
 lemma relpow_imp_rtrancl:
   assumes "p \<in> R ^^ n"
   shows "p \<in> R\<^sup>*"
 proof (cases p)
   case (Pair x y)
   with assms have "(x, y) \<in> R ^^ n" by simp
   then have "(x, y) \<in> R\<^sup>*"
   proof (induct n arbitrary: x y)
     case 0
     then show ?case by simp
   next
     case Suc
     then show ?case
       by (blast elim: relpow_Suc_E intro: rtrancl_into_rtrancl)
   qed
   with Pair show ?thesis by simp
 qed
 
 lemma relpowp_imp_rtranclp: "(P ^^ n) x y \<Longrightarrow> (P\<^sup>*\<^sup>*) x y"
   using relpow_imp_rtrancl [of "(x, y)", to_pred] by simp
 
 lemma rtrancl_is_UN_relpow: "R\<^sup>* = (\<Union>n. R ^^ n)"
   by (blast intro: rtrancl_imp_UN_relpow relpow_imp_rtrancl)
 
 lemma rtranclp_is_Sup_relpowp: "P\<^sup>*\<^sup>* = (\<Squnion>n. P ^^ n)"
   using rtrancl_is_UN_relpow [to_pred, of P] by auto
 
 lemma rtrancl_power: "p \<in> R\<^sup>* \<longleftrightarrow> (\<exists>n. p \<in> R ^^ n)"
   by (simp add: rtrancl_is_UN_relpow)
 
 lemma rtranclp_power: "(P\<^sup>*\<^sup>*) x y \<longleftrightarrow> (\<exists>n. (P ^^ n) x y)"
   by (simp add: rtranclp_is_Sup_relpowp)
 
 lemma trancl_power: "p \<in> R\<^sup>+ \<longleftrightarrow> (\<exists>n > 0. p \<in> R ^^ n)"
 proof -
   have "((a, b) \<in> R\<^sup>+) = (\<exists>n>0. (a, b) \<in> R ^^ n)" for a b
   proof safe
     show "(a, b) \<in> R\<^sup>+ \<Longrightarrow> \<exists>n>0. (a, b) \<in> R ^^ n"
       apply (drule tranclD2)
       apply (fastforce simp: rtrancl_is_UN_relpow relcomp_unfold)
       done
     show "(a, b) \<in> R\<^sup>+" if "n > 0" "(a, b) \<in> R ^^ n" for n
     proof (cases n)
       case (Suc m)
       with that show ?thesis
         by (auto simp: dest: relpow_imp_rtrancl rtrancl_into_trancl1)
     qed (use that in auto)
   qed
   then show ?thesis
     by (cases p) auto
 qed
 
 lemma tranclp_power: "(P\<^sup>+\<^sup>+) x y \<longleftrightarrow> (\<exists>n > 0. (P ^^ n) x y)"
   using trancl_power [to_pred, of P "(x, y)"] by simp
 
 lemma rtrancl_imp_relpow: "p \<in> R\<^sup>* \<Longrightarrow> \<exists>n. p \<in> R ^^ n"
   by (auto dest: rtrancl_imp_UN_relpow)
 
 lemma rtranclp_imp_relpowp: "(P\<^sup>*\<^sup>*) x y \<Longrightarrow> \<exists>n. (P ^^ n) x y"
   by (auto dest: rtranclp_imp_Sup_relpowp)
 
 text \<open>By Sternagel/Thiemann:\<close>
 lemma relpow_fun_conv: "(a, b) \<in> R ^^ n \<longleftrightarrow> (\<exists>f. f 0 = a \<and> f n = b \<and> (\<forall>i<n. (f i, f (Suc i)) \<in> R))"
 proof (induct n arbitrary: b)
   case 0
   show ?case by auto
 next
   case (Suc n)
   show ?case
   proof (simp add: relcomp_unfold Suc)
     show "(\<exists>y. (\<exists>f. f 0 = a \<and> f n = y \<and> (\<forall>i<n. (f i,f(Suc i)) \<in> R)) \<and> (y,b) \<in> R) \<longleftrightarrow>
       (\<exists>f. f 0 = a \<and> f(Suc n) = b \<and> (\<forall>i<Suc n. (f i, f (Suc i)) \<in> R))"
     (is "?l = ?r")
     proof
       assume ?l
       then obtain c f
         where 1: "f 0 = a"  "f n = c"  "\<And>i. i < n \<Longrightarrow> (f i, f (Suc i)) \<in> R"  "(c,b) \<in> R"
         by auto
       let ?g = "\<lambda> m. if m = Suc n then b else f m"
       show ?r by (rule exI[of _ ?g]) (simp add: 1)
     next
       assume ?r
       then obtain f where 1: "f 0 = a"  "b = f (Suc n)"  "\<And>i. i < Suc n \<Longrightarrow> (f i, f (Suc i)) \<in> R"
         by auto
       show ?l by (rule exI[of _ "f n"], rule conjI, rule exI[of _ f], insert 1, auto)
     qed
   qed
 qed
 
 lemma relpowp_fun_conv: "(P ^^ n) x y \<longleftrightarrow> (\<exists>f. f 0 = x \<and> f n = y \<and> (\<forall>i<n. P (f i) (f (Suc i))))"
   by (fact relpow_fun_conv [to_pred])
 
 lemma relpow_finite_bounded1:
   fixes R :: "('a \<times> 'a) set"
   assumes "finite R" and "k > 0"
   shows "R^^k \<subseteq> (\<Union>n\<in>{n. 0 < n \<and> n \<le> card R}. R^^n)"
     (is "_ \<subseteq> ?r")
 proof -
   have "(a, b) \<in> R^^(Suc k) \<Longrightarrow> \<exists>n. 0 < n \<and> n \<le> card R \<and> (a, b) \<in> R^^n" for a b k
   proof (induct k arbitrary: b)
     case 0
     then have "R \<noteq> {}" by auto
     with card_0_eq[OF \<open>finite R\<close>] have "card R \<ge> Suc 0" by auto
     then show ?case using 0 by force
   next
     case (Suc k)
     then obtain a' where "(a, a') \<in> R^^(Suc k)" and "(a', b) \<in> R"
       by auto
     from Suc(1)[OF \<open>(a, a') \<in> R^^(Suc k)\<close>] obtain n where "n \<le> card R" and "(a, a') \<in> R ^^ n"
       by auto
     have "(a, b) \<in> R^^(Suc n)"
       using \<open>(a, a') \<in> R^^n\<close> and \<open>(a', b)\<in> R\<close> by auto
     from \<open>n \<le> card R\<close> consider "n < card R" | "n = card R" by force
     then show ?case
     proof cases
       case 1
       then show ?thesis
         using \<open>(a, b) \<in> R^^(Suc n)\<close> Suc_leI[OF \<open>n < card R\<close>] by blast
     next
       case 2
       from \<open>(a, b) \<in> R ^^ (Suc n)\<close> [unfolded relpow_fun_conv]
       obtain f where "f 0 = a" and "f (Suc n) = b"
         and steps: "\<And>i. i \<le> n \<Longrightarrow> (f i, f (Suc i)) \<in> R" by auto
       let ?p = "\<lambda>i. (f i, f(Suc i))"
       let ?N = "{i. i \<le> n}"
       have "?p ` ?N \<subseteq> R"
         using steps by auto
       from card_mono[OF assms(1) this] have "card (?p ` ?N) \<le> card R" .
       also have "\<dots> < card ?N"
         using \<open>n = card R\<close> by simp
       finally have "\<not> inj_on ?p ?N"
         by (rule pigeonhole)
       then obtain i j where i: "i \<le> n" and j: "j \<le> n" and ij: "i \<noteq> j" and pij: "?p i = ?p j"
         by (auto simp: inj_on_def)
       let ?i = "min i j"
       let ?j = "max i j"
       have i: "?i \<le> n" and j: "?j \<le> n" and pij: "?p ?i = ?p ?j" and ij: "?i < ?j"
         using i j ij pij unfolding min_def max_def by auto
       from i j pij ij obtain i j where i: "i \<le> n" and j: "j \<le> n" and ij: "i < j"
         and pij: "?p i = ?p j"
         by blast
       let ?g = "\<lambda>l. if l \<le> i then f l else f (l + (j - i))"
       let ?n = "Suc (n - (j - i))"
       have abl: "(a, b) \<in> R ^^ ?n"
         unfolding relpow_fun_conv
       proof (rule exI[of _ ?g], intro conjI impI allI)
         show "?g ?n = b"
           using \<open>f(Suc n) = b\<close> j ij by auto
       next
         fix k
         assume "k < ?n"
         show "(?g k, ?g (Suc k)) \<in> R"
         proof (cases "k < i")
           case True
           with i have "k \<le> n"
             by auto
           from steps[OF this] show ?thesis
             using True by simp
         next
           case False
           then have "i \<le> k" by auto
           show ?thesis
           proof (cases "k = i")
             case True
             then show ?thesis
               using ij pij steps[OF i] by simp
           next
             case False
             with \<open>i \<le> k\<close> have "i < k" by auto
             then have small: "k + (j - i) \<le> n"
               using \<open>k<?n\<close> by arith
             show ?thesis
               using steps[OF small] \<open>i<k\<close> by auto
           qed
         qed
       qed (simp add: \<open>f 0 = a\<close>)
       moreover have "?n \<le> n"
         using i j ij by arith
       ultimately show ?thesis
         using \<open>n = card R\<close> by blast
     qed
   qed
   then show ?thesis
     using gr0_implies_Suc[OF \<open>k > 0\<close>] by auto
 qed
 
 lemma relpow_finite_bounded:
   fixes R :: "('a \<times> 'a) set"
   assumes "finite R"
   shows "R^^k \<subseteq> (\<Union>n\<in>{n. n \<le> card R}. R^^n)"
   apply (cases k, force)
   apply (use relpow_finite_bounded1[OF assms, of k] in auto)
   done
 
 lemma rtrancl_finite_eq_relpow: "finite R \<Longrightarrow> R\<^sup>* = (\<Union>n\<in>{n. n \<le> card R}. R^^n)"
   by (fastforce simp: rtrancl_power dest: relpow_finite_bounded)
 
 lemma trancl_finite_eq_relpow: "finite R \<Longrightarrow> R\<^sup>+ = (\<Union>n\<in>{n. 0 < n \<and> n \<le> card R}. R^^n)"
   apply (auto simp: trancl_power)
   apply (auto dest: relpow_finite_bounded1)
   done
 
 lemma finite_relcomp[simp,intro]:
   assumes "finite R" and "finite S"
   shows "finite (R O S)"
 proof-
   have "R O S = (\<Union>(x, y)\<in>R. \<Union>(u, v)\<in>S. if u = y then {(x, v)} else {})"
     by (force simp: split_def image_constant_conv split: if_splits)
   then show ?thesis
     using assms by clarsimp
 qed
 
 lemma finite_relpow [simp, intro]:
   fixes R :: "('a \<times> 'a) set"
   assumes "finite R"
   shows "n > 0 \<Longrightarrow> finite (R^^n)"
 proof (induct n)
   case 0
   then show ?case by simp
 next
   case (Suc n)
   then show ?case by (cases n) (use assms in simp_all)
 qed
 
 lemma single_valued_relpow:
   fixes R :: "('a \<times> 'a) set"
   shows "single_valued R \<Longrightarrow> single_valued (R ^^ n)"
 proof (induct n arbitrary: R)
   case 0
   then show ?case by simp
 next
   case (Suc n)
   show ?case
     by (rule single_valuedI)
       (use Suc in \<open>fast dest: single_valuedD elim: relpow_Suc_E\<close>)
 qed
 
 
 subsection \<open>Bounded transitive closure\<close>
 
 definition ntrancl :: "nat \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set"
   where "ntrancl n R = (\<Union>i\<in>{i. 0 < i \<and> i \<le> Suc n}. R ^^ i)"
 
 lemma ntrancl_Zero [simp, code]: "ntrancl 0 R = R"
 proof
   show "R \<subseteq> ntrancl 0 R"
     unfolding ntrancl_def by fastforce
   have "0 < i \<and> i \<le> Suc 0 \<longleftrightarrow> i = 1" for i
     by auto
   then show "ntrancl 0 R \<le> R"
     unfolding ntrancl_def by auto
 qed
 
 lemma ntrancl_Suc [simp]: "ntrancl (Suc n) R = ntrancl n R O (Id \<union> R)"
 proof
   have "(a, b) \<in> ntrancl n R O (Id \<union> R)" if "(a, b) \<in> ntrancl (Suc n) R" for a b
   proof -
     from that obtain i where "0 < i" "i \<le> Suc (Suc n)" "(a, b) \<in> R ^^ i"
       unfolding ntrancl_def by auto
     show ?thesis
     proof (cases "i = 1")
       case True
       from this \<open>(a, b) \<in> R ^^ i\<close> show ?thesis
         by (auto simp: ntrancl_def)
     next
       case False
       with \<open>0 < i\<close> obtain j where j: "i = Suc j" "0 < j"
         by (cases i) auto
       with \<open>(a, b) \<in> R ^^ i\<close> obtain c where c1: "(a, c) \<in> R ^^ j" and c2: "(c, b) \<in> R"
         by auto
       from c1 j \<open>i \<le> Suc (Suc n)\<close> have "(a, c) \<in> ntrancl n R"
         by (fastforce simp: ntrancl_def)
       with c2 show ?thesis by fastforce
     qed
   qed
   then show "ntrancl (Suc n) R \<subseteq> ntrancl n R O (Id \<union> R)"
     by auto
   show "ntrancl n R O (Id \<union> R) \<subseteq> ntrancl (Suc n) R"
     by (fastforce simp: ntrancl_def)
 qed
 
 lemma [code]: "ntrancl (Suc n) r = (let r' = ntrancl n r in r' \<union> r' O r)"
   by (auto simp: Let_def)
 
 lemma finite_trancl_ntranl: "finite R \<Longrightarrow> trancl R = ntrancl (card R - 1) R"
   by (cases "card R") (auto simp: trancl_finite_eq_relpow relpow_empty ntrancl_def)
 
 
 subsection \<open>Acyclic relations\<close>
 
 definition acyclic :: "('a \<times> 'a) set \<Rightarrow> bool"
   where "acyclic r \<longleftrightarrow> (\<forall>x. (x,x) \<notin> r\<^sup>+)"
 
 abbreviation acyclicP :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
   where "acyclicP r \<equiv> acyclic {(x, y). r x y}"
 
 lemma acyclic_irrefl [code]: "acyclic r \<longleftrightarrow> irrefl (r\<^sup>+)"
   by (simp add: acyclic_def irrefl_def)
 
 lemma acyclicI: "\<forall>x. (x, x) \<notin> r\<^sup>+ \<Longrightarrow> acyclic r"
   by (simp add: acyclic_def)
 
 lemma (in preorder) acyclicI_order:
   assumes *: "\<And>a b. (a, b) \<in> r \<Longrightarrow> f b < f a"
   shows "acyclic r"
 proof -
   have "f b < f a" if "(a, b) \<in> r\<^sup>+" for a b
     using that by induct (auto intro: * less_trans)
   then show ?thesis
     by (auto intro!: acyclicI)
 qed
 
 lemma acyclic_insert [iff]: "acyclic (insert (y, x) r) \<longleftrightarrow> acyclic r \<and> (x, y) \<notin> r\<^sup>*"
   by (simp add: acyclic_def trancl_insert) (blast intro: rtrancl_trans)
 
 lemma acyclic_converse [iff]: "acyclic (r\<inverse>) \<longleftrightarrow> acyclic r"
   by (simp add: acyclic_def trancl_converse)
 
 lemmas acyclicP_converse [iff] = acyclic_converse [to_pred]
 
 lemma acyclic_impl_antisym_rtrancl: "acyclic r \<Longrightarrow> antisym (r\<^sup>*)"
   by (simp add: acyclic_def antisym_def)
     (blast elim: rtranclE intro: rtrancl_into_trancl1 rtrancl_trancl_trancl)
 
 (* Other direction:
 acyclic = no loops
 antisym = only self loops
 Goalw [acyclic_def,antisym_def] "antisym( r\<^sup>* ) \<Longrightarrow> acyclic(r - Id)
 \<Longrightarrow> antisym( r\<^sup>* ) = acyclic(r - Id)";
 *)
 
 lemma acyclic_subset: "acyclic s \<Longrightarrow> r \<subseteq> s \<Longrightarrow> acyclic r"
   unfolding acyclic_def by (blast intro: trancl_mono)
 
 
 subsection \<open>Setup of transitivity reasoner\<close>
 
 ML \<open>
 structure Trancl_Tac = Trancl_Tac
 (
   val r_into_trancl = @{thm trancl.r_into_trancl};
   val trancl_trans  = @{thm trancl_trans};
   val rtrancl_refl = @{thm rtrancl.rtrancl_refl};
   val r_into_rtrancl = @{thm r_into_rtrancl};
   val trancl_into_rtrancl = @{thm trancl_into_rtrancl};
   val rtrancl_trancl_trancl = @{thm rtrancl_trancl_trancl};
   val trancl_rtrancl_trancl = @{thm trancl_rtrancl_trancl};
   val rtrancl_trans = @{thm rtrancl_trans};
 
   fun decomp (\<^const>\<open>Trueprop\<close> $ t) =
         let
           fun dec (Const (\<^const_name>\<open>Set.member\<close>, _) $ (Const (\<^const_name>\<open>Pair\<close>, _) $ a $ b) $ rel) =
               let
                 fun decr (Const (\<^const_name>\<open>rtrancl\<close>, _ ) $ r) = (r,"r*")
                   | decr (Const (\<^const_name>\<open>trancl\<close>, _ ) $ r)  = (r,"r+")
                   | decr r = (r,"r");
                 val (rel,r) = decr (Envir.beta_eta_contract rel);
               in SOME (a,b,rel,r) end
           | dec _ =  NONE
         in dec t end
     | decomp _ = NONE;
 );
 
 structure Tranclp_Tac = Trancl_Tac
 (
   val r_into_trancl = @{thm tranclp.r_into_trancl};
   val trancl_trans  = @{thm tranclp_trans};
   val rtrancl_refl = @{thm rtranclp.rtrancl_refl};
   val r_into_rtrancl = @{thm r_into_rtranclp};
   val trancl_into_rtrancl = @{thm tranclp_into_rtranclp};
   val rtrancl_trancl_trancl = @{thm rtranclp_tranclp_tranclp};
   val trancl_rtrancl_trancl = @{thm tranclp_rtranclp_tranclp};
   val rtrancl_trans = @{thm rtranclp_trans};
 
   fun decomp (\<^const>\<open>Trueprop\<close> $ t) =
         let
           fun dec (rel $ a $ b) =
             let
               fun decr (Const (\<^const_name>\<open>rtranclp\<close>, _ ) $ r) = (r,"r*")
                 | decr (Const (\<^const_name>\<open>tranclp\<close>, _ ) $ r)  = (r,"r+")
                 | decr r = (r,"r");
               val (rel,r) = decr rel;
             in SOME (a, b, rel, r) end
           | dec _ =  NONE
         in dec t end
     | decomp _ = NONE;
 );
 \<close>
 
 setup \<open>
   map_theory_simpset (fn ctxt => ctxt
     addSolver (mk_solver "Trancl" Trancl_Tac.trancl_tac)
     addSolver (mk_solver "Rtrancl" Trancl_Tac.rtrancl_tac)
     addSolver (mk_solver "Tranclp" Tranclp_Tac.trancl_tac)
     addSolver (mk_solver "Rtranclp" Tranclp_Tac.rtrancl_tac))
 \<close>
 
+lemma transp_rtranclp [simp]: "transp R\<^sup>*\<^sup>*"
+  by(auto simp add: transp_def)
 
 text \<open>Optional methods.\<close>
 
 method_setup trancl =
   \<open>Scan.succeed (SIMPLE_METHOD' o Trancl_Tac.trancl_tac)\<close>
   \<open>simple transitivity reasoner\<close>
 method_setup rtrancl =
   \<open>Scan.succeed (SIMPLE_METHOD' o Trancl_Tac.rtrancl_tac)\<close>
   \<open>simple transitivity reasoner\<close>
 method_setup tranclp =
   \<open>Scan.succeed (SIMPLE_METHOD' o Tranclp_Tac.trancl_tac)\<close>
   \<open>simple transitivity reasoner (predicate version)\<close>
 method_setup rtranclp =
   \<open>Scan.succeed (SIMPLE_METHOD' o Tranclp_Tac.rtrancl_tac)\<close>
   \<open>simple transitivity reasoner (predicate version)\<close>
 
 end