merged, using src/HOL/Tools/Sledgehammer/sledgehammer_isar.ML and src/HOL/Tools/Sledgehammer/sledgehammer_run.ML from 347c3b0cab44;
authorwenzelm
Mon Nov 11 17:44:21 2013 +0100 (2013-11-11)
changeset 5438450199af40c27
parent 54383 9d3c7a04a65e
parent 54298 347c3b0cab44
child 54385 27246f8b2dac
merged, using src/HOL/Tools/Sledgehammer/sledgehammer_isar.ML and src/HOL/Tools/Sledgehammer/sledgehammer_run.ML from 347c3b0cab44;
CONTRIBUTORS
NEWS
src/Doc/manual.bib
src/HOL/BNF/Tools/bnf_fp_rec_sugar.ML
src/HOL/BNF/Tools/bnf_fp_rec_sugar_tactics.ML
src/HOL/Library/Abstract_Rat.thy
src/HOL/Library/Glbs.thy
src/HOL/Library/Univ_Poly.thy
src/HOL/Lubs.thy
     1.1 --- a/CONTRIBUTORS	Mon Nov 11 17:34:44 2013 +0100
     1.2 +++ b/CONTRIBUTORS	Mon Nov 11 17:44:21 2013 +0100
     1.3 @@ -3,6 +3,10 @@
     1.4  who is listed as an author in one of the source files of this Isabelle
     1.5  distribution.
     1.6  
     1.7 +Contributions to this Isabelle version
     1.8 +--------------------------------------
     1.9 +
    1.10 +
    1.11  Contributions to Isabelle2013-1
    1.12  -------------------------------
    1.13  
     2.1 --- a/NEWS	Mon Nov 11 17:34:44 2013 +0100
     2.2 +++ b/NEWS	Mon Nov 11 17:44:21 2013 +0100
     2.3 @@ -1,6 +1,67 @@
     2.4  Isabelle NEWS -- history user-relevant changes
     2.5  ==============================================
     2.6  
     2.7 +New in this Isabelle version
     2.8 +----------------------------
     2.9 +
    2.10 +*** HOL ***
    2.11 +
    2.12 +* Qualified constant names Wellfounded.acc, Wellfounded.accp.
    2.13 +INCOMPATIBILITY.
    2.14 +
    2.15 +* Fact generalization and consolidation:
    2.16 +    neq_one_mod_two, mod_2_not_eq_zero_eq_one_int ~> not_mod_2_eq_0_eq_1
    2.17 +INCOMPATIBILITY.
    2.18 +
    2.19 +* Purely algebraic definition of even.  Fact generalization and consolidation:
    2.20 +    nat_even_iff_2_dvd, int_even_iff_2_dvd ~> even_iff_2_dvd
    2.21 +    even_zero_(nat|int) ~> even_zero
    2.22 +INCOMPATIBILITY.
    2.23 +
    2.24 +* Elimination of fact duplicates:
    2.25 +    equals_zero_I ~> minus_unique
    2.26 +    diff_eq_0_iff_eq ~> right_minus_eq
    2.27 +INCOMPATIBILITY.
    2.28 +
    2.29 +* Fact name consolidation:
    2.30 +    diff_def, diff_minus, ab_diff_minus ~> diff_conv_add_uminus
    2.31 +    minus_le_self_iff ~> neg_less_eq_nonneg
    2.32 +    le_minus_self_iff ~> less_eq_neg_nonpos
    2.33 +    neg_less_nonneg ~> neg_less_pos
    2.34 +    less_minus_self_iff ~> less_neg_neg [simp]
    2.35 +INCOMPATIBILITY.
    2.36 +
    2.37 +* More simplification rules on unary and binary minus:
    2.38 +add_diff_cancel, add_diff_cancel_left, add_le_same_cancel1,
    2.39 +add_le_same_cancel2, add_less_same_cancel1, add_less_same_cancel2,
    2.40 +add_minus_cancel, diff_add_cancel, le_add_same_cancel1,
    2.41 +le_add_same_cancel2, less_add_same_cancel1, less_add_same_cancel2,
    2.42 +minus_add_cancel, uminus_add_conv_diff.  These correspondingly
    2.43 +have been taken away from fact collections algebra_simps and
    2.44 +field_simps.  INCOMPATIBILITY.
    2.45 +
    2.46 +To restore proofs, the following patterns are helpful:
    2.47 +
    2.48 +a) Arbitrary failing proof not involving "diff_def":
    2.49 +Consider simplification with algebra_simps or field_simps.
    2.50 +
    2.51 +b) Lifting rules from addition to subtraction:
    2.52 +Try with "using <rule for addition> of [… "- _" …]" by simp".
    2.53 +
    2.54 +c) Simplification with "diff_def": just drop "diff_def".
    2.55 +Consider simplification with algebra_simps or field_simps;
    2.56 +or the brute way with
    2.57 +"simp add: diff_conv_add_uminus del: add_uminus_conv_diff".
    2.58 +
    2.59 +* SUP and INF generalized to conditionally_complete_lattice
    2.60 +
    2.61 +* Theory Lubs moved HOL image to HOL-Library. It is replaced by
    2.62 +Conditionally_Complete_Lattices.   INCOMPATIBILITY.
    2.63 +
    2.64 +* Introduce bdd_above and bdd_below in Conditionally_Complete_Lattices, use them
    2.65 +instead of explicitly stating boundedness of sets.
    2.66 +
    2.67 +
    2.68  New in Isabelle2013-1 (November 2013)
    2.69  -------------------------------------
    2.70  
     3.1 --- a/src/Doc/Datatypes/Datatypes.thy	Mon Nov 11 17:34:44 2013 +0100
     3.2 +++ b/src/Doc/Datatypes/Datatypes.thy	Mon Nov 11 17:44:21 2013 +0100
     3.3 @@ -9,21 +9,8 @@
     3.4  
     3.5  theory Datatypes
     3.6  imports Setup
     3.7 -keywords
     3.8 -  "primcorec_notyet" :: thy_decl
     3.9  begin
    3.10  
    3.11 -(*<*)
    3.12 -(* FIXME: Temporary setup until "primcorec" and "primcorecursive" are fully implemented. *)
    3.13 -ML_command {*
    3.14 -fun add_dummy_cmd _ _ lthy = lthy;
    3.15 -
    3.16 -val _ = Outer_Syntax.local_theory @{command_spec "primcorec_notyet"} ""
    3.17 -  (Parse.fixes -- Parse_Spec.where_alt_specs >> uncurry add_dummy_cmd);
    3.18 -*}
    3.19 -(*>*)
    3.20 -
    3.21 -
    3.22  section {* Introduction
    3.23    \label{sec:introduction} *}
    3.24  
    3.25 @@ -54,17 +41,19 @@
    3.26  
    3.27  text {*
    3.28  \noindent
    3.29 -The package also provides some convenience, notably automatically generated
    3.30 -discriminators and selectors.
    3.31 -
    3.32 -In addition to plain inductive datatypes, the new package supports coinductive
    3.33 -datatypes, or \emph{codatatypes}, which may have infinite values. For example,
    3.34 -the following command introduces the type of lazy lists, which comprises both
    3.35 -finite and infinite values:
    3.36 +Furthermore, the package provides a lot of convenience, including automatically
    3.37 +generated discriminators, selectors, and relators as well as a wealth of
    3.38 +properties about them.
    3.39 +
    3.40 +In addition to inductive datatypes, the new package supports coinductive
    3.41 +datatypes, or \emph{codatatypes}, which allow infinite values. For example, the
    3.42 +following command introduces the type of lazy lists, which comprises both finite
    3.43 +and infinite values:
    3.44  *}
    3.45  
    3.46  (*<*)
    3.47      locale early
    3.48 +    locale late
    3.49  (*>*)
    3.50      codatatype (*<*)(in early) (*>*)'a llist = LNil | LCons 'a "'a llist"
    3.51  
    3.52 @@ -80,10 +69,10 @@
    3.53      codatatype (*<*)(in early) (*>*)'a tree\<^sub>i\<^sub>i = Node\<^sub>i\<^sub>i 'a "'a tree\<^sub>i\<^sub>i llist"
    3.54  
    3.55  text {*
    3.56 -The first two tree types allow only finite branches, whereas the last two allow
    3.57 -branches of infinite length. Orthogonally, the nodes in the first and third
    3.58 -types have finite branching, whereas those of the second and fourth may have
    3.59 -infinitely many direct subtrees.
    3.60 +The first two tree types allow only paths of finite length, whereas the last two
    3.61 +allow infinite paths. Orthogonally, the nodes in the first and third types have
    3.62 +finitely many direct subtrees, whereas those of the second and fourth may have
    3.63 +infinite branching.
    3.64  
    3.65  To use the package, it is necessary to import the @{theory BNF} theory, which
    3.66  can be precompiled into the \texttt{HOL-BNF} image. The following commands show
    3.67 @@ -152,15 +141,15 @@
    3.68  
    3.69  
    3.70  \newbox\boxA
    3.71 -\setbox\boxA=\hbox{\texttt{nospam}}
    3.72 -
    3.73 -\newcommand\authoremaili{\texttt{blan{\color{white}nospam}\kern-\wd\boxA{}chette@\allowbreak
    3.74 +\setbox\boxA=\hbox{\texttt{NOSPAM}}
    3.75 +
    3.76 +\newcommand\authoremaili{\texttt{blan{\color{white}NOSPAM}\kern-\wd\boxA{}chette@\allowbreak
    3.77  in.\allowbreak tum.\allowbreak de}}
    3.78 -\newcommand\authoremailii{\texttt{lore{\color{white}nospam}\kern-\wd\boxA{}nz.panny@\allowbreak
    3.79 +\newcommand\authoremailii{\texttt{lore{\color{white}NOSPAM}\kern-\wd\boxA{}nz.panny@\allowbreak
    3.80  \allowbreak tum.\allowbreak de}}
    3.81 -\newcommand\authoremailiii{\texttt{pope{\color{white}nospam}\kern-\wd\boxA{}scua@\allowbreak
    3.82 +\newcommand\authoremailiii{\texttt{pope{\color{white}NOSPAM}\kern-\wd\boxA{}scua@\allowbreak
    3.83  in.\allowbreak tum.\allowbreak de}}
    3.84 -\newcommand\authoremailiv{\texttt{tray{\color{white}nospam}\kern-\wd\boxA{}tel@\allowbreak
    3.85 +\newcommand\authoremailiv{\texttt{tray{\color{white}NOSPAM}\kern-\wd\boxA{}tel@\allowbreak
    3.86  in.\allowbreak tum.\allowbreak de}}
    3.87  
    3.88  The commands @{command datatype_new} and @{command primrec_new} are expected to
    3.89 @@ -171,13 +160,6 @@
    3.90  Comments and bug reports concerning either the tool or this tutorial should be
    3.91  directed to the authors at \authoremaili, \authoremailii, \authoremailiii,
    3.92  and \authoremailiv.
    3.93 -
    3.94 -\begin{framed}
    3.95 -\noindent
    3.96 -\textbf{Warning:}\enskip This tutorial and the package it describes are under
    3.97 -construction. Please forgive their appearance. Should you have suggestions
    3.98 -or comments regarding either, please let the authors know.
    3.99 -\end{framed}
   3.100  *}
   3.101  
   3.102  
   3.103 @@ -195,7 +177,7 @@
   3.104  text {*
   3.105  Datatypes are illustrated through concrete examples featuring different flavors
   3.106  of recursion. More examples can be found in the directory
   3.107 -\verb|~~/src/HOL/BNF/Examples|.
   3.108 +\verb|~~/src/HOL/|\allowbreak\verb|BNF/Examples|.
   3.109  *}
   3.110  
   3.111  subsubsection {* Nonrecursive Types
   3.112 @@ -260,7 +242,8 @@
   3.113  
   3.114  text {*
   3.115  \noindent
   3.116 -Lists were shown in the introduction. Terminated lists are a variant:
   3.117 +Lists were shown in the introduction. Terminated lists are a variant that
   3.118 +stores a value of type @{typ 'b} at the very end:
   3.119  *}
   3.120  
   3.121      datatype_new (*<*)(in early) (*>*)('a, 'b) tlist = TNil 'b | TCons 'a "('a, 'b) tlist"
   3.122 @@ -310,7 +293,7 @@
   3.123  Not all nestings are admissible. For example, this command will fail:
   3.124  *}
   3.125  
   3.126 -    datatype_new 'a wrong = Wrong (*<*)'a
   3.127 +    datatype_new 'a wrong = W1 | W2 (*<*)'a
   3.128      typ (*>*)"'a wrong \<Rightarrow> 'a"
   3.129  
   3.130  text {*
   3.131 @@ -321,7 +304,7 @@
   3.132  *}
   3.133  
   3.134      datatype_new ('a, 'b) fn = Fn "'a \<Rightarrow> 'b"
   3.135 -    datatype_new 'a also_wrong = Also_Wrong (*<*)'a
   3.136 +    datatype_new 'a also_wrong = W1 | W2 (*<*)'a
   3.137      typ (*>*)"('a also_wrong, 'a) fn"
   3.138  
   3.139  text {*
   3.140 @@ -344,20 +327,30 @@
   3.141  datatype_new} and @{command codatatype} commands.
   3.142  Section~\ref{sec:registering-bounded-natural-functors} explains how to register
   3.143  arbitrary type constructors as BNFs.
   3.144 +
   3.145 +Here is another example that fails:
   3.146  *}
   3.147  
   3.148 -
   3.149 -subsubsection {* Custom Names and Syntaxes
   3.150 -  \label{sssec:datatype-custom-names-and-syntaxes} *}
   3.151 +    datatype_new 'a pow_list = PNil 'a (*<*)'a
   3.152 +    datatype_new 'a pow_list' = PNil' 'a (*>*)| PCons "('a * 'a) pow_list"
   3.153 +
   3.154 +text {*
   3.155 +\noindent
   3.156 +This one features a different flavor of nesting, where the recursive call in the
   3.157 +type specification occurs around (rather than inside) another type constructor.
   3.158 +*}
   3.159 +
   3.160 +subsubsection {* Auxiliary Constants and Properties
   3.161 +  \label{sssec:datatype-auxiliary-constants-and-properties} *}
   3.162  
   3.163  text {*
   3.164  The @{command datatype_new} command introduces various constants in addition to
   3.165  the constructors. With each datatype are associated set functions, a map
   3.166  function, a relator, discriminators, and selectors, all of which can be given
   3.167 -custom names. In the example below, the traditional names
   3.168 -@{text set}, @{text map}, @{text list_all2}, @{text null}, @{text hd}, and
   3.169 -@{text tl} override the default names @{text list_set}, @{text list_map}, @{text
   3.170 -list_rel}, @{text is_Nil}, @{text un_Cons1}, and @{text un_Cons2}:
   3.171 +custom names. In the example below, the familiar names @{text null}, @{text hd},
   3.172 +@{text tl}, @{text set}, @{text map}, and @{text list_all2}, override the
   3.173 +default names @{text is_Nil}, @{text un_Cons1}, @{text un_Cons2},
   3.174 +@{text list_set}, @{text list_map}, and @{text list_rel}:
   3.175  *}
   3.176  
   3.177  (*<*)
   3.178 @@ -380,14 +373,34 @@
   3.179  
   3.180  text {*
   3.181  \noindent
   3.182 -The command introduces a discriminator @{const null} and a pair of selectors
   3.183 -@{const hd} and @{const tl} characterized as follows:
   3.184 +
   3.185 +\begin{tabular}{@ {}ll@ {}}
   3.186 +Constructors: &
   3.187 +  @{text "Nil \<Colon> 'a list"} \\
   3.188 +&
   3.189 +  @{text "Cons \<Colon> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list"} \\
   3.190 +Discriminator: &
   3.191 +  @{text "null \<Colon> 'a list \<Rightarrow> bool"} \\
   3.192 +Selectors: &
   3.193 +  @{text "hd \<Colon> 'a list \<Rightarrow> 'a"} \\
   3.194 +&
   3.195 +  @{text "tl \<Colon> 'a list \<Rightarrow> 'a list"} \\
   3.196 +Set function: &
   3.197 +  @{text "set \<Colon> 'a list \<Rightarrow> 'a set"} \\
   3.198 +Map function: &
   3.199 +  @{text "map \<Colon> ('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list"} \\
   3.200 +Relator: &
   3.201 +  @{text "list_all2 \<Colon> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> bool"}
   3.202 +\end{tabular}
   3.203 +
   3.204 +The discriminator @{const null} and the selectors @{const hd} and @{const tl}
   3.205 +are characterized as follows:
   3.206  %
   3.207  \[@{thm list.collapse(1)[of xs, no_vars]}
   3.208    \qquad @{thm list.collapse(2)[of xs, no_vars]}\]
   3.209  %
   3.210 -For two-constructor datatypes, a single discriminator constant suffices. The
   3.211 -discriminator associated with @{const Cons} is simply
   3.212 +For two-constructor datatypes, a single discriminator constant is sufficient.
   3.213 +The discriminator associated with @{const Cons} is simply
   3.214  @{term "\<lambda>xs. \<not> null xs"}.
   3.215  
   3.216  The @{text defaults} clause following the @{const Nil} constructor specifies a
   3.217 @@ -589,6 +602,10 @@
   3.218  or the function type. In principle, it should be possible to support old-style
   3.219  datatypes as well, but the command does not support this yet (and there is
   3.220  currently no way to register old-style datatypes as new-style datatypes).
   3.221 +
   3.222 +\item The recursor produced for types that recurse through functions has a
   3.223 +different signature than with the old package. This makes it impossible to use
   3.224 +the old \keyw{primrec} command.
   3.225  \end{itemize}
   3.226  
   3.227  An alternative to @{command datatype_new_compat} is to use the old package's
   3.228 @@ -636,7 +653,7 @@
   3.229  \noindent
   3.230  The case combinator, discriminators, and selectors are collectively called
   3.231  \emph{destructors}. The prefix ``@{text "t."}'' is an optional component of the
   3.232 -name and is normally hidden. 
   3.233 +name and is normally hidden.
   3.234  *}
   3.235  
   3.236  
   3.237 @@ -798,6 +815,10 @@
   3.238  
   3.239  \end{description}
   3.240  \end{indentblock}
   3.241 +
   3.242 +\noindent
   3.243 +In addition, equational versions of @{text t.disc} are registered with the @{text "[code]"}
   3.244 +attribute.
   3.245  *}
   3.246  
   3.247  
   3.248 @@ -818,16 +839,20 @@
   3.249  @{thm list.map(1)[no_vars]} \\
   3.250  @{thm list.map(2)[no_vars]}
   3.251  
   3.252 -\item[@{text "t."}\hthm{rel\_inject} @{text "[simp, code]"}\rm:] ~ \\
   3.253 +\item[@{text "t."}\hthm{rel\_inject} @{text "[simp]"}\rm:] ~ \\
   3.254  @{thm list.rel_inject(1)[no_vars]} \\
   3.255  @{thm list.rel_inject(2)[no_vars]}
   3.256  
   3.257 -\item[@{text "t."}\hthm{rel\_distinct} @{text "[simp, code]"}\rm:] ~ \\
   3.258 +\item[@{text "t."}\hthm{rel\_distinct} @{text "[simp]"}\rm:] ~ \\
   3.259  @{thm list.rel_distinct(1)[no_vars]} \\
   3.260  @{thm list.rel_distinct(2)[no_vars]}
   3.261  
   3.262  \end{description}
   3.263  \end{indentblock}
   3.264 +
   3.265 +\noindent
   3.266 +In addition, equational versions of @{text t.rel_inject} and @{text
   3.267 +rel_distinct} are registered with the @{text "[code]"} attribute.
   3.268  *}
   3.269  
   3.270  
   3.271 @@ -890,17 +915,18 @@
   3.272  to register new-style datatypes as old-style datatypes.
   3.273  
   3.274  \item \emph{The recursor @{text "t_rec"} has a different signature for nested
   3.275 -recursive datatypes.} In the old package, nested recursion was internally
   3.276 -reduced to mutual recursion. This reduction was visible in the type of the
   3.277 -recursor, used by \keyw{primrec}. In the new package, nested recursion is
   3.278 -handled in a more modular fashion. The old-style recursor can be generated on
   3.279 -demand using @{command primrec_new}, as explained in
   3.280 +recursive datatypes.} In the old package, nested recursion through non-functions
   3.281 +was internally reduced to mutual recursion. This reduction was visible in the
   3.282 +type of the recursor, used by \keyw{primrec}. Recursion through functions was
   3.283 +handled specially. In the new package, nested recursion (for functions and
   3.284 +non-functions) is handled in a more modular fashion. The old-style recursor can
   3.285 +be generated on demand using @{command primrec_new}, as explained in
   3.286  Section~\ref{sssec:primrec-nested-as-mutual-recursion}, if the recursion is via
   3.287  new-style datatypes.
   3.288  
   3.289 -\item \emph{Accordingly, the induction principle is different for nested
   3.290 -recursive datatypes.} Again, the old-style induction principle can be generated
   3.291 -on demand using @{command primrec_new}, as explained in
   3.292 +\item \emph{Accordingly, the induction rule is different for nested recursive
   3.293 +datatypes.} Again, the old-style induction rule can be generated on demand using
   3.294 +@{command primrec_new}, as explained in
   3.295  Section~\ref{sssec:primrec-nested-as-mutual-recursion}, if the recursion is via
   3.296  new-style datatypes.
   3.297  
   3.298 @@ -940,9 +966,9 @@
   3.299    \label{sec:defining-recursive-functions} *}
   3.300  
   3.301  text {*
   3.302 -Recursive functions over datatypes can be specified using @{command
   3.303 -primrec_new}, which supports primitive recursion, or using the more general
   3.304 -\keyw{fun} and \keyw{function} commands. Here, the focus is on @{command
   3.305 +Recursive functions over datatypes can be specified using the @{command
   3.306 +primrec_new} command, which supports primitive recursion, or using the more
   3.307 +general \keyw{fun} and \keyw{function} commands. Here, the focus is on @{command
   3.308  primrec_new}; the other two commands are described in a separate tutorial
   3.309  \cite{isabelle-function}.
   3.310  
   3.311 @@ -1026,9 +1052,10 @@
   3.312  
   3.313  text {*
   3.314  \noindent
   3.315 -The next example is not primitive recursive, but it can be defined easily using
   3.316 -\keyw{fun}. The @{command datatype_new_compat} command is needed to register
   3.317 -new-style datatypes for use with \keyw{fun} and \keyw{function}
   3.318 +The next example is defined using \keyw{fun} to escape the syntactic
   3.319 +restrictions imposed on primitive recursive functions. The
   3.320 +@{command datatype_new_compat} command is needed to register new-style datatypes
   3.321 +for use with \keyw{fun} and \keyw{function}
   3.322  (Section~\ref{sssec:datatype-new-compat}):
   3.323  *}
   3.324  
   3.325 @@ -1124,28 +1151,51 @@
   3.326  (@{text \<Rightarrow>}) is simply composition (@{text "op \<circ>"}):
   3.327  *}
   3.328  
   3.329 -    primrec_new (*<*)(in early) (*>*)ftree_map :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a ftree \<Rightarrow> 'a ftree" where
   3.330 -      "ftree_map f (FTLeaf x) = FTLeaf (f x)" |
   3.331 -      "ftree_map f (FTNode g) = FTNode (ftree_map f \<circ> g)"
   3.332 +    primrec_new (*<*)(in early) (*>*)relabel_ft :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a ftree \<Rightarrow> 'a ftree" where
   3.333 +      "relabel_ft f (FTLeaf x) = FTLeaf (f x)" |
   3.334 +      "relabel_ft f (FTNode g) = FTNode (relabel_ft f \<circ> g)"
   3.335 +
   3.336 +text {*
   3.337 +\noindent
   3.338 +For convenience, recursion through functions can also be expressed using
   3.339 +$\lambda$-abstractions and function application rather than through composition.
   3.340 +For example:
   3.341 +*}
   3.342 +
   3.343 +    primrec_new relabel_ft :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a ftree \<Rightarrow> 'a ftree" where
   3.344 +      "relabel_ft f (FTLeaf x) = FTLeaf (f x)" |
   3.345 +      "relabel_ft f (FTNode g) = FTNode (\<lambda>x. relabel_ft f (g x))"
   3.346 +
   3.347 +text {* \blankline *}
   3.348 +
   3.349 +    primrec_new subtree_ft :: "'a \<Rightarrow> 'a ftree \<Rightarrow> 'a ftree" where
   3.350 +      "subtree_ft x (FTNode g) = g x"
   3.351  
   3.352  text {*
   3.353  \noindent
   3.354 -(No such map function is defined by the package because the type
   3.355 -variable @{typ 'a} is dead in @{typ "'a ftree"}.)
   3.356 -
   3.357 -Using \keyw{fun} or \keyw{function}, recursion through functions can be
   3.358 -expressed using $\lambda$-expressions and function application rather
   3.359 -than through composition. For example:
   3.360 +For recursion through curried $n$-ary functions, $n$ applications of
   3.361 +@{term "op \<circ>"} are necessary. The examples below illustrate the case where
   3.362 +$n = 2$:
   3.363  *}
   3.364  
   3.365 -    datatype_new_compat ftree
   3.366 +    datatype_new 'a ftree2 = FTLeaf2 'a | FTNode2 "'a \<Rightarrow> 'a \<Rightarrow> 'a ftree2"
   3.367  
   3.368  text {* \blankline *}
   3.369  
   3.370 -    function ftree_map :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a ftree \<Rightarrow> 'a ftree" where
   3.371 -      "ftree_map f (FTLeaf x) = FTLeaf (f x)" |
   3.372 -      "ftree_map f (FTNode g) = FTNode (\<lambda>x. ftree_map f (g x))"
   3.373 -    by auto (metis ftree.exhaust)
   3.374 +    primrec_new (*<*)(in early) (*>*)relabel_ft2 :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a ftree2 \<Rightarrow> 'a ftree2" where
   3.375 +      "relabel_ft2 f (FTLeaf2 x) = FTLeaf2 (f x)" |
   3.376 +      "relabel_ft2 f (FTNode2 g) = FTNode2 (op \<circ> (op \<circ> (relabel_ft2 f)) g)"
   3.377 +
   3.378 +text {* \blankline *}
   3.379 +
   3.380 +    primrec_new relabel_ft2 :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a ftree2 \<Rightarrow> 'a ftree2" where
   3.381 +      "relabel_ft2 f (FTLeaf2 x) = FTLeaf2 (f x)" |
   3.382 +      "relabel_ft2 f (FTNode2 g) = FTNode2 (\<lambda>x y. relabel_ft2 f (g x y))"
   3.383 +
   3.384 +text {* \blankline *}
   3.385 +
   3.386 +    primrec_new subtree_ft2 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a ftree2 \<Rightarrow> 'a ftree2" where
   3.387 +      "subtree_ft2 x y (FTNode2 g) = g x y"
   3.388  
   3.389  
   3.390  subsubsection {* Nested-as-Mutual Recursion
   3.391 @@ -1177,12 +1227,12 @@
   3.392  
   3.393  text {*
   3.394  \noindent
   3.395 -Appropriate induction principles are generated under the names
   3.396 +Appropriate induction rules are generated as
   3.397  @{thm [source] at\<^sub>f\<^sub>f.induct},
   3.398  @{thm [source] ats\<^sub>f\<^sub>f.induct}, and
   3.399 -@{thm [source] at\<^sub>f\<^sub>f_ats\<^sub>f\<^sub>f.induct}.
   3.400 -
   3.401 -%%% TODO: Add recursors.
   3.402 +@{thm [source] at\<^sub>f\<^sub>f_ats\<^sub>f\<^sub>f.induct}. The
   3.403 +induction rules and the underlying recursors are generated on a per-need basis
   3.404 +and are kept in a cache to speed up subsequent definitions.
   3.405  
   3.406  Here is a second example:
   3.407  *}
   3.408 @@ -1340,7 +1390,7 @@
   3.409  \begin{itemize}
   3.410  \setlength{\itemsep}{0pt}
   3.411  
   3.412 -\item \emph{Theorems sometimes have different names.}
   3.413 +\item \emph{Some theorems have different names.}
   3.414  For $m > 1$ mutually recursive functions,
   3.415  @{text "f\<^sub>1_\<dots>_f\<^sub>m.simps"} has been broken down into separate
   3.416  subcollections @{text "f\<^sub>i.simps"}.
   3.417 @@ -1415,7 +1465,7 @@
   3.418  text {*
   3.419  \noindent
   3.420  Notice that the @{const cont} selector is associated with both @{const Skip}
   3.421 -and @{const Choice}.
   3.422 +and @{const Action}.
   3.423  *}
   3.424  
   3.425  
   3.426 @@ -1606,10 +1656,10 @@
   3.427    \label{sec:defining-corecursive-functions} *}
   3.428  
   3.429  text {*
   3.430 -Corecursive functions can be specified using @{command primcorec} and
   3.431 -@{command primcorecursive}, which support primitive corecursion, or using the
   3.432 -more general \keyw{partial\_function} command. Here, the focus is on
   3.433 -the former two. More examples can be found in the directory
   3.434 +Corecursive functions can be specified using the @{command primcorec} and
   3.435 +\keyw{prim\-corec\-ursive} commands, which support primitive corecursion, or
   3.436 +using the more general \keyw{partial\_function} command. Here, the focus is on
   3.437 +the first two. More examples can be found in the directory
   3.438  \verb|~~/src/HOL/BNF/Examples|.
   3.439  
   3.440  Whereas recursive functions consume datatypes one constructor at a time,
   3.441 @@ -1630,7 +1680,7 @@
   3.442  This style is popular in the coalgebraic literature.
   3.443  
   3.444  \item The \emph{constructor view} specifies $f$ by equations of the form
   3.445 -\[@{text "\<dots> \<Longrightarrow> f x\<^sub>1 \<dots> x\<^sub>n = C \<dots>"}\]
   3.446 +\[@{text "\<dots> \<Longrightarrow> f x\<^sub>1 \<dots> x\<^sub>n = C\<^sub>j \<dots>"}\]
   3.447  This style is often more concise than the previous one.
   3.448  
   3.449  \item The \emph{code view} specifies $f$ by a single equation of the form
   3.450 @@ -1643,14 +1693,6 @@
   3.451  All three styles are available as input syntax. Whichever syntax is chosen,
   3.452  characteristic theorems for all three styles are generated.
   3.453  
   3.454 -\begin{framed}
   3.455 -\noindent
   3.456 -\textbf{Warning:}\enskip The @{command primcorec} and @{command primcorecursive}
   3.457 -commands are under development. Some of the functionality described here is
   3.458 -vaporware. An alternative is to define corecursive functions directly using the
   3.459 -generated @{text t_unfold} or @{text t_corec} combinators.
   3.460 -\end{framed}
   3.461 -
   3.462  %%% TODO: partial_function? E.g. for defining tail recursive function on lazy
   3.463  %%% lists (cf. terminal0 in TLList.thy)
   3.464  *}
   3.465 @@ -1668,11 +1710,6 @@
   3.466  present the same examples expressed using the constructor and destructor views.
   3.467  *}
   3.468  
   3.469 -(*<*)
   3.470 -    locale code_view
   3.471 -    begin
   3.472 -(*>*)
   3.473 -
   3.474  subsubsection {* Simple Corecursion
   3.475    \label{sssec:primcorec-simple-corecursion} *}
   3.476  
   3.477 @@ -1683,19 +1720,19 @@
   3.478  *}
   3.479  
   3.480      primcorec literate :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a llist" where
   3.481 -      "literate f x = LCons x (literate f (f x))"
   3.482 +      "literate g x = LCons x (literate g (g x))"
   3.483  
   3.484  text {* \blankline *}
   3.485  
   3.486      primcorec siterate :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a stream" where
   3.487 -      "siterate f x = SCons x (siterate f (f x))"
   3.488 +      "siterate g x = SCons x (siterate g (g x))"
   3.489  
   3.490  text {*
   3.491  \noindent
   3.492  The constructor ensures that progress is made---i.e., the function is
   3.493  \emph{productive}. The above functions compute the infinite lazy list or stream
   3.494 -@{text "[x, f x, f (f x), \<dots>]"}. Productivity guarantees that prefixes
   3.495 -@{text "[x, f x, f (f x), \<dots>, (f ^^ k) x]"} of arbitrary finite length
   3.496 +@{text "[x, g x, g (g x), \<dots>]"}. Productivity guarantees that prefixes
   3.497 +@{text "[x, g x, g (g x), \<dots>, (g ^^ k) x]"} of arbitrary finite length
   3.498  @{text k} can be computed by unfolding the code equation a finite number of
   3.499  times.
   3.500  
   3.501 @@ -1714,7 +1751,7 @@
   3.502  appear around constructors that guard corecursive calls:
   3.503  *}
   3.504  
   3.505 -    primcorec_notyet lappend :: "'a llist \<Rightarrow> 'a llist \<Rightarrow> 'a llist" where
   3.506 +    primcorec lappend :: "'a llist \<Rightarrow> 'a llist \<Rightarrow> 'a llist" where
   3.507        "lappend xs ys =
   3.508           (case xs of
   3.509              LNil \<Rightarrow> ys
   3.510 @@ -1735,7 +1772,7 @@
   3.511  pseudorandom seed (@{text n}):
   3.512  *}
   3.513  
   3.514 -    primcorec_notyet
   3.515 +    primcorec
   3.516        random_process :: "'a stream \<Rightarrow> (int \<Rightarrow> int) \<Rightarrow> int \<Rightarrow> 'a process"
   3.517      where
   3.518        "random_process s f n =
   3.519 @@ -1780,43 +1817,71 @@
   3.520  The next pair of examples generalize the @{const literate} and @{const siterate}
   3.521  functions (Section~\ref{sssec:primcorec-nested-corecursion}) to possibly
   3.522  infinite trees in which subnodes are organized either as a lazy list (@{text
   3.523 -tree\<^sub>i\<^sub>i}) or as a finite set (@{text tree\<^sub>i\<^sub>s}):
   3.524 +tree\<^sub>i\<^sub>i}) or as a finite set (@{text tree\<^sub>i\<^sub>s}). They rely on the map functions of
   3.525 +the nesting type constructors to lift the corecursive calls:
   3.526  *}
   3.527  
   3.528      primcorec iterate\<^sub>i\<^sub>i :: "('a \<Rightarrow> 'a llist) \<Rightarrow> 'a \<Rightarrow> 'a tree\<^sub>i\<^sub>i" where
   3.529 -      "iterate\<^sub>i\<^sub>i f x = Node\<^sub>i\<^sub>i x (lmap (iterate\<^sub>i\<^sub>i f) (f x))"
   3.530 +      "iterate\<^sub>i\<^sub>i g x = Node\<^sub>i\<^sub>i x (lmap (iterate\<^sub>i\<^sub>i g) (g x))"
   3.531  
   3.532  text {* \blankline *}
   3.533  
   3.534      primcorec iterate\<^sub>i\<^sub>s :: "('a \<Rightarrow> 'a fset) \<Rightarrow> 'a \<Rightarrow> 'a tree\<^sub>i\<^sub>s" where
   3.535 -      "iterate\<^sub>i\<^sub>s f x = Node\<^sub>i\<^sub>s x (fimage (iterate\<^sub>i\<^sub>s f) (f x))"
   3.536 +      "iterate\<^sub>i\<^sub>s g x = Node\<^sub>i\<^sub>s x (fimage (iterate\<^sub>i\<^sub>s g) (g x))"
   3.537  
   3.538  text {*
   3.539  \noindent
   3.540 -Deterministic finite automata (DFAs) are traditionally defined as 5-tuples
   3.541 -@{text "(Q, \<Sigma>, \<delta>, q\<^sub>0, F)"}, where @{text Q} is a finite set of states,
   3.542 +Both examples follow the usual format for constructor arguments associated
   3.543 +with nested recursive occurrences of the datatype. Consider
   3.544 +@{const iterate\<^sub>i\<^sub>i}. The term @{term "g x"} constructs an @{typ "'a llist"}
   3.545 +value, which is turned into an @{typ "'a tree\<^sub>i\<^sub>i llist"} value using
   3.546 +@{const lmap}.
   3.547 +
   3.548 +This format may sometimes feel artificial. The following function constructs
   3.549 +a tree with a single, infinite branch from a stream:
   3.550 +*}
   3.551 +
   3.552 +    primcorec tree\<^sub>i\<^sub>i_of_stream :: "'a stream \<Rightarrow> 'a tree\<^sub>i\<^sub>i" where
   3.553 +      "tree\<^sub>i\<^sub>i_of_stream s =
   3.554 +         Node\<^sub>i\<^sub>i (shd s) (lmap tree\<^sub>i\<^sub>i_of_stream (LCons (stl s) LNil))"
   3.555 +
   3.556 +text {*
   3.557 +\noindent
   3.558 +Fortunately, it is easy to prove the following lemma, where the corecursive call
   3.559 +is moved inside the lazy list constructor, thereby eliminating the need for
   3.560 +@{const lmap}:
   3.561 +*}
   3.562 +
   3.563 +    lemma tree\<^sub>i\<^sub>i_of_stream_alt:
   3.564 +      "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)"
   3.565 +    by (subst tree\<^sub>i\<^sub>i_of_stream.code) simp
   3.566 +
   3.567 +text {*
   3.568 +The next example illustrates corecursion through functions, which is a bit
   3.569 +special. Deterministic finite automata (DFAs) are traditionally defined as
   3.570 +5-tuples @{text "(Q, \<Sigma>, \<delta>, q\<^sub>0, F)"}, where @{text Q} is a finite set of states,
   3.571  @{text \<Sigma>} is a finite alphabet, @{text \<delta>} is a transition function, @{text q\<^sub>0}
   3.572  is an initial state, and @{text F} is a set of final states. The following
   3.573  function translates a DFA into a @{type state_machine}:
   3.574  *}
   3.575  
   3.576 -    primcorec (*<*)(in early) (*>*)
   3.577 -      sm_of_dfa :: "('q \<Rightarrow> 'a \<Rightarrow> 'q) \<Rightarrow> 'q set \<Rightarrow> 'q \<Rightarrow> 'a state_machine"
   3.578 +    primcorec
   3.579 +      (*<*)(in early) (*>*)sm_of_dfa :: "('q \<Rightarrow> 'a \<Rightarrow> 'q) \<Rightarrow> 'q set \<Rightarrow> 'q \<Rightarrow> 'a state_machine"
   3.580      where
   3.581 -      "sm_of_dfa \<delta> F q = State_Machine (q \<in> F) (sm_of_dfa \<delta> F o \<delta> q)"
   3.582 +      "sm_of_dfa \<delta> F q = State_Machine (q \<in> F) (sm_of_dfa \<delta> F \<circ> \<delta> q)"
   3.583  
   3.584  text {*
   3.585  \noindent
   3.586  The map function for the function type (@{text \<Rightarrow>}) is composition
   3.587 -(@{text "op \<circ>"}). For convenience, corecursion through functions can be
   3.588 -expressed using $\lambda$-expressions and function application rather
   3.589 +(@{text "op \<circ>"}). For convenience, corecursion through functions can
   3.590 +also be expressed using $\lambda$-abstractions and function application rather
   3.591  than through composition. For example:
   3.592  *}
   3.593  
   3.594      primcorec
   3.595        sm_of_dfa :: "('q \<Rightarrow> 'a \<Rightarrow> 'q) \<Rightarrow> 'q set \<Rightarrow> 'q \<Rightarrow> 'a state_machine"
   3.596      where
   3.597 -      "sm_of_dfa \<delta> F q = State_Machine (q \<in> F) (sm_of_dfa \<delta> F o \<delta> q)"
   3.598 +      "sm_of_dfa \<delta> F q = State_Machine (q \<in> F) (\<lambda>a. sm_of_dfa \<delta> F (\<delta> q a))"
   3.599  
   3.600  text {* \blankline *}
   3.601  
   3.602 @@ -1833,9 +1898,32 @@
   3.603      primcorec
   3.604        or_sm :: "'a state_machine \<Rightarrow> 'a state_machine \<Rightarrow> 'a state_machine"
   3.605      where
   3.606 -      "or_sm M N =
   3.607 -         State_Machine (accept M \<or> accept N)
   3.608 -           (\<lambda>a. or_sm (trans M a) (trans N a))"
   3.609 +      "or_sm M N = State_Machine (accept M \<or> accept N)
   3.610 +         (\<lambda>a. or_sm (trans M a) (trans N a))"
   3.611 +
   3.612 +text {*
   3.613 +\noindent
   3.614 +For recursion through curried $n$-ary functions, $n$ applications of
   3.615 +@{term "op \<circ>"} are necessary. The examples below illustrate the case where
   3.616 +$n = 2$:
   3.617 +*}
   3.618 +
   3.619 +    codatatype ('a, 'b) state_machine2 =
   3.620 +      State_Machine2 (accept2: bool) (trans2: "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) state_machine2")
   3.621 +
   3.622 +text {* \blankline *}
   3.623 +
   3.624 +    primcorec
   3.625 +      (*<*)(in early) (*>*)sm2_of_dfa :: "('q \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'q) \<Rightarrow> 'q set \<Rightarrow> 'q \<Rightarrow> ('a, 'b) state_machine2"
   3.626 +    where
   3.627 +      "sm2_of_dfa \<delta> F q = State_Machine2 (q \<in> F) (op \<circ> (op \<circ> (sm2_of_dfa \<delta> F)) (\<delta> q))"
   3.628 +
   3.629 +text {* \blankline *}
   3.630 +
   3.631 +    primcorec
   3.632 +      sm2_of_dfa :: "('q \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'q) \<Rightarrow> 'q set \<Rightarrow> 'q \<Rightarrow> ('a, 'b) state_machine2"
   3.633 +    where
   3.634 +      "sm2_of_dfa \<delta> F q = State_Machine2 (q \<in> F) (\<lambda>a b. sm2_of_dfa \<delta> F (\<delta> q a b))"
   3.635  
   3.636  
   3.637  subsubsection {* Nested-as-Mutual Corecursion
   3.638 @@ -1848,15 +1936,31 @@
   3.639  pretend that nested codatatypes are mutually corecursive. For example:
   3.640  *}
   3.641  
   3.642 -    primcorec_notyet
   3.643 +(*<*)
   3.644 +    context late
   3.645 +    begin
   3.646 +(*>*)
   3.647 +    primcorec
   3.648        iterate\<^sub>i\<^sub>i :: "('a \<Rightarrow> 'a llist) \<Rightarrow> 'a \<Rightarrow> 'a tree\<^sub>i\<^sub>i" and
   3.649        iterates\<^sub>i\<^sub>i :: "('a \<Rightarrow> 'a llist) \<Rightarrow> 'a llist \<Rightarrow> 'a tree\<^sub>i\<^sub>i llist"
   3.650      where
   3.651 -      "iterate\<^sub>i\<^sub>i f x = Node\<^sub>i\<^sub>i x (iterates\<^sub>i\<^sub>i f (f x))" |
   3.652 -      "iterates\<^sub>i\<^sub>i f xs =
   3.653 +      "iterate\<^sub>i\<^sub>i g x = Node\<^sub>i\<^sub>i x (iterates\<^sub>i\<^sub>i g (g x))" |
   3.654 +      "iterates\<^sub>i\<^sub>i g xs =
   3.655           (case xs of
   3.656              LNil \<Rightarrow> LNil
   3.657 -          | LCons x xs' \<Rightarrow> LCons (iterate\<^sub>i\<^sub>i f x) (iterates\<^sub>i\<^sub>i f xs'))"
   3.658 +          | LCons x xs' \<Rightarrow> LCons (iterate\<^sub>i\<^sub>i g x) (iterates\<^sub>i\<^sub>i g xs'))"
   3.659 +
   3.660 +text {*
   3.661 +\noindent
   3.662 +Coinduction rules are generated as
   3.663 +@{thm [source] iterate\<^sub>i\<^sub>i.coinduct},
   3.664 +@{thm [source] iterates\<^sub>i\<^sub>i.coinduct}, and
   3.665 +@{thm [source] iterate\<^sub>i\<^sub>i_iterates\<^sub>i\<^sub>i.coinduct}
   3.666 +and analogously for @{text strong_coinduct}. These rules and the
   3.667 +underlying corecursors are generated on a per-need basis and are kept in a cache
   3.668 +to speed up subsequent definitions.
   3.669 +*}
   3.670 +
   3.671  (*<*)
   3.672      end
   3.673  (*>*)
   3.674 @@ -1866,7 +1970,7 @@
   3.675    \label{ssec:primrec-constructor-view} *}
   3.676  
   3.677  (*<*)
   3.678 -    locale ctr_view = code_view
   3.679 +    locale ctr_view
   3.680      begin
   3.681  (*>*)
   3.682  
   3.683 @@ -1937,7 +2041,7 @@
   3.684    \label{ssec:primrec-destructor-view} *}
   3.685  
   3.686  (*<*)
   3.687 -    locale dest_view
   3.688 +    locale dtr_view
   3.689      begin
   3.690  (*>*)
   3.691  
   3.692 @@ -1951,13 +2055,13 @@
   3.693      primcorec literate :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a llist" where
   3.694        "\<not> lnull (literate _ x)" |
   3.695        "lhd (literate _ x) = x" |
   3.696 -      "ltl (literate f x) = literate f (f x)"
   3.697 +      "ltl (literate g x) = literate g (g x)"
   3.698  
   3.699  text {* \blankline *}
   3.700  
   3.701      primcorec siterate :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a stream" where
   3.702        "shd (siterate _ x) = x" |
   3.703 -      "stl (siterate f x) = siterate f (f x)"
   3.704 +      "stl (siterate g x) = siterate g (g x)"
   3.705  
   3.706  text {* \blankline *}
   3.707  
   3.708 @@ -1993,6 +2097,9 @@
   3.709  (*<*)
   3.710      end
   3.711  
   3.712 +    locale dtr_view2
   3.713 +    begin
   3.714 +
   3.715      primcorec lappend :: "'a llist \<Rightarrow> 'a llist \<Rightarrow> 'a llist" where
   3.716        "lnull xs \<Longrightarrow> lnull ys \<Longrightarrow> lnull (lappend xs ys)" |
   3.717  (*>*)
   3.718 @@ -2000,8 +2107,6 @@
   3.719  (*<*) |
   3.720        "lhd (lappend xs ys) = lhd (if lnull xs then ys else xs)" |
   3.721        "ltl (lappend xs ys) = (if xs = LNil then ltl ys else lappend (ltl xs) ys)"
   3.722 -
   3.723 -    context dest_view begin
   3.724  (*>*)
   3.725  
   3.726  text {*
   3.727 @@ -2044,8 +2149,8 @@
   3.728  text {* \blankline *}
   3.729  
   3.730      primcorec iterate\<^sub>i\<^sub>i :: "('a \<Rightarrow> 'a llist) \<Rightarrow> 'a \<Rightarrow> 'a tree\<^sub>i\<^sub>i" where
   3.731 -      "lbl\<^sub>i\<^sub>i (iterate\<^sub>i\<^sub>i f x) = x" |
   3.732 -      "sub\<^sub>i\<^sub>i (iterate\<^sub>i\<^sub>i f x) = lmap (iterate\<^sub>i\<^sub>i f) (f x)"
   3.733 +      "lbl\<^sub>i\<^sub>i (iterate\<^sub>i\<^sub>i g x) = x" |
   3.734 +      "sub\<^sub>i\<^sub>i (iterate\<^sub>i\<^sub>i g x) = lmap (iterate\<^sub>i\<^sub>i g) (g x)"
   3.735  (*<*)
   3.736      end
   3.737  (*>*)
   3.738 @@ -2149,13 +2254,30 @@
   3.739  
   3.740  @{rail "
   3.741    @@{command bnf} target? (name ':')? term \\
   3.742 -    term_list term term_list term?
   3.743 +    term_list term term_list? term?
   3.744    ;
   3.745    X_list: '[' (X + ',') ']'
   3.746  "}
   3.747  *}
   3.748  
   3.749  
   3.750 +(* NOTYET
   3.751 +subsubsection {* \keyw{bnf\_decl}
   3.752 +  \label{sssec:bnf-decl} *}
   3.753 +
   3.754 +text {*
   3.755 +%%% TODO: use command_def once the command is available
   3.756 +\begin{matharray}{rcl}
   3.757 +  @{text "bnf_decl"} & : & @{text "local_theory \<rightarrow> local_theory"}
   3.758 +\end{matharray}
   3.759 +
   3.760 +@{rail "
   3.761 +  @@{command bnf} target? dt_name
   3.762 +"}
   3.763 +*}
   3.764 +*)
   3.765 +
   3.766 +
   3.767  subsubsection {* \keyw{print\_bnfs}
   3.768    \label{sssec:print-bnfs} *}
   3.769  
   3.770 @@ -2307,8 +2429,9 @@
   3.771  suggested major simplifications to the internal constructions, much of which has
   3.772  yet to be implemented. Florian Haftmann and Christian Urban provided general
   3.773  advice on Isabelle and package writing. Stefan Milius and Lutz Schr\"oder
   3.774 -found an elegant proof to eliminate one of the BNF assumptions. Christian
   3.775 -Sternagel suggested many textual improvements to this tutorial.
   3.776 +found an elegant proof to eliminate one of the BNF assumptions. Andreas
   3.777 +Lochbihler and Christian Sternagel suggested many textual improvements to this
   3.778 +tutorial.
   3.779  *}
   3.780  
   3.781  end
     4.1 --- a/src/Doc/Datatypes/document/root.tex	Mon Nov 11 17:34:44 2013 +0100
     4.2 +++ b/src/Doc/Datatypes/document/root.tex	Mon Nov 11 17:44:21 2013 +0100
     4.3 @@ -58,10 +58,10 @@
     4.4  
     4.5  \begin{abstract}
     4.6  \noindent
     4.7 -This tutorial describes how to use the new package for defining datatypes and
     4.8 -codatatypes in Isabelle/HOL. The package provides five main commands:
     4.9 +This tutorial describes the new package for defining datatypes and codatatypes
    4.10 +in Isabelle/HOL. The package provides four main commands:
    4.11  \keyw{datatype\_new}, \keyw{codatatype}, \keyw{primrec\_new},
    4.12 -\keyw{primcorecursive}, and \keyw{primcorec}. The commands suffixed by
    4.13 +and \keyw{primcorec}. The commands suffixed by
    4.14  \keyw{\_new} are intended to subsume, and eventually replace, the corresponding
    4.15  commands from the old datatype package.
    4.16  \end{abstract}
     5.1 --- a/src/Doc/Functions/Functions.thy	Mon Nov 11 17:34:44 2013 +0100
     5.2 +++ b/src/Doc/Functions/Functions.thy	Mon Nov 11 17:44:21 2013 +0100
     5.3 @@ -1003,13 +1003,13 @@
     5.4    recursive calls. In general, there is one introduction rule for each
     5.5    recursive call.
     5.6  
     5.7 -  The predicate @{term "accp findzero_rel"} is the accessible part of
     5.8 +  The predicate @{term "Wellfounded.accp findzero_rel"} is the accessible part of
     5.9    that relation. An argument belongs to the accessible part, if it can
    5.10    be reached in a finite number of steps (cf.~its definition in @{text
    5.11    "Wellfounded.thy"}).
    5.12  
    5.13    Since the domain predicate is just an abbreviation, you can use
    5.14 -  lemmas for @{const accp} and @{const findzero_rel} directly. Some
    5.15 +  lemmas for @{const Wellfounded.accp} and @{const findzero_rel} directly. Some
    5.16    lemmas which are occasionally useful are @{thm [source] accpI}, @{thm [source]
    5.17    accp_downward}, and of course the introduction and elimination rules
    5.18    for the recursion relation @{thm [source] "findzero_rel.intros"} and @{thm
     6.1 --- a/src/Doc/Nitpick/document/root.tex	Mon Nov 11 17:34:44 2013 +0100
     6.2 +++ b/src/Doc/Nitpick/document/root.tex	Mon Nov 11 17:44:21 2013 +0100
     6.3 @@ -1965,6 +1965,8 @@
     6.4  \texttt{.kki}, \texttt{.cnf}, \texttt{.out}, and
     6.5  \texttt{.err}; you may safely remove them after Nitpick has run.
     6.6  
     6.7 +\textbf{Warning:} This option is not thread-safe. Use at your own risks.
     6.8 +
     6.9  \nopagebreak
    6.10  {\small See also \textit{debug} (\S\ref{output-format}).}
    6.11  \end{enum}
    6.12 @@ -2794,11 +2796,12 @@
    6.13  \subsection{Registering Coinductive Datatypes}
    6.14  \label{registering-coinductive-datatypes}
    6.15  
    6.16 +Coinductive datatypes defined using the \textbf{codatatype} command that do not
    6.17 +involve nested recursion through non-codatatypes are supported by Nitpick.
    6.18  If you have defined a custom coinductive datatype, you can tell Nitpick about
    6.19 -it, so that it can use an efficient Kodkod axiomatization similar to the one it
    6.20 -uses for lazy lists. The interface for registering and unregistering coinductive
    6.21 -datatypes consists of the following pair of functions defined in the
    6.22 -\textit{Nitpick\_HOL} structure:
    6.23 +it, so that it can use an efficient Kodkod axiomatization. The interface for
    6.24 +registering and unregistering coinductive datatypes consists of the following
    6.25 +pair of functions defined in the \textit{Nitpick\_HOL} structure:
    6.26  
    6.27  \prew
    6.28  $\textbf{val}\,~\textit{register\_codatatype\/} : {}$ \\
    6.29 @@ -2886,6 +2889,12 @@
    6.30  \item[\labelitemi] Nitpick produces spurious counterexamples when invoked after a
    6.31  \textbf{guess} command in a structured proof.
    6.32  
    6.33 +\item[\labelitemi] Datatypes defined using \textbf{datatype\_new} are not
    6.34 +supported.
    6.35 +
    6.36 +\item[\labelitemi] Codatatypes defined using \textbf{codatatype} that
    6.37 +involve nested recursion through non-codatatypes are not supported.
    6.38 +
    6.39  \item[\labelitemi] The \textit{nitpick\_xxx} attributes and the
    6.40  \textit{Nitpick\_xxx.register\_yyy} functions can cause havoc if used
    6.41  improperly.
     7.1 --- a/src/Doc/ProgProve/Bool_nat_list.thy	Mon Nov 11 17:34:44 2013 +0100
     7.2 +++ b/src/Doc/ProgProve/Bool_nat_list.thy	Mon Nov 11 17:44:21 2013 +0100
     7.3 @@ -422,10 +422,16 @@
     7.4  \subsection{Exercises}
     7.5  
     7.6  \begin{exercise}
     7.7 +Use the \isacom{value} command to evaluate the following expressions:
     7.8 +@{term[source] "1 + (2::nat)"}, @{term[source] "1 + (2::int)"},
     7.9 +@{term[source] "1 - (2::nat)"} and @{term[source] "1 - (2::int)"}.
    7.10 +\end{exercise}
    7.11 +
    7.12 +\begin{exercise}
    7.13  Start from the definition of @{const add} given above.
    7.14 -Prove it is associative (@{prop"add (add m n) p = add m (add n p)"})
    7.15 -and commutative (@{prop"add m n = add n m"}). Define a recursive function
    7.16 -@{text double} @{text"::"} @{typ"nat \<Rightarrow> nat"} and prove that @{prop"double m = add m m"}.
    7.17 +Prove that @{const add} it is associative and commutative.
    7.18 +Define a recursive function @{text double} @{text"::"} @{typ"nat \<Rightarrow> nat"}
    7.19 +and prove @{prop"double m = add m m"}.
    7.20  \end{exercise}
    7.21  
    7.22  \begin{exercise}
    7.23 @@ -436,11 +442,15 @@
    7.24  
    7.25  \begin{exercise}
    7.26  Define a recursive function @{text "snoc ::"} @{typ"'a list \<Rightarrow> 'a \<Rightarrow> 'a list"}
    7.27 -that appends an element to the end of a list. Do not use the predefined append
    7.28 -operator @{text"@"}. With the help of @{text snoc} define a recursive function
    7.29 -@{text "reverse ::"} @{typ"'a list \<Rightarrow> 'a list"} that reverses a list. Do not
    7.30 -use the predefined function @{const rev}.
    7.31 -Prove @{prop"reverse(reverse xs) = xs"}.
    7.32 +that appends an element to the end of a list. With the help of @{text snoc}
    7.33 +define a recursive function @{text "reverse ::"} @{typ"'a list \<Rightarrow> 'a list"}
    7.34 +that reverses a list. Prove @{prop"reverse(reverse xs) = xs"}.
    7.35 +\end{exercise}
    7.36 +
    7.37 +\begin{exercise}
    7.38 +Define a recursive function @{text "sum ::"} @{typ"nat \<Rightarrow> nat"} such that
    7.39 +\mbox{@{text"sum n"}} @{text"="} @{text"0 + ... + n"} and prove
    7.40 +@{prop" sum(n::nat) = n * (n+1) div 2"}.
    7.41  \end{exercise}
    7.42  *}
    7.43  (*<*)
     8.1 --- a/src/Doc/ProgProve/Isar.thy	Mon Nov 11 17:34:44 2013 +0100
     8.2 +++ b/src/Doc/ProgProve/Isar.thy	Mon Nov 11 17:44:21 2013 +0100
     8.3 @@ -595,10 +595,10 @@
     8.4  \exercise
     8.5  Give a readable, structured proof of the following lemma:
     8.6  *}
     8.7 -lemma assumes T: "\<forall> x y. T x y \<or> T y x"
     8.8 -  and A: "\<forall> x y. A x y \<and> A y x \<longrightarrow> x = y"
     8.9 -  and TA: "\<forall> x y. T x y \<longrightarrow> A x y" and "A x y"
    8.10 -shows "T x y"
    8.11 +lemma assumes T: "\<forall>x y. T x y \<or> T y x"
    8.12 +  and A: "\<forall>x y. A x y \<and> A y x \<longrightarrow> x = y"
    8.13 +  and TA: "\<forall>x y. T x y \<longrightarrow> A x y" and "A x y"
    8.14 +  shows "T x y"
    8.15  (*<*)oops(*>*)
    8.16  text{*
    8.17  \endexercise
    8.18 @@ -612,10 +612,11 @@
    8.19  text{*
    8.20  Hint: There are predefined functions @{const_typ take} and @{const_typ drop}
    8.21  such that @{text"take k [x\<^sub>1,\<dots>] = [x\<^sub>1,\<dots>,x\<^sub>k]"} and
    8.22 -@{text"drop k [x\<^sub>1,\<dots>] = [x\<^bsub>k+1\<^esub>,\<dots>]"}. Let @{text simp} and especially
    8.23 -sledgehammer find and apply the relevant @{const take} and @{const drop} lemmas for you.
    8.24 +@{text"drop k [x\<^sub>1,\<dots>] = [x\<^bsub>k+1\<^esub>,\<dots>]"}. Let sledgehammer find and apply
    8.25 +the relevant @{const take} and @{const drop} lemmas for you.
    8.26  \endexercise
    8.27  
    8.28 +
    8.29  \section{Case Analysis and Induction}
    8.30  
    8.31  \subsection{Datatype Case Analysis}
    8.32 @@ -1075,45 +1076,38 @@
    8.33  @{text induct} method.
    8.34  \end{warn}
    8.35  
    8.36 +
    8.37  \subsection{Exercises}
    8.38  
    8.39 +
    8.40 +\exercise
    8.41 +Give a structured proof by rule inversion:
    8.42 +*}
    8.43 +
    8.44 +lemma assumes a: "ev(Suc(Suc n))" shows "ev n"
    8.45 +(*<*)oops(*>*)
    8.46 +
    8.47 +text{*
    8.48 +\endexercise
    8.49 +
    8.50 +\begin{exercise}
    8.51 +Give a structured proof of @{prop "\<not> ev(Suc(Suc(Suc 0)))"}
    8.52 +by rule inversions. If there are no cases to be proved you can close
    8.53 +a proof immediateley with \isacom{qed}.
    8.54 +\end{exercise}
    8.55 +
    8.56 +\begin{exercise}
    8.57 +Recall predicate @{text star} from \autoref{sec:star} and @{text iter}
    8.58 +from Exercise~\ref{exe:iter}. Prove @{prop "iter r n x y \<Longrightarrow> star r x y"}
    8.59 +in a structured style, do not just sledgehammer each case of the
    8.60 +required induction.
    8.61 +\end{exercise}
    8.62 +
    8.63  \begin{exercise}
    8.64  Define a recursive function @{text "elems ::"} @{typ"'a list \<Rightarrow> 'a set"}
    8.65  and prove @{prop "x : elems xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> elems ys"}.
    8.66  \end{exercise}
    8.67 -
    8.68 -\begin{exercise}
    8.69 -A context-free grammar can be seen as an inductive definition where each
    8.70 -nonterminal $A$ is an inductively defined predicate on lists of terminal
    8.71 -symbols: $A(w)$ mans
    8.72 -that $w$ is in the language generated by $A$. For example, the production $S
    8.73 -\to a S b$ can be viewed as the implication @{prop"S w \<Longrightarrow> S (a # w @ [b])"}
    8.74 -where @{text a} and @{text b} are constructors of some datatype of terminal
    8.75 -symbols: \isacom{datatype} @{text"tsymbs = a | b | \<dots>"}
    8.76 -
    8.77 -Define the two grammars
    8.78 -\[
    8.79 -\begin{array}{r@ {\quad}c@ {\quad}l}
    8.80 -S &\to& \varepsilon \quad\mid\quad a~S~b \quad\mid\quad S~S \\
    8.81 -T &\to& \varepsilon \quad\mid\quad T~a~T~b
    8.82 -\end{array}
    8.83 -\]
    8.84 -($\varepsilon$ is the empty word)
    8.85 -as two inductive predicates and prove @{prop"S w \<longleftrightarrow> T w"}.
    8.86 -\end{exercise}
    8.87 -
    8.88  *}
    8.89 -(*
    8.90 -lemma "\<not> ev(Suc(Suc(Suc 0)))"
    8.91 -proof
    8.92 -  assume "ev(Suc(Suc(Suc 0)))"
    8.93 -  then show False
    8.94 -  proof cases
    8.95 -    case evSS
    8.96 -    from `ev(Suc 0)` show False by cases
    8.97 -  qed
    8.98 -qed
    8.99 -*)
   8.100  
   8.101  (*<*)
   8.102  end
     9.1 --- a/src/Doc/ProgProve/Logic.thy	Mon Nov 11 17:34:44 2013 +0100
     9.2 +++ b/src/Doc/ProgProve/Logic.thy	Mon Nov 11 17:44:21 2013 +0100
     9.3 @@ -141,6 +141,28 @@
     9.4  See \cite{Nipkow-Main} for the wealth of further predefined functions in theory
     9.5  @{theory Main}.
     9.6  
     9.7 +
     9.8 +\subsection{Exercises}
     9.9 +
    9.10 +\exercise
    9.11 +Start from the data type of binary trees defined earlier:
    9.12 +*}
    9.13 +
    9.14 +datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"
    9.15 +
    9.16 +text{*
    9.17 +Define a function @{text "set ::"} @{typ "'a tree \<Rightarrow> 'a set"}
    9.18 +that returns the elements in a tree and a function
    9.19 +@{text "ord ::"} @{typ "int tree \<Rightarrow> bool"}
    9.20 +the tests if an @{typ "int tree"} is ordered.
    9.21 +
    9.22 +Define a function @{text ins} that inserts an element into an ordered @{typ "int tree"}
    9.23 +while maintaining the order of the tree. If the element is already in the tree, the
    9.24 +same tree should be returned. Prove correctness of @{text ins}:
    9.25 +@{prop "set(ins x t) = {x} \<union> set t"} and @{prop "ord t \<Longrightarrow> ord(ins i t)"}.
    9.26 +\endexercise
    9.27 +
    9.28 +
    9.29  \section{Proof Automation}
    9.30  
    9.31  So far we have only seen @{text simp} and @{text auto}: Both perform
    9.32 @@ -459,12 +481,12 @@
    9.33  text{* In this particular example we could have backchained with
    9.34  @{thm[source] Suc_leD}, too, but because the premise is more complicated than the conclusion this can easily lead to nontermination.
    9.35  
    9.36 -\subsection{Finding Theorems}
    9.37 -
    9.38 -Command \isacom{find{\isacharunderscorekeyword}theorems} searches for specific theorems in the current
    9.39 -theory. Search criteria include pattern matching on terms and on names.
    9.40 -For details see the Isabelle/Isar Reference Manual~\cite{IsarRef}.
    9.41 -\bigskip
    9.42 +%\subsection{Finding Theorems}
    9.43 +%
    9.44 +%Command \isacom{find{\isacharunderscorekeyword}theorems} searches for specific theorems in the current
    9.45 +%theory. Search criteria include pattern matching on terms and on names.
    9.46 +%For details see the Isabelle/Isar Reference Manual~\cite{IsarRef}.
    9.47 +%\bigskip
    9.48  
    9.49  \begin{warn}
    9.50  To ease readability we will drop the question marks
    9.51 @@ -708,8 +730,8 @@
    9.52  apply(rename_tac u x y)
    9.53  defer
    9.54  (*>*)
    9.55 -txt{* The induction is over @{prop"star r x y"} and we try to prove
    9.56 -\mbox{@{prop"star r y z \<Longrightarrow> star r x z"}},
    9.57 +txt{* The induction is over @{prop"star r x y"} (the first matching assumption)
    9.58 +and we try to prove \mbox{@{prop"star r y z \<Longrightarrow> star r x z"}},
    9.59  which we abbreviate by @{prop"P x y"}. These are our two subgoals:
    9.60  @{subgoals[display,indent=0]}
    9.61  The first one is @{prop"P x x"}, the result of case @{thm[source]refl},
    9.62 @@ -764,6 +786,95 @@
    9.63  conditions}. In rule inductions, these side-conditions appear as additional
    9.64  assumptions. The \isacom{for} clause seen in the definition of the reflexive
    9.65  transitive closure merely simplifies the form of the induction rule.
    9.66 +
    9.67 +
    9.68 +\subsection{Exercises}
    9.69 +
    9.70 +\begin{exercise}
    9.71 +Formalise the following definition of palindromes
    9.72 +\begin{itemize}
    9.73 +\item The empty list and a singleton list are palindromes.
    9.74 +\item If @{text xs} is a palindrome, so is @{term "a # xs @ [a]"}.
    9.75 +\end{itemize}
    9.76 +as an inductive predicate @{text "palindrome ::"} @{typ "'a list \<Rightarrow> bool"}
    9.77 +and prove that @{prop "rev xs = xs"} if @{text xs} is a palindrome.
    9.78 +\end{exercise}
    9.79 +
    9.80 +\exercise
    9.81 +We could also have defined @{const star} as follows:
    9.82 +*}
    9.83 +
    9.84 +inductive star' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
    9.85 +refl': "star' r x x" |
    9.86 +step': "star' r x y \<Longrightarrow> r y z \<Longrightarrow> star' r x z"
    9.87 +
    9.88 +text{*
    9.89 +The single @{text r} step is performer after rather than before the @{text star'}
    9.90 +steps. Prove @{prop "star' r x y \<Longrightarrow> star r x y"} and
    9.91 +@{prop "star r x y \<Longrightarrow> star r' x y"}. You may need lemmas.
    9.92 +Note that rule induction fails
    9.93 +if the assumption about the inductive predicate is not the first assumption.
    9.94 +\endexercise
    9.95 +
    9.96 +\begin{exercise}\label{exe:iter}
    9.97 +Analogous to @{const star}, give an inductive definition of the @{text n}-fold iteration
    9.98 +of a relation @{text r}: @{term "iter r n x y"} should hold if there are @{text x\<^sub>0}, \dots, @{text x\<^sub>n}
    9.99 +such that @{prop"x = x\<^sub>0"}, @{prop"x\<^sub>n = y"} and @{text"r x\<^bsub>i\<^esub> x\<^bsub>i+1\<^esub>"} for
   9.100 +all @{prop"i < n"}. Correct and prove the following claim:
   9.101 +@{prop"star r x y \<Longrightarrow> iter r n x y"}.
   9.102 +\end{exercise}
   9.103 +
   9.104 +\begin{exercise}
   9.105 +A context-free grammar can be seen as an inductive definition where each
   9.106 +nonterminal $A$ is an inductively defined predicate on lists of terminal
   9.107 +symbols: $A(w)$ mans that $w$ is in the language generated by $A$.
   9.108 +For example, the production $S \to a S b$ can be viewed as the implication
   9.109 +@{prop"S w \<Longrightarrow> S (a # w @ [b])"} where @{text a} and @{text b} are terminal symbols,
   9.110 +i.e., elements of some alphabet. The alphabet can be defined like this:
   9.111 +\isacom{datatype} @{text"alpha = a | b | \<dots>"}
   9.112 +
   9.113 +Define the two grammars (where $\varepsilon$ is the empty word)
   9.114 +\[
   9.115 +\begin{array}{r@ {\quad}c@ {\quad}l}
   9.116 +S &\to& \varepsilon \quad\mid\quad aSb \quad\mid\quad SS \\
   9.117 +T &\to& \varepsilon \quad\mid\quad TaTb
   9.118 +\end{array}
   9.119 +\]
   9.120 +as two inductive predicates.
   9.121 +If you think of @{text a} and @{text b} as ``@{text "("}'' and  ``@{text ")"}'',
   9.122 +the grammars defines strings of balanced parentheses.
   9.123 +Prove @{prop"T w \<Longrightarrow> S w"} and @{prop "S w \<Longrightarrow> T w"} separately and conclude
   9.124 +@{prop "S w = T w"}.
   9.125 +\end{exercise}
   9.126 +
   9.127 +\ifsem
   9.128 +\begin{exercise}
   9.129 +In \autoref{sec:AExp} we defined a recursive evaluation function
   9.130 +@{text "aval :: aexp \<Rightarrow> state \<Rightarrow> val"}.
   9.131 +Define an inductive evaluation predicate
   9.132 +@{text "aval_rel :: aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool"}
   9.133 +and prove that it agrees with the recursive function:
   9.134 +@{prop "aval_rel a s v \<Longrightarrow> aval a s = v"}, 
   9.135 +@{prop "aval a s = v \<Longrightarrow> aval_rel a s v"} and thus
   9.136 +\noquotes{@{prop [source] "aval_rel a s v \<longleftrightarrow> aval a s = v"}}.
   9.137 +\end{exercise}
   9.138 +
   9.139 +\begin{exercise}
   9.140 +Consider the stack machine from Chapter~3
   9.141 +and recall the concept of \concept{stack underflow}
   9.142 +from Exercise~\ref{exe:stack-underflow}.
   9.143 +Define an inductive predicate
   9.144 +@{text "ok :: nat \<Rightarrow> instr list \<Rightarrow> nat \<Rightarrow> bool"}
   9.145 +such that @{text "ok n is n'"} means that with any initial stack of length
   9.146 +@{text n} the instructions @{text "is"} can be executed
   9.147 +without stack underflow and that the final stack has length @{text n'}.
   9.148 +Prove that @{text ok} correctly computes the final stack size
   9.149 +@{prop[display] "\<lbrakk>ok n is n'; length stk = n\<rbrakk> \<Longrightarrow> length (exec is s stk) = n'"}
   9.150 +and that instruction sequences generated by @{text comp}
   9.151 +cannot cause stack underflow: \ @{text "ok n (comp a) ?"} \ for
   9.152 +some suitable value of @{text "?"}.
   9.153 +\end{exercise}
   9.154 +\fi
   9.155  *}
   9.156  (*<*)
   9.157  end
    10.1 --- a/src/Doc/ProgProve/Types_and_funs.thy	Mon Nov 11 17:34:44 2013 +0100
    10.2 +++ b/src/Doc/ProgProve/Types_and_funs.thy	Mon Nov 11 17:44:21 2013 +0100
    10.3 @@ -156,7 +156,7 @@
    10.4  
    10.5  fun div2 :: "nat \<Rightarrow> nat" where
    10.6  "div2 0 = 0" |
    10.7 -"div2 (Suc 0) = Suc 0" |
    10.8 +"div2 (Suc 0) = 0" |
    10.9  "div2 (Suc(Suc n)) = Suc(div2 n)"
   10.10  
   10.11  text{* does not just define @{const div2} but also proves a
   10.12 @@ -200,6 +200,34 @@
   10.13  But note that the induction rule does not mention @{text f} at all,
   10.14  except in its name, and is applicable independently of @{text f}.
   10.15  
   10.16 +
   10.17 +\subsection{Exercises}
   10.18 +
   10.19 +\begin{exercise}
   10.20 +Starting from the type @{text "'a tree"} defined in the text, define
   10.21 +a function @{text "contents ::"} @{typ "'a tree \<Rightarrow> 'a list"}
   10.22 +that collects all values in a tree in a list, in any order,
   10.23 +without removing duplicates.
   10.24 +Then define a function @{text "treesum ::"} @{typ "nat tree \<Rightarrow> nat"}
   10.25 +that sums up all values in a tree of natural numbers
   10.26 +and prove @{prop "treesum t = listsum(contents t)"}.
   10.27 +\end{exercise}
   10.28 +
   10.29 +\begin{exercise}
   10.30 +Define a new type @{text "'a tree2"} of binary trees where values are also
   10.31 +stored in the leaves of the tree.  Also reformulate the
   10.32 +@{const mirror} function accordingly. Define two functions
   10.33 +@{text "pre_order"} and @{text "post_order"} of type @{text "'a tree2 \<Rightarrow> 'a list"}
   10.34 +that traverse a tree and collect all stored values in the respective order in
   10.35 +a list. Prove @{prop "pre_order (mirror t) = rev (post_order t)"}.
   10.36 +\end{exercise}
   10.37 +
   10.38 +\begin{exercise}
   10.39 +Prove that @{const div2} defined above divides every number by @{text 2},
   10.40 +not just those of the form @{text"n+n"}: @{prop "div2 n = n div 2"}.
   10.41 +\end{exercise}
   10.42 +
   10.43 +
   10.44  \section{Induction Heuristics}
   10.45  
   10.46  We have already noted that theorems about recursive functions are proved by
   10.47 @@ -307,6 +335,18 @@
   10.48  matters in some cases. The variables that need to be quantified are typically
   10.49  those that change in recursive calls.
   10.50  
   10.51 +
   10.52 +\subsection{Exercises}
   10.53 +
   10.54 +\begin{exercise}
   10.55 +Write a tail-recursive variant of the @{text add} function on @{typ nat}:
   10.56 +@{term "itadd :: nat \<Rightarrow> nat \<Rightarrow> nat"}.
   10.57 +Tail-recursive means that in the recursive case, @{text itadd} needs to call
   10.58 +itself directly: \mbox{@{term"itadd (Suc m) n"}} @{text"= itadd \<dots>"}.
   10.59 +Prove @{prop "itadd m n = add m n"}.
   10.60 +\end{exercise}
   10.61 +
   10.62 +
   10.63  \section{Simplification}
   10.64  
   10.65  So far we have talked a lot about simplifying terms without explaining the concept. \concept{Simplification} means
   10.66 @@ -485,6 +525,31 @@
   10.67  
   10.68  \subsection{Exercises}
   10.69  
   10.70 +\exercise\label{exe:tree0}
   10.71 +Define a datatype @{text tree0} of binary tree skeletons which do not store
   10.72 +any information, neither in the inner nodes nor in the leaves.
   10.73 +Define a function @{text "nodes :: tree0 \<Rightarrow> nat"} that counts the total number
   10.74 +all nodes (inner nodes and leaves) in such a tree.
   10.75 +Consider the following recursive function:
   10.76 +*}
   10.77 +(*<*)
   10.78 +datatype tree0 = Tip | Node tree0 tree0
   10.79 +(*>*)
   10.80 +fun explode :: "nat \<Rightarrow> tree0 \<Rightarrow> tree0" where
   10.81 +"explode 0 t = t" |
   10.82 +"explode (Suc n) t = explode n (Node t t)"
   10.83 +
   10.84 +text {*
   10.85 +Find an equation expressing the size of a tree after exploding it
   10.86 +(\noquotes{@{term [source] "nodes (explode n t)"}}) as a function
   10.87 +of @{term "nodes t"} and @{text n}. Prove your equation.
   10.88 +You may use the usual arithmetic operators including the exponentiation
   10.89 +operator ``@{text"^"}''. For example, \noquotes{@{prop [source] "2 ^ 2 = 4"}}.
   10.90 +
   10.91 +Hint: simplifying with the list of theorems @{thm[source] algebra_simps}
   10.92 +takes care of common algebraic properties of the arithmetic operators.
   10.93 +\endexercise
   10.94 +
   10.95  \exercise
   10.96  Define arithmetic expressions in one variable over integers (type @{typ int})
   10.97  as a data type:
   10.98 @@ -506,8 +571,7 @@
   10.99  that transforms an expression into a polynomial. This may require auxiliary
  10.100  functions. Prove that @{text coeffs} preserves the value of the expression:
  10.101  \mbox{@{prop"evalp (coeffs e) x = eval e x"}.}
  10.102 -Hint: simplifying with @{thm[source] algebra_simps} takes care of
  10.103 -common algebraic properties of @{text "+"} and @{text "*"}.
  10.104 +Hint: consider the hint in \autoref{exe:tree0}.
  10.105  \endexercise
  10.106  *}
  10.107  (*<*)
    11.1 --- a/src/Doc/Sledgehammer/document/root.tex	Mon Nov 11 17:34:44 2013 +0100
    11.2 +++ b/src/Doc/Sledgehammer/document/root.tex	Mon Nov 11 17:44:21 2013 +0100
    11.3 @@ -121,8 +121,8 @@
    11.4  
    11.5  For Isabelle/jEdit users, Sledgehammer provides an automatic mode that can be
    11.6  enabled via the ``Auto Sledgehammer'' option under ``Plugins > Plugin Options >
    11.7 -Isabelle > General.'' In this mode, Sledgehammer is run on every newly entered
    11.8 -theorem.
    11.9 +Isabelle > General.'' In this mode, a reduced version of Sledgehammer is run on
   11.10 +every newly entered theorem for a few seconds.
   11.11  
   11.12  \newbox\boxA
   11.13  \setbox\boxA=\hbox{\texttt{NOSPAM}}
   11.14 @@ -719,12 +719,16 @@
   11.15  If you use Isabelle/jEdit, Sledgehammer also provides an automatic mode that can
   11.16  be enabled via the ``Auto Sledgehammer'' option under ``Plugins > Plugin Options
   11.17  > Isabelle > General.'' For automatic runs, only the first prover set using
   11.18 -\textit{provers} (\S\ref{mode-of-operation}) is considered, fewer facts are
   11.19 -passed to the prover, \textit{slice} (\S\ref{mode-of-operation}) is disabled,
   11.20 -\textit{strict} (\S\ref{problem-encoding}) is enabled, \textit{verbose}
   11.21 -(\S\ref{output-format}) and \textit{debug} (\S\ref{output-format}) are disabled,
   11.22 -and \textit{timeout} (\S\ref{timeouts}) is superseded by the ``Auto Time Limit''
   11.23 -option in jEdit. Sledgehammer's output is also more concise.
   11.24 +\textit{provers} (\S\ref{mode-of-operation}) is considered (typically E),
   11.25 +\textit{slice} (\S\ref{mode-of-operation}) is disabled,
   11.26 +\textit{minimize} (\S\ref{mode-of-operation}) is disabled, fewer facts are
   11.27 +passed to the prover, \textit{fact\_filter} (\S\ref{relevance-filter}) is set to
   11.28 +\textit{mepo}, \textit{strict} (\S\ref{problem-encoding}) is enabled,
   11.29 +\textit{verbose} (\S\ref{output-format}) and \textit{debug}
   11.30 +(\S\ref{output-format}) are disabled, \textit{preplay\_timeout}
   11.31 +(\S\ref{timeouts}) is set to 0, and \textit{timeout} (\S\ref{timeouts}) is
   11.32 +superseded by the ``Auto Time Limit'' option in jEdit. Sledgehammer's output is
   11.33 +also more concise.
   11.34  
   11.35  \subsection{Metis}
   11.36  
   11.37 @@ -999,8 +1003,7 @@
   11.38  number of facts. For SMT solvers, several slices are tried with the same options
   11.39  each time but fewer and fewer facts. According to benchmarks with a timeout of
   11.40  30 seconds, slicing is a valuable optimization, and you should probably leave it
   11.41 -enabled unless you are conducting experiments. This option is implicitly
   11.42 -disabled for (short) automatic runs.
   11.43 +enabled unless you are conducting experiments.
   11.44  
   11.45  \nopagebreak
   11.46  {\small See also \textit{verbose} (\S\ref{output-format}).}
   11.47 @@ -1035,6 +1038,8 @@
   11.48  simultaneously. The files are identified by the prefixes \texttt{prob\_} and
   11.49  \texttt{mash\_}; you may safely remove them after Sledgehammer has run.
   11.50  
   11.51 +\textbf{Warning:} This option is not thread-safe. Use at your own risks.
   11.52 +
   11.53  \nopagebreak
   11.54  {\small See also \textit{debug} (\S\ref{output-format}).}
   11.55  \end{enum}
   11.56 @@ -1282,14 +1287,12 @@
   11.57  
   11.58  \opfalse{verbose}{quiet}
   11.59  Specifies whether the \textbf{sledgehammer} command should explain what it does.
   11.60 -This option is implicitly disabled for automatic runs.
   11.61  
   11.62  \opfalse{debug}{no\_debug}
   11.63  Specifies whether Sledgehammer should display additional debugging information
   11.64  beyond what \textit{verbose} already displays. Enabling \textit{debug} also
   11.65  enables \textit{verbose} and \textit{blocking} (\S\ref{mode-of-operation})
   11.66 -behind the scenes. The \textit{debug} option is implicitly disabled for
   11.67 -automatic runs.
   11.68 +behind the scenes.
   11.69  
   11.70  \nopagebreak
   11.71  {\small See also \textit{spy} (\S\ref{mode-of-operation}) and
   11.72 @@ -1349,8 +1352,6 @@
   11.73  \opdefault{timeout}{float\_or\_none}{\upshape 30}
   11.74  Specifies the maximum number of seconds that the automatic provers should spend
   11.75  searching for a proof. This excludes problem preparation and is a soft limit.
   11.76 -For automatic runs, the ``Auto Time Limit'' option under ``Plugins > Plugin
   11.77 -Options > Isabelle > General'' is used instead.
   11.78  
   11.79  \opdefault{preplay\_timeout}{float\_or\_none}{\upshape 3}
   11.80  Specifies the maximum number of seconds that \textit{metis} or \textit{smt}
    12.1 --- a/src/Doc/Tutorial/document/sets.tex	Mon Nov 11 17:34:44 2013 +0100
    12.2 +++ b/src/Doc/Tutorial/document/sets.tex	Mon Nov 11 17:44:21 2013 +0100
    12.3 @@ -660,8 +660,8 @@
    12.4  \textbf{Composition} of relations (the infix \sdx{O}) is also
    12.5  available: 
    12.6  \begin{isabelle}
    12.7 -r\ O\ s\ \isasymequiv\ \isacharbraceleft(x,z).\ \isasymexists y.\ (x,y)\ \isasymin\ s\ \isasymand\ (y,z)\ \isasymin\ r\isacharbraceright
    12.8 -\rulenamedx{rel_comp_def}
    12.9 +r\ O\ s\ = \isacharbraceleft(x,z).\ \isasymexists y.\ (x,y)\ \isasymin\ s\ \isasymand\ (y,z)\ \isasymin\ r\isacharbraceright
   12.10 +\rulenamedx{relcomp_unfold}
   12.11  \end{isabelle}
   12.12  %
   12.13  This is one of the many lemmas proved about these concepts: 
   12.14 @@ -677,7 +677,7 @@
   12.15  \isasymlbrakk r\isacharprime\ \isasymsubseteq\ r;\ s\isacharprime\
   12.16  \isasymsubseteq\ s\isasymrbrakk\ \isasymLongrightarrow\ r\isacharprime\ O\
   12.17  s\isacharprime\ \isasymsubseteq\ r\ O\ s%
   12.18 -\rulename{rel_comp_mono}
   12.19 +\rulename{relcomp_mono}
   12.20  \end{isabelle}
   12.21  
   12.22  \indexbold{converse!of a relation}%
   12.23 @@ -695,7 +695,7 @@
   12.24  Here is a typical law proved about converse and composition: 
   12.25  \begin{isabelle}
   12.26  (r\ O\ s)\isasyminverse\ =\ s\isasyminverse\ O\ r\isasyminverse
   12.27 -\rulename{converse_rel_comp}
   12.28 +\rulename{converse_relcomp}
   12.29  \end{isabelle}
   12.30  
   12.31  \indexbold{image!under a relation}%
    13.1 --- a/src/Doc/manual.bib	Mon Nov 11 17:34:44 2013 +0100
    13.2 +++ b/src/Doc/manual.bib	Mon Nov 11 17:44:21 2013 +0100
    13.3 @@ -926,7 +926,7 @@
    13.4    note = "\url{https://github.com/frelindb/agsyHOL}"}
    13.5  
    13.6  @incollection{lochbihler-2010,
    13.7 -  title = "Coinduction",
    13.8 +  title = "Coinductive",
    13.9    author = "Andreas Lochbihler",
   13.10    booktitle = "The Archive of Formal Proofs",
   13.11    editor = "Gerwin Klein and Tobias Nipkow and Lawrence C. Paulson",
    14.1 --- a/src/HOL/ATP.thy	Mon Nov 11 17:34:44 2013 +0100
    14.2 +++ b/src/HOL/ATP.thy	Mon Nov 11 17:44:21 2013 +0100
    14.3 @@ -18,34 +18,34 @@
    14.4  
    14.5  subsection {* Higher-order reasoning helpers *}
    14.6  
    14.7 -definition fFalse :: bool where [no_atp]:
    14.8 +definition fFalse :: bool where
    14.9  "fFalse \<longleftrightarrow> False"
   14.10  
   14.11 -definition fTrue :: bool where [no_atp]:
   14.12 +definition fTrue :: bool where
   14.13  "fTrue \<longleftrightarrow> True"
   14.14  
   14.15 -definition fNot :: "bool \<Rightarrow> bool" where [no_atp]:
   14.16 +definition fNot :: "bool \<Rightarrow> bool" where
   14.17  "fNot P \<longleftrightarrow> \<not> P"
   14.18  
   14.19 -definition fComp :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" where [no_atp]:
   14.20 +definition fComp :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" where
   14.21  "fComp P = (\<lambda>x. \<not> P x)"
   14.22  
   14.23 -definition fconj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where [no_atp]:
   14.24 +definition fconj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
   14.25  "fconj P Q \<longleftrightarrow> P \<and> Q"
   14.26  
   14.27 -definition fdisj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where [no_atp]:
   14.28 +definition fdisj :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
   14.29  "fdisj P Q \<longleftrightarrow> P \<or> Q"
   14.30  
   14.31 -definition fimplies :: "bool \<Rightarrow> bool \<Rightarrow> bool" where [no_atp]:
   14.32 +definition fimplies :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
   14.33  "fimplies P Q \<longleftrightarrow> (P \<longrightarrow> Q)"
   14.34  
   14.35 -definition fequal :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where [no_atp]:
   14.36 +definition fequal :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
   14.37  "fequal x y \<longleftrightarrow> (x = y)"
   14.38  
   14.39 -definition fAll :: "('a \<Rightarrow> bool) \<Rightarrow> bool" where [no_atp]:
   14.40 +definition fAll :: "('a \<Rightarrow> bool) \<Rightarrow> bool" where
   14.41  "fAll P \<longleftrightarrow> All P"
   14.42  
   14.43 -definition fEx :: "('a \<Rightarrow> bool) \<Rightarrow> bool" where [no_atp]:
   14.44 +definition fEx :: "('a \<Rightarrow> bool) \<Rightarrow> bool" where
   14.45  "fEx P \<longleftrightarrow> Ex P"
   14.46  
   14.47  lemma fTrue_ne_fFalse: "fFalse \<noteq> fTrue"
    15.1 --- a/src/HOL/Archimedean_Field.thy	Mon Nov 11 17:34:44 2013 +0100
    15.2 +++ b/src/HOL/Archimedean_Field.thy	Mon Nov 11 17:44:21 2013 +0100
    15.3 @@ -129,12 +129,8 @@
    15.4    fix y z assume
    15.5      "of_int y \<le> x \<and> x < of_int (y + 1)"
    15.6      "of_int z \<le> x \<and> x < of_int (z + 1)"
    15.7 -  then have
    15.8 -    "of_int y \<le> x" "x < of_int (y + 1)"
    15.9 -    "of_int z \<le> x" "x < of_int (z + 1)"
   15.10 -    by simp_all
   15.11 -  from le_less_trans [OF `of_int y \<le> x` `x < of_int (z + 1)`]
   15.12 -       le_less_trans [OF `of_int z \<le> x` `x < of_int (y + 1)`]
   15.13 +  with le_less_trans [of "of_int y" "x" "of_int (z + 1)"]
   15.14 +       le_less_trans [of "of_int z" "x" "of_int (y + 1)"]
   15.15    show "y = z" by (simp del: of_int_add)
   15.16  qed
   15.17  
    16.1 --- a/src/HOL/BNF/BNF_FP_Base.thy	Mon Nov 11 17:34:44 2013 +0100
    16.2 +++ b/src/HOL/BNF/BNF_FP_Base.thy	Mon Nov 11 17:44:21 2013 +0100
    16.3 @@ -172,7 +172,5 @@
    16.4  ML_file "Tools/bnf_fp_n2m.ML"
    16.5  ML_file "Tools/bnf_fp_n2m_sugar.ML"
    16.6  ML_file "Tools/bnf_fp_rec_sugar_util.ML"
    16.7 -ML_file "Tools/bnf_fp_rec_sugar_tactics.ML"
    16.8 -ML_file "Tools/bnf_fp_rec_sugar.ML"
    16.9  
   16.10  end
    17.1 --- a/src/HOL/BNF/BNF_GFP.thy	Mon Nov 11 17:34:44 2013 +0100
    17.2 +++ b/src/HOL/BNF/BNF_GFP.thy	Mon Nov 11 17:44:21 2013 +0100
    17.3 @@ -308,6 +308,8 @@
    17.4  lemma fun_rel_image2p: "(fun_rel R (image2p f g R)) f g"
    17.5    unfolding fun_rel_def image2p_def by auto
    17.6  
    17.7 +ML_file "Tools/bnf_gfp_rec_sugar_tactics.ML"
    17.8 +ML_file "Tools/bnf_gfp_rec_sugar.ML"
    17.9  ML_file "Tools/bnf_gfp_util.ML"
   17.10  ML_file "Tools/bnf_gfp_tactics.ML"
   17.11  ML_file "Tools/bnf_gfp.ML"
    18.1 --- a/src/HOL/BNF/BNF_LFP.thy	Mon Nov 11 17:34:44 2013 +0100
    18.2 +++ b/src/HOL/BNF/BNF_LFP.thy	Mon Nov 11 17:44:21 2013 +0100
    18.3 @@ -230,6 +230,7 @@
    18.4  lemma predicate2D_vimage2p: "\<lbrakk>R \<le> vimage2p f g S; R x y\<rbrakk> \<Longrightarrow> S (f x) (g y)"
    18.5    unfolding vimage2p_def by auto
    18.6  
    18.7 +ML_file "Tools/bnf_lfp_rec_sugar.ML"
    18.8  ML_file "Tools/bnf_lfp_util.ML"
    18.9  ML_file "Tools/bnf_lfp_tactics.ML"
   18.10  ML_file "Tools/bnf_lfp.ML"
    19.1 --- a/src/HOL/BNF/Basic_BNFs.thy	Mon Nov 11 17:34:44 2013 +0100
    19.2 +++ b/src/HOL/BNF/Basic_BNFs.thy	Mon Nov 11 17:44:21 2013 +0100
    19.3 @@ -27,15 +27,14 @@
    19.4  lemma wpull_Grp_def: "wpull A B1 B2 f1 f2 p1 p2 \<longleftrightarrow> Grp B1 f1 OO (Grp B2 f2)\<inverse>\<inverse> \<le> (Grp A p1)\<inverse>\<inverse> OO Grp A p2"
    19.5    unfolding wpull_def Grp_def by auto
    19.6  
    19.7 -bnf ID: "id :: ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" ["\<lambda>x. {x}"] "\<lambda>_:: 'a. natLeq" ["id :: 'a \<Rightarrow> 'a"]
    19.8 +bnf ID: "id :: ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" ["\<lambda>x. {x}"] "\<lambda>_:: 'a. natLeq"
    19.9    "id :: ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
   19.10  apply (auto simp: Grp_def fun_eq_iff relcompp.simps natLeq_card_order natLeq_cinfinite)
   19.11  apply (rule ordLess_imp_ordLeq[OF finite_ordLess_infinite[OF _ natLeq_Well_order]])
   19.12  apply (auto simp add: Field_card_of Field_natLeq card_of_well_order_on)[3]
   19.13  done
   19.14  
   19.15 -bnf DEADID: "id :: 'a \<Rightarrow> 'a" [] "\<lambda>_:: 'a. natLeq +c |UNIV :: 'a set|" ["SOME x :: 'a. True"]
   19.16 -  "op = :: 'a \<Rightarrow> 'a \<Rightarrow> bool"
   19.17 +bnf DEADID: "id :: 'a \<Rightarrow> 'a" [] "\<lambda>_:: 'a. natLeq +c |UNIV :: 'a set|" "op = :: 'a \<Rightarrow> 'a \<Rightarrow> bool"
   19.18  by (auto simp add: wpull_Grp_def Grp_def
   19.19    card_order_csum natLeq_card_order card_of_card_order_on
   19.20    cinfinite_csum natLeq_cinfinite)
   19.21 @@ -148,7 +147,7 @@
   19.22  
   19.23  lemmas prod_set_defs = fsts_def[abs_def] snds_def[abs_def]
   19.24  
   19.25 -bnf map_pair [fsts, snds] "\<lambda>_::'a \<times> 'b. natLeq" [Pair] prod_rel
   19.26 +bnf map_pair [fsts, snds] "\<lambda>_::'a \<times> 'b. natLeq" prod_rel
   19.27  proof (unfold prod_set_defs)
   19.28    show "map_pair id id = id" by (rule map_pair.id)
   19.29  next
   19.30 @@ -193,7 +192,7 @@
   19.31          Grp {x. {fst x} \<subseteq> Collect (split R) \<and> {snd x} \<subseteq> Collect (split S)} (map_pair snd snd)"
   19.32    unfolding prod_set_defs prod_rel_def Grp_def relcompp.simps conversep.simps fun_eq_iff
   19.33    by auto
   19.34 -qed simp+
   19.35 +qed
   19.36  
   19.37  (* Categorical version of pullback: *)
   19.38  lemma wpull_cat:
   19.39 @@ -231,7 +230,7 @@
   19.40    ultimately show ?thesis using card_of_ordLeq by fast
   19.41  qed
   19.42  
   19.43 -bnf "op \<circ>" [range] "\<lambda>_:: 'a \<Rightarrow> 'b. natLeq +c |UNIV :: 'a set|" ["%c x::'b::type. c::'a::type"]
   19.44 +bnf "op \<circ>" [range] "\<lambda>_:: 'a \<Rightarrow> 'b. natLeq +c |UNIV :: 'a set|"
   19.45    "fun_rel op ="
   19.46  proof
   19.47    fix f show "id \<circ> f = id f" by simp
   19.48 @@ -278,6 +277,6 @@
   19.49           Grp {x. range x \<subseteq> Collect (split R)} (op \<circ> snd)"
   19.50    unfolding fun_rel_def Grp_def fun_eq_iff relcompp.simps conversep.simps  subset_iff image_iff
   19.51    by auto (force, metis pair_collapse)
   19.52 -qed auto
   19.53 +qed
   19.54  
   19.55  end
    20.1 --- a/src/HOL/BNF/Examples/Misc_Codatatype.thy	Mon Nov 11 17:34:44 2013 +0100
    20.2 +++ b/src/HOL/BNF/Examples/Misc_Codatatype.thy	Mon Nov 11 17:44:21 2013 +0100
    20.3 @@ -19,9 +19,9 @@
    20.4  
    20.5  codatatype simple'' = X1'' nat int | X2''
    20.6  
    20.7 -codatatype 'a stream = Stream 'a "'a stream"
    20.8 +codatatype 'a stream = Stream (shd: 'a) (stl: "'a stream")
    20.9  
   20.10 -codatatype 'a mylist = MyNil | MyCons 'a "'a mylist"
   20.11 +codatatype 'a mylist = MyNil | MyCons (myhd: 'a) (mytl: "'a mylist")
   20.12  
   20.13  codatatype ('b, 'c, 'd, 'e) some_passive =
   20.14    SP1 "('b, 'c, 'd, 'e) some_passive" | SP2 'b | SP3 'c | SP4 'd | SP5 'e
    21.1 --- a/src/HOL/BNF/Examples/Misc_Datatype.thy	Mon Nov 11 17:34:44 2013 +0100
    21.2 +++ b/src/HOL/BNF/Examples/Misc_Datatype.thy	Mon Nov 11 17:44:21 2013 +0100
    21.3 @@ -19,7 +19,7 @@
    21.4  
    21.5  datatype_new simple'' = X1'' nat int | X2''
    21.6  
    21.7 -datatype_new 'a mylist = MyNil | MyCons 'a "'a mylist"
    21.8 +datatype_new 'a mylist = MyNil | MyCons (myhd: 'a) (mytl: "'a mylist")
    21.9  
   21.10  datatype_new ('b, 'c, 'd, 'e) some_passive =
   21.11    SP1 "('b, 'c, 'd, 'e) some_passive" | SP2 'b | SP3 'c | SP4 'd | SP5 'e
    22.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    22.2 +++ b/src/HOL/BNF/Examples/Misc_Primcorec.thy	Mon Nov 11 17:44:21 2013 +0100
    22.3 @@ -0,0 +1,112 @@
    22.4 +(*  Title:      HOL/BNF/Examples/Misc_Primcorec.thy
    22.5 +    Author:     Jasmin Blanchette, TU Muenchen
    22.6 +    Copyright   2013
    22.7 +
    22.8 +Miscellaneous primitive corecursive function definitions.
    22.9 +*)
   22.10 +
   22.11 +header {* Miscellaneous Primitive Corecursive Function Definitions *}
   22.12 +
   22.13 +theory Misc_Primcorec
   22.14 +imports Misc_Codatatype
   22.15 +begin
   22.16 +
   22.17 +primcorec simple_of_bools :: "bool \<Rightarrow> bool \<Rightarrow> simple" where
   22.18 +  "simple_of_bools b b' = (if b then if b' then X1 else X2 else if b' then X3 else X4)"
   22.19 +
   22.20 +primcorec simple'_of_bools :: "bool \<Rightarrow> bool \<Rightarrow> simple'" where
   22.21 +  "simple'_of_bools b b' =
   22.22 +     (if b then if b' then X1' () else X2' () else if b' then X3' () else X4' ())"
   22.23 +
   22.24 +primcorec inc_simple'' :: "nat \<Rightarrow> simple'' \<Rightarrow> simple''" where
   22.25 +  "inc_simple'' k s = (case s of X1'' n i \<Rightarrow> X1'' (n + k) (i + int k) | X2'' \<Rightarrow> X2'')"
   22.26 +
   22.27 +primcorec sinterleave :: "'a stream \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where
   22.28 +  "sinterleave s s' = Stream (shd s) (sinterleave s' (stl s))"
   22.29 +
   22.30 +primcorec myapp :: "'a mylist \<Rightarrow> 'a mylist \<Rightarrow> 'a mylist" where
   22.31 +  "myapp xs ys =
   22.32 +     (if xs = MyNil then ys
   22.33 +      else if ys = MyNil then xs
   22.34 +      else MyCons (myhd xs) (myapp (mytl xs) ys))"
   22.35 +
   22.36 +primcorec shuffle_sp :: "('a, 'b, 'c, 'd) some_passive \<Rightarrow> ('d, 'a, 'b, 'c) some_passive" where
   22.37 +  "shuffle_sp sp =
   22.38 +     (case sp of
   22.39 +       SP1 sp' \<Rightarrow> SP1 (shuffle_sp sp')
   22.40 +     | SP2 a \<Rightarrow> SP3 a
   22.41 +     | SP3 b \<Rightarrow> SP4 b
   22.42 +     | SP4 c \<Rightarrow> SP5 c
   22.43 +     | SP5 d \<Rightarrow> SP2 d)"
   22.44 +
   22.45 +primcorec rename_lam :: "(string \<Rightarrow> string) \<Rightarrow> lambda \<Rightarrow> lambda" where
   22.46 +  "rename_lam f l =
   22.47 +     (case l of
   22.48 +       Var s \<Rightarrow> Var (f s)
   22.49 +     | App l l' \<Rightarrow> App (rename_lam f l) (rename_lam f l')
   22.50 +     | Abs s l \<Rightarrow> Abs (f s) (rename_lam f l)
   22.51 +     | Let SL l \<Rightarrow> Let (fimage (map_pair f (rename_lam f)) SL) (rename_lam f l))"
   22.52 +
   22.53 +primcorec
   22.54 +  j1_sum :: "('a\<Colon>{zero,one,plus}) \<Rightarrow> 'a J1" and
   22.55 +  j2_sum :: "'a \<Rightarrow> 'a J2"
   22.56 +where
   22.57 +  "n = 0 \<Longrightarrow> is_J11 (j1_sum n)" |
   22.58 +  "un_J111 (j1_sum _) = 0" |
   22.59 +  "un_J112 (j1_sum _) = j1_sum 0" |
   22.60 +  "un_J121 (j1_sum n) = n + 1" |
   22.61 +  "un_J122 (j1_sum n) = j2_sum (n + 1)" |
   22.62 +  "n = 0 \<Longrightarrow> is_J21 (j2_sum n)" |
   22.63 +  "un_J221 (j2_sum n) = j1_sum (n + 1)" |
   22.64 +  "un_J222 (j2_sum n) = j2_sum (n + 1)"
   22.65 +
   22.66 +primcorec forest_of_mylist :: "'a tree mylist \<Rightarrow> 'a forest" where
   22.67 +  "forest_of_mylist ts =
   22.68 +     (case ts of
   22.69 +       MyNil \<Rightarrow> FNil
   22.70 +     | MyCons t ts \<Rightarrow> FCons t (forest_of_mylist ts))"
   22.71 +
   22.72 +primcorec mylist_of_forest :: "'a forest \<Rightarrow> 'a tree mylist" where
   22.73 +  "mylist_of_forest f =
   22.74 +     (case f of
   22.75 +       FNil \<Rightarrow> MyNil
   22.76 +     | FCons t ts \<Rightarrow> MyCons t (mylist_of_forest ts))"
   22.77 +
   22.78 +primcorec semi_stream :: "'a stream \<Rightarrow> 'a stream" where
   22.79 +  "semi_stream s = Stream (shd s) (semi_stream (stl (stl s)))"
   22.80 +
   22.81 +primcorec
   22.82 +  tree'_of_stream :: "'a stream \<Rightarrow> 'a tree'" and
   22.83 +  branch_of_stream :: "'a stream \<Rightarrow> 'a branch"
   22.84 +where
   22.85 +  "tree'_of_stream s =
   22.86 +     TNode' (branch_of_stream (semi_stream s)) (branch_of_stream (semi_stream (stl s)))" |
   22.87 +  "branch_of_stream s = (case s of Stream h t \<Rightarrow> Branch h (tree'_of_stream t))"
   22.88 +
   22.89 +primcorec
   22.90 +  freeze_exp :: "('b \<Rightarrow> 'a) \<Rightarrow> ('a, 'b) exp \<Rightarrow> ('a, 'b) exp" and
   22.91 +  freeze_trm :: "('b \<Rightarrow> 'a) \<Rightarrow> ('a, 'b) trm \<Rightarrow> ('a, 'b) trm" and
   22.92 +  freeze_factor :: "('b \<Rightarrow> 'a) \<Rightarrow> ('a, 'b) factor \<Rightarrow> ('a, 'b) factor"
   22.93 +where
   22.94 +  "freeze_exp g e =
   22.95 +     (case e of
   22.96 +       Term t \<Rightarrow> Term (freeze_trm g t)
   22.97 +     | Sum t e \<Rightarrow> Sum (freeze_trm g t) (freeze_exp g e))" |
   22.98 +  "freeze_trm g t =
   22.99 +     (case t of
  22.100 +       Factor f \<Rightarrow> Factor (freeze_factor g f)
  22.101 +     | Prod f t \<Rightarrow> Prod (freeze_factor g f) (freeze_trm g t))" |
  22.102 +  "freeze_factor g f =
  22.103 +     (case f of
  22.104 +       C a \<Rightarrow> C a
  22.105 +     | V b \<Rightarrow> C (g b)
  22.106 +     | Paren e \<Rightarrow> Paren (freeze_exp g e))"
  22.107 +
  22.108 +primcorec poly_unity :: "'a poly_unit" where
  22.109 +  "poly_unity = U (\<lambda>_. poly_unity)"
  22.110 +
  22.111 +primcorec build_cps :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> bool stream) \<Rightarrow> 'a \<Rightarrow> bool stream \<Rightarrow> 'a cps" where
  22.112 +  "shd b \<Longrightarrow> build_cps f g a b = CPS1 a" |
  22.113 +  "_ \<Longrightarrow> build_cps f g a b = CPS2 (\<lambda>a. build_cps f g (f a) (g a))"
  22.114 +
  22.115 +end
    23.1 --- a/src/HOL/BNF/Examples/Misc_Primrec.thy	Mon Nov 11 17:34:44 2013 +0100
    23.2 +++ b/src/HOL/BNF/Examples/Misc_Primrec.thy	Mon Nov 11 17:44:21 2013 +0100
    23.3 @@ -14,7 +14,7 @@
    23.4  primrec_new nat_of_simple :: "simple \<Rightarrow> nat" where
    23.5    "nat_of_simple X1 = 1" |
    23.6    "nat_of_simple X2 = 2" |
    23.7 -  "nat_of_simple X3 = 2" |
    23.8 +  "nat_of_simple X3 = 3" |
    23.9    "nat_of_simple X4 = 4"
   23.10  
   23.11  primrec_new simple_of_simple' :: "simple' \<Rightarrow> simple" where
    24.1 --- a/src/HOL/BNF/Tools/bnf_comp_tactics.ML	Mon Nov 11 17:34:44 2013 +0100
    24.2 +++ b/src/HOL/BNF/Tools/bnf_comp_tactics.ML	Mon Nov 11 17:44:21 2013 +0100
    24.3 @@ -164,10 +164,9 @@
    24.4  fun mk_comp_wit_tac ctxt Gwit_thms collect_set_map Fwit_thms =
    24.5    ALLGOALS (dtac @{thm in_Union_o_assoc}) THEN
    24.6    unfold_thms_tac ctxt (collect_set_map :: comp_wit_thms) THEN
    24.7 -  REPEAT_DETERM (
    24.8 -    atac 1 ORELSE
    24.9 -    REPEAT_DETERM (eresolve_tac @{thms UnionE UnE imageE} 1) THEN
   24.10 -    (TRY o dresolve_tac Gwit_thms THEN'
   24.11 +  REPEAT_DETERM ((atac ORELSE'
   24.12 +    REPEAT_DETERM o eresolve_tac @{thms UnionE UnE} THEN'
   24.13 +    etac imageE THEN' TRY o dresolve_tac Gwit_thms THEN'
   24.14      (etac FalseE ORELSE'
   24.15      hyp_subst_tac ctxt THEN'
   24.16      dresolve_tac Fwit_thms THEN'
    25.1 --- a/src/HOL/BNF/Tools/bnf_def.ML	Mon Nov 11 17:34:44 2013 +0100
    25.2 +++ b/src/HOL/BNF/Tools/bnf_def.ML	Mon Nov 11 17:44:21 2013 +0100
    25.3 @@ -77,14 +77,20 @@
    25.4    val wit_thms_of_bnf: bnf -> thm list
    25.5    val wit_thmss_of_bnf: bnf -> thm list list
    25.6  
    25.7 +  val mk_map: int -> typ list -> typ list -> term -> term
    25.8 +  val mk_rel: int -> typ list -> typ list -> term -> term
    25.9 +  val build_map: Proof.context -> (typ * typ -> term) -> typ * typ -> term
   25.10 +  val build_rel: Proof.context -> (typ * typ -> term) -> typ * typ -> term
   25.11 +  val flatten_type_args_of_bnf: bnf -> 'a -> 'a list -> 'a list
   25.12 +  val map_flattened_map_args: Proof.context -> string -> (term list -> 'a list) -> term list ->
   25.13 +    'a list
   25.14 +
   25.15    val mk_witness: int list * term -> thm list -> nonemptiness_witness
   25.16    val minimize_wits: (''a list * 'b) list -> (''a list * 'b) list
   25.17    val wits_of_bnf: bnf -> nonemptiness_witness list
   25.18  
   25.19    val zip_axioms: 'a -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a list
   25.20  
   25.21 -  val flatten_type_args_of_bnf: bnf -> 'a -> 'a list -> 'a list
   25.22 -
   25.23    datatype const_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline
   25.24    datatype fact_policy = Dont_Note | Note_Some | Note_All
   25.25  
   25.26 @@ -447,7 +453,6 @@
   25.27    #> Option.map (morph_bnf (Morphism.thm_morphism (Thm.transfer (Proof_Context.theory_of ctxt))));
   25.28  
   25.29  
   25.30 -
   25.31  (* Utilities *)
   25.32  
   25.33  fun normalize_set insts instA set =
   25.34 @@ -487,6 +492,46 @@
   25.35         else minimize ((I, wit) :: done) todo;
   25.36   in minimize [] wits end;
   25.37  
   25.38 +fun mk_map live Ts Us t =
   25.39 +  let val (Type (_, Ts0), Type (_, Us0)) = strip_typeN (live + 1) (fastype_of t) |>> List.last in
   25.40 +    Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
   25.41 +  end;
   25.42 +
   25.43 +fun mk_rel live Ts Us t =
   25.44 +  let val [Type (_, Ts0), Type (_, Us0)] = binder_types (snd (strip_typeN live (fastype_of t))) in
   25.45 +    Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
   25.46 +  end;
   25.47 +
   25.48 +fun build_map_or_rel mk const of_bnf dest ctxt build_simple =
   25.49 +  let
   25.50 +    fun build (TU as (T, U)) =
   25.51 +      if T = U then
   25.52 +        const T
   25.53 +      else
   25.54 +        (case TU of
   25.55 +          (Type (s, Ts), Type (s', Us)) =>
   25.56 +          if s = s' then
   25.57 +            let
   25.58 +              val bnf = the (bnf_of ctxt s);
   25.59 +              val live = live_of_bnf bnf;
   25.60 +              val mapx = mk live Ts Us (of_bnf bnf);
   25.61 +              val TUs' = map dest (fst (strip_typeN live (fastype_of mapx)));
   25.62 +            in Term.list_comb (mapx, map build TUs') end
   25.63 +          else
   25.64 +            build_simple TU
   25.65 +        | _ => build_simple TU);
   25.66 +  in build end;
   25.67 +
   25.68 +val build_map = build_map_or_rel mk_map HOLogic.id_const map_of_bnf dest_funT;
   25.69 +val build_rel = build_map_or_rel mk_rel HOLogic.eq_const rel_of_bnf dest_pred2T;
   25.70 +
   25.71 +fun map_flattened_map_args ctxt s map_args fs =
   25.72 +  let
   25.73 +    val flat_fs = flatten_type_args_of_bnf (the (bnf_of ctxt s)) Term.dummy fs;
   25.74 +    val flat_fs' = map_args flat_fs;
   25.75 +  in
   25.76 +    permute_like (op aconv) flat_fs fs flat_fs'
   25.77 +  end;
   25.78  
   25.79  
   25.80  (* Names *)
   25.81 @@ -612,14 +657,12 @@
   25.82      val fact_policy = mk_fact_policy no_defs_lthy;
   25.83      val bnf_b = qualify raw_bnf_b;
   25.84      val live = length raw_sets;
   25.85 -    val nwits = length raw_wits;
   25.86  
   25.87      val map_rhs = prep_term no_defs_lthy raw_map;
   25.88      val set_rhss = map (prep_term no_defs_lthy) raw_sets;
   25.89      val (bd_rhsT, bd_rhs) = (case prep_term no_defs_lthy raw_bd_Abs of
   25.90        Abs (_, T, t) => (T, t)
   25.91      | _ => error "Bad bound constant");
   25.92 -    val wit_rhss = map (prep_term no_defs_lthy) raw_wits;
   25.93  
   25.94      fun err T =
   25.95        error ("Trying to register the type " ^ quote (Syntax.string_of_typ no_defs_lthy T) ^
   25.96 @@ -633,7 +676,7 @@
   25.97          | T => err T)
   25.98        else (bnf_b, Local_Theory.full_name no_defs_lthy bnf_b);
   25.99  
  25.100 -    val def_qualify = Binding.qualify false (Binding.name_of bnf_b);
  25.101 +    val def_qualify = Binding.conceal o Binding.qualify false (Binding.name_of bnf_b);
  25.102  
  25.103      fun mk_suffix_binding suf = Binding.suffix_name ("_" ^ suf) bnf_b;
  25.104  
  25.105 @@ -672,21 +715,14 @@
  25.106            else map (fn i => set_name i (fn () => mk_suffix_binding (mk_setN i))) (1 upto live);
  25.107        in bs ~~ set_rhss end;
  25.108      val bd_bind_def = (fn () => def_qualify (mk_suffix_binding bdN), bd_rhs);
  25.109 -    val wit_binds_defs =
  25.110 -      let
  25.111 -        val bs = if nwits = 1 then [fn () => def_qualify (mk_suffix_binding witN)]
  25.112 -          else map (fn i => fn () => def_qualify (mk_suffix_binding (mk_witN i))) (1 upto nwits);
  25.113 -      in bs ~~ wit_rhss end;
  25.114  
  25.115 -    val (((((bnf_map_term, raw_map_def),
  25.116 +    val ((((bnf_map_term, raw_map_def),
  25.117        (bnf_set_terms, raw_set_defs)),
  25.118 -      (bnf_bd_term, raw_bd_def)),
  25.119 -      (bnf_wit_terms, raw_wit_defs)), (lthy, lthy_old)) =
  25.120 +      (bnf_bd_term, raw_bd_def)), (lthy, lthy_old)) =
  25.121          no_defs_lthy
  25.122          |> maybe_define true map_bind_def
  25.123          ||>> apfst split_list o fold_map (maybe_define true) set_binds_defs
  25.124          ||>> maybe_define true bd_bind_def
  25.125 -        ||>> apfst split_list o fold_map (maybe_define true) wit_binds_defs
  25.126          ||> `(maybe_restore no_defs_lthy);
  25.127  
  25.128      val phi = Proof_Context.export_morphism lthy_old lthy;
  25.129 @@ -694,7 +730,6 @@
  25.130      val bnf_map_def = Morphism.thm phi raw_map_def;
  25.131      val bnf_set_defs = map (Morphism.thm phi) raw_set_defs;
  25.132      val bnf_bd_def = Morphism.thm phi raw_bd_def;
  25.133 -    val bnf_wit_defs = map (Morphism.thm phi) raw_wit_defs;
  25.134  
  25.135      val bnf_map = Morphism.term phi bnf_map_term;
  25.136  
  25.137 @@ -713,7 +748,6 @@
  25.138      val bdT = Morphism.typ phi bd_rhsT;
  25.139      val bnf_bd =
  25.140        Term.subst_TVars (Term.add_tvar_namesT bdT [] ~~ CA_params) (Morphism.term phi bnf_bd_term);
  25.141 -    val bnf_wits = map (normalize_wit CA_params CA alphas o Morphism.term phi) bnf_wit_terms;
  25.142  
  25.143      (*TODO: assert Ds = (TVars of bnf_map) \ (alphas @ betas) as sets*)
  25.144      val deads = (case Ds_opt of
  25.145 @@ -770,7 +804,6 @@
  25.146      val bnf_sets_As = map (mk_bnf_t As') bnf_sets;
  25.147      val bnf_sets_Bs = map (mk_bnf_t Bs') bnf_sets;
  25.148      val bnf_bd_As = mk_bnf_t As' bnf_bd;
  25.149 -    val bnf_wit_As = map (apsnd (mk_bnf_t As')) bnf_wits;
  25.150  
  25.151      val pre_names_lthy = lthy;
  25.152      val ((((((((((((((((((((((((fs, gs), hs), x), y), zs), ys), As),
  25.153 @@ -827,9 +860,23 @@
  25.154        (fn () => def_qualify (if Binding.is_empty rel_b then mk_suffix_binding relN else rel_b),
  25.155           rel_rhs);
  25.156  
  25.157 -    val ((bnf_rel_term, raw_rel_def), (lthy, lthy_old)) =
  25.158 +    val wit_rhss =
  25.159 +      if null raw_wits then
  25.160 +        [fold_rev Term.absdummy As' (Term.list_comb (bnf_map_AsAs,
  25.161 +          map2 (fn T => fn i => Term.absdummy T (Bound i)) As' (live downto 1)) $
  25.162 +          Const (@{const_name undefined}, CA'))]
  25.163 +      else map (prep_term no_defs_lthy) raw_wits;
  25.164 +    val nwits = length wit_rhss;
  25.165 +    val wit_binds_defs =
  25.166 +      let
  25.167 +        val bs = if nwits = 1 then [fn () => def_qualify (mk_suffix_binding witN)]
  25.168 +          else map (fn i => fn () => def_qualify (mk_suffix_binding (mk_witN i))) (1 upto nwits);
  25.169 +      in bs ~~ wit_rhss end;
  25.170 +
  25.171 +    val (((bnf_rel_term, raw_rel_def), (bnf_wit_terms, raw_wit_defs)), (lthy, lthy_old)) =
  25.172        lthy
  25.173        |> maybe_define (is_some raw_rel_opt) rel_bind_def
  25.174 +      ||>> apfst split_list o fold_map (maybe_define (not (null raw_wits))) wit_binds_defs
  25.175        ||> `(maybe_restore lthy);
  25.176  
  25.177      val phi = Proof_Context.export_morphism lthy_old lthy;
  25.178 @@ -841,11 +888,9 @@
  25.179      val rel = mk_bnf_rel pred2RTs CA' CB';
  25.180      val relAsAs = mk_bnf_rel self_pred2RTs CA' CA';
  25.181  
  25.182 -    val _ = case no_reflexive (raw_map_def :: raw_set_defs @ [raw_bd_def] @
  25.183 -        raw_wit_defs @ [raw_rel_def]) of
  25.184 -        [] => ()
  25.185 -      | defs => Proof_Display.print_consts true lthy_old (K false)
  25.186 -          (map (dest_Free o fst o Logic.dest_equals o prop_of) defs);
  25.187 +    val bnf_wit_defs = map (Morphism.thm phi) raw_wit_defs;
  25.188 +    val bnf_wits = map (normalize_wit CA_params CA alphas o Morphism.term phi) bnf_wit_terms;
  25.189 +    val bnf_wit_As = map (apsnd (mk_bnf_t As')) bnf_wits;
  25.190  
  25.191      val map_id0_goal =
  25.192        let val bnf_map_app_id = Term.list_comb (bnf_map_AsAs, map HOLogic.id_const As') in
  25.193 @@ -945,11 +990,14 @@
  25.194          map wit_goal (0 upto live - 1)
  25.195        end;
  25.196  
  25.197 -    val wit_goalss = map mk_wit_goals bnf_wit_As;
  25.198 +    val trivial_wit_tac = mk_trivial_wit_tac bnf_wit_defs;
  25.199  
  25.200 -    fun after_qed thms lthy =
  25.201 +    val wit_goalss =
  25.202 +      (if null raw_wits then SOME trivial_wit_tac else NONE, map mk_wit_goals bnf_wit_As);
  25.203 +
  25.204 +    fun after_qed mk_wit_thms thms lthy =
  25.205        let
  25.206 -        val (axioms, wit_thms) = apfst (mk_axioms live) (chop (length goals) thms);
  25.207 +        val (axioms, nontriv_wit_thms) = apfst (mk_axioms live) (chop (length goals) thms);
  25.208  
  25.209          val bd_Card_order = #bd_card_order axioms RS @{thm conjunct2[OF card_order_on_Card_order]};
  25.210          val bd_Cinfinite = @{thm conjI} OF [#bd_cinfinite axioms, bd_Card_order];
  25.211 @@ -1022,6 +1070,9 @@
  25.212  
  25.213          val set_map = map (fn thm => Lazy.lazy (fn () => mk_set_map thm)) (#set_map0 axioms);
  25.214  
  25.215 +        val wit_thms =
  25.216 +          if null nontriv_wit_thms then mk_wit_thms (map Lazy.force set_map) else nontriv_wit_thms;
  25.217 +
  25.218          fun mk_in_bd () =
  25.219            let
  25.220              val bdT = fst (dest_relT (fastype_of bnf_bd_As));
  25.221 @@ -1265,35 +1316,45 @@
  25.222    (bnf, Local_Theory.declaration {syntax = false, pervasive = true}
  25.223      (fn phi => Data.map (Symtab.default (key, morph_bnf phi bnf))) lthy);
  25.224  
  25.225 -(* TODO: Once the invariant "nwits > 0" holds, remove "mk_conjunction_balanced'" and "rtac TrueI"
  25.226 -   below *)
  25.227 -fun mk_conjunction_balanced' [] = @{prop True}
  25.228 -  | mk_conjunction_balanced' ts = Logic.mk_conjunction_balanced ts;
  25.229 -
  25.230  fun bnf_def const_policy fact_policy qualify tacs wit_tac Ds map_b rel_b set_bs =
  25.231 -  (fn (_, goals, wit_goalss, after_qed, lthy, one_step_defs) =>
  25.232 +  (fn (_, goals, (triv_tac_opt, wit_goalss), after_qed, lthy, one_step_defs) =>
  25.233    let
  25.234 -    val wits_tac =
  25.235 -      K (TRYALL Goal.conjunction_tac) THEN' K (TRYALL (rtac TrueI)) THEN'
  25.236 -      mk_unfold_thms_then_tac lthy one_step_defs wit_tac;
  25.237 -    val wit_goals = map mk_conjunction_balanced' wit_goalss;
  25.238 -    val wit_thms =
  25.239 -      Goal.prove_sorry lthy [] [] (mk_conjunction_balanced' wit_goals) wits_tac
  25.240 -      |> Conjunction.elim_balanced (length wit_goals)
  25.241 -      |> map2 (Conjunction.elim_balanced o length) wit_goalss
  25.242 -      |> map (map (Thm.close_derivation o Thm.forall_elim_vars 0));
  25.243 +    fun mk_wits_tac set_maps =
  25.244 +      K (TRYALL Goal.conjunction_tac) THEN'
  25.245 +      (case triv_tac_opt of
  25.246 +        SOME tac => tac set_maps
  25.247 +      | NONE => mk_unfold_thms_then_tac lthy one_step_defs wit_tac);
  25.248 +    val wit_goals = map Logic.mk_conjunction_balanced wit_goalss;
  25.249 +    fun mk_wit_thms set_maps =
  25.250 +      Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced wit_goals) (mk_wits_tac set_maps)
  25.251 +        |> Conjunction.elim_balanced (length wit_goals)
  25.252 +        |> map2 (Conjunction.elim_balanced o length) wit_goalss
  25.253 +        |> map (map (Thm.close_derivation o Thm.forall_elim_vars 0));
  25.254    in
  25.255      map2 (Thm.close_derivation oo Goal.prove_sorry lthy [] [])
  25.256        goals (map (mk_unfold_thms_then_tac lthy one_step_defs) tacs)
  25.257 -    |> (fn thms => after_qed (map single thms @ wit_thms) lthy)
  25.258 +    |> (fn thms => after_qed mk_wit_thms (map single thms) lthy)
  25.259    end) oo prepare_def const_policy fact_policy qualify (K I) Ds map_b rel_b set_bs;
  25.260  
  25.261 -val bnf_cmd = (fn (key, goals, wit_goals, after_qed, lthy, defs) =>
  25.262 -  Proof.unfolding ([[(defs, [])]])
  25.263 -    (Proof.theorem NONE (snd o register_bnf key oo after_qed)
  25.264 -      (map (single o rpair []) goals @ map (map (rpair [])) wit_goals) lthy)) oo
  25.265 -  prepare_def Do_Inline (user_policy Note_Some) I Syntax.read_term NONE Binding.empty Binding.empty
  25.266 -    [];
  25.267 +val bnf_cmd = (fn (key, goals, (triv_tac_opt, wit_goalss), after_qed, lthy, defs) =>
  25.268 +  let
  25.269 +    val wit_goals = map Logic.mk_conjunction_balanced wit_goalss;
  25.270 +    fun mk_triv_wit_thms tac set_maps =
  25.271 +      Goal.prove_sorry lthy [] [] (Logic.mk_conjunction_balanced wit_goals)
  25.272 +        (K (TRYALL Goal.conjunction_tac) THEN' tac set_maps)
  25.273 +        |> Conjunction.elim_balanced (length wit_goals)
  25.274 +        |> map2 (Conjunction.elim_balanced o length) wit_goalss
  25.275 +        |> map (map (Thm.close_derivation o Thm.forall_elim_vars 0));
  25.276 +    val (mk_wit_thms, nontriv_wit_goals) = 
  25.277 +      (case triv_tac_opt of
  25.278 +        NONE => (fn _ => [], map (map (rpair [])) wit_goalss)
  25.279 +      | SOME tac => (mk_triv_wit_thms tac, []));
  25.280 +  in
  25.281 +    Proof.unfolding ([[(defs, [])]])
  25.282 +      (Proof.theorem NONE (snd o register_bnf key oo after_qed mk_wit_thms)
  25.283 +        (map (single o rpair []) goals @ nontriv_wit_goals) lthy)
  25.284 +  end) oo prepare_def Do_Inline (user_policy Note_Some) I Syntax.read_term NONE
  25.285 +    Binding.empty Binding.empty [];
  25.286  
  25.287  fun print_bnfs ctxt =
  25.288    let
  25.289 @@ -1330,7 +1391,9 @@
  25.290      "register a type as a bounded natural functor"
  25.291      ((parse_opt_binding_colon -- Parse.term --
  25.292         (@{keyword "["} |-- Parse.list Parse.term --| @{keyword "]"}) -- Parse.term --
  25.293 -       (@{keyword "["} |-- Parse.list Parse.term --| @{keyword "]"}) -- Scan.option Parse.term)
  25.294 +       (Scan.option ((@{keyword "["} |-- Parse.list Parse.term --| @{keyword "]"}))
  25.295 +         >> the_default []) --
  25.296 +       Scan.option Parse.term)
  25.297         >> bnf_cmd);
  25.298  
  25.299  end;
    26.1 --- a/src/HOL/BNF/Tools/bnf_def_tactics.ML	Mon Nov 11 17:34:44 2013 +0100
    26.2 +++ b/src/HOL/BNF/Tools/bnf_def_tactics.ML	Mon Nov 11 17:44:21 2013 +0100
    26.3 @@ -31,7 +31,10 @@
    26.4      {prems: thm list, context: Proof.context} -> tactic
    26.5  
    26.6    val mk_in_bd_tac: int -> thm -> thm -> thm -> thm -> thm list -> thm list -> thm -> thm -> thm ->
    26.7 -    thm -> {prems: 'a, context: Proof.context} -> tactic
    26.8 +    thm -> {prems: thm list, context: Proof.context} -> tactic
    26.9 +
   26.10 +  val mk_trivial_wit_tac: thm list -> thm list -> {prems: thm list, context: Proof.context} ->
   26.11 +    tactic
   26.12  end;
   26.13  
   26.14  structure BNF_Def_Tactics : BNF_DEF_TACTICS =
   26.15 @@ -302,4 +305,8 @@
   26.16             map_comp RS sym, map_id])] 1
   26.17    end;
   26.18  
   26.19 +fun mk_trivial_wit_tac wit_defs set_maps {context = ctxt, prems = _} =
   26.20 +  unfold_thms_tac ctxt wit_defs THEN HEADGOAL (EVERY' (map (fn thm =>
   26.21 +    dtac (thm RS equalityD1 RS set_mp) THEN' etac imageE THEN' atac) set_maps)) THEN ALLGOALS atac;
   26.22 +
   26.23  end;
    27.1 --- a/src/HOL/BNF/Tools/bnf_fp_def_sugar.ML	Mon Nov 11 17:34:44 2013 +0100
    27.2 +++ b/src/HOL/BNF/Tools/bnf_fp_def_sugar.ML	Mon Nov 11 17:44:21 2013 +0100
    27.3 @@ -25,7 +25,9 @@
    27.4       sel_co_iterssss: thm list list list list};
    27.5  
    27.6    val of_fp_sugar: (fp_sugar -> 'a list) -> fp_sugar -> 'a
    27.7 +  val eq_fp_sugar: fp_sugar * fp_sugar -> bool
    27.8    val morph_fp_sugar: morphism -> fp_sugar -> fp_sugar
    27.9 +  val transfer_fp_sugar: Proof.context -> fp_sugar -> fp_sugar
   27.10    val fp_sugar_of: Proof.context -> string -> fp_sugar option
   27.11    val fp_sugars_of: Proof.context -> fp_sugar list
   27.12  
   27.13 @@ -39,17 +41,14 @@
   27.14      'a list
   27.15    val mk_co_iter: theory -> BNF_FP_Util.fp_kind -> typ -> typ list -> term -> term
   27.16    val nesty_bnfs: Proof.context -> typ list list list -> typ list -> BNF_Def.bnf list
   27.17 -  val mk_map: int -> typ list -> typ list -> term -> term
   27.18 -  val mk_rel: int -> typ list -> typ list -> term -> term
   27.19 -  val build_map: local_theory -> (typ * typ -> term) -> typ * typ -> term
   27.20 -  val build_rel: local_theory -> (typ * typ -> term) -> typ * typ -> term
   27.21 -  val dest_map: Proof.context -> string -> term -> term * term list
   27.22 -  val dest_ctr: Proof.context -> string -> term -> term * term list
   27.23  
   27.24    type lfp_sugar_thms =
   27.25      (thm list * thm * Args.src list)
   27.26      * (thm list list * thm list list * Args.src list)
   27.27  
   27.28 +  val morph_lfp_sugar_thms: morphism -> lfp_sugar_thms -> lfp_sugar_thms
   27.29 +  val transfer_lfp_sugar_thms: Proof.context -> lfp_sugar_thms -> lfp_sugar_thms
   27.30 +
   27.31    type gfp_sugar_thms =
   27.32      ((thm list * thm) list * Args.src list)
   27.33      * (thm list list * thm list list * Args.src list)
   27.34 @@ -57,6 +56,9 @@
   27.35      * (thm list list * thm list list * Args.src list)
   27.36      * (thm list list list * thm list list list * Args.src list)
   27.37  
   27.38 +  val morph_gfp_sugar_thms: morphism -> gfp_sugar_thms -> gfp_sugar_thms
   27.39 +  val transfer_gfp_sugar_thms: Proof.context -> gfp_sugar_thms -> gfp_sugar_thms
   27.40 +
   27.41    val mk_co_iters_prelims: BNF_FP_Util.fp_kind -> typ list list list -> typ list -> typ list ->
   27.42      int list -> int list list -> term list list -> Proof.context ->
   27.43      (term list list
   27.44 @@ -87,8 +89,9 @@
   27.45      string * term list * term list list * ((term list list * term list list list)
   27.46        * (typ list * typ list list)) list ->
   27.47      thm -> thm list -> thm list -> thm list list -> BNF_Def.bnf list -> typ list -> typ list ->
   27.48 -    int list list -> int list list -> int list -> thm list list -> Ctr_Sugar.ctr_sugar list ->
   27.49 -    term list list -> thm list list -> (thm list -> thm list) -> local_theory -> gfp_sugar_thms
   27.50 +    typ list -> typ list list list -> int list list -> int list list -> int list -> thm list list ->
   27.51 +    Ctr_Sugar.ctr_sugar list -> term list list -> thm list list -> (thm list -> thm list) ->
   27.52 +    local_theory -> gfp_sugar_thms
   27.53    val co_datatypes: BNF_FP_Util.fp_kind -> (mixfix list -> binding list -> binding list ->
   27.54        binding list list -> binding list -> (string * sort) list -> typ list * typ list list ->
   27.55        BNF_Def.bnf list -> local_theory -> BNF_FP_Util.fp_result * local_theory) ->
   27.56 @@ -207,8 +210,8 @@
   27.57  val id_def = @{thm id_def};
   27.58  val mp_conj = @{thm mp_conj};
   27.59  
   27.60 -val nitpick_attrs = @{attributes [nitpick_simp]};
   27.61 -val code_nitpick_simp_attrs = Code.add_default_eqn_attrib :: nitpick_attrs;
   27.62 +val nitpicksimp_attrs = @{attributes [nitpick_simp]};
   27.63 +val code_nitpicksimp_attrs = Code.add_default_eqn_attrib :: nitpicksimp_attrs;
   27.64  val simp_attrs = @{attributes [simp]};
   27.65  
   27.66  fun tvar_subst thy Ts Us =
   27.67 @@ -232,7 +235,9 @@
   27.68    | flat_corec_preds_predsss_gettersss (p :: ps) (qss :: qsss) (fss :: fsss) =
   27.69      p :: flat_corec_predss_getterss qss fss @ flat_corec_preds_predsss_gettersss ps qsss fsss;
   27.70  
   27.71 -fun mk_tupled_fun x f xs = HOLogic.tupled_lambda x (Term.list_comb (f, xs));
   27.72 +fun mk_tupled_fun x f xs =
   27.73 +  if xs = [x] then f else HOLogic.tupled_lambda x (Term.list_comb (f, xs));
   27.74 +
   27.75  fun mk_uncurried2_fun f xss =
   27.76    mk_tupled_fun (HOLogic.mk_tuple (map HOLogic.mk_tuple xss)) f (flat_rec_arg_args xss);
   27.77  
   27.78 @@ -287,66 +292,6 @@
   27.79    | unzip_corecT _ (Type (@{type_name sum}, Ts)) = Ts
   27.80    | unzip_corecT _ T = [T];
   27.81  
   27.82 -fun mk_map live Ts Us t =
   27.83 -  let val (Type (_, Ts0), Type (_, Us0)) = strip_typeN (live + 1) (fastype_of t) |>> List.last in
   27.84 -    Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
   27.85 -  end;
   27.86 -
   27.87 -fun mk_rel live Ts Us t =
   27.88 -  let val [Type (_, Ts0), Type (_, Us0)] = binder_types (snd (strip_typeN live (fastype_of t))) in
   27.89 -    Term.subst_atomic_types (Ts0 @ Us0 ~~ Ts @ Us) t
   27.90 -  end;
   27.91 -
   27.92 -local
   27.93 -
   27.94 -fun build_map_or_rel mk const of_bnf dest lthy build_simple =
   27.95 -  let
   27.96 -    fun build (TU as (T, U)) =
   27.97 -      if T = U then
   27.98 -        const T
   27.99 -      else
  27.100 -        (case TU of
  27.101 -          (Type (s, Ts), Type (s', Us)) =>
  27.102 -          if s = s' then
  27.103 -            let
  27.104 -              val bnf = the (bnf_of lthy s);
  27.105 -              val live = live_of_bnf bnf;
  27.106 -              val mapx = mk live Ts Us (of_bnf bnf);
  27.107 -              val TUs' = map dest (fst (strip_typeN live (fastype_of mapx)));
  27.108 -            in Term.list_comb (mapx, map build TUs') end
  27.109 -          else
  27.110 -            build_simple TU
  27.111 -        | _ => build_simple TU);
  27.112 -  in build end;
  27.113 -
  27.114 -in
  27.115 -
  27.116 -val build_map = build_map_or_rel mk_map HOLogic.id_const map_of_bnf dest_funT;
  27.117 -val build_rel = build_map_or_rel mk_rel HOLogic.eq_const rel_of_bnf dest_pred2T;
  27.118 -
  27.119 -end;
  27.120 -
  27.121 -val dummy_var_name = "?f"
  27.122 -
  27.123 -fun mk_map_pattern ctxt s =
  27.124 -  let
  27.125 -    val bnf = the (bnf_of ctxt s);
  27.126 -    val mapx = map_of_bnf bnf;
  27.127 -    val live = live_of_bnf bnf;
  27.128 -    val (f_Ts, _) = strip_typeN live (fastype_of mapx);
  27.129 -    val fs = map_index (fn (i, T) => Var ((dummy_var_name, i), T)) f_Ts;
  27.130 -  in
  27.131 -    (mapx, betapplys (mapx, fs))
  27.132 -  end;
  27.133 -
  27.134 -fun dest_map ctxt s call =
  27.135 -  let
  27.136 -    val (map0, pat) = mk_map_pattern ctxt s;
  27.137 -    val (_, tenv) = fo_match ctxt call pat;
  27.138 -  in
  27.139 -    (map0, Vartab.fold_rev (fn (_, (_, f)) => cons f) tenv [])
  27.140 -  end;
  27.141 -
  27.142  fun liveness_of_fp_bnf n bnf =
  27.143    (case T_of_bnf bnf of
  27.144      Type (_, Ts) => map (not o member (op =) (deads_of_bnf bnf)) Ts
  27.145 @@ -388,12 +333,19 @@
  27.146  fun nesty_bnfs ctxt ctr_Tsss Us =
  27.147    map_filter (bnf_of ctxt) (fold (fold (fold (add_nesty_bnf_names Us))) ctr_Tsss []);
  27.148  
  27.149 -fun indexify proj xs f p = f (find_index (curry op = (proj p)) xs) p;
  27.150 +fun indexify proj xs f p = f (find_index (curry (op =) (proj p)) xs) p;
  27.151  
  27.152  type lfp_sugar_thms =
  27.153    (thm list * thm * Args.src list)
  27.154    * (thm list list * thm list list * Args.src list)
  27.155  
  27.156 +fun morph_lfp_sugar_thms phi ((inducts, induct, induct_attrs), (foldss, recss, iter_attrs)) =
  27.157 +  ((map (Morphism.thm phi) inducts, Morphism.thm phi induct, induct_attrs),
  27.158 +   (map (map (Morphism.thm phi)) foldss, map (map (Morphism.thm phi)) recss, iter_attrs));
  27.159 +
  27.160 +val transfer_lfp_sugar_thms =
  27.161 +  morph_lfp_sugar_thms o Morphism.thm_morphism o Thm.transfer o Proof_Context.theory_of;
  27.162 +
  27.163  type gfp_sugar_thms =
  27.164    ((thm list * thm) list * Args.src list)
  27.165    * (thm list list * thm list list * Args.src list)
  27.166 @@ -401,6 +353,23 @@
  27.167    * (thm list list * thm list list * Args.src list)
  27.168    * (thm list list list * thm list list list * Args.src list);
  27.169  
  27.170 +fun morph_gfp_sugar_thms phi ((coinducts_pairs, coinduct_attrs),
  27.171 +    (unfoldss, corecss, coiter_attrs), (disc_unfoldss, disc_corecss, disc_iter_attrs),
  27.172 +    (disc_unfold_iffss, disc_corec_iffss, disc_iter_iff_attrs),
  27.173 +    (sel_unfoldsss, sel_corecsss, sel_iter_attrs)) =
  27.174 +  ((map (apfst (map (Morphism.thm phi)) o apsnd (Morphism.thm phi)) coinducts_pairs,
  27.175 +    coinduct_attrs),
  27.176 +   (map (map (Morphism.thm phi)) unfoldss, map (map (Morphism.thm phi)) corecss, coiter_attrs),
  27.177 +   (map (map (Morphism.thm phi)) disc_unfoldss, map (map (Morphism.thm phi)) disc_corecss,
  27.178 +    disc_iter_attrs),
  27.179 +   (map (map (Morphism.thm phi)) disc_unfold_iffss, map (map (Morphism.thm phi)) disc_corec_iffss,
  27.180 +    disc_iter_iff_attrs),
  27.181 +   (map (map (map (Morphism.thm phi))) sel_unfoldsss,
  27.182 +    map (map (map (Morphism.thm phi))) sel_corecsss, sel_iter_attrs));
  27.183 +
  27.184 +val transfer_gfp_sugar_thms =
  27.185 +  morph_gfp_sugar_thms o Morphism.thm_morphism o Thm.transfer o Proof_Context.theory_of;
  27.186 +
  27.187  fun mk_iter_fun_arg_types0 n ms = map2 dest_tupleT ms o dest_sumTN_balanced n o domain_type;
  27.188  
  27.189  fun mk_iter_fun_arg_types ctr_Tsss ns mss =
  27.190 @@ -430,7 +399,7 @@
  27.191          ns mss ctr_Tsss ctor_iter_fun_Tss;
  27.192  
  27.193      val z_Tsss' = map (map flat_rec_arg_args) z_Tssss;
  27.194 -    val h_Tss = map2 (map2 (curry op --->)) z_Tsss' Css;
  27.195 +    val h_Tss = map2 (map2 (curry (op --->))) z_Tsss' Css;
  27.196  
  27.197      val hss = map2 (map2 retype_free) h_Tss gss;
  27.198      val zssss_hd = map2 (map2 (map2 (retype_free o hd))) z_Tssss ysss;
  27.199 @@ -452,7 +421,7 @@
  27.200      val f_sum_prod_Ts = map range_type fun_Ts;
  27.201      val f_prod_Tss = map2 dest_sumTN_balanced ns f_sum_prod_Ts;
  27.202      val f_Tsss = map2 (map2 (dest_tupleT o length)) ctr_Tsss' f_prod_Tss;
  27.203 -    val f_Tssss = map3 (fn C => map2 (map2 (map (curry op --> C) oo unzip_corecT)))
  27.204 +    val f_Tssss = map3 (fn C => map2 (map2 (map (curry (op -->) C) oo unzip_corecT)))
  27.205        Cs ctr_Tsss' f_Tsss;
  27.206      val q_Tssss = map (map (map (fn [_] => [] | [_, T] => [mk_pred1T (domain_type T)]))) f_Tssss;
  27.207    in
  27.208 @@ -577,7 +546,7 @@
  27.209  
  27.210      fun generate_iter suf (f_Tss, _, fss, xssss) ctor_iter =
  27.211        let
  27.212 -        val res_T = fold_rev (curry op --->) f_Tss fpT_to_C;
  27.213 +        val res_T = fold_rev (curry (op --->)) f_Tss fpT_to_C;
  27.214          val b = mk_binding suf;
  27.215          val spec =
  27.216            mk_Trueprop_eq (lists_bmoc fss (Free (Binding.name_of b, res_T)),
  27.217 @@ -596,7 +565,7 @@
  27.218  
  27.219      fun generate_coiter suf ((pfss, cqfsss), (f_sum_prod_Ts, pf_Tss)) dtor_coiter =
  27.220        let
  27.221 -        val res_T = fold_rev (curry op --->) pf_Tss C_to_fpT;
  27.222 +        val res_T = fold_rev (curry (op --->)) pf_Tss C_to_fpT;
  27.223          val b = mk_binding suf;
  27.224          val spec =
  27.225            mk_Trueprop_eq (lists_bmoc pfss (Free (Binding.name_of b, res_T)),
  27.226 @@ -645,7 +614,7 @@
  27.227          val lives = lives_of_bnf bnf;
  27.228          val sets = sets_of_bnf bnf;
  27.229          fun mk_set U =
  27.230 -          (case find_index (curry op = U) lives of
  27.231 +          (case find_index (curry (op =) U) lives of
  27.232              ~1 => Term.dummy
  27.233            | i => nth sets i);
  27.234        in
  27.235 @@ -662,7 +631,7 @@
  27.236            end;
  27.237  
  27.238          fun mk_raw_prem_prems _ (x as Free (_, Type _)) (X as TFree _) =
  27.239 -            [([], (find_index (curry op = X) Xs + 1, x))]
  27.240 +            [([], (find_index (curry (op =) X) Xs + 1, x))]
  27.241            | mk_raw_prem_prems names_lthy (x as Free (s, Type (T_name, Ts0))) (Type (_, Xs_Ts0)) =
  27.242              (case AList.lookup (op =) setss_nested T_name of
  27.243                NONE => []
  27.244 @@ -702,7 +671,7 @@
  27.245  
  27.246          val goal =
  27.247            Library.foldr (Logic.list_implies o apfst (map mk_prem)) (raw_premss,
  27.248 -            HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj (map2 (curry op $) ps us)));
  27.249 +            HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj (map2 (curry (op $)) ps us)));
  27.250  
  27.251          val kksss = map (map (map (fst o snd) o #2)) raw_premss;
  27.252  
  27.253 @@ -763,13 +732,13 @@
  27.254      val rec_thmss = mk_iter_thmss rec_args_types recs rec_defs (map co_rec_of ctor_iter_thmss);
  27.255    in
  27.256      ((induct_thms, induct_thm, [induct_case_names_attr]),
  27.257 -     (fold_thmss, rec_thmss, code_nitpick_simp_attrs @ simp_attrs))
  27.258 +     (fold_thmss, rec_thmss, code_nitpicksimp_attrs @ simp_attrs))
  27.259    end;
  27.260  
  27.261  fun derive_coinduct_coiters_thms_for_types pre_bnfs (z, cs, cpss,
  27.262        coiters_args_types as [((pgss, crgsss), _), ((phss, cshsss), _)])
  27.263 -    dtor_coinduct dtor_injects dtor_ctors dtor_coiter_thmss nesting_bnfs fpTs Cs kss mss ns
  27.264 -    ctr_defss (ctr_sugars : ctr_sugar list) coiterss coiter_defss export_args lthy =
  27.265 +    dtor_coinduct dtor_injects dtor_ctors dtor_coiter_thmss nesting_bnfs fpTs Cs Xs ctrXs_Tsss kss
  27.266 +    mss ns ctr_defss (ctr_sugars : ctr_sugar list) coiterss coiter_defss export_args lthy =
  27.267    let
  27.268      fun mk_ctor_dtor_coiter_thm dtor_inject dtor_ctor coiter =
  27.269        iffD1 OF [dtor_inject, trans OF [coiter, dtor_ctor RS sym]];
  27.270 @@ -821,40 +790,29 @@
  27.271            map4 (fn u => fn v => fn uvr => fn uv_eq =>
  27.272              fold_rev Term.lambda [u, v] (HOLogic.mk_disj (uvr, uv_eq))) us vs uvrs uv_eqs;
  27.273  
  27.274 -        (* TODO: generalize (cf. "build_map") *)
  27.275 -        fun build_rel rs' T =
  27.276 -          (case find_index (curry op = T) fpTs of
  27.277 -            ~1 =>
  27.278 -            if exists_subtype_in fpTs T then
  27.279 -              let
  27.280 -                val Type (s, Ts) = T
  27.281 -                val bnf = the (bnf_of lthy s);
  27.282 -                val live = live_of_bnf bnf;
  27.283 -                val rel = mk_rel live Ts Ts (rel_of_bnf bnf);
  27.284 -                val Ts' = map domain_type (fst (strip_typeN live (fastype_of rel)));
  27.285 -              in Term.list_comb (rel, map (build_rel rs') Ts') end
  27.286 -            else
  27.287 -              HOLogic.eq_const T
  27.288 -          | kk => nth rs' kk);
  27.289 +        fun build_the_rel rs' T Xs_T =
  27.290 +          build_rel lthy (fn (_, X) => nth rs' (find_index (curry (op =) X) Xs)) (T, Xs_T)
  27.291 +          |> Term.subst_atomic_types (Xs ~~ fpTs);
  27.292  
  27.293 -        fun build_rel_app rs' usel vsel = fold rapp [usel, vsel] (build_rel rs' (fastype_of usel));
  27.294 +        fun build_rel_app rs' usel vsel Xs_T =
  27.295 +          fold rapp [usel, vsel] (build_the_rel rs' (fastype_of usel) Xs_T);
  27.296  
  27.297 -        fun mk_prem_ctr_concls rs' n k udisc usels vdisc vsels =
  27.298 +        fun mk_prem_ctr_concls rs' n k udisc usels vdisc vsels ctrXs_Ts =
  27.299            (if k = n then [] else [HOLogic.mk_eq (udisc, vdisc)]) @
  27.300            (if null usels then
  27.301               []
  27.302             else
  27.303               [Library.foldr HOLogic.mk_imp (if n = 1 then [] else [udisc, vdisc],
  27.304 -                Library.foldr1 HOLogic.mk_conj (map2 (build_rel_app rs') usels vsels))]);
  27.305 +                Library.foldr1 HOLogic.mk_conj (map3 (build_rel_app rs') usels vsels ctrXs_Ts))]);
  27.306  
  27.307 -        fun mk_prem_concl rs' n udiscs uselss vdiscs vselss =
  27.308 -          Library.foldr1 HOLogic.mk_conj
  27.309 -            (flat (map5 (mk_prem_ctr_concls rs' n) (1 upto n) udiscs uselss vdiscs vselss))
  27.310 +        fun mk_prem_concl rs' n udiscs uselss vdiscs vselss ctrXs_Tss =
  27.311 +          Library.foldr1 HOLogic.mk_conj (flat (map6 (mk_prem_ctr_concls rs' n)
  27.312 +            (1 upto n) udiscs uselss vdiscs vselss ctrXs_Tss))
  27.313            handle List.Empty => @{term True};
  27.314  
  27.315 -        fun mk_prem rs' uvr u v n udiscs uselss vdiscs vselss =
  27.316 +        fun mk_prem rs' uvr u v n udiscs uselss vdiscs vselss ctrXs_Tss =
  27.317            fold_rev Logic.all [u, v] (Logic.mk_implies (HOLogic.mk_Trueprop uvr,
  27.318 -            HOLogic.mk_Trueprop (mk_prem_concl rs' n udiscs uselss vdiscs vselss)));
  27.319 +            HOLogic.mk_Trueprop (mk_prem_concl rs' n udiscs uselss vdiscs vselss ctrXs_Tss)));
  27.320  
  27.321          val concl =
  27.322            HOLogic.mk_Trueprop (Library.foldr1 HOLogic.mk_conj
  27.323 @@ -862,8 +820,8 @@
  27.324                 uvrs us vs));
  27.325  
  27.326          fun mk_goal rs' =
  27.327 -          Logic.list_implies (map8 (mk_prem rs') uvrs us vs ns udiscss uselsss vdiscss vselsss,
  27.328 -            concl);
  27.329 +          Logic.list_implies (map9 (mk_prem rs') uvrs us vs ns udiscss uselsss vdiscss vselsss
  27.330 +            ctrXs_Tsss, concl);
  27.331  
  27.332          val goals = map mk_goal [rs, strong_rs];
  27.333  
  27.334 @@ -1024,7 +982,7 @@
  27.335        coinduct_consumes_attr :: coinduct_case_names_attr :: coinduct_case_concl_attrs;
  27.336    in
  27.337      ((coinduct_thms_pairs, coinduct_case_attrs),
  27.338 -     (unfold_thmss, corec_thmss, code_nitpick_simp_attrs),
  27.339 +     (unfold_thmss, corec_thmss, code_nitpicksimp_attrs),
  27.340       (disc_unfold_thmss, disc_corec_thmss, []),
  27.341       (disc_unfold_iff_thmss, disc_corec_iff_thmss, simp_attrs),
  27.342       (sel_unfold_thmsss, sel_corec_thmsss, simp_attrs))
  27.343 @@ -1074,7 +1032,7 @@
  27.344  
  27.345      val qsoty = quote o Syntax.string_of_typ fake_lthy;
  27.346  
  27.347 -    val _ = (case duplicates (op =) unsorted_As of [] => ()
  27.348 +    val _ = (case Library.duplicates (op =) unsorted_As of [] => ()
  27.349        | A :: _ => error ("Duplicate type parameter " ^ qsoty A ^ " in " ^ co_prefix fp ^
  27.350            "datatype specification"));
  27.351  
  27.352 @@ -1087,7 +1045,7 @@
  27.353  
  27.354      val mixfixes = map mixfix_of specs;
  27.355  
  27.356 -    val _ = (case duplicates Binding.eq_name fp_bs of [] => ()
  27.357 +    val _ = (case Library.duplicates Binding.eq_name fp_bs of [] => ()
  27.358        | b :: _ => error ("Duplicate type name declaration " ^ quote (Binding.name_of b)));
  27.359  
  27.360      val ctr_specss = map ctr_specs_of specs;
  27.361 @@ -1380,15 +1338,22 @@
  27.362                val (rel_distinct_thms, _) =
  27.363                  join_halves n half_rel_distinct_thmss other_half_rel_distinct_thmss;
  27.364  
  27.365 +              val anonymous_notes =
  27.366 +                [(map (fn th => th RS @{thm eq_False[THEN iffD2]}) rel_distinct_thms,
  27.367 +                  code_nitpicksimp_attrs),
  27.368 +                 (map2 (fn th => fn 0 => th RS @{thm eq_True[THEN iffD2]} | _ => th)
  27.369 +                    rel_inject_thms ms, code_nitpicksimp_attrs)]
  27.370 +                |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])]));
  27.371 +
  27.372                val notes =
  27.373 -                [(mapN, map_thms, code_nitpick_simp_attrs @ simp_attrs),
  27.374 -                 (rel_distinctN, rel_distinct_thms, code_nitpick_simp_attrs @ simp_attrs),
  27.375 -                 (rel_injectN, rel_inject_thms, code_nitpick_simp_attrs @ simp_attrs),
  27.376 -                 (setN, flat set_thmss, code_nitpick_simp_attrs @ simp_attrs)]
  27.377 +                [(mapN, map_thms, code_nitpicksimp_attrs @ simp_attrs),
  27.378 +                 (rel_distinctN, rel_distinct_thms, simp_attrs),
  27.379 +                 (rel_injectN, rel_inject_thms, simp_attrs),
  27.380 +                 (setN, flat set_thmss, code_nitpicksimp_attrs @ simp_attrs)]
  27.381                  |> massage_simple_notes fp_b_name;
  27.382              in
  27.383                (((map_thms, rel_inject_thms, rel_distinct_thms, set_thmss), ctr_sugar),
  27.384 -               lthy |> Local_Theory.notes notes |> snd)
  27.385 +               lthy |> Local_Theory.notes (anonymous_notes @ notes) |> snd)
  27.386              end;
  27.387  
  27.388          fun mk_binding suf = qualify false fp_b_name (Binding.suffix_name ("_" ^ suf) fp_b);
  27.389 @@ -1457,8 +1422,9 @@
  27.390               (disc_unfold_iff_thmss, disc_corec_iff_thmss, disc_coiter_iff_attrs),
  27.391               (sel_unfold_thmsss, sel_corec_thmsss, sel_coiter_attrs)) =
  27.392            derive_coinduct_coiters_thms_for_types pre_bnfs (the coiters_args_types) xtor_co_induct
  27.393 -            dtor_injects dtor_ctors xtor_co_iter_thmss nesting_bnfs fpTs Cs kss mss ns ctr_defss
  27.394 -            ctr_sugars coiterss coiter_defss (Proof_Context.export lthy' no_defs_lthy) lthy;
  27.395 +            dtor_injects dtor_ctors xtor_co_iter_thmss nesting_bnfs fpTs Cs Xs ctrXs_Tsss kss mss ns
  27.396 +            ctr_defss ctr_sugars coiterss coiter_defss (Proof_Context.export lthy' no_defs_lthy)
  27.397 +            lthy;
  27.398  
  27.399          val sel_unfold_thmss = map flat sel_unfold_thmsss;
  27.400          val sel_corec_thmss = map flat sel_corec_thmsss;
  27.401 @@ -1496,6 +1462,12 @@
  27.402             (unfoldN, unfold_thmss, K coiter_attrs)]
  27.403            |> massage_multi_notes;
  27.404  
  27.405 +        fun is_codatatype (Type (s, _)) =
  27.406 +            (case fp_sugar_of lthy s of SOME {fp = Greatest_FP, ...} => true | _ => false)
  27.407 +          | is_codatatype _ = false;
  27.408 +
  27.409 +        val nitpick_supported = forall (is_codatatype o T_of_bnf) nested_bnfs;
  27.410 +
  27.411          fun register_nitpick fpT ({ctrs, casex, ...} : ctr_sugar) =
  27.412            Nitpick_HOL.register_codatatype fpT (fst (dest_Const casex))
  27.413              (map (dest_Const o mk_ctr As) ctrs)
  27.414 @@ -1507,7 +1479,7 @@
  27.415            ctr_sugars coiterss mapss [coinduct_thm, strong_coinduct_thm]
  27.416            (transpose [unfold_thmss, corec_thmss]) (transpose [disc_unfold_thmss, disc_corec_thmss])
  27.417            (transpose [sel_unfold_thmsss, sel_corec_thmsss])
  27.418 -        |> fold2 register_nitpick fpTs ctr_sugars
  27.419 +        |> nitpick_supported ? fold2 register_nitpick fpTs ctr_sugars
  27.420        end;
  27.421  
  27.422      val lthy'' = lthy'
    28.1 --- a/src/HOL/BNF/Tools/bnf_fp_def_sugar_tactics.ML	Mon Nov 11 17:34:44 2013 +0100
    28.2 +++ b/src/HOL/BNF/Tools/bnf_fp_def_sugar_tactics.ML	Mon Nov 11 17:44:21 2013 +0100
    28.3 @@ -151,12 +151,17 @@
    28.4    (atac ORELSE' REPEAT o etac conjE THEN'
    28.5       full_simp_tac
    28.6         (ss_only (@{thm prod.inject} :: no_refl discs @ rel_eqs @ more_simp_thms) ctxt) THEN'
    28.7 -     REPEAT o etac conjE THEN_MAYBE' REPEAT o hyp_subst_tac ctxt THEN' REPEAT o rtac conjI THEN'
    28.8 -     REPEAT o (rtac refl ORELSE' atac));
    28.9 +     REPEAT o etac conjE THEN_MAYBE' REPEAT o hyp_subst_tac ctxt THEN'
   28.10 +     REPEAT o (resolve_tac [refl, conjI] ORELSE' atac));
   28.11  
   28.12  fun mk_coinduct_distinct_ctrs_tac ctxt discs discs' =
   28.13 -  hyp_subst_tac ctxt THEN' REPEAT o etac conjE THEN'
   28.14 -  full_simp_tac (ss_only (refl :: no_refl (union Thm.eq_thm discs discs') @ basic_simp_thms) ctxt);
   28.15 +  let
   28.16 +    val discs'' = map (perhaps (try (fn th => th RS @{thm notnotD}))) (discs @ discs')
   28.17 +      |> distinct Thm.eq_thm_prop;
   28.18 +  in
   28.19 +    hyp_subst_tac ctxt THEN' REPEAT o etac conjE THEN'
   28.20 +    full_simp_tac (ss_only (refl :: no_refl discs'' @ basic_simp_thms) ctxt)
   28.21 +  end;
   28.22  
   28.23  fun mk_coinduct_discharge_prem_tac ctxt rel_eqs' nn kk n pre_rel_def dtor_ctor exhaust ctr_defs
   28.24      discss selss =
    29.1 --- a/src/HOL/BNF/Tools/bnf_fp_n2m.ML	Mon Nov 11 17:34:44 2013 +0100
    29.2 +++ b/src/HOL/BNF/Tools/bnf_fp_n2m.ML	Mon Nov 11 17:44:21 2013 +0100
    29.3 @@ -23,7 +23,7 @@
    29.4  open BNF_FP_N2M_Tactics
    29.5  
    29.6  fun force_typ ctxt T =
    29.7 -  map_types Type_Infer.paramify_vars 
    29.8 +  map_types Type_Infer.paramify_vars
    29.9    #> Type.constraint T
   29.10    #> Syntax.check_term ctxt
   29.11    #> singleton (Variable.polymorphic ctxt);
   29.12 @@ -99,10 +99,6 @@
   29.13      val fp_nesty_bnfss = fp_bnfs :: nesty_bnfss;
   29.14      val fp_nesty_bnfs = distinct eq_bnf (flat fp_nesty_bnfss);
   29.15  
   29.16 -    fun abstract t =
   29.17 -      let val Ts = Term.add_frees t [];
   29.18 -      in fold_rev Term.absfree (filter (member op = Ts) phis') t end;
   29.19 -
   29.20      val rels =
   29.21        let
   29.22          fun find_rel T As Bs = fp_nesty_bnfss
   29.23 @@ -121,10 +117,11 @@
   29.24                in
   29.25                  Term.list_comb (rel, rels)
   29.26                end
   29.27 -          | mk_rel (T as TFree _) _ = nth phis (find_index (curry op = T) As)
   29.28 +          | mk_rel (T as TFree _) _ = (nth phis (find_index (curry op = T) As)
   29.29 +              handle General.Subscript => HOLogic.eq_const T)
   29.30            | mk_rel _ _ = raise Fail "fpTs contains schematic type variables";
   29.31        in
   29.32 -        map2 (abstract oo mk_rel) fpTs fpTs'
   29.33 +        map2 (fold_rev Term.absfree phis' oo mk_rel) fpTs fpTs'
   29.34        end;
   29.35  
   29.36      val pre_rels = map2 (fn Ds => mk_rel_of_bnf Ds (As @ fpTs) (Bs @ fpTs')) Dss bnfs;
   29.37 @@ -224,7 +221,7 @@
   29.38          fun mk_s TU' =
   29.39            let
   29.40              val i = find_index (fn T => co_alg_argT TU' = T) Xs;
   29.41 -            val sF = co_alg_funT TU'; 
   29.42 +            val sF = co_alg_funT TU';
   29.43              val F = nth iter_preTs i;
   29.44              val s = nth iter_strs i;
   29.45            in
   29.46 @@ -238,7 +235,7 @@
   29.47                    |> force_typ names_lthy smapT
   29.48                    |> hidden_to_unit;
   29.49                  val smap_argTs = strip_typeN live (fastype_of smap) |> fst;
   29.50 -                fun mk_smap_arg TU =              
   29.51 +                fun mk_smap_arg TU =
   29.52                    (if domain_type TU = range_type TU then
   29.53                      HOLogic.id_const (domain_type TU)
   29.54                    else if is_rec then
   29.55 @@ -265,7 +262,7 @@
   29.56        in
   29.57          (case b_opt of
   29.58            NONE => ((t, Drule.dummy_thm), lthy)
   29.59 -        | SOME b => Local_Theory.define ((b, NoSyn), ((Thm.def_binding b, []), 
   29.60 +        | SOME b => Local_Theory.define ((b, NoSyn), ((Binding.conceal (Thm.def_binding b), []),
   29.61              fold_rev Term.absfree (if is_rec then rec_strs' else fold_strs') t)) lthy |>> apsnd snd)
   29.62        end;
   29.63  
   29.64 @@ -376,6 +373,6 @@
   29.65         |> morph_fp_result (Morphism.term_morphism (singleton (Variable.polymorphic lthy))));
   29.66    in
   29.67      (fp_res, lthy)
   29.68 -  end
   29.69 +  end;
   29.70  
   29.71  end;
    30.1 --- a/src/HOL/BNF/Tools/bnf_fp_n2m_sugar.ML	Mon Nov 11 17:34:44 2013 +0100
    30.2 +++ b/src/HOL/BNF/Tools/bnf_fp_n2m_sugar.ML	Mon Nov 11 17:44:21 2013 +0100
    30.3 @@ -7,14 +7,16 @@
    30.4  
    30.5  signature BNF_FP_N2M_SUGAR =
    30.6  sig
    30.7 -  val mutualize_fp_sugars: bool -> BNF_FP_Util.fp_kind -> binding list -> typ list ->
    30.8 -    (term -> int list) -> term list list list list -> BNF_FP_Def_Sugar.fp_sugar list ->
    30.9 -    local_theory ->
   30.10 +  val unfold_let: term -> term
   30.11 +  val dest_map: Proof.context -> string -> term -> term * term list
   30.12 +
   30.13 +  val mutualize_fp_sugars: BNF_FP_Util.fp_kind -> binding list -> typ list -> (term -> int list) ->
   30.14 +    term list list list list -> BNF_FP_Def_Sugar.fp_sugar list -> local_theory ->
   30.15      (BNF_FP_Def_Sugar.fp_sugar list
   30.16       * (BNF_FP_Def_Sugar.lfp_sugar_thms option * BNF_FP_Def_Sugar.gfp_sugar_thms option))
   30.17      * local_theory
   30.18 -  val pad_and_indexify_calls: BNF_FP_Def_Sugar.fp_sugar list -> int ->
   30.19 -    (term * term list list) list list -> term list list list list
   30.20 +  val indexify_callsss: BNF_FP_Def_Sugar.fp_sugar -> (term * term list list) list ->
   30.21 +    term list list list
   30.22    val nested_to_mutual_fps: BNF_FP_Util.fp_kind -> binding list -> typ list -> (term -> int list) ->
   30.23      (term * term list list) list list -> local_theory ->
   30.24      (typ list * int list * BNF_FP_Def_Sugar.fp_sugar list
   30.25 @@ -34,171 +36,246 @@
   30.26  
   30.27  val n2mN = "n2m_"
   30.28  
   30.29 -(* TODO: test with sort constraints on As *)
   30.30 -(* TODO: use right sorting order for "fp_sort" w.r.t. original BNFs (?) -- treat new variables
   30.31 -   as deads? *)
   30.32 -fun mutualize_fp_sugars mutualize fp bs fpTs get_indices callssss fp_sugars0 no_defs_lthy0 =
   30.33 -  if mutualize orelse has_duplicates (op =) fpTs then
   30.34 -    let
   30.35 -      val thy = Proof_Context.theory_of no_defs_lthy0;
   30.36 +type n2m_sugar = fp_sugar list * (lfp_sugar_thms option * gfp_sugar_thms option);
   30.37 +
   30.38 +structure Data = Generic_Data
   30.39 +(
   30.40 +  type T = n2m_sugar Typtab.table;
   30.41 +  val empty = Typtab.empty;
   30.42 +  val extend = I;
   30.43 +  val merge = Typtab.merge (eq_fst (eq_list eq_fp_sugar));
   30.44 +);
   30.45  
   30.46 -      val qsotm = quote o Syntax.string_of_term no_defs_lthy0;
   30.47 +fun morph_n2m_sugar phi (fp_sugars, (lfp_sugar_thms_opt, gfp_sugar_thms_opt)) =
   30.48 +  (map (morph_fp_sugar phi) fp_sugars,
   30.49 +   (Option.map (morph_lfp_sugar_thms phi) lfp_sugar_thms_opt,
   30.50 +    Option.map (morph_gfp_sugar_thms phi) gfp_sugar_thms_opt));
   30.51 +
   30.52 +val transfer_n2m_sugar =
   30.53 +  morph_n2m_sugar o Morphism.thm_morphism o Thm.transfer o Proof_Context.theory_of;
   30.54  
   30.55 -      fun heterogeneous_call t = error ("Heterogeneous recursive call: " ^ qsotm t);
   30.56 -      fun incompatible_calls t1 t2 =
   30.57 -        error ("Incompatible recursive calls: " ^ qsotm t1 ^ " vs. " ^ qsotm t2);
   30.58 +fun n2m_sugar_of ctxt =
   30.59 +  Typtab.lookup (Data.get (Context.Proof ctxt))
   30.60 +  #> Option.map (transfer_n2m_sugar ctxt);
   30.61  
   30.62 -      val b_names = map Binding.name_of bs;
   30.63 -      val fp_b_names = map base_name_of_typ fpTs;
   30.64 +fun register_n2m_sugar key n2m_sugar =
   30.65 +  Local_Theory.declaration {syntax = false, pervasive = false}
   30.66 +    (fn phi => Data.map (Typtab.default (key, morph_n2m_sugar phi n2m_sugar)));
   30.67  
   30.68 -      val nn = length fpTs;
   30.69 +fun unfold_let (Const (@{const_name Let}, _) $ arg1 $ arg2) = unfold_let (betapply (arg2, arg1))
   30.70 +  | unfold_let (Const (@{const_name prod_case}, _) $ t) =
   30.71 +    (case unfold_let t of
   30.72 +      t' as Abs (s1, T1, Abs (s2, T2, _)) =>
   30.73 +      let
   30.74 +        val x = (s1 ^ s2, Term.maxidx_of_term t + 1);
   30.75 +        val v = Var (x, HOLogic.mk_prodT (T1, T2));
   30.76 +      in
   30.77 +        lambda v (unfold_let (betapplys (t', [HOLogic.mk_fst v, HOLogic.mk_snd v])))
   30.78 +      end
   30.79 +    | _ => t)
   30.80 +  | unfold_let (t $ u) = betapply (unfold_let t, unfold_let u)
   30.81 +  | unfold_let (Abs (s, T, t)) = Abs (s, T, unfold_let t)
   30.82 +  | unfold_let t = t;
   30.83  
   30.84 -      fun target_ctr_sugar_of_fp_sugar fpT ({T, index, ctr_sugars, ...} : fp_sugar) =
   30.85 -        let
   30.86 -          val rho = Vartab.fold (cons o apsnd snd) (Sign.typ_match thy (T, fpT) Vartab.empty) [];
   30.87 -          val phi = Morphism.term_morphism (Term.subst_TVars rho);
   30.88 -        in
   30.89 -          morph_ctr_sugar phi (nth ctr_sugars index)
   30.90 -        end;
   30.91 -
   30.92 -      val ctr_defss = map (of_fp_sugar #ctr_defss) fp_sugars0;
   30.93 -      val mapss = map (of_fp_sugar #mapss) fp_sugars0;
   30.94 -      val ctr_sugars0 = map2 target_ctr_sugar_of_fp_sugar fpTs fp_sugars0;
   30.95 -
   30.96 -      val ctrss = map #ctrs ctr_sugars0;
   30.97 -      val ctr_Tss = map (map fastype_of) ctrss;
   30.98 +fun mk_map_pattern ctxt s =
   30.99 +  let
  30.100 +    val bnf = the (bnf_of ctxt s);
  30.101 +    val mapx = map_of_bnf bnf;
  30.102 +    val live = live_of_bnf bnf;
  30.103 +    val (f_Ts, _) = strip_typeN live (fastype_of mapx);
  30.104 +    val fs = map_index (fn (i, T) => Var (("?f", i), T)) f_Ts;
  30.105 +  in
  30.106 +    (mapx, betapplys (mapx, fs))
  30.107 +  end;
  30.108  
  30.109 -      val As' = fold (fold Term.add_tfreesT) ctr_Tss [];
  30.110 -      val As = map TFree As';
  30.111 +fun dest_map ctxt s call =
  30.112 +  let
  30.113 +    val (map0, pat) = mk_map_pattern ctxt s;
  30.114 +    val (_, tenv) = fo_match ctxt call pat;
  30.115 +  in
  30.116 +    (map0, Vartab.fold_rev (fn (_, (_, f)) => cons f) tenv [])
  30.117 +  end;
  30.118 +
  30.119 +fun dest_abs_or_applied_map _ _ (Abs (_, _, t)) = (Term.dummy, [t])
  30.120 +  | dest_abs_or_applied_map ctxt s (t1 $ _) = dest_map ctxt s t1;
  30.121  
  30.122 -      val ((Cs, Xs), no_defs_lthy) =
  30.123 -        no_defs_lthy0
  30.124 -        |> fold Variable.declare_typ As
  30.125 -        |> mk_TFrees nn
  30.126 -        ||>> variant_tfrees fp_b_names;
  30.127 +fun map_partition f xs =
  30.128 +  fold_rev (fn x => fn (ys, (good, bad)) =>
  30.129 +      case f x of SOME y => (y :: ys, (x :: good, bad)) | NONE => (ys, (good, x :: bad)))
  30.130 +    xs ([], ([], []));
  30.131  
  30.132 -      fun freeze_fp_default (T as Type (s, Ts)) =
  30.133 -          (case find_index (curry (op =) T) fpTs of
  30.134 -            ~1 => Type (s, map freeze_fp_default Ts)
  30.135 -          | kk => nth Xs kk)
  30.136 -        | freeze_fp_default T = T;
  30.137 +fun key_of_fp_eqs fp fpTs fp_eqs =
  30.138 +  Type (fp_case fp "l" "g", fpTs @ maps (fn (x, T) => [TFree x, T]) fp_eqs);
  30.139 +
  30.140 +(* TODO: test with sort constraints on As *)
  30.141 +fun mutualize_fp_sugars fp bs fpTs get_indices callssss fp_sugars0 no_defs_lthy0 =
  30.142 +  let
  30.143 +    val thy = Proof_Context.theory_of no_defs_lthy0;
  30.144 +
  30.145 +    val qsotm = quote o Syntax.string_of_term no_defs_lthy0;
  30.146  
  30.147 -      fun get_indices_checked call =
  30.148 -        (case get_indices call of
  30.149 -          _ :: _ :: _ => heterogeneous_call call
  30.150 -        | kks => kks);
  30.151 +    fun incompatible_calls t1 t2 =
  30.152 +      error ("Incompatible " ^ co_prefix fp ^ "recursive calls: " ^ qsotm t1 ^ " vs. " ^ qsotm t2);
  30.153 +
  30.154 +    val b_names = map Binding.name_of bs;
  30.155 +    val fp_b_names = map base_name_of_typ fpTs;
  30.156 +
  30.157 +    val nn = length fpTs;
  30.158  
  30.159 -      fun freeze_fp calls (T as Type (s, Ts)) =
  30.160 -          (case map_filter (try (snd o dest_map no_defs_lthy s)) calls of
  30.161 -            [] =>
  30.162 -            (case union (op = o pairself fst)
  30.163 -                (maps (fn call => map (rpair call) (get_indices_checked call)) calls) [] of
  30.164 -              [] => freeze_fp_default T
  30.165 -            | [(kk, _)] => nth Xs kk
  30.166 -            | (_, call1) :: (_, call2) :: _ => incompatible_calls call1 call2)
  30.167 -          | callss =>
  30.168 -            Type (s, map2 freeze_fp (flatten_type_args_of_bnf (the (bnf_of no_defs_lthy s)) []
  30.169 -              (transpose callss)) Ts))
  30.170 -        | freeze_fp _ T = T;
  30.171 +    fun target_ctr_sugar_of_fp_sugar fpT ({T, index, ctr_sugars, ...} : fp_sugar) =
  30.172 +      let
  30.173 +        val rho = Vartab.fold (cons o apsnd snd) (Sign.typ_match thy (T, fpT) Vartab.empty) [];
  30.174 +        val phi = Morphism.term_morphism (Term.subst_TVars rho);
  30.175 +      in
  30.176 +        morph_ctr_sugar phi (nth ctr_sugars index)
  30.177 +      end;
  30.178  
  30.179 -      val ctr_Tsss = map (map binder_types) ctr_Tss;
  30.180 -      val ctrXs_Tsss = map2 (map2 (map2 freeze_fp)) callssss ctr_Tsss;
  30.181 -      val ctrXs_sum_prod_Ts = map (mk_sumTN_balanced o map HOLogic.mk_tupleT) ctrXs_Tsss;
  30.182 -      val Ts = map (body_type o hd) ctr_Tss;
  30.183 +    val ctr_defss = map (of_fp_sugar #ctr_defss) fp_sugars0;
  30.184 +    val mapss = map (of_fp_sugar #mapss) fp_sugars0;
  30.185 +    val ctr_sugars0 = map2 target_ctr_sugar_of_fp_sugar fpTs fp_sugars0;
  30.186 +
  30.187 +    val ctrss = map #ctrs ctr_sugars0;
  30.188 +    val ctr_Tss = map (map fastype_of) ctrss;
  30.189 +
  30.190 +    val As' = fold (fold Term.add_tfreesT) ctr_Tss [];
  30.191 +    val As = map TFree As';
  30.192  
  30.193 -      val ns = map length ctr_Tsss;
  30.194 -      val kss = map (fn n => 1 upto n) ns;
  30.195 -      val mss = map (map length) ctr_Tsss;
  30.196 +    val ((Cs, Xs), no_defs_lthy) =
  30.197 +      no_defs_lthy0
  30.198 +      |> fold Variable.declare_typ As
  30.199 +      |> mk_TFrees nn
  30.200 +      ||>> variant_tfrees fp_b_names;
  30.201  
  30.202 -      val fp_eqs = map dest_TFree Xs ~~ ctrXs_sum_prod_Ts;
  30.203 +    fun check_call_dead live_call call =
  30.204 +      if null (get_indices call) then () else incompatible_calls live_call call;
  30.205  
  30.206 -      val base_fp_names = Name.variant_list [] fp_b_names;
  30.207 -      val fp_bs = map2 (fn b_name => fn base_fp_name =>
  30.208 -          Binding.qualify true b_name (Binding.name (n2mN ^ base_fp_name)))
  30.209 -        b_names base_fp_names;
  30.210 +    fun freeze_fpTs_simple (T as Type (s, Ts)) =
  30.211 +        (case find_index (curry (op =) T) fpTs of
  30.212 +          ~1 => Type (s, map freeze_fpTs_simple Ts)
  30.213 +        | kk => nth Xs kk)
  30.214 +      | freeze_fpTs_simple T = T;
  30.215  
  30.216 -      val (pre_bnfs, (fp_res as {xtor_co_iterss = xtor_co_iterss0, xtor_co_induct,
  30.217 -             dtor_injects, dtor_ctors, xtor_co_iter_thmss, ...}, lthy)) =
  30.218 -        fp_bnf (construct_mutualized_fp fp fpTs fp_sugars0) fp_bs As' fp_eqs no_defs_lthy;
  30.219 -
  30.220 -      val nesting_bnfs = nesty_bnfs lthy ctrXs_Tsss As;
  30.221 -      val nested_bnfs = nesty_bnfs lthy ctrXs_Tsss Xs;
  30.222 +    fun freeze_fpTs_map (callss, (live_call :: _, dead_calls)) s Ts =
  30.223 +      (List.app (check_call_dead live_call) dead_calls;
  30.224 +       Type (s, map2 freeze_fpTs (flatten_type_args_of_bnf (the (bnf_of no_defs_lthy s)) []
  30.225 +         (transpose callss)) Ts))
  30.226 +    and freeze_fpTs calls (T as Type (s, Ts)) =
  30.227 +        (case map_partition (try (snd o dest_map no_defs_lthy s)) calls of
  30.228 +          ([], _) =>
  30.229 +          (case map_partition (try (snd o dest_abs_or_applied_map no_defs_lthy s)) calls of
  30.230 +            ([], _) => freeze_fpTs_simple T
  30.231 +          | callsp => freeze_fpTs_map callsp s Ts)
  30.232 +        | callsp => freeze_fpTs_map callsp s Ts)
  30.233 +      | freeze_fpTs _ T = T;
  30.234  
  30.235 -      val ((xtor_co_iterss, iters_args_types, coiters_args_types), _) =
  30.236 -        mk_co_iters_prelims fp ctr_Tsss fpTs Cs ns mss xtor_co_iterss0 lthy;
  30.237 +    val ctr_Tsss = map (map binder_types) ctr_Tss;
  30.238 +    val ctrXs_Tsss = map2 (map2 (map2 freeze_fpTs)) callssss ctr_Tsss;
  30.239 +    val ctrXs_sum_prod_Ts = map (mk_sumTN_balanced o map HOLogic.mk_tupleT) ctrXs_Tsss;
  30.240 +    val Ts = map (body_type o hd) ctr_Tss;
  30.241  
  30.242 -      fun mk_binding b suf = Binding.suffix_name ("_" ^ suf) b;
  30.243 +    val ns = map length ctr_Tsss;
  30.244 +    val kss = map (fn n => 1 upto n) ns;
  30.245 +    val mss = map (map length) ctr_Tsss;
  30.246  
  30.247 -      val ((co_iterss, co_iter_defss), lthy) =
  30.248 -        fold_map2 (fn b =>
  30.249 -          (if fp = Least_FP then define_iters [foldN, recN] (the iters_args_types)
  30.250 -           else define_coiters [unfoldN, corecN] (the coiters_args_types))
  30.251 -            (mk_binding b) fpTs Cs) fp_bs xtor_co_iterss lthy
  30.252 -        |>> split_list;
  30.253 +    val fp_eqs = map dest_TFree Xs ~~ ctrXs_sum_prod_Ts;
  30.254 +    val key = key_of_fp_eqs fp fpTs fp_eqs;
  30.255 +  in
  30.256 +    (case n2m_sugar_of no_defs_lthy key of
  30.257 +      SOME n2m_sugar => (n2m_sugar, no_defs_lthy)
  30.258 +    | NONE =>
  30.259 +      let
  30.260 +        val base_fp_names = Name.variant_list [] fp_b_names;
  30.261 +        val fp_bs = map2 (fn b_name => fn base_fp_name =>
  30.262 +            Binding.qualify true b_name (Binding.name (n2mN ^ base_fp_name)))
  30.263 +          b_names base_fp_names;
  30.264  
  30.265 -      val rho = tvar_subst thy Ts fpTs;
  30.266 -      val ctr_sugar_phi =
  30.267 -        Morphism.compose (Morphism.typ_morphism (Term.typ_subst_TVars rho))
  30.268 -          (Morphism.term_morphism (Term.subst_TVars rho));
  30.269 -      val inst_ctr_sugar = morph_ctr_sugar ctr_sugar_phi;
  30.270 +        val (pre_bnfs, (fp_res as {xtor_co_iterss = xtor_co_iterss0, xtor_co_induct, dtor_injects,
  30.271 +               dtor_ctors, xtor_co_iter_thmss, ...}, lthy)) =
  30.272 +          fp_bnf (construct_mutualized_fp fp fpTs fp_sugars0) fp_bs As' fp_eqs no_defs_lthy;
  30.273 +
  30.274 +        val nesting_bnfs = nesty_bnfs lthy ctrXs_Tsss As;
  30.275 +        val nested_bnfs = nesty_bnfs lthy ctrXs_Tsss Xs;
  30.276  
  30.277 -      val ctr_sugars = map inst_ctr_sugar ctr_sugars0;
  30.278 +        val ((xtor_co_iterss, iters_args_types, coiters_args_types), _) =
  30.279 +          mk_co_iters_prelims fp ctr_Tsss fpTs Cs ns mss xtor_co_iterss0 lthy;
  30.280 +
  30.281 +        fun mk_binding b suf = Binding.suffix_name ("_" ^ suf) b;
  30.282 +
  30.283 +        val ((co_iterss, co_iter_defss), lthy) =
  30.284 +          fold_map2 (fn b =>
  30.285 +            (if fp = Least_FP then define_iters [foldN, recN] (the iters_args_types)
  30.286 +             else define_coiters [unfoldN, corecN] (the coiters_args_types))
  30.287 +              (mk_binding b) fpTs Cs) fp_bs xtor_co_iterss lthy
  30.288 +          |>> split_list;
  30.289 +
  30.290 +        val rho = tvar_subst thy Ts fpTs;
  30.291 +        val ctr_sugar_phi = Morphism.compose (Morphism.typ_morphism (Term.typ_subst_TVars rho))
  30.292 +            (Morphism.term_morphism (Term.subst_TVars rho));
  30.293 +        val inst_ctr_sugar = morph_ctr_sugar ctr_sugar_phi;
  30.294 +
  30.295 +        val ctr_sugars = map inst_ctr_sugar ctr_sugars0;
  30.296  
  30.297 -      val ((co_inducts, un_fold_thmss, co_rec_thmss, disc_unfold_thmss, disc_corec_thmss,
  30.298 -            sel_unfold_thmsss, sel_corec_thmsss), fp_sugar_thms) =
  30.299 -        if fp = Least_FP then
  30.300 -          derive_induct_iters_thms_for_types pre_bnfs (the iters_args_types) xtor_co_induct
  30.301 -            xtor_co_iter_thmss nesting_bnfs nested_bnfs fpTs Cs Xs ctrXs_Tsss ctrss ctr_defss
  30.302 -            co_iterss co_iter_defss lthy
  30.303 -          |> `(fn ((_, induct, _), (fold_thmss, rec_thmss, _)) =>
  30.304 -            ([induct], fold_thmss, rec_thmss, [], [], [], []))
  30.305 -          ||> (fn info => (SOME info, NONE))
  30.306 -        else
  30.307 -          derive_coinduct_coiters_thms_for_types pre_bnfs (the coiters_args_types) xtor_co_induct
  30.308 -            dtor_injects dtor_ctors xtor_co_iter_thmss nesting_bnfs fpTs Cs kss mss ns ctr_defss
  30.309 -            ctr_sugars co_iterss co_iter_defss (Proof_Context.export lthy no_defs_lthy) lthy
  30.310 -          |> `(fn ((coinduct_thms_pairs, _), (unfold_thmss, corec_thmss, _),
  30.311 -                  (disc_unfold_thmss, disc_corec_thmss, _), _,
  30.312 -                  (sel_unfold_thmsss, sel_corec_thmsss, _)) =>
  30.313 -            (map snd coinduct_thms_pairs, unfold_thmss, corec_thmss, disc_unfold_thmss,
  30.314 -             disc_corec_thmss, sel_unfold_thmsss, sel_corec_thmsss))
  30.315 -          ||> (fn info => (NONE, SOME info));
  30.316 +        val ((co_inducts, un_fold_thmss, co_rec_thmss, disc_unfold_thmss, disc_corec_thmss,
  30.317 +              sel_unfold_thmsss, sel_corec_thmsss), fp_sugar_thms) =
  30.318 +          if fp = Least_FP then
  30.319 +            derive_induct_iters_thms_for_types pre_bnfs (the iters_args_types) xtor_co_induct
  30.320 +              xtor_co_iter_thmss nesting_bnfs nested_bnfs fpTs Cs Xs ctrXs_Tsss ctrss ctr_defss
  30.321 +              co_iterss co_iter_defss lthy
  30.322 +            |> `(fn ((_, induct, _), (fold_thmss, rec_thmss, _)) =>
  30.323 +              ([induct], fold_thmss, rec_thmss, [], [], [], []))
  30.324 +            ||> (fn info => (SOME info, NONE))
  30.325 +          else
  30.326 +            derive_coinduct_coiters_thms_for_types pre_bnfs (the coiters_args_types) xtor_co_induct
  30.327 +              dtor_injects dtor_ctors xtor_co_iter_thmss nesting_bnfs fpTs Cs Xs ctrXs_Tsss kss mss
  30.328 +              ns ctr_defss ctr_sugars co_iterss co_iter_defss
  30.329 +              (Proof_Context.export lthy no_defs_lthy) lthy
  30.330 +            |> `(fn ((coinduct_thms_pairs, _), (unfold_thmss, corec_thmss, _),
  30.331 +                    (disc_unfold_thmss, disc_corec_thmss, _), _,
  30.332 +                    (sel_unfold_thmsss, sel_corec_thmsss, _)) =>
  30.333 +              (map snd coinduct_thms_pairs, unfold_thmss, corec_thmss, disc_unfold_thmss,
  30.334 +               disc_corec_thmss, sel_unfold_thmsss, sel_corec_thmsss))
  30.335 +            ||> (fn info => (NONE, SOME info));
  30.336  
  30.337 -      val phi = Proof_Context.export_morphism no_defs_lthy no_defs_lthy0;
  30.338 +        val phi = Proof_Context.export_morphism no_defs_lthy no_defs_lthy0;
  30.339  
  30.340 -      fun mk_target_fp_sugar (kk, T) =
  30.341 -        {T = T, fp = fp, index = kk, pre_bnfs = pre_bnfs, nested_bnfs = nested_bnfs,
  30.342 -         nesting_bnfs = nesting_bnfs, fp_res = fp_res, ctr_defss = ctr_defss,
  30.343 -         ctr_sugars = ctr_sugars, co_iterss = co_iterss, mapss = mapss, co_inducts = co_inducts,
  30.344 -         co_iter_thmsss = transpose [un_fold_thmss, co_rec_thmss],
  30.345 -         disc_co_itersss = transpose [disc_unfold_thmss, disc_corec_thmss],
  30.346 -         sel_co_iterssss = transpose [sel_unfold_thmsss, sel_corec_thmsss]}
  30.347 -        |> morph_fp_sugar phi;
  30.348 -    in
  30.349 -      ((map_index mk_target_fp_sugar fpTs, fp_sugar_thms), lthy)
  30.350 -    end
  30.351 -  else
  30.352 -    (* TODO: reorder hypotheses and predicates in (co)induction rules? *)
  30.353 -    ((fp_sugars0, (NONE, NONE)), no_defs_lthy0);
  30.354 +        fun mk_target_fp_sugar (kk, T) =
  30.355 +          {T = T, fp = fp, index = kk, pre_bnfs = pre_bnfs, nested_bnfs = nested_bnfs,
  30.356 +           nesting_bnfs = nesting_bnfs, fp_res = fp_res, ctr_defss = ctr_defss,
  30.357 +           ctr_sugars = ctr_sugars, co_iterss = co_iterss, mapss = mapss, co_inducts = co_inducts,
  30.358 +           co_iter_thmsss = transpose [un_fold_thmss, co_rec_thmss],
  30.359 +           disc_co_itersss = transpose [disc_unfold_thmss, disc_corec_thmss],
  30.360 +           sel_co_iterssss = transpose [sel_unfold_thmsss, sel_corec_thmsss]}
  30.361 +          |> morph_fp_sugar phi;
  30.362 +
  30.363 +        val n2m_sugar = (map_index mk_target_fp_sugar fpTs, fp_sugar_thms);
  30.364 +      in
  30.365 +        (n2m_sugar, lthy |> register_n2m_sugar key n2m_sugar)
  30.366 +      end)
  30.367 +  end;
  30.368  
  30.369  fun indexify_callsss fp_sugar callsss =
  30.370    let
  30.371      val {ctrs, ...} = of_fp_sugar #ctr_sugars fp_sugar;
  30.372 -    fun do_ctr ctr =
  30.373 +    fun indexify_ctr ctr =
  30.374        (case AList.lookup Term.aconv_untyped callsss ctr of
  30.375          NONE => replicate (num_binder_types (fastype_of ctr)) []
  30.376 -      | SOME callss => map (map Envir.beta_eta_contract) callss);
  30.377 +      | SOME callss => map (map (Envir.beta_eta_contract o unfold_let)) callss);
  30.378    in
  30.379 -    map do_ctr ctrs
  30.380 +    map indexify_ctr ctrs
  30.381    end;
  30.382  
  30.383 -fun pad_and_indexify_calls fp_sugars0 = map2 indexify_callsss fp_sugars0 oo pad_list [];
  30.384 +fun retypargs tyargs (Type (s, _)) = Type (s, tyargs);
  30.385 +
  30.386 +fun fold_subtype_pairs f (T as Type (s, Ts), U as Type (s', Us)) =
  30.387 +    f (T, U) #> (if s = s' then fold (fold_subtype_pairs f) (Ts ~~ Us) else I)
  30.388 +  | fold_subtype_pairs f TU = f TU;
  30.389  
  30.390  fun nested_to_mutual_fps fp actual_bs actual_Ts get_indices actual_callssss0 lthy =
  30.391    let
  30.392      val qsoty = quote o Syntax.string_of_typ lthy;
  30.393      val qsotys = space_implode " or " o map qsoty;
  30.394  
  30.395 +    fun duplicate_datatype T = error (qsoty T ^ " is not mutually recursive with itself");
  30.396      fun not_co_datatype0 T = error (qsoty T ^ " is not a " ^ co_prefix fp ^ "datatype");
  30.397      fun not_co_datatype (T as Type (s, _)) =
  30.398          if fp = Least_FP andalso
  30.399 @@ -208,32 +285,80 @@
  30.400            not_co_datatype0 T
  30.401        | not_co_datatype T = not_co_datatype0 T;
  30.402      fun not_mutually_nested_rec Ts1 Ts2 =
  30.403 -      error (qsotys Ts1 ^ " is neither mutually recursive with nor nested recursive via " ^
  30.404 -        qsotys Ts2);
  30.405 +      error (qsotys Ts1 ^ " is neither mutually recursive with " ^ qsotys Ts2 ^
  30.406 +        " nor nested recursive via " ^ qsotys Ts2);
  30.407 +
  30.408 +    val _ = (case Library.duplicates (op =) actual_Ts of [] => () | T :: _ => duplicate_datatype T);
  30.409  
  30.410 -    val perm_actual_Ts as Type (_, ty_args0) :: _ =
  30.411 -      sort (int_ord o pairself Term.size_of_typ) actual_Ts;
  30.412 +    val perm_actual_Ts =
  30.413 +      sort (prod_ord int_ord Term_Ord.typ_ord o pairself (`Term.size_of_typ)) actual_Ts;
  30.414 +
  30.415 +    fun the_ctrs_of (Type (s, Ts)) = map (mk_ctr Ts) (#ctrs (the (ctr_sugar_of lthy s)));
  30.416 +
  30.417 +    fun the_fp_sugar_of (T as Type (T_name, _)) =
  30.418 +      (case fp_sugar_of lthy T_name of
  30.419 +        SOME (fp_sugar as {fp = fp', ...}) => if fp = fp' then fp_sugar else not_co_datatype T
  30.420 +      | NONE => not_co_datatype T);
  30.421  
  30.422 -    fun check_enrich_with_mutuals _ [] = []
  30.423 -      | check_enrich_with_mutuals seen ((T as Type (T_name, ty_args)) :: Ts) =
  30.424 -        (case fp_sugar_of lthy T_name of
  30.425 -          SOME ({fp = fp', fp_res = {Ts = Ts', ...}, ...}) =>
  30.426 -          if fp = fp' then
  30.427 +    fun gen_rhss_in gen_Ts rho subTs =
  30.428 +      let
  30.429 +        fun maybe_insert (T, Type (_, gen_tyargs)) =
  30.430 +            if member (op =) subTs T then insert (op =) gen_tyargs else I
  30.431 +          | maybe_insert _ = I;
  30.432 +
  30.433 +        val ctrs = maps the_ctrs_of gen_Ts;
  30.434 +        val gen_ctr_Ts = maps (binder_types o fastype_of) ctrs;
  30.435 +        val ctr_Ts = map (Term.typ_subst_atomic rho) gen_ctr_Ts;
  30.436 +      in
  30.437 +        fold (fold_subtype_pairs maybe_insert) (ctr_Ts ~~ gen_ctr_Ts) []
  30.438 +      end;
  30.439 +
  30.440 +    fun gather_types _ _ num_groups seen gen_seen [] = (num_groups, seen, gen_seen)
  30.441 +      | gather_types lthy rho num_groups seen gen_seen ((T as Type (_, tyargs)) :: Ts) =
  30.442 +        let
  30.443 +          val {fp_res = {Ts = mutual_Ts0, ...}, ...} = the_fp_sugar_of T;
  30.444 +          val mutual_Ts = map (retypargs tyargs) mutual_Ts0;
  30.445 +
  30.446 +          val _ = seen = [] orelse exists (exists_subtype_in seen) mutual_Ts orelse
  30.447 +            not_mutually_nested_rec mutual_Ts seen;
  30.448 +
  30.449 +          fun fresh_tyargs () =
  30.450              let
  30.451 -              val mutual_Ts = map (fn Type (s, _) => Type (s, ty_args)) Ts';
  30.452 -              val _ =
  30.453 -                seen = [] orelse exists (exists_subtype_in seen) mutual_Ts orelse
  30.454 -                not_mutually_nested_rec mutual_Ts seen;
  30.455 -              val (seen', Ts') = List.partition (member (op =) mutual_Ts) Ts;
  30.456 +              (* The name "'z" is unlikely to clash with the context, yielding more cache hits. *)
  30.457 +              val (gen_tyargs, lthy') =
  30.458 +                variant_tfrees (replicate (length tyargs) "z") lthy
  30.459 +                |>> map Logic.varifyT_global;
  30.460 +              val rho' = (gen_tyargs ~~ tyargs) @ rho;
  30.461              in
  30.462 -              mutual_Ts @ check_enrich_with_mutuals (seen @ T :: seen') Ts'
  30.463 -            end
  30.464 -          else
  30.465 -            not_co_datatype T
  30.466 -        | NONE => not_co_datatype T)
  30.467 -      | check_enrich_with_mutuals _ (T :: _) = not_co_datatype T;
  30.468 +              (rho', gen_tyargs, gen_seen, lthy')
  30.469 +            end;
  30.470  
  30.471 -    val perm_Ts = check_enrich_with_mutuals [] perm_actual_Ts;
  30.472 +          val (rho', gen_tyargs, gen_seen', lthy') =
  30.473 +            if exists (exists_subtype_in seen) mutual_Ts then
  30.474 +              (case gen_rhss_in gen_seen rho mutual_Ts of
  30.475 +                [] => fresh_tyargs ()
  30.476 +              | gen_tyargss as gen_tyargs :: gen_tyargss_tl =>
  30.477 +                let
  30.478 +                  val unify_pairs = split_list (maps (curry (op ~~) gen_tyargs) gen_tyargss_tl);
  30.479 +                  val mgu = Type.raw_unifys unify_pairs Vartab.empty;
  30.480 +                  val gen_tyargs' = map (Envir.subst_type mgu) gen_tyargs;
  30.481 +                  val gen_seen' = map (Envir.subst_type mgu) gen_seen;
  30.482 +                in
  30.483 +                  (rho, gen_tyargs', gen_seen', lthy)
  30.484 +                end)
  30.485 +            else
  30.486 +              fresh_tyargs ();
  30.487 +
  30.488 +          val gen_mutual_Ts = map (retypargs gen_tyargs) mutual_Ts0;
  30.489 +          val Ts' = filter_out (member (op =) mutual_Ts) Ts;
  30.490 +        in
  30.491 +          gather_types lthy' rho' (num_groups + 1) (seen @ mutual_Ts) (gen_seen' @ gen_mutual_Ts)
  30.492 +            Ts'
  30.493 +        end
  30.494 +      | gather_types _ _ _ _ _ (T :: _) = not_co_datatype T;
  30.495 +
  30.496 +    val (num_groups, perm_Ts, perm_gen_Ts) = gather_types lthy [] 0 [] [] perm_actual_Ts;
  30.497 +    val perm_frozen_gen_Ts = map Logic.unvarifyT_global perm_gen_Ts;
  30.498  
  30.499      val missing_Ts = perm_Ts |> subtract (op =) actual_Ts;
  30.500      val Ts = actual_Ts @ missing_Ts;
  30.501 @@ -241,6 +366,8 @@
  30.502      val nn = length Ts;
  30.503      val kks = 0 upto nn - 1;
  30.504  
  30.505 +    val callssss0 = pad_list [] nn actual_callssss0;
  30.506 +
  30.507      val common_name = mk_common_name (map Binding.name_of actual_bs);
  30.508      val bs = pad_list (Binding.name common_name) nn actual_bs;
  30.509  
  30.510 @@ -249,16 +376,19 @@
  30.511  
  30.512      val perm_bs = permute bs;
  30.513      val perm_kks = permute kks;
  30.514 +    val perm_callssss0 = permute callssss0;
  30.515      val perm_fp_sugars0 = map (the o fp_sugar_of lthy o fst o dest_Type) perm_Ts;
  30.516  
  30.517 -    val mutualize = exists (fn Type (_, ty_args) => ty_args <> ty_args0) Ts;
  30.518 -    val perm_callssss = pad_and_indexify_calls perm_fp_sugars0 nn actual_callssss0;
  30.519 +    val perm_callssss = map2 indexify_callsss perm_fp_sugars0 perm_callssss0;
  30.520  
  30.521      val get_perm_indices = map (fn kk => find_index (curry (op =) kk) perm_kks) o get_indices;
  30.522  
  30.523      val ((perm_fp_sugars, fp_sugar_thms), lthy) =
  30.524 -      mutualize_fp_sugars mutualize fp perm_bs perm_Ts get_perm_indices perm_callssss
  30.525 -        perm_fp_sugars0 lthy;
  30.526 +      if num_groups > 1 then
  30.527 +        mutualize_fp_sugars fp perm_bs perm_frozen_gen_Ts get_perm_indices perm_callssss
  30.528 +          perm_fp_sugars0 lthy
  30.529 +      else
  30.530 +        ((perm_fp_sugars0, (NONE, NONE)), lthy);
  30.531  
  30.532      val fp_sugars = unpermute perm_fp_sugars;
  30.533    in
    31.1 --- a/src/HOL/BNF/Tools/bnf_fp_rec_sugar.ML	Mon Nov 11 17:34:44 2013 +0100
    31.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    31.3 @@ -1,986 +0,0 @@
    31.4 -(*  Title:      HOL/BNF/Tools/bnf_fp_rec_sugar.ML
    31.5 -    Author:     Lorenz Panny, TU Muenchen
    31.6 -    Copyright   2013
    31.7 -
    31.8 -Recursor and corecursor sugar.
    31.9 -*)
   31.10 -
   31.11 -signature BNF_FP_REC_SUGAR =
   31.12 -sig
   31.13 -  val add_primrec: (binding * typ option * mixfix) list ->
   31.14 -    (Attrib.binding * term) list -> local_theory -> (term list * thm list list) * local_theory
   31.15 -  val add_primrec_cmd: (binding * string option * mixfix) list ->
   31.16 -    (Attrib.binding * string) list -> local_theory -> (term list * thm list list) * local_theory
   31.17 -  val add_primrec_global: (binding * typ option * mixfix) list ->
   31.18 -    (Attrib.binding * term) list -> theory -> (term list * thm list list) * theory
   31.19 -  val add_primrec_overloaded: (string * (string * typ) * bool) list ->
   31.20 -    (binding * typ option * mixfix) list ->
   31.21 -    (Attrib.binding * term) list -> theory -> (term list * thm list list) * theory
   31.22 -  val add_primrec_simple: ((binding * typ) * mixfix) list -> term list ->
   31.23 -    local_theory -> (string list * (term list * (int list list * thm list list))) * local_theory
   31.24 -  val add_primcorecursive_cmd: bool ->
   31.25 -    (binding * string option * mixfix) list * ((Attrib.binding * string) * string option) list ->
   31.26 -    Proof.context -> Proof.state
   31.27 -  val add_primcorec_cmd: bool ->
   31.28 -    (binding * string option * mixfix) list * ((Attrib.binding * string) * string option) list ->
   31.29 -    local_theory -> local_theory
   31.30 -end;
   31.31 -
   31.32 -structure BNF_FP_Rec_Sugar : BNF_FP_REC_SUGAR =
   31.33 -struct
   31.34 -
   31.35 -open BNF_Util
   31.36 -open BNF_FP_Util
   31.37 -open BNF_FP_Rec_Sugar_Util
   31.38 -open BNF_FP_Rec_Sugar_Tactics
   31.39 -
   31.40 -val codeN = "code"
   31.41 -val ctrN = "ctr"
   31.42 -val discN = "disc"
   31.43 -val selN = "sel"
   31.44 -
   31.45 -val nitpick_attrs = @{attributes [nitpick_simp]};
   31.46 -val simp_attrs = @{attributes [simp]};
   31.47 -val code_nitpick_attrs = Code.add_default_eqn_attrib :: nitpick_attrs;
   31.48 -val code_nitpick_simp_attrs = Code.add_default_eqn_attrib :: nitpick_attrs @ simp_attrs;
   31.49 -
   31.50 -exception Primrec_Error of string * term list;
   31.51 -
   31.52 -fun primrec_error str = raise Primrec_Error (str, []);
   31.53 -fun primrec_error_eqn str eqn = raise Primrec_Error (str, [eqn]);
   31.54 -fun primrec_error_eqns str eqns = raise Primrec_Error (str, eqns);
   31.55 -
   31.56 -fun finds eq = fold_map (fn x => List.partition (curry eq x) #>> pair x);
   31.57 -
   31.58 -val free_name = try (fn Free (v, _) => v);
   31.59 -val const_name = try (fn Const (v, _) => v);
   31.60 -val undef_const = Const (@{const_name undefined}, dummyT);
   31.61 -
   31.62 -fun permute_args n t = list_comb (t, map Bound (0 :: (n downto 1)))
   31.63 -  |> fold (K (Term.abs (Name.uu, dummyT))) (0 upto n);
   31.64 -val abs_tuple = HOLogic.tupled_lambda o HOLogic.mk_tuple;
   31.65 -fun drop_All t = subst_bounds (strip_qnt_vars @{const_name all} t |> map Free |> rev,
   31.66 -  strip_qnt_body @{const_name all} t)
   31.67 -fun abstract vs =
   31.68 -  let fun a n (t $ u) = a n t $ a n u
   31.69 -        | a n (Abs (v, T, b)) = Abs (v, T, a (n + 1) b)
   31.70 -        | a n t = let val idx = find_index (equal t) vs in
   31.71 -            if idx < 0 then t else Bound (n + idx) end
   31.72 -  in a 0 end;
   31.73 -fun mk_prod1 Ts (t, u) = HOLogic.pair_const (fastype_of1 (Ts, t)) (fastype_of1 (Ts, u)) $ t $ u;
   31.74 -fun mk_tuple1 Ts = the_default HOLogic.unit o try (foldr1 (mk_prod1 Ts));
   31.75 -
   31.76 -fun get_indices fixes t = map (fst #>> Binding.name_of #> Free) fixes
   31.77 -  |> map_index (fn (i, v) => if exists_subterm (equal v) t then SOME i else NONE)
   31.78 -  |> map_filter I;
   31.79 -
   31.80 -
   31.81 -(* Primrec *)
   31.82 -
   31.83 -type eqn_data = {
   31.84 -  fun_name: string,
   31.85 -  rec_type: typ,
   31.86 -  ctr: term,
   31.87 -  ctr_args: term list,
   31.88 -  left_args: term list,
   31.89 -  right_args: term list,
   31.90 -  res_type: typ,
   31.91 -  rhs_term: term,
   31.92 -  user_eqn: term
   31.93 -};
   31.94 -
   31.95 -fun dissect_eqn lthy fun_names eqn' =
   31.96 -  let
   31.97 -    val eqn = drop_All eqn' |> HOLogic.dest_Trueprop
   31.98 -      handle TERM _ =>
   31.99 -        primrec_error_eqn "malformed function equation (expected \"lhs = rhs\")" eqn';
  31.100 -    val (lhs, rhs) = HOLogic.dest_eq eqn
  31.101 -        handle TERM _ =>
  31.102 -          primrec_error_eqn "malformed function equation (expected \"lhs = rhs\")" eqn';
  31.103 -    val (fun_name, args) = strip_comb lhs
  31.104 -      |>> (fn x => if is_Free x then fst (dest_Free x)
  31.105 -          else primrec_error_eqn "malformed function equation (does not start with free)" eqn);
  31.106 -    val (left_args, rest) = take_prefix is_Free args;
  31.107 -    val (nonfrees, right_args) = take_suffix is_Free rest;
  31.108 -    val num_nonfrees = length nonfrees;
  31.109 -    val _ = num_nonfrees = 1 orelse if num_nonfrees = 0 then
  31.110 -      primrec_error_eqn "constructor pattern missing in left-hand side" eqn else
  31.111 -      primrec_error_eqn "more than one non-variable argument in left-hand side" eqn;
  31.112 -    val _ = member (op =) fun_names fun_name orelse
  31.113 -      primrec_error_eqn "malformed function equation (does not start with function name)" eqn
  31.114 -
  31.115 -    val (ctr, ctr_args) = strip_comb (the_single nonfrees);
  31.116 -    val _ = try (num_binder_types o fastype_of) ctr = SOME (length ctr_args) orelse
  31.117 -      primrec_error_eqn "partially applied constructor in pattern" eqn;
  31.118 -    val _ = let val d = duplicates (op =) (left_args @ ctr_args @ right_args) in null d orelse
  31.119 -      primrec_error_eqn ("duplicate variable \"" ^ Syntax.string_of_term lthy (hd d) ^
  31.120 -        "\" in left-hand side") eqn end;
  31.121 -    val _ = forall is_Free ctr_args orelse
  31.122 -      primrec_error_eqn "non-primitive pattern in left-hand side" eqn;
  31.123 -    val _ =
  31.124 -      let val b = fold_aterms (fn x as Free (v, _) =>
  31.125 -        if (not (member (op =) (left_args @ ctr_args @ right_args) x) andalso
  31.126 -        not (member (op =) fun_names v) andalso
  31.127 -        not (Variable.is_fixed lthy v)) then cons x else I | _ => I) rhs []
  31.128 -      in
  31.129 -        null b orelse
  31.130 -        primrec_error_eqn ("extra variable(s) in right-hand side: " ^
  31.131 -          commas (map (Syntax.string_of_term lthy) b)) eqn
  31.132 -      end;
  31.133 -  in
  31.134 -    {fun_name = fun_name,
  31.135 -     rec_type = body_type (type_of ctr),
  31.136 -     ctr = ctr,
  31.137 -     ctr_args = ctr_args,
  31.138 -     left_args = left_args,
  31.139 -     right_args = right_args,
  31.140 -     res_type = map fastype_of (left_args @ right_args) ---> fastype_of rhs,
  31.141 -     rhs_term = rhs,
  31.142 -     user_eqn = eqn'}
  31.143 -  end;
  31.144 -
  31.145 -fun rewrite_map_arg get_ctr_pos rec_type res_type =
  31.146 -  let
  31.147 -    val pT = HOLogic.mk_prodT (rec_type, res_type);
  31.148 -
  31.149 -    val maybe_suc = Option.map (fn x => x + 1);
  31.150 -    fun subst d (t as Bound d') = t |> d = SOME d' ? curry (op $) (fst_const pT)
  31.151 -      | subst d (Abs (v, T, b)) = Abs (v, if d = SOME ~1 then pT else T, subst (maybe_suc d) b)
  31.152 -      | subst d t =
  31.153 -        let
  31.154 -          val (u, vs) = strip_comb t;
  31.155 -          val ctr_pos = try (get_ctr_pos o the) (free_name u) |> the_default ~1;
  31.156 -        in
  31.157 -          if ctr_pos >= 0 then
  31.158 -            if d = SOME ~1 andalso length vs = ctr_pos then
  31.159 -              list_comb (permute_args ctr_pos (snd_const pT), vs)
  31.160 -            else if length vs > ctr_pos andalso is_some d
  31.161 -                andalso d = try (fn Bound n => n) (nth vs ctr_pos) then
  31.162 -              list_comb (snd_const pT $ nth vs ctr_pos, map (subst d) (nth_drop ctr_pos vs))
  31.163 -            else
  31.164 -              primrec_error_eqn ("recursive call not directly applied to constructor argument") t
  31.165 -          else if d = SOME ~1 andalso const_name u = SOME @{const_name comp} then
  31.166 -            list_comb (map_types (K dummyT) u, map2 subst [NONE, d] vs)
  31.167 -          else
  31.168 -            list_comb (u, map (subst (d |> d = SOME ~1 ? K NONE)) vs)
  31.169 -        end
  31.170 -  in
  31.171 -    subst (SOME ~1)
  31.172 -  end;
  31.173 -
  31.174 -fun subst_rec_calls lthy get_ctr_pos has_call ctr_args direct_calls indirect_calls t =
  31.175 -  let
  31.176 -    fun subst bound_Ts (Abs (v, T, b)) = Abs (v, T, subst (T :: bound_Ts) b)
  31.177 -      | subst bound_Ts (t as g' $ y) =
  31.178 -        let
  31.179 -          val maybe_direct_y' = AList.lookup (op =) direct_calls y;
  31.180 -          val maybe_indirect_y' = AList.lookup (op =) indirect_calls y;
  31.181 -          val (g, g_args) = strip_comb g';
  31.182 -          val ctr_pos = try (get_ctr_pos o the) (free_name g) |> the_default ~1;
  31.183 -          val _ = ctr_pos < 0 orelse length g_args >= ctr_pos orelse
  31.184 -            primrec_error_eqn "too few arguments in recursive call" t;
  31.185 -        in
  31.186 -          if not (member (op =) ctr_args y) then
  31.187 -            pairself (subst bound_Ts) (g', y) |> (op $)
  31.188 -          else if ctr_pos >= 0 then
  31.189 -            list_comb (the maybe_direct_y', g_args)
  31.190 -          else if is_some maybe_indirect_y' then
  31.191 -            (if has_call g' then t else y)
  31.192 -            |> massage_indirect_rec_call lthy has_call
  31.193 -              (rewrite_map_arg get_ctr_pos) bound_Ts y (the maybe_indirect_y')
  31.194 -            |> (if has_call g' then I else curry (op $) g')
  31.195 -          else
  31.196 -            t
  31.197 -        end
  31.198 -      | subst _ t = t
  31.199 -  in
  31.200 -    subst [] t
  31.201 -    |> tap (fn u => has_call u andalso (* FIXME detect this case earlier *)
  31.202 -      primrec_error_eqn "recursive call not directly applied to constructor argument" t)
  31.203 -  end;
  31.204 -
  31.205 -fun build_rec_arg lthy (funs_data : eqn_data list list) has_call (ctr_spec : rec_ctr_spec)
  31.206 -    (maybe_eqn_data : eqn_data option) =
  31.207 -  if is_none maybe_eqn_data then undef_const else
  31.208 -    let
  31.209 -      val eqn_data = the maybe_eqn_data;
  31.210 -      val t = #rhs_term eqn_data;
  31.211 -      val ctr_args = #ctr_args eqn_data;
  31.212 -
  31.213 -      val calls = #calls ctr_spec;
  31.214 -      val n_args = fold (curry (op +) o (fn Direct_Rec _ => 2 | _ => 1)) calls 0;
  31.215 -
  31.216 -      val no_calls' = tag_list 0 calls
  31.217 -        |> map_filter (try (apsnd (fn No_Rec n => n | Direct_Rec (n, _) => n)));
  31.218 -      val direct_calls' = tag_list 0 calls
  31.219 -        |> map_filter (try (apsnd (fn Direct_Rec (_, n) => n)));
  31.220 -      val indirect_calls' = tag_list 0 calls
  31.221 -        |> map_filter (try (apsnd (fn Indirect_Rec n => n)));
  31.222 -
  31.223 -      fun make_direct_type _ = dummyT; (* FIXME? *)
  31.224 -
  31.225 -      val rec_res_type_list = map (fn (x :: _) => (#rec_type x, #res_type x)) funs_data;
  31.226 -
  31.227 -      fun make_indirect_type (Type (Tname, Ts)) = Type (Tname, Ts |> map (fn T =>
  31.228 -        let val maybe_res_type = AList.lookup (op =) rec_res_type_list T in
  31.229 -          if is_some maybe_res_type
  31.230 -          then HOLogic.mk_prodT (T, the maybe_res_type)
  31.231 -          else make_indirect_type T end))
  31.232 -        | make_indirect_type T = T;
  31.233 -
  31.234 -      val args = replicate n_args ("", dummyT)
  31.235 -        |> Term.rename_wrt_term t
  31.236 -        |> map Free
  31.237 -        |> fold (fn (ctr_arg_idx, arg_idx) =>
  31.238 -            nth_map arg_idx (K (nth ctr_args ctr_arg_idx)))
  31.239 -          no_calls'
  31.240 -        |> fold (fn (ctr_arg_idx, arg_idx) =>
  31.241 -            nth_map arg_idx (K (nth ctr_args ctr_arg_idx |> map_types make_direct_type)))
  31.242 -          direct_calls'
  31.243 -        |> fold (fn (ctr_arg_idx, arg_idx) =>
  31.244 -            nth_map arg_idx (K (nth ctr_args ctr_arg_idx |> map_types make_indirect_type)))
  31.245 -          indirect_calls';
  31.246 -
  31.247 -      val fun_name_ctr_pos_list =
  31.248 -        map (fn (x :: _) => (#fun_name x, length (#left_args x))) funs_data;
  31.249 -      val get_ctr_pos = try (the o AList.lookup (op =) fun_name_ctr_pos_list) #> the_default ~1;
  31.250 -      val direct_calls = map (apfst (nth ctr_args) o apsnd (nth args)) direct_calls';
  31.251 -      val indirect_calls = map (apfst (nth ctr_args) o apsnd (nth args)) indirect_calls';
  31.252 -
  31.253 -      val abstractions = args @ #left_args eqn_data @ #right_args eqn_data;
  31.254 -    in
  31.255 -      t
  31.256 -      |> subst_rec_calls lthy get_ctr_pos has_call ctr_args direct_calls indirect_calls
  31.257 -      |> fold_rev lambda abstractions
  31.258 -    end;
  31.259 -
  31.260 -fun build_defs lthy bs mxs (funs_data : eqn_data list list) (rec_specs : rec_spec list) has_call =
  31.261 -  let
  31.262 -    val n_funs = length funs_data;
  31.263 -
  31.264 -    val ctr_spec_eqn_data_list' =
  31.265 -      (take n_funs rec_specs |> map #ctr_specs) ~~ funs_data
  31.266 -      |> maps (uncurry (finds (fn (x, y) => #ctr x = #ctr y))
  31.267 -          ##> (fn x => null x orelse
  31.268 -            primrec_error_eqns "excess equations in definition" (map #rhs_term x)) #> fst);
  31.269 -    val _ = ctr_spec_eqn_data_list' |> map (fn (_, x) => length x <= 1 orelse
  31.270 -      primrec_error_eqns ("multiple equations for constructor") (map #user_eqn x));
  31.271 -
  31.272 -    val ctr_spec_eqn_data_list =
  31.273 -      ctr_spec_eqn_data_list' @ (drop n_funs rec_specs |> maps #ctr_specs |> map (rpair []));
  31.274 -
  31.275 -    val recs = take n_funs rec_specs |> map #recx;
  31.276 -    val rec_args = ctr_spec_eqn_data_list
  31.277 -      |> sort ((op <) o pairself (#offset o fst) |> make_ord)
  31.278 -      |> map (uncurry (build_rec_arg lthy funs_data has_call) o apsnd (try the_single));
  31.279 -    val ctr_poss = map (fn x =>
  31.280 -      if length (distinct ((op =) o pairself (length o #left_args)) x) <> 1 then
  31.281 -        primrec_error ("inconstant constructor pattern position for function " ^
  31.282 -          quote (#fun_name (hd x)))
  31.283 -      else
  31.284 -        hd x |> #left_args |> length) funs_data;
  31.285 -  in
  31.286 -    (recs, ctr_poss)
  31.287 -    |-> map2 (fn recx => fn ctr_pos => list_comb (recx, rec_args) |> permute_args ctr_pos)
  31.288 -    |> Syntax.check_terms lthy
  31.289 -    |> map3 (fn b => fn mx => fn t => ((b, mx), ((Binding.map_name Thm.def_name b, []), t))) bs mxs
  31.290 -  end;
  31.291 -
  31.292 -fun find_rec_calls has_call (eqn_data : eqn_data) =
  31.293 -  let
  31.294 -    fun find (Abs (_, _, b)) ctr_arg = find b ctr_arg
  31.295 -      | find (t as _ $ _) ctr_arg =
  31.296 -        let
  31.297 -          val (f', args') = strip_comb t;
  31.298 -          val n = find_index (equal ctr_arg) args';
  31.299 -        in
  31.300 -          if n < 0 then
  31.301 -            find f' ctr_arg @ maps (fn x => find x ctr_arg) args'
  31.302 -          else
  31.303 -            let val (f, args) = chop n args' |>> curry list_comb f' in
  31.304 -              if has_call f then
  31.305 -                f :: maps (fn x => find x ctr_arg) args
  31.306 -              else
  31.307 -                find f ctr_arg @ maps (fn x => find x ctr_arg) args
  31.308 -            end
  31.309 -        end
  31.310 -      | find _ _ = [];
  31.311 -  in
  31.312 -    map (find (#rhs_term eqn_data)) (#ctr_args eqn_data)
  31.313 -    |> (fn [] => NONE | callss => SOME (#ctr eqn_data, callss))
  31.314 -  end;
  31.315 -
  31.316 -fun prepare_primrec fixes specs lthy =
  31.317 -  let
  31.318 -    val (bs, mxs) = map_split (apfst fst) fixes;
  31.319 -    val fun_names = map Binding.name_of bs;
  31.320 -    val eqns_data = map (dissect_eqn lthy fun_names) specs;
  31.321 -    val funs_data = eqns_data
  31.322 -      |> partition_eq ((op =) o pairself #fun_name)
  31.323 -      |> finds (fn (x, y) => x = #fun_name (hd y)) fun_names |> fst
  31.324 -      |> map (fn (x, y) => the_single y handle List.Empty =>
  31.325 -          primrec_error ("missing equations for function " ^ quote x));
  31.326 -
  31.327 -    val has_call = exists_subterm (map (fst #>> Binding.name_of #> Free) fixes |> member (op =));
  31.328 -    val arg_Ts = map (#rec_type o hd) funs_data;
  31.329 -    val res_Ts = map (#res_type o hd) funs_data;
  31.330 -    val callssss = funs_data
  31.331 -      |> map (partition_eq ((op =) o pairself #ctr))
  31.332 -      |> map (maps (map_filter (find_rec_calls has_call)));
  31.333 -
  31.334 -    val ((n2m, rec_specs, _, induct_thm, induct_thms), lthy') =
  31.335 -      rec_specs_of bs arg_Ts res_Ts (get_indices fixes) callssss lthy;
  31.336 -
  31.337 -    val actual_nn = length funs_data;
  31.338 -
  31.339 -    val _ = let val ctrs = (maps (map #ctr o #ctr_specs) rec_specs) in
  31.340 -      map (fn {ctr, user_eqn, ...} => member (op =) ctrs ctr orelse
  31.341 -        primrec_error_eqn ("argument " ^ quote (Syntax.string_of_term lthy' ctr) ^
  31.342 -          " is not a constructor in left-hand side") user_eqn) eqns_data end;
  31.343 -
  31.344 -    val defs = build_defs lthy' bs mxs funs_data rec_specs has_call;
  31.345 -
  31.346 -    fun prove lthy def_thms' ({ctr_specs, nested_map_idents, nested_map_comps, ...} : rec_spec)
  31.347 -        (fun_data : eqn_data list) =
  31.348 -      let
  31.349 -        val def_thms = map (snd o snd) def_thms';
  31.350 -        val simp_thmss = finds (fn (x, y) => #ctr x = #ctr y) fun_data ctr_specs
  31.351 -          |> fst
  31.352 -          |> map_filter (try (fn (x, [y]) =>
  31.353 -            (#user_eqn x, length (#left_args x) + length (#right_args x), #rec_thm y)))
  31.354 -          |> map (fn (user_eqn, num_extra_args, rec_thm) =>
  31.355 -            mk_primrec_tac lthy num_extra_args nested_map_idents nested_map_comps def_thms rec_thm
  31.356 -            |> K |> Goal.prove lthy [] [] user_eqn);
  31.357 -        val poss = find_indices (fn (x, y) => #ctr x = #ctr y) fun_data eqns_data;
  31.358 -      in
  31.359 -        (poss, simp_thmss)
  31.360 -      end;
  31.361 -
  31.362 -    val notes =
  31.363 -      (if n2m then map2 (fn name => fn thm =>
  31.364 -        (name, inductN, [thm], [])) fun_names (take actual_nn induct_thms) else [])
  31.365 -      |> map (fn (prefix, thmN, thms, attrs) =>
  31.366 -        ((Binding.qualify true prefix (Binding.name thmN), attrs), [(thms, [])]));
  31.367 -
  31.368 -    val common_name = mk_common_name fun_names;
  31.369 -
  31.370 -    val common_notes =
  31.371 -      (if n2m then [(inductN, [induct_thm], [])] else [])
  31.372 -      |> map (fn (thmN, thms, attrs) =>
  31.373 -        ((Binding.qualify true common_name (Binding.name thmN), attrs), [(thms, [])]));
  31.374 -  in
  31.375 -    (((fun_names, defs),
  31.376 -      fn lthy => fn defs =>
  31.377 -        split_list (map2 (prove lthy defs) (take actual_nn rec_specs) funs_data)),
  31.378 -      lthy' |> Local_Theory.notes (notes @ common_notes) |> snd)
  31.379 -  end;
  31.380 -
  31.381 -(* primrec definition *)
  31.382 -
  31.383 -fun add_primrec_simple fixes ts lthy =
  31.384 -  let
  31.385 -    val (((names, defs), prove), lthy) = prepare_primrec fixes ts lthy
  31.386 -      handle ERROR str => primrec_error str;
  31.387 -  in
  31.388 -    lthy
  31.389 -    |> fold_map Local_Theory.define defs
  31.390 -    |-> (fn defs => `(fn lthy => (names, (map fst defs, prove lthy defs))))
  31.391 -  end
  31.392 -  handle Primrec_Error (str, eqns) =>
  31.393 -    if null eqns
  31.394 -    then error ("primrec_new error:\n  " ^ str)
  31.395 -    else error ("primrec_new error:\n  " ^ str ^ "\nin\n  " ^
  31.396 -      space_implode "\n  " (map (quote o Syntax.string_of_term lthy) eqns));
  31.397 -
  31.398 -local
  31.399 -
  31.400 -fun gen_primrec prep_spec (raw_fixes : (binding * 'a option * mixfix) list) raw_spec lthy =
  31.401 -  let
  31.402 -    val d = duplicates (op =) (map (Binding.name_of o #1) raw_fixes)
  31.403 -    val _ = null d orelse primrec_error ("duplicate function name(s): " ^ commas d);
  31.404 -
  31.405 -    val (fixes, specs) = fst (prep_spec raw_fixes raw_spec lthy);
  31.406 -
  31.407 -    val mk_notes =
  31.408 -      flat ooo map3 (fn poss => fn prefix => fn thms =>
  31.409 -        let
  31.410 -          val (bs, attrss) = map_split (fst o nth specs) poss;
  31.411 -          val notes =
  31.412 -            map3 (fn b => fn attrs => fn thm =>
  31.413 -              ((Binding.qualify false prefix b, code_nitpick_simp_attrs @ attrs), [([thm], [])]))
  31.414 -            bs attrss thms;
  31.415 -        in
  31.416 -          ((Binding.qualify true prefix (Binding.name simpsN), []), [(thms, [])]) :: notes
  31.417 -        end);
  31.418 -  in
  31.419 -    lthy
  31.420 -    |> add_primrec_simple fixes (map snd specs)
  31.421 -    |-> (fn (names, (ts, (posss, simpss))) =>
  31.422 -      Spec_Rules.add Spec_Rules.Equational (ts, flat simpss)
  31.423 -      #> Local_Theory.notes (mk_notes posss names simpss)
  31.424 -      #>> pair ts o map snd)
  31.425 -  end;
  31.426 -
  31.427 -in
  31.428 -
  31.429 -val add_primrec = gen_primrec Specification.check_spec;
  31.430 -val add_primrec_cmd = gen_primrec Specification.read_spec;
  31.431 -
  31.432 -end;
  31.433 -
  31.434 -fun add_primrec_global fixes specs thy =
  31.435 -  let
  31.436 -    val lthy = Named_Target.theory_init thy;
  31.437 -    val ((ts, simps), lthy') = add_primrec fixes specs lthy;
  31.438 -    val simps' = burrow (Proof_Context.export lthy' lthy) simps;
  31.439 -  in ((ts, simps'), Local_Theory.exit_global lthy') end;
  31.440 -
  31.441 -fun add_primrec_overloaded ops fixes specs thy =
  31.442 -  let
  31.443 -    val lthy = Overloading.overloading ops thy;
  31.444 -    val ((ts, simps), lthy') = add_primrec fixes specs lthy;
  31.445 -    val simps' = burrow (Proof_Context.export lthy' lthy) simps;
  31.446 -  in ((ts, simps'), Local_Theory.exit_global lthy') end;
  31.447 -
  31.448 -
  31.449 -
  31.450 -(* Primcorec *)
  31.451 -
  31.452 -type co_eqn_data_disc = {
  31.453 -  fun_name: string,
  31.454 -  fun_T: typ,
  31.455 -  fun_args: term list,
  31.456 -  ctr: term,
  31.457 -  ctr_no: int, (*###*)
  31.458 -  disc: term,
  31.459 -  prems: term list,
  31.460 -  auto_gen: bool,
  31.461 -  user_eqn: term
  31.462 -};
  31.463 -
  31.464 -type co_eqn_data_sel = {
  31.465 -  fun_name: string,
  31.466 -  fun_T: typ,
  31.467 -  fun_args: term list,
  31.468 -  ctr: term,
  31.469 -  sel: term,
  31.470 -  rhs_term: term,
  31.471 -  user_eqn: term
  31.472 -};
  31.473 -
  31.474 -datatype co_eqn_data =
  31.475 -  Disc of co_eqn_data_disc |
  31.476 -  Sel of co_eqn_data_sel;
  31.477 -
  31.478 -fun co_dissect_eqn_disc sequential fun_names (corec_specs : corec_spec list) prems' concl
  31.479 -    matchedsss =
  31.480 -  let
  31.481 -    fun find_subterm p = let (* FIXME \<exists>? *)
  31.482 -      fun f (t as u $ v) = if p t then SOME t else merge_options (f u, f v)
  31.483 -        | f t = if p t then SOME t else NONE
  31.484 -      in f end;
  31.485 -
  31.486 -    val applied_fun = concl
  31.487 -      |> find_subterm (member ((op =) o apsnd SOME) fun_names o try (fst o dest_Free o head_of))
  31.488 -      |> the
  31.489 -      handle Option.Option => primrec_error_eqn "malformed discriminator equation" concl;
  31.490 -    val ((fun_name, fun_T), fun_args) = strip_comb applied_fun |>> dest_Free;
  31.491 -    val {ctr_specs, ...} = the (AList.lookup (op =) (fun_names ~~ corec_specs) fun_name);
  31.492 -
  31.493 -    val discs = map #disc ctr_specs;
  31.494 -    val ctrs = map #ctr ctr_specs;
  31.495 -    val not_disc = head_of concl = @{term Not};
  31.496 -    val _ = not_disc andalso length ctrs <> 2 andalso
  31.497 -      primrec_error_eqn "\<not>ed discriminator for a type with \<noteq> 2 constructors" concl;
  31.498 -    val disc = find_subterm (member (op =) discs o head_of) concl;
  31.499 -    val eq_ctr0 = concl |> perhaps (try (HOLogic.dest_not)) |> try (HOLogic.dest_eq #> snd)
  31.500 -        |> (fn SOME t => let val n = find_index (equal t) ctrs in
  31.501 -          if n >= 0 then SOME n else NONE end | _ => NONE);
  31.502 -    val _ = is_some disc orelse is_some eq_ctr0 orelse
  31.503 -      primrec_error_eqn "no discriminator in equation" concl;
  31.504 -    val ctr_no' =
  31.505 -      if is_none disc then the eq_ctr0 else find_index (equal (head_of (the disc))) discs;
  31.506 -    val ctr_no = if not_disc then 1 - ctr_no' else ctr_no';
  31.507 -    val ctr = #ctr (nth ctr_specs ctr_no);
  31.508 -
  31.509 -    val catch_all = try (fst o dest_Free o the_single) prems' = SOME Name.uu_;
  31.510 -    val matchedss = AList.lookup (op =) matchedsss fun_name |> the_default [];
  31.511 -    val prems = map (abstract (List.rev fun_args)) prems';
  31.512 -    val real_prems =
  31.513 -      (if catch_all orelse sequential then maps negate_disj matchedss else []) @
  31.514 -      (if catch_all then [] else prems);
  31.515 -
  31.516 -    val matchedsss' = AList.delete (op =) fun_name matchedsss
  31.517 -      |> cons (fun_name, if sequential then matchedss @ [prems] else matchedss @ [real_prems]);
  31.518 -
  31.519 -    val user_eqn =
  31.520 -      (real_prems, betapply (#disc (nth ctr_specs ctr_no), applied_fun))
  31.521 -      |>> map HOLogic.mk_Trueprop ||> HOLogic.mk_Trueprop
  31.522 -      |> Logic.list_implies;
  31.523 -  in
  31.524 -    (Disc {
  31.525 -      fun_name = fun_name,
  31.526 -      fun_T = fun_T,
  31.527 -      fun_args = fun_args,
  31.528 -      ctr = ctr,
  31.529 -      ctr_no = ctr_no,
  31.530 -      disc = #disc (nth ctr_specs ctr_no),
  31.531 -      prems = real_prems,
  31.532 -      auto_gen = catch_all,
  31.533 -      user_eqn = user_eqn
  31.534 -    }, matchedsss')
  31.535 -  end;
  31.536 -
  31.537 -fun co_dissect_eqn_sel fun_names (corec_specs : corec_spec list) eqn' of_spec eqn =
  31.538 -  let
  31.539 -    val (lhs, rhs) = HOLogic.dest_eq eqn
  31.540 -      handle TERM _ =>
  31.541 -        primrec_error_eqn "malformed function equation (expected \"lhs = rhs\")" eqn;
  31.542 -    val sel = head_of lhs;
  31.543 -    val ((fun_name, fun_T), fun_args) = dest_comb lhs |> snd |> strip_comb |> apfst dest_Free
  31.544 -      handle TERM _ =>
  31.545 -        primrec_error_eqn "malformed selector argument in left-hand side" eqn;
  31.546 -    val corec_spec = the (AList.lookup (op =) (fun_names ~~ corec_specs) fun_name)
  31.547 -      handle Option.Option => primrec_error_eqn "malformed selector argument in left-hand side" eqn;
  31.548 -    val ctr_spec =
  31.549 -      if is_some of_spec
  31.550 -      then the (find_first (equal (the of_spec) o #ctr) (#ctr_specs corec_spec))
  31.551 -      else #ctr_specs corec_spec |> filter (exists (equal sel) o #sels) |> the_single
  31.552 -        handle List.Empty => primrec_error_eqn "ambiguous selector - use \"of\"" eqn;
  31.553 -    val user_eqn = drop_All eqn';
  31.554 -  in
  31.555 -    Sel {
  31.556 -      fun_name = fun_name,
  31.557 -      fun_T = fun_T,
  31.558 -      fun_args = fun_args,
  31.559 -      ctr = #ctr ctr_spec,
  31.560 -      sel = sel,
  31.561 -      rhs_term = rhs,
  31.562 -      user_eqn = user_eqn
  31.563 -    }
  31.564 -  end;
  31.565 -
  31.566 -fun co_dissect_eqn_ctr sequential fun_names (corec_specs : corec_spec list) eqn' imp_prems imp_rhs
  31.567 -    matchedsss =
  31.568 -  let
  31.569 -    val (lhs, rhs) = HOLogic.dest_eq imp_rhs;
  31.570 -    val fun_name = head_of lhs |> fst o dest_Free;
  31.571 -    val {ctr_specs, ...} = the (AList.lookup (op =) (fun_names ~~ corec_specs) fun_name);
  31.572 -    val (ctr, ctr_args) = strip_comb rhs;
  31.573 -    val {disc, sels, ...} = the (find_first (equal ctr o #ctr) ctr_specs)
  31.574 -      handle Option.Option => primrec_error_eqn "not a constructor" ctr;
  31.575 -
  31.576 -    val disc_imp_rhs = betapply (disc, lhs);
  31.577 -    val (maybe_eqn_data_disc, matchedsss') = if length ctr_specs = 1
  31.578 -      then (NONE, matchedsss)
  31.579 -      else apfst SOME (co_dissect_eqn_disc
  31.580 -          sequential fun_names corec_specs imp_prems disc_imp_rhs matchedsss);
  31.581 -
  31.582 -    val sel_imp_rhss = (sels ~~ ctr_args)
  31.583 -      |> map (fn (sel, ctr_arg) => HOLogic.mk_eq (betapply (sel, lhs), ctr_arg));
  31.584 -
  31.585 -(*
  31.586 -val _ = tracing ("reduced\n    " ^ Syntax.string_of_term @{context} imp_rhs ^ "\nto\n    \<cdot> " ^
  31.587 - (is_some maybe_eqn_data_disc ? K (Syntax.string_of_term @{context} disc_imp_rhs ^ "\n    \<cdot> ")) "" ^
  31.588 - space_implode "\n    \<cdot> " (map (Syntax.string_of_term @{context}) sel_imp_rhss));
  31.589 -*)
  31.590 -
  31.591 -    val eqns_data_sel =
  31.592 -      map (co_dissect_eqn_sel fun_names corec_specs eqn' (SOME ctr)) sel_imp_rhss;
  31.593 -  in
  31.594 -    (the_list maybe_eqn_data_disc @ eqns_data_sel, matchedsss')
  31.595 -  end;
  31.596 -
  31.597 -fun co_dissect_eqn sequential fun_names (corec_specs : corec_spec list) eqn' of_spec matchedsss =
  31.598 -  let
  31.599 -    val eqn = drop_All eqn'
  31.600 -      handle TERM _ => primrec_error_eqn "malformed function equation" eqn';
  31.601 -    val (imp_prems, imp_rhs) = Logic.strip_horn eqn
  31.602 -      |> apfst (map HOLogic.dest_Trueprop) o apsnd HOLogic.dest_Trueprop;
  31.603 -
  31.604 -    val head = imp_rhs
  31.605 -      |> perhaps (try HOLogic.dest_not) |> perhaps (try (fst o HOLogic.dest_eq))
  31.606 -      |> head_of;
  31.607 -
  31.608 -    val maybe_rhs = imp_rhs |> perhaps (try (HOLogic.dest_not)) |> try (snd o HOLogic.dest_eq);
  31.609 -
  31.610 -    val discs = maps #ctr_specs corec_specs |> map #disc;
  31.611 -    val sels = maps #ctr_specs corec_specs |> maps #sels;
  31.612 -    val ctrs = maps #ctr_specs corec_specs |> map #ctr;
  31.613 -  in
  31.614 -    if member (op =) discs head orelse
  31.615 -      is_some maybe_rhs andalso
  31.616 -        member (op =) (filter (null o binder_types o fastype_of) ctrs) (the maybe_rhs) then
  31.617 -      co_dissect_eqn_disc sequential fun_names corec_specs imp_prems imp_rhs matchedsss
  31.618 -      |>> single
  31.619 -    else if member (op =) sels head then
  31.620 -      ([co_dissect_eqn_sel fun_names corec_specs eqn' of_spec imp_rhs], matchedsss)
  31.621 -    else if is_Free head andalso member (op =) fun_names (fst (dest_Free head)) then
  31.622 -      co_dissect_eqn_ctr sequential fun_names corec_specs eqn' imp_prems imp_rhs matchedsss
  31.623 -    else
  31.624 -      primrec_error_eqn "malformed function equation" eqn
  31.625 -  end;
  31.626 -
  31.627 -fun build_corec_arg_disc (ctr_specs : corec_ctr_spec list)
  31.628 -    ({fun_args, ctr_no, prems, ...} : co_eqn_data_disc) =
  31.629 -  if is_none (#pred (nth ctr_specs ctr_no)) then I else
  31.630 -    mk_conjs prems
  31.631 -    |> curry subst_bounds (List.rev fun_args)
  31.632 -    |> HOLogic.tupled_lambda (HOLogic.mk_tuple fun_args)
  31.633 -    |> K |> nth_map (the (#pred (nth ctr_specs ctr_no)));
  31.634 -
  31.635 -fun build_corec_arg_no_call (sel_eqns : co_eqn_data_sel list) sel =
  31.636 -  find_first (equal sel o #sel) sel_eqns
  31.637 -  |> try (fn SOME {fun_args, rhs_term, ...} => abs_tuple fun_args rhs_term)
  31.638 -  |> the_default undef_const
  31.639 -  |> K;
  31.640 -
  31.641 -fun build_corec_args_direct_call lthy has_call (sel_eqns : co_eqn_data_sel list) sel =
  31.642 -  let
  31.643 -    val maybe_sel_eqn = find_first (equal sel o #sel) sel_eqns;
  31.644 -  in
  31.645 -    if is_none maybe_sel_eqn then (I, I, I) else
  31.646 -    let
  31.647 -      val {fun_args, rhs_term, ... } = the maybe_sel_eqn;
  31.648 -      fun rewrite_q _ t = if has_call t then @{term False} else @{term True};
  31.649 -      fun rewrite_g _ t = if has_call t then undef_const else t;
  31.650 -      fun rewrite_h bound_Ts t =
  31.651 -        if has_call t then mk_tuple1 bound_Ts (snd (strip_comb t)) else undef_const;
  31.652 -      fun massage f t = massage_direct_corec_call lthy has_call f [] rhs_term |> abs_tuple fun_args;
  31.653 -    in
  31.654 -      (massage rewrite_q,
  31.655 -       massage rewrite_g,
  31.656 -       massage rewrite_h)
  31.657 -    end
  31.658 -  end;
  31.659 -
  31.660 -fun build_corec_arg_indirect_call lthy has_call (sel_eqns : co_eqn_data_sel list) sel =
  31.661 -  let
  31.662 -    val maybe_sel_eqn = find_first (equal sel o #sel) sel_eqns;
  31.663 -  in
  31.664 -    if is_none maybe_sel_eqn then I else
  31.665 -    let
  31.666 -      val {fun_args, rhs_term, ...} = the maybe_sel_eqn;
  31.667 -      fun rewrite bound_Ts U T (Abs (v, V, b)) = Abs (v, V, rewrite (V :: bound_Ts) U T b)
  31.668 -        | rewrite bound_Ts U T (t as _ $ _) =
  31.669 -          let val (u, vs) = strip_comb t in
  31.670 -            if is_Free u andalso has_call u then
  31.671 -              Inr_const U T $ mk_tuple1 bound_Ts vs
  31.672 -            else if try (fst o dest_Const) u = SOME @{const_name prod_case} then
  31.673 -              map (rewrite bound_Ts U T) vs |> chop 1 |>> HOLogic.mk_split o the_single |> list_comb
  31.674 -            else
  31.675 -              list_comb (rewrite bound_Ts U T u, map (rewrite bound_Ts U T) vs)
  31.676 -          end
  31.677 -        | rewrite _ U T t =
  31.678 -          if is_Free t andalso has_call t then Inr_const U T $ HOLogic.unit else t;
  31.679 -      fun massage t =
  31.680 -        massage_indirect_corec_call lthy has_call rewrite [] (range_type (fastype_of t)) rhs_term
  31.681 -        |> abs_tuple fun_args;
  31.682 -    in
  31.683 -      massage
  31.684 -    end
  31.685 -  end;
  31.686 -
  31.687 -fun build_corec_args_sel lthy has_call (all_sel_eqns : co_eqn_data_sel list)
  31.688 -    (ctr_spec : corec_ctr_spec) =
  31.689 -  let val sel_eqns = filter (equal (#ctr ctr_spec) o #ctr) all_sel_eqns in
  31.690 -    if null sel_eqns then I else
  31.691 -      let
  31.692 -        val sel_call_list = #sels ctr_spec ~~ #calls ctr_spec;
  31.693 -
  31.694 -        val no_calls' = map_filter (try (apsnd (fn No_Corec n => n))) sel_call_list;
  31.695 -        val direct_calls' = map_filter (try (apsnd (fn Direct_Corec n => n))) sel_call_list;
  31.696 -        val indirect_calls' = map_filter (try (apsnd (fn Indirect_Corec n => n))) sel_call_list;
  31.697 -      in
  31.698 -        I
  31.699 -        #> fold (fn (sel, n) => nth_map n (build_corec_arg_no_call sel_eqns sel)) no_calls'
  31.700 -        #> fold (fn (sel, (q, g, h)) =>
  31.701 -          let val (fq, fg, fh) = build_corec_args_direct_call lthy has_call sel_eqns sel in
  31.702 -            nth_map q fq o nth_map g fg o nth_map h fh end) direct_calls'
  31.703 -        #> fold (fn (sel, n) => nth_map n
  31.704 -          (build_corec_arg_indirect_call lthy has_call sel_eqns sel)) indirect_calls'
  31.705 -      end
  31.706 -  end;
  31.707 -
  31.708 -fun co_build_defs lthy bs mxs has_call arg_Tss (corec_specs : corec_spec list)
  31.709 -    (disc_eqnss : co_eqn_data_disc list list) (sel_eqnss : co_eqn_data_sel list list) =
  31.710 -  let
  31.711 -    val corec_specs' = take (length bs) corec_specs;
  31.712 -    val corecs = map #corec corec_specs';
  31.713 -    val ctr_specss = map #ctr_specs corec_specs';
  31.714 -    val corec_args = hd corecs
  31.715 -      |> fst o split_last o binder_types o fastype_of
  31.716 -      |> map (Const o pair @{const_name undefined})
  31.717 -      |> fold2 (fold o build_corec_arg_disc) ctr_specss disc_eqnss
  31.718 -      |> fold2 (fold o build_corec_args_sel lthy has_call) sel_eqnss ctr_specss;
  31.719 -    fun currys [] t = t
  31.720 -      | currys Ts t = t $ mk_tuple1 (List.rev Ts) (map Bound (length Ts - 1 downto 0))
  31.721 -          |> fold_rev (Term.abs o pair Name.uu) Ts;
  31.722 -
  31.723 -(*
  31.724 -val _ = tracing ("corecursor arguments:\n    \<cdot> " ^
  31.725 - space_implode "\n    \<cdot> " (map (Syntax.string_of_term lthy) corec_args));
  31.726 -*)
  31.727 -
  31.728 -    val exclss' =
  31.729 -      disc_eqnss
  31.730 -      |> map (map (fn x => (#fun_args x, #ctr_no x, #prems x, #auto_gen x))
  31.731 -        #> fst o (fn xs => fold_map (fn x => fn ys => ((x, ys), ys @ [x])) xs [])
  31.732 -        #> maps (uncurry (map o pair)
  31.733 -          #> map (fn ((fun_args, c, x, a), (_, c', y, a')) =>
  31.734 -              ((c, c', a orelse a'), (x, s_not (mk_conjs y)))
  31.735 -            ||> apfst (map HOLogic.mk_Trueprop) o apsnd HOLogic.mk_Trueprop
  31.736 -            ||> Logic.list_implies
  31.737 -            ||> curry Logic.list_all (map dest_Free fun_args))))
  31.738 -  in
  31.739 -    map (list_comb o rpair corec_args) corecs
  31.740 -    |> map2 (fn Ts => fn t => if length Ts = 0 then t $ HOLogic.unit else t) arg_Tss
  31.741 -    |> map2 currys arg_Tss
  31.742 -    |> Syntax.check_terms lthy
  31.743 -    |> map3 (fn b => fn mx => fn t => ((b, mx), ((Binding.map_name Thm.def_name b, []), t))) bs mxs
  31.744 -    |> rpair exclss'
  31.745 -  end;
  31.746 -
  31.747 -fun mk_real_disc_eqns fun_binding arg_Ts ({ctr_specs, ...} : corec_spec)
  31.748 -    (sel_eqns : co_eqn_data_sel list) (disc_eqns : co_eqn_data_disc list) =
  31.749 -  if length disc_eqns <> length ctr_specs - 1 then disc_eqns else
  31.750 -    let
  31.751 -      val n = 0 upto length ctr_specs
  31.752 -        |> the o find_first (fn idx => not (exists (equal idx o #ctr_no) disc_eqns));
  31.753 -      val fun_args = (try (#fun_args o hd) disc_eqns, try (#fun_args o hd) sel_eqns)
  31.754 -        |> the_default (map (curry Free Name.uu) arg_Ts) o merge_options;
  31.755 -      val extra_disc_eqn = {
  31.756 -        fun_name = Binding.name_of fun_binding,
  31.757 -        fun_T = arg_Ts ---> body_type (fastype_of (#ctr (hd ctr_specs))),
  31.758 -        fun_args = fun_args,
  31.759 -        ctr = #ctr (nth ctr_specs n),
  31.760 -        ctr_no = n,
  31.761 -        disc = #disc (nth ctr_specs n),
  31.762 -        prems = maps (negate_conj o #prems) disc_eqns,
  31.763 -        auto_gen = true,
  31.764 -        user_eqn = undef_const};
  31.765 -    in
  31.766 -      chop n disc_eqns ||> cons extra_disc_eqn |> (op @)
  31.767 -    end;
  31.768 -
  31.769 -fun add_primcorec simple sequential fixes specs of_specs lthy =
  31.770 -  let
  31.771 -    val (bs, mxs) = map_split (apfst fst) fixes;
  31.772 -    val (arg_Ts, res_Ts) = map (strip_type o snd o fst #>> HOLogic.mk_tupleT) fixes |> split_list;
  31.773 -
  31.774 -    val callssss = []; (* FIXME *)
  31.775 -
  31.776 -    val ((n2m, corec_specs', _, coinduct_thm, strong_coinduct_thm, coinduct_thms,
  31.777 -          strong_coinduct_thms), lthy') =
  31.778 -      corec_specs_of bs arg_Ts res_Ts (get_indices fixes) callssss lthy;
  31.779 -
  31.780 -    val actual_nn = length bs;
  31.781 -    val fun_names = map Binding.name_of bs;
  31.782 -    val corec_specs = take actual_nn corec_specs'; (*###*)
  31.783 -
  31.784 -    val eqns_data =
  31.785 -      fold_map2 (co_dissect_eqn sequential fun_names corec_specs) (map snd specs) of_specs []
  31.786 -      |> flat o fst;
  31.787 -
  31.788 -    val disc_eqnss' = map_filter (try (fn Disc x => x)) eqns_data
  31.789 -      |> partition_eq ((op =) o pairself #fun_name)
  31.790 -      |> fst o finds (fn (x, ({fun_name, ...} :: _)) => x = fun_name) fun_names
  31.791 -      |> map (sort ((op <) o pairself #ctr_no |> make_ord) o flat o snd);
  31.792 -    val _ = disc_eqnss' |> map (fn x =>
  31.793 -      let val d = duplicates ((op =) o pairself #ctr_no) x in null d orelse
  31.794 -        primrec_error_eqns "excess discriminator equations in definition"
  31.795 -          (maps (fn t => filter (equal (#ctr_no t) o #ctr_no) x) d |> map #user_eqn) end);
  31.796 -
  31.797 -    val sel_eqnss = map_filter (try (fn Sel x => x)) eqns_data
  31.798 -      |> partition_eq ((op =) o pairself #fun_name)
  31.799 -      |> fst o finds (fn (x, ({fun_name, ...} :: _)) => x = fun_name) fun_names
  31.800 -      |> map (flat o snd);
  31.801 -
  31.802 -    val has_call = exists_subterm (map (fst #>> Binding.name_of #> Free) fixes |> member (op =));
  31.803 -    val arg_Tss = map (binder_types o snd o fst) fixes;
  31.804 -    val disc_eqnss = map5 mk_real_disc_eqns bs arg_Tss corec_specs sel_eqnss disc_eqnss';
  31.805 -    val (defs, exclss') =
  31.806 -      co_build_defs lthy' bs mxs has_call arg_Tss corec_specs disc_eqnss sel_eqnss;
  31.807 -
  31.808 -    fun excl_tac (c, c', a) =
  31.809 -      if a orelse c = c' orelse sequential then
  31.810 -        SOME (K (HEADGOAL (mk_primcorec_assumption_tac lthy [])))
  31.811 -      else if simple then
  31.812 -        SOME (K (auto_tac lthy))
  31.813 -      else
  31.814 -        NONE;
  31.815 -
  31.816 -(*
  31.817 -val _ = tracing ("exclusiveness properties:\n    \<cdot> " ^
  31.818 - space_implode "\n    \<cdot> " (maps (map (Syntax.string_of_term lthy o snd)) exclss'));
  31.819 -*)
  31.820 -
  31.821 -    val exclss'' = exclss' |> map (map (fn (idx, t) =>
  31.822 -      (idx, (Option.map (Goal.prove lthy [] [] t) (excl_tac idx), t))));
  31.823 -    val taut_thmss = map (map (apsnd (the o fst)) o filter (is_some o fst o snd)) exclss'';
  31.824 -    val (obligation_idxss, obligationss) = exclss''
  31.825 -      |> map (map (apsnd (rpair [] o snd)) o filter (is_none o fst o snd))
  31.826 -      |> split_list o map split_list;
  31.827 -
  31.828 -    fun prove thmss' def_thms' lthy =
  31.829 -      let
  31.830 -        val def_thms = map (snd o snd) def_thms';
  31.831 -
  31.832 -        val exclss' = map (op ~~) (obligation_idxss ~~ thmss');
  31.833 -        fun mk_exclsss excls n =
  31.834 -          (excls, map (fn k => replicate k [TrueI] @ replicate (n - k) []) (0 upto n - 1))
  31.835 -          |-> fold (fn ((c, c', _), thm) => nth_map c (nth_map c' (K [thm])));
  31.836 -        val exclssss = (exclss' ~~ taut_thmss |> map (op @), fun_names ~~ corec_specs)
  31.837 -          |-> map2 (fn excls => fn (_, {ctr_specs, ...}) => mk_exclsss excls (length ctr_specs));
  31.838 -
  31.839 -        fun prove_disc ({ctr_specs, ...} : corec_spec) exclsss
  31.840 -            ({fun_name, fun_T, fun_args, ctr_no, prems, ...} : co_eqn_data_disc) =
  31.841 -          if Term.aconv_untyped (#disc (nth ctr_specs ctr_no), @{term "\<lambda>x. x = x"}) then [] else
  31.842 -            let
  31.843 -              val {disc_corec, ...} = nth ctr_specs ctr_no;
  31.844 -              val k = 1 + ctr_no;
  31.845 -              val m = length prems;
  31.846 -              val t =
  31.847 -                list_comb (Free (fun_name, fun_T), map Bound (length fun_args - 1 downto 0))
  31.848 -                |> curry betapply (#disc (nth ctr_specs ctr_no)) (*###*)
  31.849 -                |> HOLogic.mk_Trueprop
  31.850 -                |> curry Logic.list_implies (map HOLogic.mk_Trueprop prems)
  31.851 -                |> curry Logic.list_all (map dest_Free fun_args);
  31.852 -            in
  31.853 -              mk_primcorec_disc_tac lthy def_thms disc_corec k m exclsss
  31.854 -              |> K |> Goal.prove lthy [] [] t
  31.855 -              |> pair (#disc (nth ctr_specs ctr_no))
  31.856 -              |> single
  31.857 -            end;
  31.858 -
  31.859 -        fun prove_sel ({nested_maps, nested_map_idents, nested_map_comps, ctr_specs, ...}
  31.860 -            : corec_spec) (disc_eqns : co_eqn_data_disc list) exclsss
  31.861 -            ({fun_name, fun_T, fun_args, ctr, sel, rhs_term, ...} : co_eqn_data_sel) =
  31.862 -          let
  31.863 -            val SOME ctr_spec = find_first (equal ctr o #ctr) ctr_specs;
  31.864 -            val ctr_no = find_index (equal ctr o #ctr) ctr_specs;
  31.865 -            val prems = the_default (maps (negate_conj o #prems) disc_eqns)
  31.866 -                (find_first (equal ctr_no o #ctr_no) disc_eqns |> Option.map #prems);
  31.867 -            val sel_corec = find_index (equal sel) (#sels ctr_spec)
  31.868 -              |> nth (#sel_corecs ctr_spec);
  31.869 -            val k = 1 + ctr_no;
  31.870 -            val m = length prems;
  31.871 -            val t =
  31.872 -              list_comb (Free (fun_name, fun_T), map Bound (length fun_args - 1 downto 0))
  31.873 -              |> curry betapply sel
  31.874 -              |> rpair (abstract (List.rev fun_args) rhs_term)
  31.875 -              |> HOLogic.mk_Trueprop o HOLogic.mk_eq
  31.876 -              |> curry Logic.list_implies (map HOLogic.mk_Trueprop prems)
  31.877 -              |> curry Logic.list_all (map dest_Free fun_args);
  31.878 -            val (distincts, _, sel_splits, sel_split_asms) = case_thms_of_term lthy [] rhs_term;
  31.879 -          in
  31.880 -            mk_primcorec_sel_tac lthy def_thms distincts sel_splits sel_split_asms nested_maps
  31.881 -              nested_map_idents nested_map_comps sel_corec k m exclsss
  31.882 -            |> K |> Goal.prove lthy [] [] t
  31.883 -            |> pair sel
  31.884 -          end;
  31.885 -
  31.886 -        fun prove_ctr disc_alist sel_alist (disc_eqns : co_eqn_data_disc list)
  31.887 -            (sel_eqns : co_eqn_data_sel list) ({ctr, disc, sels, collapse, ...} : corec_ctr_spec) =
  31.888 -          if not (exists (equal ctr o #ctr) disc_eqns)
  31.889 -              andalso not (exists (equal ctr o #ctr) sel_eqns)
  31.890 -            orelse (* don't try to prove theorems when some sel_eqns are missing *)
  31.891 -              filter (equal ctr o #ctr) sel_eqns
  31.892 -              |> fst o finds ((op =) o apsnd #sel) sels
  31.893 -              |> exists (null o snd)
  31.894 -          then [] else
  31.895 -            let
  31.896 -              val (fun_name, fun_T, fun_args, prems) =
  31.897 -                (find_first (equal ctr o #ctr) disc_eqns, find_first (equal ctr o #ctr) sel_eqns)
  31.898 -                |>> Option.map (fn x => (#fun_name x, #fun_T x, #fun_args x, #prems x))
  31.899 -                ||> Option.map (fn x => (#fun_name x, #fun_T x, #fun_args x, []))
  31.900 -                |> the o merge_options;
  31.901 -              val m = length prems;
  31.902 -              val t = filter (equal ctr o #ctr) sel_eqns
  31.903 -                |> fst o finds ((op =) o apsnd #sel) sels
  31.904 -                |> map (snd #> (fn [x] => (List.rev (#fun_args x), #rhs_term x)) #-> abstract)
  31.905 -                |> curry list_comb ctr
  31.906 -                |> curry HOLogic.mk_eq (list_comb (Free (fun_name, fun_T),
  31.907 -                  map Bound (length fun_args - 1 downto 0)))
  31.908 -                |> HOLogic.mk_Trueprop
  31.909 -                |> curry Logic.list_implies (map HOLogic.mk_Trueprop prems)
  31.910 -                |> curry Logic.list_all (map dest_Free fun_args);
  31.911 -              val maybe_disc_thm = AList.lookup (op =) disc_alist disc;
  31.912 -              val sel_thms = map snd (filter (member (op =) sels o fst) sel_alist);
  31.913 -            in
  31.914 -              mk_primcorec_ctr_of_dtr_tac lthy m collapse maybe_disc_thm sel_thms
  31.915 -              |> K |> Goal.prove lthy [] [] t
  31.916 -              |> single
  31.917 -            end;
  31.918 -
  31.919 -        val disc_alists = map3 (maps oo prove_disc) corec_specs exclssss disc_eqnss;
  31.920 -        val sel_alists = map4 (map ooo prove_sel) corec_specs disc_eqnss exclssss sel_eqnss;
  31.921 -
  31.922 -        val disc_thmss = map (map snd) disc_alists;
  31.923 -        val sel_thmss = map (map snd) sel_alists;
  31.924 -        val ctr_thmss = map5 (maps oooo prove_ctr) disc_alists sel_alists disc_eqnss sel_eqnss
  31.925 -          (map #ctr_specs corec_specs);
  31.926 -
  31.927 -        val simp_thmss = map2 append disc_thmss sel_thmss
  31.928 -
  31.929 -        val common_name = mk_common_name fun_names;
  31.930 -
  31.931 -        val notes =
  31.932 -          [(coinductN, map (if n2m then single else K []) coinduct_thms, []),
  31.933 -           (codeN, ctr_thmss(*FIXME*), code_nitpick_attrs),
  31.934 -           (ctrN, ctr_thmss, []),
  31.935 -           (discN, disc_thmss, simp_attrs),
  31.936 -           (selN, sel_thmss, simp_attrs),
  31.937 -           (simpsN, simp_thmss, []),
  31.938 -           (strong_coinductN, map (if n2m then single else K []) strong_coinduct_thms, [])]
  31.939 -          |> maps (fn (thmN, thmss, attrs) =>
  31.940 -            map2 (fn fun_name => fn thms =>
  31.941 -                ((Binding.qualify true fun_name (Binding.name thmN), attrs), [(thms, [])]))
  31.942 -              fun_names (take actual_nn thmss))
  31.943 -          |> filter_out (null o fst o hd o snd);
  31.944 -
  31.945 -        val common_notes =
  31.946 -          [(coinductN, if n2m then [coinduct_thm] else [], []),
  31.947 -           (strong_coinductN, if n2m then [strong_coinduct_thm] else [], [])]
  31.948 -          |> filter_out (null o #2)
  31.949 -          |> map (fn (thmN, thms, attrs) =>
  31.950 -            ((Binding.qualify true common_name (Binding.name thmN), attrs), [(thms, [])]));
  31.951 -      in
  31.952 -        lthy |> Local_Theory.notes (notes @ common_notes) |> snd
  31.953 -      end;
  31.954 -
  31.955 -    fun after_qed thmss' = fold_map Local_Theory.define defs #-> prove thmss';
  31.956 -
  31.957 -    val _ = if not simple orelse forall null obligationss then () else
  31.958 -      primrec_error "need exclusiveness proofs - use primcorecursive instead of primcorec";
  31.959 -  in
  31.960 -    if simple then
  31.961 -      lthy'
  31.962 -      |> after_qed (map (fn [] => []) obligationss)
  31.963 -      |> pair NONE o SOME
  31.964 -    else
  31.965 -      lthy'
  31.966 -      |> Proof.theorem NONE after_qed obligationss
  31.967 -      |> Proof.refine (Method.primitive_text I)
  31.968 -      |> Seq.hd
  31.969 -      |> rpair NONE o SOME
  31.970 -  end;
  31.971 -
  31.972 -fun add_primcorec_ursive_cmd simple seq (raw_fixes, raw_specs') lthy =
  31.973 -  let
  31.974 -    val (raw_specs, of_specs) = split_list raw_specs' ||> map (Option.map (Syntax.read_term lthy));
  31.975 -    val ((fixes, specs), _) = Specification.read_spec raw_fixes raw_specs lthy;
  31.976 -  in
  31.977 -    add_primcorec simple seq fixes specs of_specs lthy
  31.978 -    handle ERROR str => primrec_error str
  31.979 -  end
  31.980 -  handle Primrec_Error (str, eqns) =>
  31.981 -    if null eqns
  31.982 -    then error ("primcorec error:\n  " ^ str)
  31.983 -    else error ("primcorec error:\n  " ^ str ^ "\nin\n  " ^
  31.984 -      space_implode "\n  " (map (quote o Syntax.string_of_term lthy) eqns));
  31.985 -
  31.986 -val add_primcorecursive_cmd = (the o fst) ooo add_primcorec_ursive_cmd false;
  31.987 -val add_primcorec_cmd = (the o snd) ooo add_primcorec_ursive_cmd true;
  31.988 -
  31.989 -end;
    32.1 --- a/src/HOL/BNF/Tools/bnf_fp_rec_sugar_tactics.ML	Mon Nov 11 17:34:44 2013 +0100
    32.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    32.3 @@ -1,116 +0,0 @@
    32.4 -(*  Title:      HOL/BNF/Tools/bnf_fp_rec_sugar_tactics.ML
    32.5 -    Author:     Jasmin Blanchette, TU Muenchen
    32.6 -    Copyright   2013
    32.7 -
    32.8 -Tactics for recursor and corecursor sugar.
    32.9 -*)
   32.10 -
   32.11 -signature BNF_FP_REC_SUGAR_TACTICS =
   32.12 -sig
   32.13 -  val mk_primcorec_assumption_tac: Proof.context -> thm list -> int -> tactic
   32.14 -  val mk_primcorec_code_of_raw_code_tac: thm list -> thm -> tactic
   32.15 -  val mk_primcorec_ctr_of_dtr_tac: Proof.context -> int -> thm -> thm option -> thm list -> tactic
   32.16 -  val mk_primcorec_disc_tac: Proof.context -> thm list -> thm -> int -> int -> thm list list list ->
   32.17 -    tactic
   32.18 -  val mk_primcorec_raw_code_of_ctr_tac: Proof.context -> thm list -> thm list -> thm list ->
   32.19 -    thm list -> int list -> thm list -> tactic
   32.20 -  val mk_primcorec_sel_tac: Proof.context -> thm list -> thm list -> thm list -> thm list ->
   32.21 -    thm list -> thm list -> thm list -> thm -> int -> int -> thm list list list -> tactic
   32.22 -  val mk_primrec_tac: Proof.context -> int -> thm list -> thm list -> thm list -> thm -> tactic
   32.23 -end;
   32.24 -
   32.25 -structure BNF_FP_Rec_Sugar_Tactics : BNF_FP_REC_SUGAR_TACTICS =
   32.26 -struct
   32.27 -
   32.28 -open BNF_Util
   32.29 -open BNF_Tactics
   32.30 -
   32.31 -val falseEs = @{thms not_TrueE FalseE};
   32.32 -val neq_eq_eq_contradict = @{thm neq_eq_eq_contradict};
   32.33 -val split_if = @{thm split_if};
   32.34 -val split_if_asm = @{thm split_if_asm};
   32.35 -val split_connectI = @{thms allI impI conjI};
   32.36 -
   32.37 -fun mk_primrec_tac ctxt num_extra_args map_idents map_comps fun_defs recx =
   32.38 -  unfold_thms_tac ctxt fun_defs THEN
   32.39 -  HEADGOAL (rtac (funpow num_extra_args (fn thm => thm RS fun_cong) recx RS trans)) THEN
   32.40 -  unfold_thms_tac ctxt (@{thms id_def split o_def fst_conv snd_conv} @ map_comps @ map_idents) THEN
   32.41 -  HEADGOAL (rtac refl);
   32.42 -
   32.43 -fun mk_primcorec_assumption_tac ctxt discIs =
   32.44 -  SELECT_GOAL (unfold_thms_tac ctxt
   32.45 -      @{thms not_not not_False_eq_True de_Morgan_conj de_Morgan_disj} THEN
   32.46 -    SOLVE (HEADGOAL (REPEAT o (rtac refl ORELSE' atac ORELSE' etac conjE ORELSE'
   32.47 -    resolve_tac @{thms TrueI conjI disjI1 disjI2} ORELSE'
   32.48 -    dresolve_tac discIs THEN' atac ORELSE'
   32.49 -    etac notE THEN' atac ORELSE'
   32.50 -    etac disjE))));
   32.51 -
   32.52 -fun mk_primcorec_same_case_tac m =
   32.53 -  HEADGOAL (if m = 0 then rtac TrueI
   32.54 -    else REPEAT_DETERM_N (m - 1) o (rtac conjI THEN' atac) THEN' atac);
   32.55 -
   32.56 -fun mk_primcorec_different_case_tac ctxt excl =
   32.57 -  unfold_thms_tac ctxt @{thms not_not not_False_eq_True not_True_eq_False} THEN
   32.58 -  HEADGOAL (rtac excl THEN_ALL_NEW mk_primcorec_assumption_tac ctxt []);
   32.59 -
   32.60 -fun mk_primcorec_cases_tac ctxt k m exclsss =
   32.61 -  let val n = length exclsss in
   32.62 -    EVERY (map (fn [] => if k = n then all_tac else mk_primcorec_same_case_tac m
   32.63 -        | [excl] => mk_primcorec_different_case_tac ctxt excl)
   32.64 -      (take k (nth exclsss (k - 1))))
   32.65 -  end;
   32.66 -
   32.67 -fun mk_primcorec_prelude ctxt defs thm =
   32.68 -  unfold_thms_tac ctxt defs THEN HEADGOAL (rtac thm) THEN
   32.69 -  unfold_thms_tac ctxt @{thms Let_def split};
   32.70 -
   32.71 -fun mk_primcorec_disc_tac ctxt defs disc_corec k m exclsss =
   32.72 -  mk_primcorec_prelude ctxt defs disc_corec THEN mk_primcorec_cases_tac ctxt k m exclsss;
   32.73 -
   32.74 -fun mk_primcorec_sel_tac ctxt defs distincts splits split_asms maps map_idents map_comps f_sel k m
   32.75 -    exclsss =
   32.76 -  mk_primcorec_prelude ctxt defs (f_sel RS trans) THEN
   32.77 -  mk_primcorec_cases_tac ctxt k m exclsss THEN
   32.78 -  HEADGOAL (REPEAT_DETERM o (rtac refl ORELSE' rtac ext ORELSE'
   32.79 -    eresolve_tac falseEs ORELSE'
   32.80 -    resolve_tac split_connectI ORELSE'
   32.81 -    Splitter.split_asm_tac (split_if_asm :: split_asms) ORELSE'
   32.82 -    Splitter.split_tac (split_if :: splits) ORELSE'
   32.83 -    eresolve_tac (map (fn thm => thm RS neq_eq_eq_contradict) distincts) THEN' atac ORELSE'
   32.84 -    etac notE THEN' atac ORELSE'
   32.85 -    (CHANGED o SELECT_GOAL (unfold_thms_tac ctxt
   32.86 -      (@{thms id_apply o_def split_def sum.cases} @ maps @ map_comps @ map_idents)))));
   32.87 -
   32.88 -fun mk_primcorec_ctr_of_dtr_tac ctxt m collapse maybe_disc_f sel_fs =
   32.89 -  HEADGOAL (rtac ((if null sel_fs then collapse else collapse RS sym) RS trans) THEN'
   32.90 -    (the_default (K all_tac) (Option.map rtac maybe_disc_f)) THEN' REPEAT_DETERM_N m o atac) THEN
   32.91 -  unfold_thms_tac ctxt sel_fs THEN HEADGOAL (rtac refl);
   32.92 -
   32.93 -(* TODO: reduce code duplication with selector tactic above *)
   32.94 -fun mk_primcorec_raw_code_of_ctr_single_tac ctxt distincts discIs splits split_asms m f_ctr =
   32.95 -  HEADGOAL (REPEAT o (resolve_tac split_connectI ORELSE' split_tac (split_if :: splits))) THEN
   32.96 -  mk_primcorec_prelude ctxt [] (f_ctr RS trans) THEN
   32.97 -  HEADGOAL ((REPEAT_DETERM_N m o mk_primcorec_assumption_tac ctxt discIs) THEN'
   32.98 -    SELECT_GOAL (SOLVE (HEADGOAL (REPEAT_DETERM o
   32.99 -    (rtac refl ORELSE' atac ORELSE'
  32.100 -     resolve_tac split_connectI ORELSE'
  32.101 -     Splitter.split_asm_tac (split_if_asm :: split_asms) ORELSE'
  32.102 -     Splitter.split_tac (split_if :: splits) ORELSE'
  32.103 -     mk_primcorec_assumption_tac ctxt discIs ORELSE'
  32.104 -     eresolve_tac (map (fn thm => thm RS neq_eq_eq_contradict) distincts) THEN' atac ORELSE'
  32.105 -     (TRY o dresolve_tac discIs) THEN' etac notE THEN' atac)))));
  32.106 -
  32.107 -fun mk_primcorec_raw_code_of_ctr_tac ctxt distincts discIs splits split_asms ms ctr_thms =
  32.108 -  EVERY (map2 (mk_primcorec_raw_code_of_ctr_single_tac ctxt distincts discIs splits split_asms)
  32.109 -    ms ctr_thms);
  32.110 -
  32.111 -fun mk_primcorec_code_of_raw_code_tac splits raw =
  32.112 -  HEADGOAL (rtac raw ORELSE' rtac (raw RS trans) THEN' REPEAT_DETERM o
  32.113 -    (rtac refl ORELSE'
  32.114 -     (TRY o rtac sym) THEN' atac ORELSE'
  32.115 -     resolve_tac split_connectI ORELSE'
  32.116 -     Splitter.split_tac (split_if :: splits) ORELSE'
  32.117 -     etac notE THEN' atac));
  32.118 -
  32.119 -end;
    33.1 --- a/src/HOL/BNF/Tools/bnf_fp_rec_sugar_util.ML	Mon Nov 11 17:34:44 2013 +0100
    33.2 +++ b/src/HOL/BNF/Tools/bnf_fp_rec_sugar_util.ML	Mon Nov 11 17:44:21 2013 +0100
    33.3 @@ -8,410 +8,26 @@
    33.4  
    33.5  signature BNF_FP_REC_SUGAR_UTIL =
    33.6  sig
    33.7 -  datatype rec_call =
    33.8 -    No_Rec of int |
    33.9 -    Direct_Rec of int (*before*) * int (*after*) |
   33.10 -    Indirect_Rec of int
   33.11 -
   33.12 -  datatype corec_call =
   33.13 -    Dummy_No_Corec of int |
   33.14 -    No_Corec of int |
   33.15 -    Direct_Corec of int (*stop?*) * int (*end*) * int (*continue*) |
   33.16 -    Indirect_Corec of int
   33.17 -
   33.18 -  type rec_ctr_spec =
   33.19 -    {ctr: term,
   33.20 -     offset: int,
   33.21 -     calls: rec_call list,
   33.22 -     rec_thm: thm}
   33.23 -
   33.24 -  type corec_ctr_spec =
   33.25 -    {ctr: term,
   33.26 -     disc: term,
   33.27 -     sels: term list,
   33.28 -     pred: int option,
   33.29 -     calls: corec_call list,
   33.30 -     discI: thm,
   33.31 -     sel_thms: thm list,
   33.32 -     collapse: thm,
   33.33 -     corec_thm: thm,
   33.34 -     disc_corec: thm,
   33.35 -     sel_corecs: thm list}
   33.36 +  val indexed: 'a list -> int -> int list * int
   33.37 +  val indexedd: 'a list list -> int -> int list list * int
   33.38 +  val indexeddd: ''a list list list -> int -> int list list list * int
   33.39 +  val indexedddd: 'a list list list list -> int -> int list list list list * int
   33.40 +  val find_index_eq: ''a list -> ''a -> int
   33.41 +  val finds: ('a * 'b -> bool) -> 'a list -> 'b list -> ('a * 'b list) list * 'b list
   33.42  
   33.43 -  type rec_spec =
   33.44 -    {recx: term,
   33.45 -     nested_map_idents: thm list,
   33.46 -     nested_map_comps: thm list,
   33.47 -     ctr_specs: rec_ctr_spec list}
   33.48 -
   33.49 -  type corec_spec =
   33.50 -    {corec: term,
   33.51 -     nested_maps: thm list,
   33.52 -     nested_map_idents: thm list,
   33.53 -     nested_map_comps: thm list,
   33.54 -     ctr_specs: corec_ctr_spec list}
   33.55 -
   33.56 -  val s_not: term -> term
   33.57 -  val mk_conjs: term list -> term
   33.58 -  val mk_disjs: term list -> term
   33.59 -  val s_not_disj: term -> term list
   33.60 -  val negate_conj: term list -> term list
   33.61 -  val negate_disj: term list -> term list
   33.62 +  val drop_All: term -> term
   33.63  
   33.64 -  val massage_indirect_rec_call: Proof.context -> (term -> bool) -> (typ -> typ -> term -> term) ->
   33.65 -    typ list -> term -> term -> term -> term
   33.66 -  val massage_direct_corec_call: Proof.context -> (term -> bool) -> (typ list -> term -> term) ->
   33.67 -    typ list -> term -> term
   33.68 -  val massage_indirect_corec_call: Proof.context -> (term -> bool) ->
   33.69 -    (typ list -> typ -> typ -> term -> term) -> typ list -> typ -> term -> term
   33.70 -  val expand_corec_code_rhs: Proof.context -> (term -> bool) -> typ list -> term -> term
   33.71 -  val massage_corec_code_rhs: Proof.context -> (typ list -> term -> term list -> term) ->
   33.72 -    typ list -> term -> term
   33.73 -  val fold_rev_corec_code_rhs: Proof.context -> (term list -> term -> term list -> 'a -> 'a) ->
   33.74 -    typ list -> term -> 'a -> 'a
   33.75 -  val case_thms_of_term: Proof.context -> typ list -> term ->
   33.76 -    thm list * thm list * thm list * thm list
   33.77 +  val mk_partial_compN: int -> typ -> term -> term
   33.78 +  val mk_partial_comp: typ -> typ -> term -> term
   33.79 +  val mk_compN: int -> typ list -> term * term -> term
   33.80 +  val mk_comp: typ list -> term * term -> term
   33.81  
   33.82 -  val rec_specs_of: binding list -> typ list -> typ list -> (term -> int list) ->
   33.83 -    ((term * term list list) list) list -> local_theory ->
   33.84 -    (bool * rec_spec list * typ list * thm * thm list) * local_theory
   33.85 -  val corec_specs_of: binding list -> typ list -> typ list -> (term -> int list) ->
   33.86 -    ((term * term list list) list) list -> local_theory ->
   33.87 -    (bool * corec_spec list * typ list * thm * thm * thm list * thm list) * local_theory
   33.88 +  val get_indices: ((binding * typ) * 'a) list -> term -> int list
   33.89  end;
   33.90  
   33.91  structure BNF_FP_Rec_Sugar_Util : BNF_FP_REC_SUGAR_UTIL =
   33.92  struct
   33.93  
   33.94 -open Ctr_Sugar
   33.95 -open BNF_Util
   33.96 -open BNF_Def
   33.97 -open BNF_FP_Util
   33.98 -open BNF_FP_Def_Sugar
   33.99 -open BNF_FP_N2M_Sugar
  33.100 -
  33.101 -datatype rec_call =
  33.102 -  No_Rec of int |
  33.103 -  Direct_Rec of int * int |
  33.104 -  Indirect_Rec of int;
  33.105 -
  33.106 -datatype corec_call =
  33.107 -  Dummy_No_Corec of int |
  33.108 -  No_Corec of int |
  33.109 -  Direct_Corec of int * int * int |
  33.110 -  Indirect_Corec of int;
  33.111 -
  33.112 -type rec_ctr_spec =
  33.113 -  {ctr: term,
  33.114 -   offset: int,
  33.115 -   calls: rec_call list,
  33.116 -   rec_thm: thm};
  33.117 -
  33.118 -type corec_ctr_spec =
  33.119 -  {ctr: term,
  33.120 -   disc: term,
  33.121 -   sels: term list,
  33.122 -   pred: int option,
  33.123 -   calls: corec_call list,
  33.124 -   discI: thm,
  33.125 -   sel_thms: thm list,
  33.126 -   collapse: thm,
  33.127 -   corec_thm: thm,
  33.128 -   disc_corec: thm,
  33.129 -   sel_corecs: thm list};
  33.130 -
  33.131 -type rec_spec =
  33.132 -  {recx: term,
  33.133 -   nested_map_idents: thm list,
  33.134 -   nested_map_comps: thm list,
  33.135 -   ctr_specs: rec_ctr_spec list};
  33.136 -
  33.137 -type corec_spec =
  33.138 -  {corec: term,
  33.139 -   nested_maps: thm list,
  33.140 -   nested_map_idents: thm list,
  33.141 -   nested_map_comps: thm list,
  33.142 -   ctr_specs: corec_ctr_spec list};
  33.143 -
  33.144 -val id_def = @{thm id_def};
  33.145 -
  33.146 -exception AINT_NO_MAP of term;
  33.147 -
  33.148 -fun ill_formed_rec_call ctxt t =
  33.149 -  error ("Ill-formed recursive call: " ^ quote (Syntax.string_of_term ctxt t));
  33.150 -fun ill_formed_corec_call ctxt t =
  33.151 -  error ("Ill-formed corecursive call: " ^ quote (Syntax.string_of_term ctxt t));
  33.152 -fun invalid_map ctxt t =
  33.153 -  error ("Invalid map function in " ^ quote (Syntax.string_of_term ctxt t));
  33.154 -fun unexpected_rec_call ctxt t =
  33.155 -  error ("Unexpected recursive call: " ^ quote (Syntax.string_of_term ctxt t));
  33.156 -fun unexpected_corec_call ctxt t =
  33.157 -  error ("Unexpected corecursive call: " ^ quote (Syntax.string_of_term ctxt t));
  33.158 -
  33.159 -fun s_not @{const True} = @{const False}
  33.160 -  | s_not @{const False} = @{const True}
  33.161 -  | s_not (@{const Not} $ t) = t
  33.162 -  | s_not t = HOLogic.mk_not t
  33.163 -
  33.164 -val mk_conjs = try (foldr1 HOLogic.mk_conj) #> the_default @{const True};
  33.165 -val mk_disjs = try (foldr1 HOLogic.mk_disj) #> the_default @{const False};
  33.166 -
  33.167 -val s_not_disj = map s_not o HOLogic.disjuncts;
  33.168 -
  33.169 -fun negate_conj [t] = s_not_disj t
  33.170 -  | negate_conj ts = [mk_disjs (map s_not ts)];
  33.171 -
  33.172 -fun negate_disj [t] = s_not_disj t
  33.173 -  | negate_disj ts = [mk_disjs (map (mk_conjs o s_not_disj) ts)];
  33.174 -
  33.175 -fun factor_out_types ctxt massage destU U T =
  33.176 -  (case try destU U of
  33.177 -    SOME (U1, U2) => if U1 = T then massage T U2 else invalid_map ctxt
  33.178 -  | NONE => invalid_map ctxt);
  33.179 -
  33.180 -fun map_flattened_map_args ctxt s map_args fs =
  33.181 -  let
  33.182 -    val flat_fs = flatten_type_args_of_bnf (the (bnf_of ctxt s)) Term.dummy fs;
  33.183 -    val flat_fs' = map_args flat_fs;
  33.184 -  in
  33.185 -    permute_like (op aconv) flat_fs fs flat_fs'
  33.186 -  end;
  33.187 -
  33.188 -fun massage_indirect_rec_call ctxt has_call raw_massage_fun bound_Ts y y' =
  33.189 -  let
  33.190 -    val typof = curry fastype_of1 bound_Ts;
  33.191 -    val build_map_fst = build_map ctxt (fst_const o fst);
  33.192 -
  33.193 -    val yT = typof y;
  33.194 -    val yU = typof y';
  33.195 -
  33.196 -    fun y_of_y' () = build_map_fst (yU, yT) $ y';
  33.197 -    val elim_y = Term.map_aterms (fn t => if t = y then y_of_y' () else t);
  33.198 -
  33.199 -    fun massage_direct_fun U T t =
  33.200 -      if has_call t then factor_out_types ctxt raw_massage_fun HOLogic.dest_prodT U T t
  33.201 -      else HOLogic.mk_comp (t, build_map_fst (U, T));
  33.202 -
  33.203 -    fun massage_map (Type (_, Us)) (Type (s, Ts)) t =
  33.204 -        (case try (dest_map ctxt s) t of
  33.205 -          SOME (map0, fs) =>
  33.206 -          let
  33.207 -            val Type (_, ran_Ts) = range_type (typof t);
  33.208 -            val map' = mk_map (length fs) Us ran_Ts map0;
  33.209 -            val fs' = map_flattened_map_args ctxt s (map3 massage_map_or_map_arg Us Ts) fs;
  33.210 -          in
  33.211 -            Term.list_comb (map', fs')
  33.212 -          end
  33.213 -        | NONE => raise AINT_NO_MAP t)
  33.214 -      | massage_map _ _ t = raise AINT_NO_MAP t
  33.215 -    and massage_map_or_map_arg U T t =
  33.216 -      if T = U then
  33.217 -        if has_call t then unexpected_rec_call ctxt t else t
  33.218 -      else
  33.219 -        massage_map U T t
  33.220 -        handle AINT_NO_MAP _ => massage_direct_fun U T t;
  33.221 -
  33.222 -    fun massage_call (t as t1 $ t2) =
  33.223 -        if t2 = y then
  33.224 -          massage_map yU yT (elim_y t1) $ y'
  33.225 -          handle AINT_NO_MAP t' => invalid_map ctxt t'
  33.226 -        else
  33.227 -          ill_formed_rec_call ctxt t
  33.228 -      | massage_call t = if t = y then y_of_y' () else ill_formed_rec_call ctxt t;
  33.229 -  in
  33.230 -    massage_call
  33.231 -  end;
  33.232 -
  33.233 -fun fold_rev_let_if_case ctxt f bound_Ts t =
  33.234 -  let
  33.235 -    val thy = Proof_Context.theory_of ctxt;
  33.236 -
  33.237 -    fun fld conds t =
  33.238 -      (case Term.strip_comb t of
  33.239 -        (Const (@{const_name Let}, _), [arg1, arg2]) => fld conds (betapply (arg2, arg1))
  33.240 -      | (Const (@{const_name If}, _), [cond, then_branch, else_branch]) =>
  33.241 -        fld (conds @ HOLogic.conjuncts cond) then_branch
  33.242 -        o fld (conds @ s_not_disj cond) else_branch
  33.243 -      | (Const (c, _), args as _ :: _ :: _) =>
  33.244 -        let val n = num_binder_types (Sign.the_const_type thy c) - 1 in
  33.245 -          if n >= 0 andalso n < length args then
  33.246 -            (case fastype_of1 (bound_Ts, nth args n) of
  33.247 -              Type (s, Ts) =>
  33.248 -              (case dest_case ctxt s Ts t of
  33.249 -                NONE => apsnd (f conds t)
  33.250 -              | SOME (conds', branches) =>
  33.251 -                apfst (cons s) o fold_rev (uncurry fld)
  33.252 -                  (map (append conds o HOLogic.conjuncts) conds' ~~ branches))
  33.253 -            | _ => apsnd (f conds t))
  33.254 -          else
  33.255 -            apsnd (f conds t)
  33.256 -        end
  33.257 -      | _ => apsnd (f conds t))
  33.258 -  in
  33.259 -    fld [] t o pair []
  33.260 -  end;
  33.261 -
  33.262 -fun case_of ctxt = ctr_sugar_of ctxt #> Option.map (fst o dest_Const o #casex);
  33.263 -
  33.264 -fun massage_let_if_case ctxt has_call massage_leaf =
  33.265 -  let
  33.266 -    val thy = Proof_Context.theory_of ctxt;
  33.267 -
  33.268 -    fun check_no_call t = if has_call t then unexpected_corec_call ctxt t else ();
  33.269 -
  33.270 -    fun massage_abs bound_Ts (Abs (s, T, t)) = Abs (s, T, massage_abs (T :: bound_Ts) t)
  33.271 -      | massage_abs bound_Ts t = massage_rec bound_Ts t
  33.272 -    and massage_rec bound_Ts t =
  33.273 -      let val typof = curry fastype_of1 bound_Ts in
  33.274 -        (case Term.strip_comb t of
  33.275 -          (Const (@{const_name Let}, _), [arg1, arg2]) =>
  33.276 -          massage_rec bound_Ts (betapply (arg2, arg1))
  33.277 -        | (Const (@{const_name If}, _), obj :: (branches as [_, _])) =>
  33.278 -          let val branches' = map (massage_rec bound_Ts) branches in
  33.279 -            Term.list_comb (If_const (typof (hd branches')) $ tap check_no_call obj, branches')
  33.280 -          end
  33.281 -        | (Const (c, _), args as _ :: _ :: _) =>
  33.282 -          let
  33.283 -            val gen_T = Sign.the_const_type thy c;
  33.284 -            val (gen_branch_Ts, gen_body_fun_T) = strip_fun_type gen_T;
  33.285 -            val n = length gen_branch_Ts;
  33.286 -          in
  33.287 -            if n < length args then
  33.288 -              (case gen_body_fun_T of
  33.289 -                Type (_, [Type (T_name, _), _]) =>
  33.290 -                if case_of ctxt T_name = SOME c then
  33.291 -                  let
  33.292 -                    val (branches, obj_leftovers) = chop n args;
  33.293 -                    val branches' = map (massage_abs bound_Ts o Envir.eta_long bound_Ts) branches;
  33.294 -                    val branch_Ts' = map typof branches';
  33.295 -                    val casex' = Const (c, branch_Ts' ---> map typof obj_leftovers --->
  33.296 -                      snd (strip_typeN (num_binder_types (hd gen_branch_Ts)) (hd branch_Ts')));
  33.297 -                  in
  33.298 -                    Term.list_comb (casex', branches' @ tap (List.app check_no_call) obj_leftovers)
  33.299 -                  end
  33.300 -                else
  33.301 -                  massage_leaf bound_Ts t
  33.302 -              | _ => massage_leaf bound_Ts t)
  33.303 -            else
  33.304 -              massage_leaf bound_Ts t
  33.305 -          end
  33.306 -        | _ => massage_leaf bound_Ts t)
  33.307 -      end
  33.308 -  in
  33.309 -    massage_rec
  33.310 -  end;
  33.311 -
  33.312 -val massage_direct_corec_call = massage_let_if_case;
  33.313 -
  33.314 -fun curried_type (Type (@{type_name fun}, [Type (@{type_name prod}, Ts), T])) = Ts ---> T;
  33.315 -
  33.316 -fun massage_indirect_corec_call ctxt has_call raw_massage_call bound_Ts U t =
  33.317 -  let
  33.318 -    val build_map_Inl = build_map ctxt (uncurry Inl_const o dest_sumT o snd)
  33.319 -
  33.320 -    fun massage_direct_call bound_Ts U T t =
  33.321 -      if has_call t then factor_out_types ctxt (raw_massage_call bound_Ts) dest_sumT U T t
  33.322 -      else build_map_Inl (T, U) $ t;
  33.323 -
  33.324 -    fun massage_direct_fun bound_Ts U T t =
  33.325 -      let
  33.326 -        val var = Var ((Name.uu, Term.maxidx_of_term t + 1),
  33.327 -          domain_type (fastype_of1 (bound_Ts, t)));
  33.328 -      in
  33.329 -        Term.lambda var (massage_direct_call bound_Ts U T (t $ var))
  33.330 -      end;
  33.331 -
  33.332 -    fun massage_map bound_Ts (Type (_, Us)) (Type (s, Ts)) t =
  33.333 -        (case try (dest_map ctxt s) t of
  33.334 -          SOME (map0, fs) =>
  33.335 -          let
  33.336 -            val Type (_, dom_Ts) = domain_type (fastype_of1 (bound_Ts, t));
  33.337 -            val map' = mk_map (length fs) dom_Ts Us map0;
  33.338 -            val fs' =
  33.339 -              map_flattened_map_args ctxt s (map3 (massage_map_or_map_arg bound_Ts) Us Ts) fs;
  33.340 -          in
  33.341 -            Term.list_comb (map', fs')
  33.342 -          end
  33.343 -        | NONE => raise AINT_NO_MAP t)
  33.344 -      | massage_map _ _ _ t = raise AINT_NO_MAP t
  33.345 -    and massage_map_or_map_arg bound_Ts U T t =
  33.346 -      if T = U then
  33.347 -        if has_call t then unexpected_corec_call ctxt t else t
  33.348 -      else
  33.349 -        massage_map bound_Ts U T t
  33.350 -        handle AINT_NO_MAP _ => massage_direct_fun bound_Ts U T t;
  33.351 -
  33.352 -    fun massage_call bound_Ts U T =
  33.353 -      massage_let_if_case ctxt has_call (fn bound_Ts => fn t =>
  33.354 -        if has_call t then
  33.355 -          (case U of
  33.356 -            Type (s, Us) =>
  33.357 -            (case try (dest_ctr ctxt s) t of
  33.358 -              SOME (f, args) =>
  33.359 -              let
  33.360 -                val typof = curry fastype_of1 bound_Ts;
  33.361 -                val f' = mk_ctr Us f
  33.362 -                val f'_T = typof f';
  33.363 -                val arg_Ts = map typof args;
  33.364 -              in
  33.365 -                Term.list_comb (f', map3 (massage_call bound_Ts) (binder_types f'_T) arg_Ts args)
  33.366 -              end
  33.367 -            | NONE =>
  33.368 -              (case t of
  33.369 -                Const (@{const_name prod_case}, _) $ t' =>
  33.370 -                let
  33.371 -                  val U' = curried_type U;
  33.372 -                  val T' = curried_type T;
  33.373 -                in
  33.374 -                  Const (@{const_name prod_case}, U' --> U) $ massage_call bound_Ts U' T' t'
  33.375 -                end
  33.376 -              | t1 $ t2 =>
  33.377 -                (if has_call t2 then
  33.378 -                  massage_direct_call bound_Ts U T t
  33.379 -                else
  33.380 -                  massage_map bound_Ts U T t1 $ t2
  33.381 -                  handle AINT_NO_MAP _ => massage_direct_call bound_Ts U T t)
  33.382 -              | Abs (s, T', t') =>
  33.383 -                Abs (s, T', massage_call (T' :: bound_Ts) (range_type U) (range_type T) t')
  33.384 -              | _ => massage_direct_call bound_Ts U T t))
  33.385 -          | _ => ill_formed_corec_call ctxt t)
  33.386 -        else
  33.387 -          build_map_Inl (T, U) $ t) bound_Ts;
  33.388 -
  33.389 -    val T = fastype_of1 (bound_Ts, t);
  33.390 -  in
  33.391 -    if has_call t then massage_call bound_Ts U T t else build_map_Inl (T, U) $ t
  33.392 -  end;
  33.393 -
  33.394 -fun expand_ctr_term ctxt s Ts t =
  33.395 -  (case ctr_sugar_of ctxt s of
  33.396 -    SOME {ctrs, casex, ...} =>
  33.397 -    Term.list_comb (mk_case Ts (Type (s, Ts)) casex, map (mk_ctr Ts) ctrs) $ t
  33.398 -  | NONE => raise Fail "expand_ctr_term");
  33.399 -
  33.400 -fun expand_corec_code_rhs ctxt has_call bound_Ts t =
  33.401 -  (case fastype_of1 (bound_Ts, t) of
  33.402 -    Type (s, Ts) =>
  33.403 -    massage_let_if_case ctxt has_call (fn _ => fn t =>
  33.404 -      if can (dest_ctr ctxt s) t then t else expand_ctr_term ctxt s Ts t) bound_Ts t
  33.405 -  | _ => raise Fail "expand_corec_code_rhs");
  33.406 -
  33.407 -fun massage_corec_code_rhs ctxt massage_ctr =
  33.408 -  massage_let_if_case ctxt (K false)
  33.409 -    (fn bound_Ts => uncurry (massage_ctr bound_Ts) o Term.strip_comb);
  33.410 -
  33.411 -fun fold_rev_corec_code_rhs ctxt f =
  33.412 -  snd ooo fold_rev_let_if_case ctxt (fn conds => uncurry (f conds) o Term.strip_comb);
  33.413 -
  33.414 -fun case_thms_of_term ctxt bound_Ts t =
  33.415 -  let
  33.416 -    val (caseT_names, _) = fold_rev_let_if_case ctxt (K (K I)) bound_Ts t ();
  33.417 -    val ctr_sugars = map (the o ctr_sugar_of ctxt) caseT_names;
  33.418 -  in
  33.419 -    (maps #distincts ctr_sugars, maps #discIs ctr_sugars, maps #sel_splits ctr_sugars,
  33.420 -     maps #sel_split_asms ctr_sugars)
  33.421 -  end;
  33.422 -
  33.423  fun indexed xs h = let val h' = h + length xs in (h upto h' - 1, h') end;
  33.424  fun indexedd xss = fold_map indexed xss;
  33.425  fun indexeddd xsss = fold_map indexedd xsss;
  33.426 @@ -419,205 +35,32 @@
  33.427  
  33.428  fun find_index_eq hs h = find_index (curry (op =) h) hs;
  33.429  
  33.430 -(*FIXME: remove special cases for products and sum once they are registered as datatypes*)
  33.431 -fun map_thms_of_typ ctxt (Type (s, _)) =
  33.432 -    if s = @{type_name prod} then
  33.433 -      @{thms map_pair_simp}
  33.434 -    else if s = @{type_name sum} then
  33.435 -      @{thms sum_map.simps}
  33.436 -    else
  33.437 -      (case fp_sugar_of ctxt s of
  33.438 -        SOME {index, mapss, ...} => nth mapss index
  33.439 -      | NONE => [])
  33.440 -  | map_thms_of_typ _ _ = [];
  33.441 -
  33.442 -fun rec_specs_of bs arg_Ts res_Ts get_indices callssss0 lthy =
  33.443 -  let
  33.444 -    val thy = Proof_Context.theory_of lthy;
  33.445 -
  33.446 -    val ((missing_arg_Ts, perm0_kks,
  33.447 -          fp_sugars as {nested_bnfs, fp_res = {xtor_co_iterss = ctor_iters1 :: _, ...},
  33.448 -            co_inducts = [induct_thm], ...} :: _, (lfp_sugar_thms, _)), lthy') =
  33.449 -      nested_to_mutual_fps Least_FP bs arg_Ts get_indices callssss0 lthy;
  33.450 -
  33.451 -    val perm_fp_sugars = sort (int_ord o pairself #index) fp_sugars;
  33.452 -
  33.453 -    val indices = map #index fp_sugars;
  33.454 -    val perm_indices = map #index perm_fp_sugars;
  33.455 -
  33.456 -    val perm_ctrss = map (#ctrs o of_fp_sugar #ctr_sugars) perm_fp_sugars;
  33.457 -    val perm_ctr_Tsss = map (map (binder_types o fastype_of)) perm_ctrss;
  33.458 -    val perm_fpTs = map (body_type o fastype_of o hd) perm_ctrss;
  33.459 -
  33.460 -    val nn0 = length arg_Ts;
  33.461 -    val nn = length perm_fpTs;
  33.462 -    val kks = 0 upto nn - 1;
  33.463 -    val perm_ns = map length perm_ctr_Tsss;
  33.464 -    val perm_mss = map (map length) perm_ctr_Tsss;
  33.465 -
  33.466 -    val perm_Cs = map (body_type o fastype_of o co_rec_of o of_fp_sugar (#xtor_co_iterss o #fp_res))
  33.467 -      perm_fp_sugars;
  33.468 -    val perm_fun_arg_Tssss =
  33.469 -      mk_iter_fun_arg_types perm_ctr_Tsss perm_ns perm_mss (co_rec_of ctor_iters1);
  33.470 -
  33.471 -    fun unpermute0 perm0_xs = permute_like (op =) perm0_kks kks perm0_xs;
  33.472 -    fun unpermute perm_xs = permute_like (op =) perm_indices indices perm_xs;
  33.473 -
  33.474 -    val induct_thms = unpermute0 (conj_dests nn induct_thm);
  33.475 +fun finds eq = fold_map (fn x => List.partition (curry eq x) #>> pair x);
  33.476  
  33.477 -    val fpTs = unpermute perm_fpTs;
  33.478 -    val Cs = unpermute perm_Cs;
  33.479 -
  33.480 -    val As_rho = tvar_subst thy (take nn0 fpTs) arg_Ts;
  33.481 -    val Cs_rho = map (fst o dest_TVar) Cs ~~ pad_list HOLogic.unitT nn res_Ts;
  33.482 -
  33.483 -    val substA = Term.subst_TVars As_rho;
  33.484 -    val substAT = Term.typ_subst_TVars As_rho;
  33.485 -    val substCT = Term.typ_subst_TVars Cs_rho;
  33.486 -
  33.487 -    val perm_Cs' = map substCT perm_Cs;
  33.488 -
  33.489 -    fun offset_of_ctr 0 _ = 0
  33.490 -      | offset_of_ctr n (({ctrs, ...} : ctr_sugar) :: ctr_sugars) =
  33.491 -        length ctrs + offset_of_ctr (n - 1) ctr_sugars;
  33.492 -
  33.493 -    fun call_of [i] [T] = (if exists_subtype_in Cs T then Indirect_Rec else No_Rec) i
  33.494 -      | call_of [i, i'] _ = Direct_Rec (i, i');
  33.495 +fun drop_All t =
  33.496 +  subst_bounds (strip_qnt_vars @{const_name all} t |> map Free |> rev,
  33.497 +    strip_qnt_body @{const_name all} t);
  33.498  
  33.499 -    fun mk_ctr_spec ctr offset fun_arg_Tss rec_thm =
  33.500 -      let
  33.501 -        val (fun_arg_hss, _) = indexedd fun_arg_Tss 0;
  33.502 -        val fun_arg_hs = flat_rec_arg_args fun_arg_hss;
  33.503 -        val fun_arg_iss = map (map (find_index_eq fun_arg_hs)) fun_arg_hss;
  33.504 -      in
  33.505 -        {ctr = substA ctr, offset = offset, calls = map2 call_of fun_arg_iss fun_arg_Tss,
  33.506 -         rec_thm = rec_thm}
  33.507 -      end;
  33.508 -
  33.509 -    fun mk_ctr_specs index (ctr_sugars : ctr_sugar list) iter_thmsss =
  33.510 -      let
  33.511 -        val ctrs = #ctrs (nth ctr_sugars index);
  33.512 -        val rec_thmss = co_rec_of (nth iter_thmsss index);
  33.513 -        val k = offset_of_ctr index ctr_sugars;
  33.514 -        val n = length ctrs;
  33.515 -      in
  33.516 -        map4 mk_ctr_spec ctrs (k upto k + n - 1) (nth perm_fun_arg_Tssss index) rec_thmss
  33.517 -      end;
  33.518 -
  33.519 -    fun mk_spec ({T, index, ctr_sugars, co_iterss = iterss, co_iter_thmsss = iter_thmsss, ...}
  33.520 -      : fp_sugar) =
  33.521 -      {recx = mk_co_iter thy Least_FP (substAT T) perm_Cs' (co_rec_of (nth iterss index)),
  33.522 -       nested_map_idents = map (unfold_thms lthy [id_def] o map_id0_of_bnf) nested_bnfs,
  33.523 -       nested_map_comps = map map_comp_of_bnf nested_bnfs,
  33.524 -       ctr_specs = mk_ctr_specs index ctr_sugars iter_thmsss};
  33.525 -  in
  33.526 -    ((is_some lfp_sugar_thms, map mk_spec fp_sugars, missing_arg_Ts, induct_thm, induct_thms),
  33.527 -     lthy')
  33.528 +fun mk_partial_comp gT fT g =
  33.529 +  let val T = domain_type fT --> range_type gT in
  33.530 +    Const (@{const_name Fun.comp}, gT --> fT --> T) $ g
  33.531    end;
  33.532  
  33.533 -fun corec_specs_of bs arg_Ts res_Ts get_indices callssss0 lthy =
  33.534 -  let
  33.535 -    val thy = Proof_Context.theory_of lthy;
  33.536 -
  33.537 -    val ((missing_res_Ts, perm0_kks,
  33.538 -          fp_sugars as {nested_bnfs, fp_res = {xtor_co_iterss = dtor_coiters1 :: _, ...},
  33.539 -            co_inducts = coinduct_thms, ...} :: _, (_, gfp_sugar_thms)), lthy') =
  33.540 -      nested_to_mutual_fps Greatest_FP bs res_Ts get_indices callssss0 lthy;
  33.541 -
  33.542 -    val perm_fp_sugars = sort (int_ord o pairself #index) fp_sugars;
  33.543 -
  33.544 -    val indices = map #index fp_sugars;
  33.545 -    val perm_indices = map #index perm_fp_sugars;
  33.546 -
  33.547 -    val perm_ctrss = map (#ctrs o of_fp_sugar #ctr_sugars) perm_fp_sugars;
  33.548 -    val perm_ctr_Tsss = map (map (binder_types o fastype_of)) perm_ctrss;
  33.549 -    val perm_fpTs = map (body_type o fastype_of o hd) perm_ctrss;
  33.550 -
  33.551 -    val nn0 = length res_Ts;
  33.552 -    val nn = length perm_fpTs;
  33.553 -    val kks = 0 upto nn - 1;
  33.554 -    val perm_ns = map length perm_ctr_Tsss;
  33.555 -
  33.556 -    val perm_Cs = map (domain_type o body_fun_type o fastype_of o co_rec_of o
  33.557 -      of_fp_sugar (#xtor_co_iterss o #fp_res)) perm_fp_sugars;
  33.558 -    val (perm_p_Tss, (perm_q_Tssss, _, perm_f_Tssss, _)) =
  33.559 -      mk_coiter_fun_arg_types perm_ctr_Tsss perm_Cs perm_ns (co_rec_of dtor_coiters1);
  33.560 -
  33.561 -    val (perm_p_hss, h) = indexedd perm_p_Tss 0;
  33.562 -    val (perm_q_hssss, h') = indexedddd perm_q_Tssss h;
  33.563 -    val (perm_f_hssss, _) = indexedddd perm_f_Tssss h';
  33.564 -
  33.565 -    val fun_arg_hs =
  33.566 -      flat (map3 flat_corec_preds_predsss_gettersss perm_p_hss perm_q_hssss perm_f_hssss);
  33.567 -
  33.568 -    fun unpermute0 perm0_xs = permute_like (op =) perm0_kks kks perm0_xs;
  33.569 -    fun unpermute perm_xs = permute_like (op =) perm_indices indices perm_xs;
  33.570 -
  33.571 -    val coinduct_thmss = map (unpermute0 o conj_dests nn) coinduct_thms;
  33.572 -
  33.573 -    val p_iss = map (map (find_index_eq fun_arg_hs)) (unpermute perm_p_hss);
  33.574 -    val q_issss = map (map (map (map (find_index_eq fun_arg_hs)))) (unpermute perm_q_hssss);
  33.575 -    val f_issss = map (map (map (map (find_index_eq fun_arg_hs)))) (unpermute perm_f_hssss);
  33.576 -
  33.577 -    val f_Tssss = unpermute perm_f_Tssss;
  33.578 -    val fpTs = unpermute perm_fpTs;
  33.579 -    val Cs = unpermute perm_Cs;
  33.580 -
  33.581 -    val As_rho = tvar_subst thy (take nn0 fpTs) res_Ts;
  33.582 -    val Cs_rho = map (fst o dest_TVar) Cs ~~ pad_list HOLogic.unitT nn arg_Ts;
  33.583 +fun mk_partial_compN 0 _ g = g
  33.584 +  | mk_partial_compN n fT g =
  33.585 +    let val g' = mk_partial_compN (n - 1) (range_type fT) g in
  33.586 +      mk_partial_comp (fastype_of g') fT g'
  33.587 +    end;
  33.588  
  33.589 -    val substA = Term.subst_TVars As_rho;
  33.590 -    val substAT = Term.typ_subst_TVars As_rho;
  33.591 -    val substCT = Term.typ_subst_TVars Cs_rho;
  33.592 -
  33.593 -    val perm_Cs' = map substCT perm_Cs;
  33.594 -
  33.595 -    fun call_of nullary [] [g_i] [Type (@{type_name fun}, [_, T])] =
  33.596 -        (if exists_subtype_in Cs T then Indirect_Corec
  33.597 -         else if nullary then Dummy_No_Corec
  33.598 -         else No_Corec) g_i
  33.599 -      | call_of _ [q_i] [g_i, g_i'] _ = Direct_Corec (q_i, g_i, g_i');
  33.600 -
  33.601 -    fun mk_ctr_spec ctr disc sels p_ho q_iss f_iss f_Tss discI sel_thms collapse corec_thm
  33.602 -        disc_corec sel_corecs =
  33.603 -      let val nullary = not (can dest_funT (fastype_of ctr)) in
  33.604 -        {ctr = substA ctr, disc = substA disc, sels = map substA sels, pred = p_ho,
  33.605 -         calls = map3 (call_of nullary) q_iss f_iss f_Tss, discI = discI, sel_thms = sel_thms,
  33.606 -         collapse = collapse, corec_thm = corec_thm, disc_corec = disc_corec,
  33.607 -         sel_corecs = sel_corecs}
  33.608 -      end;
  33.609 -
  33.610 -    fun mk_ctr_specs index (ctr_sugars : ctr_sugar list) p_is q_isss f_isss f_Tsss
  33.611 -        coiter_thmsss disc_coitersss sel_coiterssss =
  33.612 -      let
  33.613 -        val ctrs = #ctrs (nth ctr_sugars index);
  33.614 -        val discs = #discs (nth ctr_sugars index);
  33.615 -        val selss = #selss (nth ctr_sugars index);
  33.616 -        val p_ios = map SOME p_is @ [NONE];
  33.617 -        val discIs = #discIs (nth ctr_sugars index);
  33.618 -        val sel_thmss = #sel_thmss (nth ctr_sugars index);
  33.619 -        val collapses = #collapses (nth ctr_sugars index);
  33.620 -        val corec_thms = co_rec_of (nth coiter_thmsss index);
  33.621 -        val disc_corecs = co_rec_of (nth disc_coitersss index);
  33.622 -        val sel_corecss = co_rec_of (nth sel_coiterssss index);
  33.623 -      in
  33.624 -        map13 mk_ctr_spec ctrs discs selss p_ios q_isss f_isss f_Tsss discIs sel_thmss collapses
  33.625 -          corec_thms disc_corecs sel_corecss
  33.626 -      end;
  33.627 -
  33.628 -    fun mk_spec ({T, index, ctr_sugars, co_iterss = coiterss, co_iter_thmsss = coiter_thmsss,
  33.629 -          disc_co_itersss = disc_coitersss, sel_co_iterssss = sel_coiterssss, ...} : fp_sugar)
  33.630 -        p_is q_isss f_isss f_Tsss =
  33.631 -      {corec = mk_co_iter thy Greatest_FP (substAT T) perm_Cs' (co_rec_of (nth coiterss index)),
  33.632 -       nested_maps = maps (map_thms_of_typ lthy o T_of_bnf) nested_bnfs,
  33.633 -       nested_map_idents = map (unfold_thms lthy [id_def] o map_id0_of_bnf) nested_bnfs,
  33.634 -       nested_map_comps = map map_comp_of_bnf nested_bnfs,
  33.635 -       ctr_specs = mk_ctr_specs index ctr_sugars p_is q_isss f_isss f_Tsss coiter_thmsss
  33.636 -         disc_coitersss sel_coiterssss};
  33.637 -  in
  33.638 -    ((is_some gfp_sugar_thms, map5 mk_spec fp_sugars p_iss q_issss f_issss f_Tssss, missing_res_Ts,
  33.639 -      co_induct_of coinduct_thms, strong_co_induct_of coinduct_thms, co_induct_of coinduct_thmss,
  33.640 -      strong_co_induct_of coinduct_thmss), lthy')
  33.641 +fun mk_compN n bound_Ts (g, f) =
  33.642 +  let val typof = curry fastype_of1 bound_Ts in
  33.643 +    mk_partial_compN n (typof f) g $ f
  33.644    end;
  33.645  
  33.646 +val mk_comp = mk_compN 1;
  33.647 +
  33.648 +fun get_indices fixes t = map (fst #>> Binding.name_of #> Free) fixes
  33.649 +  |> map_index (fn (i, v) => if exists_subterm (equal v) t then SOME i else NONE)
  33.650 +  |> map_filter I;
  33.651 +
  33.652  end;
    35.1 --- a/src/HOL/BNF/Tools/bnf_gfp.ML	Mon Nov 11 17:34:44 2013 +0100
    35.2 +++ b/src/HOL/BNF/Tools/bnf_gfp.ML	Mon Nov 11 17:44:21 2013 +0100
    35.3 @@ -23,7 +23,7 @@
    35.4  open BNF_Comp
    35.5  open BNF_FP_Util
    35.6  open BNF_FP_Def_Sugar
    35.7 -open BNF_FP_Rec_Sugar
    35.8 +open BNF_GFP_Rec_Sugar
    35.9  open BNF_GFP_Util
   35.10  open BNF_GFP_Tactics
   35.11  
   35.12 @@ -2744,8 +2744,8 @@
   35.13                ((Binding.qualify true (Binding.name_of b) (Binding.name thmN), []), [(thms, [])]))
   35.14              bs thmss)
   35.15        in
   35.16 -       (timer, Jbnfs, (folded_dtor_map_o_thms, folded_dtor_map_thms), folded_dtor_set_thmss',
   35.17 -         dtor_set_induct_thms, dtor_Jrel_thms, Jbnf_common_notes @ Jbnf_notes, lthy)
   35.18 +        (timer, Jbnfs, (folded_dtor_map_o_thms, folded_dtor_map_thms), folded_dtor_set_thmss',
   35.19 +          dtor_set_induct_thms, dtor_Jrel_thms, Jbnf_common_notes @ Jbnf_notes, lthy)
   35.20        end;
   35.21  
   35.22        val dtor_unfold_o_map_thms = mk_xtor_un_fold_o_map_thms Greatest_FP false m
    36.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    36.2 +++ b/src/HOL/BNF/Tools/bnf_gfp_rec_sugar.ML	Mon Nov 11 17:44:21 2013 +0100
    36.3 @@ -0,0 +1,1150 @@
    36.4 +(*  Title:      HOL/BNF/Tools/bnf_gfp_rec_sugar.ML
    36.5 +    Author:     Lorenz Panny, TU Muenchen
    36.6 +    Author:     Jasmin Blanchette, TU Muenchen
    36.7 +    Copyright   2013
    36.8 +
    36.9 +Corecursor sugar.
   36.10 +*)
   36.11 +
   36.12 +signature BNF_GFP_REC_SUGAR =
   36.13 +sig
   36.14 +  val add_primcorecursive_cmd: bool ->
   36.15 +    (binding * string option * mixfix) list * ((Attrib.binding * string) * string option) list ->
   36.16 +    Proof.context -> Proof.state
   36.17 +  val add_primcorec_cmd: bool ->
   36.18 +    (binding * string option * mixfix) list * ((Attrib.binding * string) * string option) list ->
   36.19 +    local_theory -> local_theory
   36.20 +end;
   36.21 +
   36.22 +structure BNF_GFP_Rec_Sugar : BNF_GFP_REC_SUGAR =
   36.23 +struct
   36.24 +
   36.25 +open Ctr_Sugar
   36.26 +open BNF_Util
   36.27 +open BNF_Def
   36.28 +open BNF_FP_Util
   36.29 +open BNF_FP_Def_Sugar
   36.30 +open BNF_FP_N2M_Sugar
   36.31 +open BNF_FP_Rec_Sugar_Util
   36.32 +open BNF_GFP_Rec_Sugar_Tactics
   36.33 +
   36.34 +val codeN = "code"
   36.35 +val ctrN = "ctr"
   36.36 +val discN = "disc"
   36.37 +val selN = "sel"
   36.38 +
   36.39 +val nitpicksimp_attrs = @{attributes [nitpick_simp]};
   36.40 +val simp_attrs = @{attributes [simp]};
   36.41 +val code_nitpicksimp_attrs = Code.add_default_eqn_attrib :: nitpicksimp_attrs;
   36.42 +
   36.43 +exception Primcorec_Error of string * term list;
   36.44 +
   36.45 +fun primcorec_error str = raise Primcorec_Error (str, []);
   36.46 +fun primcorec_error_eqn str eqn = raise Primcorec_Error (str, [eqn]);
   36.47 +fun primcorec_error_eqns str eqns = raise Primcorec_Error (str, eqns);
   36.48 +
   36.49 +datatype corec_call =
   36.50 +  Dummy_No_Corec of int |
   36.51 +  No_Corec of int |
   36.52 +  Mutual_Corec of int * int * int |
   36.53 +  Nested_Corec of int;
   36.54 +
   36.55 +type basic_corec_ctr_spec =
   36.56 +  {ctr: term,
   36.57 +   disc: term,
   36.58 +   sels: term list};
   36.59 +
   36.60 +type corec_ctr_spec =
   36.61 +  {ctr: term,
   36.62 +   disc: term,
   36.63 +   sels: term list,
   36.64 +   pred: int option,
   36.65 +   calls: corec_call list,
   36.66 +   discI: thm,
   36.67 +   sel_thms: thm list,
   36.68 +   collapse: thm,
   36.69 +   corec_thm: thm,
   36.70 +   disc_corec: thm,
   36.71 +   sel_corecs: thm list};
   36.72 +
   36.73 +type corec_spec =
   36.74 +  {corec: term,
   36.75 +   nested_map_idents: thm list,
   36.76 +   nested_map_comps: thm list,
   36.77 +   ctr_specs: corec_ctr_spec list};
   36.78 +
   36.79 +exception AINT_NO_MAP of term;
   36.80 +
   36.81 +fun not_codatatype ctxt T =
   36.82 +  error ("Not a codatatype: " ^ Syntax.string_of_typ ctxt T);
   36.83 +fun ill_formed_corec_call ctxt t =
   36.84 +  error ("Ill-formed corecursive call: " ^ quote (Syntax.string_of_term ctxt t));
   36.85 +fun invalid_map ctxt t =
   36.86 +  error ("Invalid map function in " ^ quote (Syntax.string_of_term ctxt t));
   36.87 +fun unexpected_corec_call ctxt t =
   36.88 +  error ("Unexpected corecursive call: " ^ quote (Syntax.string_of_term ctxt t));
   36.89 +
   36.90 +val mk_conjs = try (foldr1 HOLogic.mk_conj) #> the_default @{const True};
   36.91 +val mk_disjs = try (foldr1 HOLogic.mk_disj) #> the_default @{const False};
   36.92 +
   36.93 +val conjuncts_s = filter_out (curry (op =) @{const True}) o HOLogic.conjuncts;
   36.94 +
   36.95 +fun s_not @{const True} = @{const False}
   36.96 +  | s_not @{const False} = @{const True}
   36.97 +  | s_not (@{const Not} $ t) = t
   36.98 +  | s_not (@{const conj} $ t $ u) = @{const disj} $ s_not t $ s_not u
   36.99 +  | s_not (@{const disj} $ t $ u) = @{const conj} $ s_not t $ s_not u
  36.100 +  | s_not t = @{const Not} $ t;
  36.101 +
  36.102 +val s_not_conj = conjuncts_s o s_not o mk_conjs;
  36.103 +
  36.104 +fun propagate_unit_pos u cs = if member (op aconv) cs u then [@{const False}] else cs;
  36.105 +
  36.106 +fun propagate_unit_neg not_u cs = remove (op aconv) not_u cs;
  36.107 +
  36.108 +fun propagate_units css =
  36.109 +  (case List.partition (can the_single) css of
  36.110 +     ([], _) => css
  36.111 +   | ([u] :: uss, css') =>
  36.112 +     [u] :: propagate_units (map (propagate_unit_neg (s_not u))
  36.113 +       (map (propagate_unit_pos u) (uss @ css'))));
  36.114 +
  36.115 +fun s_conjs cs =
  36.116 +  if member (op aconv) cs @{const False} then @{const False}
  36.117 +  else mk_conjs (remove (op aconv) @{const True} cs);
  36.118 +
  36.119 +fun s_disjs ds =
  36.120 +  if member (op aconv) ds @{const True} then @{const True}
  36.121 +  else mk_disjs (remove (op aconv) @{const False} ds);
  36.122 +
  36.123 +fun s_dnf css0 =
  36.124 +  let val css = propagate_units css0 in
  36.125 +    if null css then
  36.126 +      [@{const False}]
  36.127 +    else if exists null css then
  36.128 +      []
  36.129 +    else
  36.130 +      map (fn c :: cs => (c, cs)) css
  36.131 +      |> AList.coalesce (op =)
  36.132 +      |> map (fn (c, css) => c :: s_dnf css)
  36.133 +      |> (fn [cs] => cs | css => [s_disjs (map s_conjs css)])
  36.134 +  end;
  36.135 +
  36.136 +fun fold_rev_let_if_case ctxt f bound_Ts t =
  36.137 +  let
  36.138 +    val thy = Proof_Context.theory_of ctxt;
  36.139 +
  36.140 +    fun fld conds t =
  36.141 +      (case Term.strip_comb t of
  36.142 +        (Const (@{const_name Let}, _), [_, _]) => fld conds (unfold_let t)
  36.143 +      | (Const (@{const_name If}, _), [cond, then_branch, else_branch]) =>
  36.144 +        fld (conds @ conjuncts_s cond) then_branch o fld (conds @ s_not_conj [cond]) else_branch
  36.145 +      | (Const (c, _), args as _ :: _ :: _) =>
  36.146 +        let val n = num_binder_types (Sign.the_const_type thy c) - 1 in
  36.147 +          if n >= 0 andalso n < length args then
  36.148 +            (case fastype_of1 (bound_Ts, nth args n) of
  36.149 +              Type (s, Ts) =>
  36.150 +              (case dest_case ctxt s Ts t of
  36.151 +                NONE => apsnd (f conds t)
  36.152 +              | SOME (conds', branches) =>
  36.153 +                apfst (cons s) o fold_rev (uncurry fld)
  36.154 +                  (map (append conds o conjuncts_s) conds' ~~ branches))
  36.155 +            | _ => apsnd (f conds t))
  36.156 +          else
  36.157 +            apsnd (f conds t)
  36.158 +        end
  36.159 +      | _ => apsnd (f conds t))
  36.160 +  in
  36.161 +    fld [] t o pair []
  36.162 +  end;
  36.163 +
  36.164 +fun case_of ctxt = ctr_sugar_of ctxt #> Option.map (fst o dest_Const o #casex);
  36.165 +
  36.166 +fun massage_let_if_case ctxt has_call massage_leaf =
  36.167 +  let
  36.168 +    val thy = Proof_Context.theory_of ctxt;
  36.169 +
  36.170 +    fun check_no_call t = if has_call t then unexpected_corec_call ctxt t else ();
  36.171 +
  36.172 +    fun massage_abs bound_Ts 0 t = massage_rec bound_Ts t
  36.173 +      | massage_abs bound_Ts m (Abs (s, T, t)) = Abs (s, T, massage_abs (T :: bound_Ts) (m - 1) t)
  36.174 +      | massage_abs bound_Ts m t =
  36.175 +        let val T = domain_type (fastype_of1 (bound_Ts, t)) in
  36.176 +          Abs (Name.uu, T, massage_abs (T :: bound_Ts) (m - 1) (incr_boundvars 1 t $ Bound 0))
  36.177 +        end
  36.178 +    and massage_rec bound_Ts t =
  36.179 +      let val typof = curry fastype_of1 bound_Ts in
  36.180 +        (case Term.strip_comb t of
  36.181 +          (Const (@{const_name Let}, _), [_, _]) => massage_rec bound_Ts (unfold_let t)
  36.182 +        | (Const (@{const_name If}, _), obj :: (branches as [_, _])) =>
  36.183 +          let val branches' = map (massage_rec bound_Ts) branches in
  36.184 +            Term.list_comb (If_const (typof (hd branches')) $ tap check_no_call obj, branches')
  36.185 +          end
  36.186 +        | (Const (c, _), args as _ :: _ :: _) =>
  36.187 +          (case try strip_fun_type (Sign.the_const_type thy c) of
  36.188 +            SOME (gen_branch_Ts, gen_body_fun_T) =>
  36.189 +            let
  36.190 +              val gen_branch_ms = map num_binder_types gen_branch_Ts;
  36.191 +              val n = length gen_branch_ms;
  36.192 +            in
  36.193 +              if n < length args then
  36.194 +                (case gen_body_fun_T of
  36.195 +                  Type (_, [Type (T_name, _), _]) =>
  36.196 +                  if case_of ctxt T_name = SOME c then
  36.197 +                    let
  36.198 +                      val (branches, obj_leftovers) = chop n args;
  36.199 +                      val branches' = map2 (massage_abs bound_Ts) gen_branch_ms branches;
  36.200 +                      val branch_Ts' = map typof branches';
  36.201 +                      val body_T' = snd (strip_typeN (hd gen_branch_ms) (hd branch_Ts'));
  36.202 +                      val casex' = Const (c, branch_Ts' ---> map typof obj_leftovers ---> body_T');
  36.203 +                    in
  36.204 +                      Term.list_comb (casex',
  36.205 +                        branches' @ tap (List.app check_no_call) obj_leftovers)
  36.206 +                    end
  36.207 +                  else
  36.208 +                    massage_leaf bound_Ts t
  36.209 +                | _ => massage_leaf bound_Ts t)
  36.210 +              else
  36.211 +                massage_leaf bound_Ts t
  36.212 +            end
  36.213 +          | NONE => massage_leaf bound_Ts t)
  36.214 +        | _ => massage_leaf bound_Ts t)
  36.215 +      end
  36.216 +  in
  36.217 +    massage_rec
  36.218 +  end;
  36.219 +
  36.220 +val massage_mutual_corec_call = massage_let_if_case;
  36.221 +
  36.222 +fun curried_type (Type (@{type_name fun}, [Type (@{type_name prod}, Ts), T])) = Ts ---> T;
  36.223 +
  36.224 +fun massage_nested_corec_call ctxt has_call raw_massage_call bound_Ts U t =
  36.225 +  let
  36.226 +    fun check_no_call t = if has_call t then unexpected_corec_call ctxt t else ();
  36.227 +
  36.228 +    val build_map_Inl = build_map ctxt (uncurry Inl_const o dest_sumT o snd);
  36.229 +
  36.230 +    fun massage_mutual_call bound_Ts U T t =
  36.231 +      if has_call t then
  36.232 +        (case try dest_sumT U of
  36.233 +          SOME (U1, U2) => if U1 = T then raw_massage_call bound_Ts T U2 t else invalid_map ctxt t
  36.234 +        | NONE => invalid_map ctxt t)
  36.235 +      else
  36.236 +        build_map_Inl (T, U) $ t;
  36.237 +
  36.238 +    fun massage_mutual_fun bound_Ts U T t =
  36.239 +      (case t of
  36.240 +        Const (@{const_name comp}, _) $ t1 $ t2 =>
  36.241 +        mk_comp bound_Ts (massage_mutual_fun bound_Ts U T t1, tap check_no_call t2)
  36.242 +      | _ =>
  36.243 +        let
  36.244 +          val var = Var ((Name.uu, Term.maxidx_of_term t + 1),
  36.245 +            domain_type (fastype_of1 (bound_Ts, t)));
  36.246 +        in
  36.247 +          Term.lambda var (massage_mutual_call bound_Ts U T (t $ var))
  36.248 +        end);
  36.249 +
  36.250 +    fun massage_map bound_Ts (Type (_, Us)) (Type (s, Ts)) t =
  36.251 +        (case try (dest_map ctxt s) t of
  36.252 +          SOME (map0, fs) =>
  36.253 +          let
  36.254 +            val Type (_, dom_Ts) = domain_type (fastype_of1 (bound_Ts, t));
  36.255 +            val map' = mk_map (length fs) dom_Ts Us map0;
  36.256 +            val fs' =
  36.257 +              map_flattened_map_args ctxt s (map3 (massage_map_or_map_arg bound_Ts) Us Ts) fs;
  36.258 +          in
  36.259 +            Term.list_comb (map', fs')
  36.260 +          end
  36.261 +        | NONE => raise AINT_NO_MAP t)
  36.262 +      | massage_map _ _ _ t = raise AINT_NO_MAP t
  36.263 +    and massage_map_or_map_arg bound_Ts U T t =
  36.264 +      if T = U then
  36.265 +        tap check_no_call t
  36.266 +      else
  36.267 +        massage_map bound_Ts U T t
  36.268 +        handle AINT_NO_MAP _ => massage_mutual_fun bound_Ts U T t;
  36.269 +
  36.270 +    fun massage_call bound_Ts U T =
  36.271 +      massage_let_if_case ctxt has_call (fn bound_Ts => fn t =>
  36.272 +        if has_call t then
  36.273 +          (case t of
  36.274 +            Const (@{const_name prod_case}, _) $ t' =>
  36.275 +            let
  36.276 +              val U' = curried_type U;
  36.277 +              val T' = curried_type T;
  36.278 +            in
  36.279 +              Const (@{const_name prod_case}, U' --> U) $ massage_call bound_Ts U' T' t'
  36.280 +            end
  36.281 +          | t1 $ t2 =>
  36.282 +            (if has_call t2 then
  36.283 +              massage_mutual_call bound_Ts U T t
  36.284 +            else
  36.285 +              massage_map bound_Ts U T t1 $ t2
  36.286 +              handle AINT_NO_MAP _ => massage_mutual_call bound_Ts U T t)
  36.287 +          | Abs (s, T', t') =>
  36.288 +            Abs (s, T', massage_call (T' :: bound_Ts) (range_type U) (range_type T) t')
  36.289 +          | _ => massage_mutual_call bound_Ts U T t)
  36.290 +        else
  36.291 +          build_map_Inl (T, U) $ t) bound_Ts;
  36.292 +
  36.293 +    val T = fastype_of1 (bound_Ts, t);
  36.294 +  in
  36.295 +    if has_call t then massage_call bound_Ts U T t else build_map_Inl (T, U) $ t
  36.296 +  end;
  36.297 +
  36.298 +val fold_rev_corec_call = fold_rev_let_if_case;
  36.299 +
  36.300 +fun expand_to_ctr_term ctxt s Ts t =
  36.301 +  (case ctr_sugar_of ctxt s of
  36.302 +    SOME {ctrs, casex, ...} =>
  36.303 +    Term.list_comb (mk_case Ts (Type (s, Ts)) casex, map (mk_ctr Ts) ctrs) $ t
  36.304 +  | NONE => raise Fail "expand_to_ctr_term");
  36.305 +
  36.306 +fun expand_corec_code_rhs ctxt has_call bound_Ts t =
  36.307 +  (case fastype_of1 (bound_Ts, t) of
  36.308 +    Type (s, Ts) =>
  36.309 +    massage_let_if_case ctxt has_call (fn _ => fn t =>
  36.310 +      if can (dest_ctr ctxt s) t then t else expand_to_ctr_term ctxt s Ts t) bound_Ts t
  36.311 +  | _ => raise Fail "expand_corec_code_rhs");
  36.312 +
  36.313 +fun massage_corec_code_rhs ctxt massage_ctr =
  36.314 +  massage_let_if_case ctxt (K false)
  36.315 +    (fn bound_Ts => uncurry (massage_ctr bound_Ts) o Term.strip_comb);
  36.316 +
  36.317 +fun fold_rev_corec_code_rhs ctxt f =
  36.318 +  snd ooo fold_rev_let_if_case ctxt (fn conds => uncurry (f conds) o Term.strip_comb);
  36.319 +
  36.320 +fun case_thms_of_term ctxt bound_Ts t =
  36.321 +  let
  36.322 +    val (caseT_names, _) = fold_rev_let_if_case ctxt (K (K I)) bound_Ts t ();
  36.323 +    val ctr_sugars = map (the o ctr_sugar_of ctxt) caseT_names;
  36.324 +  in
  36.325 +    (maps #distincts ctr_sugars, maps #discIs ctr_sugars, maps #sel_splits ctr_sugars,
  36.326 +     maps #sel_split_asms ctr_sugars)
  36.327 +  end;
  36.328 +
  36.329 +fun basic_corec_specs_of ctxt res_T =
  36.330 +  (case res_T of
  36.331 +    Type (T_name, _) =>
  36.332 +    (case Ctr_Sugar.ctr_sugar_of ctxt T_name of
  36.333 +      NONE => not_codatatype ctxt res_T
  36.334 +    | SOME {ctrs, discs, selss, ...} =>
  36.335 +      let
  36.336 +        val thy = Proof_Context.theory_of ctxt;
  36.337 +
  36.338 +        val gfpT = body_type (fastype_of (hd ctrs));
  36.339 +        val As_rho = tvar_subst thy [gfpT] [res_T];
  36.340 +        val substA = Term.subst_TVars As_rho;
  36.341 +
  36.342 +        fun mk_spec ctr disc sels = {ctr = substA ctr, disc = substA disc, sels = map substA sels};
  36.343 +      in
  36.344 +        map3 mk_spec ctrs discs selss
  36.345 +      end)
  36.346 +  | _ => not_codatatype ctxt res_T);
  36.347 +
  36.348 +fun corec_specs_of bs arg_Ts res_Ts get_indices callssss0 lthy =
  36.349 +  let
  36.350 +    val thy = Proof_Context.theory_of lthy;
  36.351 +
  36.352 +    val ((missing_res_Ts, perm0_kks,
  36.353 +          fp_sugars as {nested_bnfs, fp_res = {xtor_co_iterss = dtor_coiters1 :: _, ...},
  36.354 +            co_inducts = coinduct_thms, ...} :: _, (_, gfp_sugar_thms)), lthy') =
  36.355 +      nested_to_mutual_fps Greatest_FP bs res_Ts get_indices callssss0 lthy;
  36.356 +
  36.357 +    val perm_fp_sugars = sort (int_ord o pairself #index) fp_sugars;
  36.358 +
  36.359 +    val indices = map #index fp_sugars;
  36.360 +    val perm_indices = map #index perm_fp_sugars;
  36.361 +
  36.362 +    val perm_ctrss = map (#ctrs o of_fp_sugar #ctr_sugars) perm_fp_sugars;
  36.363 +    val perm_ctr_Tsss = map (map (binder_types o fastype_of)) perm_ctrss;
  36.364 +    val perm_gfpTs = map (body_type o fastype_of o hd) perm_ctrss;
  36.365 +
  36.366 +    val nn0 = length res_Ts;
  36.367 +    val nn = length perm_gfpTs;
  36.368 +    val kks = 0 upto nn - 1;
  36.369 +    val perm_ns = map length perm_ctr_Tsss;
  36.370 +
  36.371 +    val perm_Cs = map (domain_type o body_fun_type o fastype_of o co_rec_of o
  36.372 +      of_fp_sugar (#xtor_co_iterss o #fp_res)) perm_fp_sugars;
  36.373 +    val (perm_p_Tss, (perm_q_Tssss, _, perm_f_Tssss, _)) =
  36.374 +      mk_coiter_fun_arg_types perm_ctr_Tsss perm_Cs perm_ns (co_rec_of dtor_coiters1);
  36.375 +
  36.376 +    val (perm_p_hss, h) = indexedd perm_p_Tss 0;
  36.377 +    val (perm_q_hssss, h') = indexedddd perm_q_Tssss h;
  36.378 +    val (perm_f_hssss, _) = indexedddd perm_f_Tssss h';
  36.379 +
  36.380 +    val fun_arg_hs =
  36.381 +      flat (map3 flat_corec_preds_predsss_gettersss perm_p_hss perm_q_hssss perm_f_hssss);
  36.382 +
  36.383 +    fun unpermute0 perm0_xs = permute_like (op =) perm0_kks kks perm0_xs;
  36.384 +    fun unpermute perm_xs = permute_like (op =) perm_indices indices perm_xs;
  36.385 +
  36.386 +    val coinduct_thmss = map (unpermute0 o conj_dests nn) coinduct_thms;
  36.387 +
  36.388 +    val p_iss = map (map (find_index_eq fun_arg_hs)) (unpermute perm_p_hss);
  36.389 +    val q_issss = map (map (map (map (find_index_eq fun_arg_hs)))) (unpermute perm_q_hssss);
  36.390 +    val f_issss = map (map (map (map (find_index_eq fun_arg_hs)))) (unpermute perm_f_hssss);
  36.391 +
  36.392 +    val f_Tssss = unpermute perm_f_Tssss;
  36.393 +    val gfpTs = unpermute perm_gfpTs;
  36.394 +    val Cs = unpermute perm_Cs;
  36.395 +
  36.396 +    val As_rho = tvar_subst thy (take nn0 gfpTs) res_Ts;
  36.397 +    val Cs_rho = map (fst o dest_TVar) Cs ~~ pad_list HOLogic.unitT nn arg_Ts;
  36.398 +
  36.399 +    val substA = Term.subst_TVars As_rho;
  36.400 +    val substAT = Term.typ_subst_TVars As_rho;
  36.401 +    val substCT = Term.typ_subst_TVars Cs_rho;
  36.402 +
  36.403 +    val perm_Cs' = map substCT perm_Cs;
  36.404 +
  36.405 +    fun call_of nullary [] [g_i] [Type (@{type_name fun}, [_, T])] =
  36.406 +        (if exists_subtype_in Cs T then Nested_Corec
  36.407 +         else if nullary then Dummy_No_Corec
  36.408 +         else No_Corec) g_i
  36.409 +      | call_of _ [q_i] [g_i, g_i'] _ = Mutual_Corec (q_i, g_i, g_i');
  36.410 +
  36.411 +    fun mk_ctr_spec ctr disc sels p_ho q_iss f_iss f_Tss discI sel_thms collapse corec_thm
  36.412 +        disc_corec sel_corecs =
  36.413 +      let val nullary = not (can dest_funT (fastype_of ctr)) in
  36.414 +        {ctr = substA ctr, disc = substA disc, sels = map substA sels, pred = p_ho,
  36.415 +         calls = map3 (call_of nullary) q_iss f_iss f_Tss, discI = discI, sel_thms = sel_thms,
  36.416 +         collapse = collapse, corec_thm = corec_thm, disc_corec = disc_corec,
  36.417 +         sel_corecs = sel_corecs}
  36.418 +      end;
  36.419 +
  36.420 +    fun mk_ctr_specs index (ctr_sugars : ctr_sugar list) p_is q_isss f_isss f_Tsss coiter_thmsss
  36.421 +        disc_coitersss sel_coiterssss =
  36.422 +      let
  36.423 +        val ctrs = #ctrs (nth ctr_sugars index);
  36.424 +        val discs = #discs (nth ctr_sugars index);
  36.425 +        val selss = #selss (nth ctr_sugars index);
  36.426 +        val p_ios = map SOME p_is @ [NONE];
  36.427 +        val discIs = #discIs (nth ctr_sugars index);
  36.428 +        val sel_thmss = #sel_thmss (nth ctr_sugars index);
  36.429 +        val collapses = #collapses (nth ctr_sugars index);
  36.430 +        val corec_thms = co_rec_of (nth coiter_thmsss index);
  36.431 +        val disc_corecs = co_rec_of (nth disc_coitersss index);
  36.432 +        val sel_corecss = co_rec_of (nth sel_coiterssss index);
  36.433 +      in
  36.434 +        map13 mk_ctr_spec ctrs discs selss p_ios q_isss f_isss f_Tsss discIs sel_thmss collapses
  36.435 +          corec_thms disc_corecs sel_corecss
  36.436 +      end;
  36.437 +
  36.438 +    fun mk_spec ({T, index, ctr_sugars, co_iterss = coiterss, co_iter_thmsss = coiter_thmsss,
  36.439 +          disc_co_itersss = disc_coitersss, sel_co_iterssss = sel_coiterssss, ...} : fp_sugar)
  36.440 +        p_is q_isss f_isss f_Tsss =
  36.441 +      {corec = mk_co_iter thy Greatest_FP (substAT T) perm_Cs' (co_rec_of (nth coiterss index)),
  36.442 +       nested_map_idents = map (unfold_thms lthy @{thms id_def} o map_id0_of_bnf) nested_bnfs,
  36.443 +       nested_map_comps = map map_comp_of_bnf nested_bnfs,
  36.444 +       ctr_specs = mk_ctr_specs index ctr_sugars p_is q_isss f_isss f_Tsss coiter_thmsss
  36.445 +         disc_coitersss sel_coiterssss};
  36.446 +  in
  36.447 +    ((is_some gfp_sugar_thms, map5 mk_spec fp_sugars p_iss q_issss f_issss f_Tssss, missing_res_Ts,
  36.448 +      co_induct_of coinduct_thms, strong_co_induct_of coinduct_thms, co_induct_of coinduct_thmss,
  36.449 +      strong_co_induct_of coinduct_thmss), lthy')
  36.450 +  end;
  36.451 +
  36.452 +val undef_const = Const (@{const_name undefined}, dummyT);
  36.453 +
  36.454 +val abs_tuple = HOLogic.tupled_lambda o HOLogic.mk_tuple;
  36.455 +fun abstract vs =
  36.456 +  let fun a n (t $ u) = a n t $ a n u
  36.457 +        | a n (Abs (v, T, b)) = Abs (v, T, a (n + 1) b)
  36.458 +        | a n t = let val idx = find_index (equal t) vs in
  36.459 +            if idx < 0 then t else Bound (n + idx) end
  36.460 +  in a 0 end;
  36.461 +
  36.462 +fun mk_prod1 bound_Ts (t, u) =
  36.463 +  HOLogic.pair_const (fastype_of1 (bound_Ts, t)) (fastype_of1 (bound_Ts, u)) $ t $ u;
  36.464 +fun mk_tuple1 bound_Ts = the_default HOLogic.unit o try (foldr1 (mk_prod1 bound_Ts));
  36.465 +
  36.466 +type coeqn_data_disc = {
  36.467 +  fun_name: string,
  36.468 +  fun_T: typ,
  36.469 +  fun_args: term list,
  36.470 +  ctr: term,
  36.471 +  ctr_no: int, (*###*)
  36.472 +  disc: term,
  36.473 +  prems: term list,
  36.474 +  auto_gen: bool,
  36.475 +  maybe_ctr_rhs: term option,
  36.476 +  maybe_code_rhs: term option,
  36.477 +  user_eqn: term
  36.478 +};
  36.479 +
  36.480 +type coeqn_data_sel = {
  36.481 +  fun_name: string,
  36.482 +  fun_T: typ,
  36.483 +  fun_args: term list,
  36.484 +  ctr: term,
  36.485 +  sel: term,
  36.486 +  rhs_term: term,
  36.487 +  user_eqn: term
  36.488 +};
  36.489 +
  36.490 +datatype coeqn_data =
  36.491 +  Disc of coeqn_data_disc |
  36.492 +  Sel of coeqn_data_sel;
  36.493 +
  36.494 +fun dissect_coeqn_disc seq fun_names (basic_ctr_specss : basic_corec_ctr_spec list list)
  36.495 +    maybe_ctr_rhs maybe_code_rhs prems' concl matchedsss =
  36.496 +  let
  36.497 +    fun find_subterm p =
  36.498 +      let (* FIXME \<exists>? *)
  36.499 +        fun find (t as u $ v) = if p t then SOME t else merge_options (find u, find v)
  36.500 +          | find t = if p t then SOME t else NONE;
  36.501 +      in find end;
  36.502 +
  36.503 +    val applied_fun = concl
  36.504 +      |> find_subterm (member ((op =) o apsnd SOME) fun_names o try (fst o dest_Free o head_of))
  36.505 +      |> the
  36.506 +      handle Option.Option => primcorec_error_eqn "malformed discriminator formula" concl;
  36.507 +    val ((fun_name, fun_T), fun_args) = strip_comb applied_fun |>> dest_Free;
  36.508 +    val SOME basic_ctr_specs = AList.lookup (op =) (fun_names ~~ basic_ctr_specss) fun_name;
  36.509 +
  36.510 +    val discs = map #disc basic_ctr_specs;
  36.511 +    val ctrs = map #ctr basic_ctr_specs;
  36.512 +    val not_disc = head_of concl = @{term Not};
  36.513 +    val _ = not_disc andalso length ctrs <> 2 andalso
  36.514 +      primcorec_error_eqn "negated discriminator for a type with \<noteq> 2 constructors" concl;
  36.515 +    val disc' = find_subterm (member (op =) discs o head_of) concl;
  36.516 +    val eq_ctr0 = concl |> perhaps (try HOLogic.dest_not) |> try (HOLogic.dest_eq #> snd)
  36.517 +        |> (fn SOME t => let val n = find_index (equal t) ctrs in
  36.518 +          if n >= 0 then SOME n else NONE end | _ => NONE);
  36.519 +    val _ = is_some disc' orelse is_some eq_ctr0 orelse
  36.520 +      primcorec_error_eqn "no discriminator in equation" concl;
  36.521 +    val ctr_no' =
  36.522 +      if is_none disc' then the eq_ctr0 else find_index (equal (head_of (the disc'))) discs;
  36.523 +    val ctr_no = if not_disc then 1 - ctr_no' else ctr_no';
  36.524 +    val {ctr, disc, ...} = nth basic_ctr_specs ctr_no;
  36.525 +
  36.526 +    val catch_all = try (fst o dest_Free o the_single) prems' = SOME Name.uu_;
  36.527 +    val matchedss = AList.lookup (op =) matchedsss fun_name |> the_default [];
  36.528 +    val prems = map (abstract (List.rev fun_args)) prems';
  36.529 +    val real_prems =
  36.530 +      (if catch_all orelse seq then maps s_not_conj matchedss else []) @
  36.531 +      (if catch_all then [] else prems);
  36.532 +
  36.533 +    val matchedsss' = AList.delete (op =) fun_name matchedsss
  36.534 +      |> cons (fun_name, if seq then matchedss @ [prems] else matchedss @ [real_prems]);
  36.535 +
  36.536 +    val user_eqn =
  36.537 +      (real_prems, concl)
  36.538 +      |>> map HOLogic.mk_Trueprop ||> HOLogic.mk_Trueprop o abstract (List.rev fun_args)
  36.539 +      |> curry Logic.list_all (map dest_Free fun_args) o Logic.list_implies;
  36.540 +  in
  36.541 +    (Disc {
  36.542 +      fun_name = fun_name,
  36.543 +      fun_T = fun_T,
  36.544 +      fun_args = fun_args,
  36.545 +      ctr = ctr,
  36.546 +      ctr_no = ctr_no,
  36.547 +      disc = disc,
  36.548 +      prems = real_prems,
  36.549 +      auto_gen = catch_all,
  36.550 +      maybe_ctr_rhs = maybe_ctr_rhs,
  36.551 +      maybe_code_rhs = maybe_code_rhs,
  36.552 +      user_eqn = user_eqn
  36.553 +    }, matchedsss')
  36.554 +  end;
  36.555 +
  36.556 +fun dissect_coeqn_sel fun_names (basic_ctr_specss : basic_corec_ctr_spec list list) eqn'
  36.557 +    maybe_of_spec eqn =
  36.558 +  let
  36.559 +    val (lhs, rhs) = HOLogic.dest_eq eqn
  36.560 +      handle TERM _ =>
  36.561 +        primcorec_error_eqn "malformed function equation (expected \"lhs = rhs\")" eqn;
  36.562 +    val sel = head_of lhs;
  36.563 +    val ((fun_name, fun_T), fun_args) = dest_comb lhs |> snd |> strip_comb |> apfst dest_Free
  36.564 +      handle TERM _ =>
  36.565 +        primcorec_error_eqn "malformed selector argument in left-hand side" eqn;
  36.566 +    val basic_ctr_specs = the (AList.lookup (op =) (fun_names ~~ basic_ctr_specss) fun_name)
  36.567 +      handle Option.Option =>
  36.568 +        primcorec_error_eqn "malformed selector argument in left-hand side" eqn;
  36.569 +    val {ctr, ...} =
  36.570 +      (case maybe_of_spec of
  36.571 +        SOME of_spec => the (find_first (equal of_spec o #ctr) basic_ctr_specs)
  36.572 +      | NONE => filter (exists (equal sel) o #sels) basic_ctr_specs |> the_single
  36.573 +          handle List.Empty => primcorec_error_eqn "ambiguous selector - use \"of\"" eqn);
  36.574 +    val user_eqn = drop_All eqn';
  36.575 +  in
  36.576 +    Sel {
  36.577 +      fun_name = fun_name,
  36.578 +      fun_T = fun_T,
  36.579 +      fun_args = fun_args,
  36.580 +      ctr = ctr,
  36.581 +      sel = sel,
  36.582 +      rhs_term = rhs,
  36.583 +      user_eqn = user_eqn
  36.584 +    }
  36.585 +  end;
  36.586 +
  36.587 +fun dissect_coeqn_ctr seq fun_names (basic_ctr_specss : basic_corec_ctr_spec list list) eqn'
  36.588 +    maybe_code_rhs prems concl matchedsss =
  36.589 +  let
  36.590 +    val (lhs, rhs) = HOLogic.dest_eq concl;
  36.591 +    val (fun_name, fun_args) = strip_comb lhs |>> fst o dest_Free;
  36.592 +    val SOME basic_ctr_specs = AList.lookup (op =) (fun_names ~~ basic_ctr_specss) fun_name;
  36.593 +    val (ctr, ctr_args) = strip_comb (unfold_let rhs);
  36.594 +    val {disc, sels, ...} = the (find_first (equal ctr o #ctr) basic_ctr_specs)
  36.595 +      handle Option.Option => primcorec_error_eqn "not a constructor" ctr;
  36.596 +
  36.597 +    val disc_concl = betapply (disc, lhs);
  36.598 +    val (maybe_eqn_data_disc, matchedsss') = if length basic_ctr_specs = 1
  36.599 +      then (NONE, matchedsss)
  36.600 +      else apfst SOME (dissect_coeqn_disc seq fun_names basic_ctr_specss
  36.601 +          (SOME (abstract (List.rev fun_args) rhs)) maybe_code_rhs prems disc_concl matchedsss);
  36.602 +
  36.603 +    val sel_concls = sels ~~ ctr_args
  36.604 +      |> map (fn (sel, ctr_arg) => HOLogic.mk_eq (betapply (sel, lhs), ctr_arg));
  36.605 +
  36.606 +(*
  36.607 +val _ = tracing ("reduced\n    " ^ Syntax.string_of_term @{context} concl ^ "\nto\n    \<cdot> " ^
  36.608 + (is_some maybe_eqn_data_disc ? K (Syntax.string_of_term @{context} disc_concl ^ "\n    \<cdot> ")) "" ^
  36.609 + space_implode "\n    \<cdot> " (map (Syntax.string_of_term @{context}) sel_concls) ^
  36.610 + "\nfor premise(s)\n    \<cdot> " ^
  36.611 + space_implode "\n    \<cdot> " (map (Syntax.string_of_term @{context}) prems));
  36.612 +*)
  36.613 +
  36.614 +    val eqns_data_sel =
  36.615 +      map (dissect_coeqn_sel fun_names basic_ctr_specss eqn' (SOME ctr)) sel_concls;
  36.616 +  in
  36.617 +    (the_list maybe_eqn_data_disc @ eqns_data_sel, matchedsss')
  36.618 +  end;
  36.619 +
  36.620 +fun dissect_coeqn_code lthy has_call fun_names basic_ctr_specss eqn' concl matchedsss =
  36.621 +  let
  36.622 +    val (lhs, (rhs', rhs)) = HOLogic.dest_eq concl ||> `(expand_corec_code_rhs lthy has_call []);
  36.623 +    val (fun_name, fun_args) = strip_comb lhs |>> fst o dest_Free;
  36.624 +    val SOME basic_ctr_specs = AList.lookup (op =) (fun_names ~~ basic_ctr_specss) fun_name;
  36.625 +
  36.626 +    val cond_ctrs = fold_rev_corec_code_rhs lthy (fn cs => fn ctr => fn _ =>
  36.627 +        if member ((op =) o apsnd #ctr) basic_ctr_specs ctr
  36.628 +        then cons (ctr, cs)
  36.629 +        else primcorec_error_eqn "not a constructor" ctr) [] rhs' []
  36.630 +      |> AList.group (op =);
  36.631 +
  36.632 +    val ctr_premss = (case cond_ctrs of [_] => [[]] | _ => map (s_dnf o snd) cond_ctrs);
  36.633 +    val ctr_concls = cond_ctrs |> map (fn (ctr, _) =>
  36.634 +        binder_types (fastype_of ctr)
  36.635 +        |> map_index (fn (n, T) => massage_corec_code_rhs lthy (fn _ => fn ctr' => fn args =>
  36.636 +          if ctr' = ctr then nth args n else Const (@{const_name undefined}, T)) [] rhs')
  36.637 +        |> curry list_comb ctr
  36.638 +        |> curry HOLogic.mk_eq lhs);
  36.639 +  in
  36.640 +    fold_map2 (dissect_coeqn_ctr false fun_names basic_ctr_specss eqn'
  36.641 +        (SOME (abstract (List.rev fun_args) rhs)))
  36.642 +      ctr_premss ctr_concls matchedsss
  36.643 +  end;
  36.644 +
  36.645 +fun dissect_coeqn lthy seq has_call fun_names (basic_ctr_specss : basic_corec_ctr_spec list list)
  36.646 +    eqn' maybe_of_spec matchedsss =
  36.647 +  let
  36.648 +    val eqn = drop_All eqn'
  36.649 +      handle TERM _ => primcorec_error_eqn "malformed function equation" eqn';
  36.650 +    val (prems, concl) = Logic.strip_horn eqn
  36.651 +      |> apfst (map HOLogic.dest_Trueprop) o apsnd HOLogic.dest_Trueprop;
  36.652 +
  36.653 +    val head = concl
  36.654 +      |> perhaps (try HOLogic.dest_not) |> perhaps (try (fst o HOLogic.dest_eq))
  36.655 +      |> head_of;
  36.656 +
  36.657 +    val maybe_rhs = concl |> perhaps (try HOLogic.dest_not) |> try (snd o HOLogic.dest_eq);
  36.658 +
  36.659 +    val discs = maps (map #disc) basic_ctr_specss;
  36.660 +    val sels = maps (maps #sels) basic_ctr_specss;
  36.661 +    val ctrs = maps (map #ctr) basic_ctr_specss;
  36.662 +  in
  36.663 +    if member (op =) discs head orelse
  36.664 +      is_some maybe_rhs andalso
  36.665 +        member (op =) (filter (null o binder_types o fastype_of) ctrs) (the maybe_rhs) then
  36.666 +      dissect_coeqn_disc seq fun_names basic_ctr_specss NONE NONE prems concl matchedsss
  36.667 +      |>> single
  36.668 +    else if member (op =) sels head then
  36.669 +      ([dissect_coeqn_sel fun_names basic_ctr_specss eqn' maybe_of_spec concl], matchedsss)
  36.670 +    else if is_Free head andalso member (op =) fun_names (fst (dest_Free head)) andalso
  36.671 +      member (op =) ctrs (head_of (unfold_let (the maybe_rhs))) then
  36.672 +      dissect_coeqn_ctr seq fun_names basic_ctr_specss eqn' NONE prems concl matchedsss
  36.673 +    else if is_Free head andalso member (op =) fun_names (fst (dest_Free head)) andalso
  36.674 +      null prems then
  36.675 +      dissect_coeqn_code lthy has_call fun_names basic_ctr_specss eqn' concl matchedsss
  36.676 +      |>> flat
  36.677 +    else
  36.678 +      primcorec_error_eqn "malformed function equation" eqn
  36.679 +  end;
  36.680 +
  36.681 +fun build_corec_arg_disc (ctr_specs : corec_ctr_spec list)
  36.682 +    ({fun_args, ctr_no, prems, ...} : coeqn_data_disc) =
  36.683 +  if is_none (#pred (nth ctr_specs ctr_no)) then I else
  36.684 +    s_conjs prems
  36.685 +    |> curry subst_bounds (List.rev fun_args)
  36.686 +    |> HOLogic.tupled_lambda (HOLogic.mk_tuple fun_args)
  36.687 +    |> K |> nth_map (the (#pred (nth ctr_specs ctr_no)));
  36.688 +
  36.689 +fun build_corec_arg_no_call (sel_eqns : coeqn_data_sel list) sel =
  36.690 +  find_first (equal sel o #sel) sel_eqns
  36.691 +  |> try (fn SOME {fun_args, rhs_term, ...} => abs_tuple fun_args rhs_term)
  36.692 +  |> the_default undef_const
  36.693 +  |> K;
  36.694 +
  36.695 +fun build_corec_args_mutual_call lthy has_call (sel_eqns : coeqn_data_sel list) sel =
  36.696 +  (case find_first (equal sel o #sel) sel_eqns of
  36.697 +    NONE => (I, I, I)
  36.698 +  | SOME {fun_args, rhs_term, ... } =>
  36.699 +    let
  36.700 +      val bound_Ts = List.rev (map fastype_of fun_args);
  36.701 +      fun rewrite_stop _ t = if has_call t then @{term False} else @{term True};
  36.702 +      fun rewrite_end _ t = if has_call t then undef_const else t;
  36.703 +      fun rewrite_cont bound_Ts t =
  36.704 +        if has_call t then mk_tuple1 bound_Ts (snd (strip_comb t)) else undef_const;
  36.705 +      fun massage f _ = massage_mutual_corec_call lthy has_call f bound_Ts rhs_term
  36.706 +        |> abs_tuple fun_args;
  36.707 +    in
  36.708 +      (massage rewrite_stop, massage rewrite_end, massage rewrite_cont)
  36.709 +    end);
  36.710 +
  36.711 +fun build_corec_arg_nested_call lthy has_call (sel_eqns : coeqn_data_sel list) sel =
  36.712 +  (case find_first (equal sel o #sel) sel_eqns of
  36.713 +    NONE => I
  36.714 +  | SOME {fun_args, rhs_term, ...} =>
  36.715 +    let
  36.716 +      val bound_Ts = List.rev (map fastype_of fun_args);
  36.717 +      fun rewrite bound_Ts U T (Abs (v, V, b)) = Abs (v, V, rewrite (V :: bound_Ts) U T b)
  36.718 +        | rewrite bound_Ts U T (t as _ $ _) =
  36.719 +          let val (u, vs) = strip_comb t in
  36.720 +            if is_Free u andalso has_call u then
  36.721 +              Inr_const U T $ mk_tuple1 bound_Ts vs
  36.722 +            else if try (fst o dest_Const) u = SOME @{const_name prod_case} then
  36.723 +              map (rewrite bound_Ts U T) vs |> chop 1 |>> HOLogic.mk_split o the_single |> list_comb
  36.724 +            else
  36.725 +              list_comb (rewrite bound_Ts U T u, map (rewrite bound_Ts U T) vs)
  36.726 +          end
  36.727 +        | rewrite _ U T t =
  36.728 +          if is_Free t andalso has_call t then Inr_const U T $ HOLogic.unit else t;
  36.729 +      fun massage t =
  36.730 +        rhs_term
  36.731 +        |> massage_nested_corec_call lthy has_call rewrite bound_Ts (range_type (fastype_of t))
  36.732 +        |> abs_tuple fun_args;
  36.733 +    in
  36.734 +      massage
  36.735 +    end);
  36.736 +
  36.737 +fun build_corec_args_sel lthy has_call (all_sel_eqns : coeqn_data_sel list)
  36.738 +    (ctr_spec : corec_ctr_spec) =
  36.739 +  (case filter (equal (#ctr ctr_spec) o #ctr) all_sel_eqns of
  36.740 +    [] => I
  36.741 +  | sel_eqns =>
  36.742 +    let
  36.743 +      val sel_call_list = #sels ctr_spec ~~ #calls ctr_spec;
  36.744 +      val no_calls' = map_filter (try (apsnd (fn No_Corec n => n))) sel_call_list;
  36.745 +      val mutual_calls' = map_filter (try (apsnd (fn Mutual_Corec n => n))) sel_call_list;
  36.746 +      val nested_calls' = map_filter (try (apsnd (fn Nested_Corec n => n))) sel_call_list;
  36.747 +    in
  36.748 +      I
  36.749 +      #> fold (fn (sel, n) => nth_map n (build_corec_arg_no_call sel_eqns sel)) no_calls'
  36.750 +      #> fold (fn (sel, (q, g, h)) =>
  36.751 +        let val (fq, fg, fh) = build_corec_args_mutual_call lthy has_call sel_eqns sel in
  36.752 +          nth_map q fq o nth_map g fg o nth_map h fh end) mutual_calls'
  36.753 +      #> fold (fn (sel, n) => nth_map n
  36.754 +        (build_corec_arg_nested_call lthy has_call sel_eqns sel)) nested_calls'
  36.755 +    end);
  36.756 +
  36.757 +fun build_codefs lthy bs mxs has_call arg_Tss (corec_specs : corec_spec list)
  36.758 +    (disc_eqnss : coeqn_data_disc list list) (sel_eqnss : coeqn_data_sel list list) =
  36.759 +  let
  36.760 +    val corecs = map #corec corec_specs;
  36.761 +    val ctr_specss = map #ctr_specs corec_specs;
  36.762 +    val corec_args = hd corecs
  36.763 +      |> fst o split_last o binder_types o fastype_of
  36.764 +      |> map (Const o pair @{const_name undefined})
  36.765 +      |> fold2 (fold o build_corec_arg_disc) ctr_specss disc_eqnss
  36.766 +      |> fold2 (fold o build_corec_args_sel lthy has_call) sel_eqnss ctr_specss;
  36.767 +    fun currys [] t = t
  36.768 +      | currys Ts t = t $ mk_tuple1 (List.rev Ts) (map Bound (length Ts - 1 downto 0))
  36.769 +          |> fold_rev (Term.abs o pair Name.uu) Ts;
  36.770 +
  36.771 +(*
  36.772 +val _ = tracing ("corecursor arguments:\n    \<cdot> " ^
  36.773 + space_implode "\n    \<cdot> " (map (Syntax.string_of_term lthy) corec_args));
  36.774 +*)
  36.775 +
  36.776 +    val exclss' =
  36.777 +      disc_eqnss
  36.778 +      |> map (map (fn x => (#fun_args x, #ctr_no x, #prems x, #auto_gen x))
  36.779 +        #> fst o (fn xs => fold_map (fn x => fn ys => ((x, ys), ys @ [x])) xs [])
  36.780 +        #> maps (uncurry (map o pair)
  36.781 +          #> map (fn ((fun_args, c, x, a), (_, c', y, a')) =>
  36.782 +              ((c, c', a orelse a'), (x, s_not (s_conjs y)))
  36.783 +            ||> apfst (map HOLogic.mk_Trueprop) o apsnd HOLogic.mk_Trueprop
  36.784 +            ||> Logic.list_implies
  36.785 +            ||> curry Logic.list_all (map dest_Free fun_args))))
  36.786 +  in
  36.787 +    map (list_comb o rpair corec_args) corecs
  36.788 +    |> map2 (fn Ts => fn t => if length Ts = 0 then t $ HOLogic.unit else t) arg_Tss
  36.789 +    |> map2 currys arg_Tss
  36.790 +    |> Syntax.check_terms lthy
  36.791 +    |> map3 (fn b => fn mx => fn t => ((b, mx), ((Binding.conceal (Thm.def_binding b), []), t)))
  36.792 +      bs mxs
  36.793 +    |> rpair exclss'
  36.794 +  end;
  36.795 +
  36.796 +fun mk_real_disc_eqns fun_binding arg_Ts ({ctr_specs, ...} : corec_spec)
  36.797 +    (sel_eqns : coeqn_data_sel list) (disc_eqns : coeqn_data_disc list) =
  36.798 +  if length disc_eqns <> length ctr_specs - 1 then disc_eqns else
  36.799 +    let
  36.800 +      val n = 0 upto length ctr_specs
  36.801 +        |> the o find_first (fn idx => not (exists (equal idx o #ctr_no) disc_eqns));
  36.802 +      val fun_args = (try (#fun_args o hd) disc_eqns, try (#fun_args o hd) sel_eqns)
  36.803 +        |> the_default (map (curry Free Name.uu) arg_Ts) o merge_options;
  36.804 +      val extra_disc_eqn = {
  36.805 +        fun_name = Binding.name_of fun_binding,
  36.806 +        fun_T = arg_Ts ---> body_type (fastype_of (#ctr (hd ctr_specs))),
  36.807 +        fun_args = fun_args,
  36.808 +        ctr = #ctr (nth ctr_specs n),
  36.809 +        ctr_no = n,
  36.810 +        disc = #disc (nth ctr_specs n),
  36.811 +        prems = maps (s_not_conj o #prems) disc_eqns,
  36.812 +        auto_gen = true,
  36.813 +        maybe_ctr_rhs = NONE,
  36.814 +        maybe_code_rhs = NONE,
  36.815 +        user_eqn = undef_const};
  36.816 +    in
  36.817 +      chop n disc_eqns ||> cons extra_disc_eqn |> (op @)
  36.818 +    end;
  36.819 +
  36.820 +fun find_corec_calls ctxt has_call basic_ctr_specs ({ctr, sel, rhs_term, ...} : coeqn_data_sel) =
  36.821 +  let
  36.822 +    val sel_no = find_first (equal ctr o #ctr) basic_ctr_specs
  36.823 +      |> find_index (equal sel) o #sels o the;
  36.824 +    fun find t = if has_call t then snd (fold_rev_corec_call ctxt (K cons) [] t []) else [];
  36.825 +  in
  36.826 +    find rhs_term
  36.827 +    |> K |> nth_map sel_no |> AList.map_entry (op =) ctr
  36.828 +  end;
  36.829 +
  36.830 +fun add_primcorec_ursive maybe_tac seq fixes specs maybe_of_specs lthy =
  36.831 +  let
  36.832 +    val thy = Proof_Context.theory_of lthy;
  36.833 +
  36.834 +    val (bs, mxs) = map_split (apfst fst) fixes;
  36.835 +    val (arg_Ts, res_Ts) = map (strip_type o snd o fst #>> HOLogic.mk_tupleT) fixes |> split_list;
  36.836 +
  36.837 +    val _ = (case filter_out (fn (_, T) => Sign.of_sort thy (T, HOLogic.typeS)) (bs ~~ arg_Ts) of
  36.838 +        [] => ()
  36.839 +      | (b, _) :: _ => primcorec_error ("type of " ^ Binding.print b ^ " contains top sort"));
  36.840 +
  36.841 +    val fun_names = map Binding.name_of bs;
  36.842 +    val basic_ctr_specss = map (basic_corec_specs_of lthy) res_Ts;
  36.843 +    val has_call = exists_subterm (map (fst #>> Binding.name_of #> Free) fixes |> member (op =));
  36.844 +    val eqns_data =
  36.845 +      fold_map2 (dissect_coeqn lthy seq has_call fun_names basic_ctr_specss) (map snd specs)
  36.846 +        maybe_of_specs []
  36.847 +      |> flat o fst;
  36.848 +
  36.849 +    val callssss =
  36.850 +      map_filter (try (fn Sel x => x)) eqns_data
  36.851 +      |> partition_eq ((op =) o pairself #fun_name)
  36.852 +      |> fst o finds (fn (x, ({fun_name, ...} :: _)) => x = fun_name) fun_names
  36.853 +      |> map (flat o snd)
  36.854 +      |> map2 (fold o find_corec_calls lthy has_call) basic_ctr_specss
  36.855 +      |> map2 (curry (op |>)) (map (map (fn {ctr, sels, ...} =>
  36.856 +        (ctr, map (K []) sels))) basic_ctr_specss);
  36.857 +
  36.858 +(*
  36.859 +val _ = tracing ("callssss = " ^ @{make_string} callssss);
  36.860 +*)
  36.861 +
  36.862 +    val ((n2m, corec_specs', _, coinduct_thm, strong_coinduct_thm, coinduct_thms,
  36.863 +          strong_coinduct_thms), lthy') =
  36.864 +      corec_specs_of bs arg_Ts res_Ts (get_indices fixes) callssss lthy;
  36.865 +    val actual_nn = length bs;
  36.866 +    val corec_specs = take actual_nn corec_specs'; (*###*)
  36.867 +    val ctr_specss = map #ctr_specs corec_specs;
  36.868 +
  36.869 +    val disc_eqnss' = map_filter (try (fn Disc x => x)) eqns_data
  36.870 +      |> partition_eq ((op =) o pairself #fun_name)
  36.871 +      |> fst o finds (fn (x, ({fun_name, ...} :: _)) => x = fun_name) fun_names
  36.872 +      |> map (sort ((op <) o pairself #ctr_no |> make_ord) o flat o snd);
  36.873 +    val _ = disc_eqnss' |> map (fn x =>
  36.874 +      let val d = duplicates ((op =) o pairself #ctr_no) x in null d orelse
  36.875 +        primcorec_error_eqns "excess discriminator formula in definition"
  36.876 +          (maps (fn t => filter (equal (#ctr_no t) o #ctr_no) x) d |> map #user_eqn) end);
  36.877 +
  36.878 +    val sel_eqnss = map_filter (try (fn Sel x => x)) eqns_data
  36.879 +      |> partition_eq ((op =) o pairself #fun_name)
  36.880 +      |> fst o finds (fn (x, ({fun_name, ...} :: _)) => x = fun_name) fun_names
  36.881 +      |> map (flat o snd);
  36.882 +
  36.883 +    val arg_Tss = map (binder_types o snd o fst) fixes;
  36.884 +    val disc_eqnss = map5 mk_real_disc_eqns bs arg_Tss corec_specs sel_eqnss disc_eqnss';
  36.885 +    val (defs, exclss') =
  36.886 +      build_codefs lthy' bs mxs has_call arg_Tss corec_specs disc_eqnss sel_eqnss;
  36.887 +
  36.888 +    fun excl_tac (c, c', a) =
  36.889 +      if a orelse c = c' orelse seq then SOME (K (HEADGOAL (mk_primcorec_assumption_tac lthy [])))
  36.890 +      else maybe_tac;
  36.891 +
  36.892 +(*
  36.893 +val _ = tracing ("exclusiveness properties:\n    \<cdot> " ^
  36.894 + space_implode "\n    \<cdot> " (maps (map (Syntax.string_of_term lthy o snd)) exclss'));
  36.895 +*)
  36.896 +
  36.897 +    val exclss'' = exclss' |> map (map (fn (idx, t) =>
  36.898 +      (idx, (Option.map (Goal.prove lthy [] [] t #> Thm.close_derivation) (excl_tac idx), t))));
  36.899 +    val taut_thmss = map (map (apsnd (the o fst)) o filter (is_some o fst o snd)) exclss'';
  36.900 +    val (goal_idxss, goalss) = exclss''
  36.901 +      |> map (map (apsnd (rpair [] o snd)) o filter (is_none o fst o snd))
  36.902 +      |> split_list o map split_list;
  36.903 +
  36.904 +    fun prove thmss' def_thms' lthy =
  36.905 +      let
  36.906 +        val def_thms = map (snd o snd) def_thms';
  36.907 +
  36.908 +        val exclss' = map (op ~~) (goal_idxss ~~ thmss');
  36.909 +        fun mk_exclsss excls n =
  36.910 +          (excls, map (fn k => replicate k [TrueI] @ replicate (n - k) []) (0 upto n - 1))
  36.911 +          |-> fold (fn ((c, c', _), thm) => nth_map c (nth_map c' (K [thm])));
  36.912 +        val exclssss = (exclss' ~~ taut_thmss |> map (op @), fun_names ~~ corec_specs)
  36.913 +          |-> map2 (fn excls => fn (_, {ctr_specs, ...}) => mk_exclsss excls (length ctr_specs));
  36.914 +
  36.915 +        fun prove_disc ({ctr_specs, ...} : corec_spec) exclsss
  36.916 +            ({fun_name, fun_T, fun_args, ctr_no, prems, ...} : coeqn_data_disc) =
  36.917 +          if Term.aconv_untyped (#disc (nth ctr_specs ctr_no), @{term "\<lambda>x. x = x"}) then
  36.918 +            []
  36.919 +          else
  36.920 +            let
  36.921 +              val {disc_corec, ...} = nth ctr_specs ctr_no;
  36.922 +              val k = 1 + ctr_no;
  36.923 +              val m = length prems;
  36.924 +              val t =
  36.925 +                list_comb (Free (fun_name, fun_T), map Bound (length fun_args - 1 downto 0))
  36.926 +                |> curry betapply (#disc (nth ctr_specs ctr_no)) (*###*)
  36.927 +                |> HOLogic.mk_Trueprop
  36.928 +                |> curry Logic.list_implies (map HOLogic.mk_Trueprop prems)
  36.929 +                |> curry Logic.list_all (map dest_Free fun_args);
  36.930 +            in
  36.931 +              if prems = [@{term False}] then [] else
  36.932 +              mk_primcorec_disc_tac lthy def_thms disc_corec k m exclsss
  36.933 +              |> K |> Goal.prove lthy [] [] t
  36.934 +              |> Thm.close_derivation
  36.935 +              |> pair (#disc (nth ctr_specs ctr_no))
  36.936 +              |> single
  36.937 +            end;
  36.938 +
  36.939 +        fun prove_sel ({nested_map_idents, nested_map_comps, ctr_specs, ...} : corec_spec)
  36.940 +            (disc_eqns : coeqn_data_disc list) exclsss
  36.941 +            ({fun_name, fun_T, fun_args, ctr, sel, rhs_term, ...} : coeqn_data_sel) =
  36.942 +          let
  36.943 +            val SOME ctr_spec = find_first (equal ctr o #ctr) ctr_specs;
  36.944 +            val ctr_no = find_index (equal ctr o #ctr) ctr_specs;
  36.945 +            val prems = the_default (maps (s_not_conj o #prems) disc_eqns)
  36.946 +                (find_first (equal ctr_no o #ctr_no) disc_eqns |> Option.map #prems);
  36.947 +            val sel_corec = find_index (equal sel) (#sels ctr_spec)
  36.948 +              |> nth (#sel_corecs ctr_spec);
  36.949 +            val k = 1 + ctr_no;
  36.950 +            val m = length prems;
  36.951 +            val t =
  36.952 +              list_comb (Free (fun_name, fun_T), map Bound (length fun_args - 1 downto 0))
  36.953 +              |> curry betapply sel
  36.954 +              |> rpair (abstract (List.rev fun_args) rhs_term)
  36.955 +              |> HOLogic.mk_Trueprop o HOLogic.mk_eq
  36.956 +              |> curry Logic.list_implies (map HOLogic.mk_Trueprop prems)
  36.957 +              |> curry Logic.list_all (map dest_Free fun_args);
  36.958 +            val (distincts, _, sel_splits, sel_split_asms) = case_thms_of_term lthy [] rhs_term;
  36.959 +          in
  36.960 +            mk_primcorec_sel_tac lthy def_thms distincts sel_splits sel_split_asms nested_map_idents
  36.961 +              nested_map_comps sel_corec k m exclsss
  36.962 +            |> K |> Goal.prove lthy [] [] t
  36.963 +            |> Thm.close_derivation
  36.964 +            |> pair sel
  36.965 +          end;
  36.966 +
  36.967 +        fun prove_ctr disc_alist sel_alist (disc_eqns : coeqn_data_disc list)
  36.968 +            (sel_eqns : coeqn_data_sel list) ({ctr, disc, sels, collapse, ...} : corec_ctr_spec) =
  36.969 +          (* don't try to prove theorems when some sel_eqns are missing *)
  36.970 +          if not (exists (equal ctr o #ctr) disc_eqns)
  36.971 +              andalso not (exists (equal ctr o #ctr) sel_eqns)
  36.972 +            orelse
  36.973 +              filter (equal ctr o #ctr) sel_eqns
  36.974 +              |> fst o finds ((op =) o apsnd #sel) sels
  36.975 +              |> exists (null o snd)
  36.976 +          then [] else
  36.977 +            let
  36.978 +              val (fun_name, fun_T, fun_args, prems, maybe_rhs) =
  36.979 +                (find_first (equal ctr o #ctr) disc_eqns, find_first (equal ctr o #ctr) sel_eqns)
  36.980 +                |>> Option.map (fn x => (#fun_name x, #fun_T x, #fun_args x, #prems x,
  36.981 +                  #maybe_ctr_rhs x))
  36.982 +                ||> Option.map (fn x => (#fun_name x, #fun_T x, #fun_args x, [], NONE))
  36.983 +                |> the o merge_options;
  36.984 +              val m = length prems;
  36.985 +              val t = (if is_some maybe_rhs then the maybe_rhs else
  36.986 +                  filter (equal ctr o #ctr) sel_eqns
  36.987 +                  |> fst o finds ((op =) o apsnd #sel) sels
  36.988 +                  |> map (snd #> (fn [x] => (List.rev (#fun_args x), #rhs_term x)) #-> abstract)
  36.989 +                  |> curry list_comb ctr)
  36.990 +                |> curry HOLogic.mk_eq (list_comb (Free (fun_name, fun_T),
  36.991 +                  map Bound (length fun_args - 1 downto 0)))
  36.992 +                |> HOLogic.mk_Trueprop
  36.993 +                |> curry Logic.list_implies (map HOLogic.mk_Trueprop prems)
  36.994 +                |> curry Logic.list_all (map dest_Free fun_args);
  36.995 +              val maybe_disc_thm = AList.lookup (op =) disc_alist disc;
  36.996 +              val sel_thms = map snd (filter (member (op =) sels o fst) sel_alist);
  36.997 +            in
  36.998 +              if prems = [@{term False}] then [] else
  36.999 +                mk_primcorec_ctr_of_dtr_tac lthy m collapse maybe_disc_thm sel_thms
 36.1000 +                |> K |> Goal.prove lthy [] [] t
 36.1001 +                |> Thm.close_derivation
 36.1002 +                |> pair ctr
 36.1003 +                |> single
 36.1004 +            end;
 36.1005 +
 36.1006 +        fun prove_code disc_eqns sel_eqns ctr_alist ctr_specs =
 36.1007 +          let
 36.1008 +            val (fun_name, fun_T, fun_args, maybe_rhs) =
 36.1009 +              (find_first (member (op =) (map #ctr ctr_specs) o #ctr) disc_eqns,
 36.1010 +               find_first (member (op =) (map #ctr ctr_specs) o #ctr) sel_eqns)
 36.1011 +              |>> Option.map (fn x => (#fun_name x, #fun_T x, #fun_args x, #maybe_code_rhs x))
 36.1012 +              ||> Option.map (fn x => (#fun_name x, #fun_T x, #fun_args x, NONE))
 36.1013 +              |> the o merge_options;
 36.1014 +
 36.1015 +            val bound_Ts = List.rev (map fastype_of fun_args);
 36.1016 +
 36.1017 +            val lhs = list_comb (Free (fun_name, fun_T), map Bound (length fun_args - 1 downto 0));
 36.1018 +            val maybe_rhs_info =
 36.1019 +              (case maybe_rhs of
 36.1020 +                SOME rhs =>
 36.1021 +                let
 36.1022 +                  val raw_rhs = expand_corec_code_rhs lthy has_call bound_Ts rhs;
 36.1023 +                  val cond_ctrs =
 36.1024 +                    fold_rev_corec_code_rhs lthy (K oo (cons oo pair)) bound_Ts raw_rhs [];
 36.1025 +                  val ctr_thms = map (the o AList.lookup (op =) ctr_alist o snd) cond_ctrs;
 36.1026 +                in SOME (rhs, raw_rhs, ctr_thms) end
 36.1027 +              | NONE =>
 36.1028 +                let
 36.1029 +                  fun prove_code_ctr {ctr, sels, ...} =
 36.1030 +                    if not (exists (equal ctr o fst) ctr_alist) then NONE else
 36.1031 +                      let
 36.1032 +                        val prems = find_first (equal ctr o #ctr) disc_eqns
 36.1033 +                          |> Option.map #prems |> the_default [];
 36.1034 +                        val t =
 36.1035 +                          filter (equal ctr o #ctr) sel_eqns
 36.1036 +                          |> fst o finds ((op =) o apsnd #sel) sels
 36.1037 +                          |> map (snd #> (fn [x] => (List.rev (#fun_args x), #rhs_term x))
 36.1038 +                            #-> abstract)
 36.1039 +                          |> curry list_comb ctr;
 36.1040 +                      in
 36.1041 +                        SOME (prems, t)
 36.1042 +                      end;
 36.1043 +                  val maybe_ctr_conds_argss = map prove_code_ctr ctr_specs;
 36.1044 +                in
 36.1045 +                  if exists is_none maybe_ctr_conds_argss then NONE else
 36.1046 +                    let
 36.1047 +                      val rhs = fold_rev (fn SOME (prems, u) => fn t => mk_If (s_conjs prems) u t)
 36.1048 +                        maybe_ctr_conds_argss
 36.1049 +                        (Const (@{const_name Code.abort}, @{typ String.literal} -->
 36.1050 +                            (@{typ unit} --> body_type fun_T) --> body_type fun_T) $
 36.1051 +                          HOLogic.mk_literal fun_name $
 36.1052 +                          absdummy @{typ unit} (incr_boundvars 1 lhs));
 36.1053 +                    in SOME (rhs, rhs, map snd ctr_alist) end
 36.1054 +                end);
 36.1055 +          in
 36.1056 +            (case maybe_rhs_info of
 36.1057 +              NONE => []
 36.1058 +            | SOME (rhs, raw_rhs, ctr_thms) =>
 36.1059 +              let
 36.1060 +                val ms = map (Logic.count_prems o prop_of) ctr_thms;
 36.1061 +                val (raw_t, t) = (raw_rhs, rhs)
 36.1062 +                  |> pairself
 36.1063 +                    (curry HOLogic.mk_eq (list_comb (Free (fun_name, fun_T),
 36.1064 +                      map Bound (length fun_args - 1 downto 0)))
 36.1065 +                    #> HOLogic.mk_Trueprop
 36.1066 +                    #> curry Logic.list_all (map dest_Free fun_args));
 36.1067 +                val (distincts, discIs, sel_splits, sel_split_asms) =
 36.1068 +                  case_thms_of_term lthy bound_Ts raw_rhs;
 36.1069 +
 36.1070 +                val raw_code_thm = mk_primcorec_raw_code_of_ctr_tac lthy distincts discIs sel_splits
 36.1071 +                    sel_split_asms ms ctr_thms
 36.1072 +                  |> K |> Goal.prove lthy [] [] raw_t
 36.1073 +                  |> Thm.close_derivation;
 36.1074 +              in
 36.1075 +                mk_primcorec_code_of_raw_code_tac lthy distincts sel_splits raw_code_thm
 36.1076 +                |> K |> Goal.prove lthy [] [] t
 36.1077 +                |> Thm.close_derivation
 36.1078 +                |> single
 36.1079 +              end)
 36.1080 +          end;
 36.1081 +
 36.1082 +        val disc_alists = map3 (maps oo prove_disc) corec_specs exclssss disc_eqnss;
 36.1083 +        val sel_alists = map4 (map ooo prove_sel) corec_specs disc_eqnss exclssss sel_eqnss;
 36.1084 +        val disc_thmss = map (map snd) disc_alists;
 36.1085 +        val sel_thmss = map (map snd) sel_alists;
 36.1086 +
 36.1087 +        val ctr_alists = map5 (maps oooo prove_ctr) disc_alists sel_alists disc_eqnss sel_eqnss
 36.1088 +          ctr_specss;
 36.1089 +        val ctr_thmss = map (map snd) ctr_alists;
 36.1090 +
 36.1091 +        val code_thmss = map4 prove_code disc_eqnss sel_eqnss ctr_alists ctr_specss;
 36.1092 +
 36.1093 +        val simp_thmss = map2 append disc_thmss sel_thmss
 36.1094 +
 36.1095 +        val common_name = mk_common_name fun_names;
 36.1096 +
 36.1097 +        val notes =
 36.1098 +          [(coinductN, map (if n2m then single else K []) coinduct_thms, []),
 36.1099 +           (codeN, code_thmss, code_nitpicksimp_attrs),
 36.1100 +           (ctrN, ctr_thmss, []),
 36.1101 +           (discN, disc_thmss, simp_attrs),
 36.1102 +           (selN, sel_thmss, simp_attrs),
 36.1103 +           (simpsN, simp_thmss, []),
 36.1104 +           (strong_coinductN, map (if n2m then single else K []) strong_coinduct_thms, [])]
 36.1105 +          |> maps (fn (thmN, thmss, attrs) =>
 36.1106 +            map2 (fn fun_name => fn thms =>
 36.1107 +                ((Binding.qualify true fun_name (Binding.name thmN), attrs), [(thms, [])]))
 36.1108 +              fun_names (take actual_nn thmss))
 36.1109 +          |> filter_out (null o fst o hd o snd);
 36.1110 +
 36.1111 +        val common_notes =
 36.1112 +          [(coinductN, if n2m then [coinduct_thm] else [], []),
 36.1113 +           (strong_coinductN, if n2m then [strong_coinduct_thm] else [], [])]
 36.1114 +          |> filter_out (null o #2)
 36.1115 +          |> map (fn (thmN, thms, attrs) =>
 36.1116 +            ((Binding.qualify true common_name (Binding.name thmN), attrs), [(thms, [])]));
 36.1117 +      in
 36.1118 +        lthy |> Local_Theory.notes (notes @ common_notes) |> snd
 36.1119 +      end;
 36.1120 +
 36.1121 +    fun after_qed thmss' = fold_map Local_Theory.define defs #-> prove thmss';
 36.1122 +  in
 36.1123 +    (goalss, after_qed, lthy')
 36.1124 +  end;
 36.1125 +
 36.1126 +fun add_primcorec_ursive_cmd maybe_tac seq (raw_fixes, raw_specs') lthy =
 36.1127 +  let
 36.1128 +    val (raw_specs, maybe_of_specs) =
 36.1129 +      split_list raw_specs' ||> map (Option.map (Syntax.read_term lthy));
 36.1130 +    val ((fixes, specs), _) = Specification.read_spec raw_fixes raw_specs lthy;
 36.1131 +  in
 36.1132 +    add_primcorec_ursive maybe_tac seq fixes specs maybe_of_specs lthy
 36.1133 +    handle ERROR str => primcorec_error str
 36.1134 +  end
 36.1135 +  handle Primcorec_Error (str, eqns) =>
 36.1136 +    if null eqns
 36.1137 +    then error ("primcorec error:\n  " ^ str)
 36.1138 +    else error ("primcorec error:\n  " ^ str ^ "\nin\n  " ^
 36.1139 +      space_implode "\n  " (map (quote o Syntax.string_of_term lthy) eqns));
 36.1140 +
 36.1141 +val add_primcorecursive_cmd = (fn (goalss, after_qed, lthy) =>
 36.1142 +  lthy
 36.1143 +  |> Proof.theorem NONE after_qed goalss
 36.1144 +  |> Proof.refine (Method.primitive_text I)
 36.1145 +  |> Seq.hd) ooo add_primcorec_ursive_cmd NONE;
 36.1146 +
 36.1147 +val add_primcorec_cmd = (fn (goalss, after_qed, lthy) =>
 36.1148 +  lthy
 36.1149 +  |> after_qed (map (fn [] => []
 36.1150 +      | _ => primcorec_error "need exclusiveness proofs - use primcorecursive instead of primcorec")
 36.1151 +    goalss)) ooo add_primcorec_ursive_cmd (SOME (fn {context = ctxt, ...} => auto_tac ctxt));
 36.1152 +
 36.1153 +end;
    37.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    37.2 +++ b/src/HOL/BNF/Tools/bnf_gfp_rec_sugar_tactics.ML	Mon Nov 11 17:44:21 2013 +0100
    37.3 @@ -0,0 +1,135 @@
    37.4 +(*  Title:      HOL/BNF/Tools/bnf_gfp_rec_sugar_tactics.ML
    37.5 +    Author:     Jasmin Blanchette, TU Muenchen
    37.6 +    Copyright   2013
    37.7 +
    37.8 +Tactics for corecursor sugar.
    37.9 +*)
   37.10 +
   37.11 +signature BNF_GFP_REC_SUGAR_TACTICS =
   37.12 +sig
   37.13 +  val mk_primcorec_assumption_tac: Proof.context -> thm list -> int -> tactic
   37.14 +  val mk_primcorec_code_of_raw_code_tac: Proof.context -> thm list -> thm list -> thm -> tactic
   37.15 +  val mk_primcorec_ctr_of_dtr_tac: Proof.context -> int -> thm -> thm option -> thm list -> tactic
   37.16 +  val mk_primcorec_disc_tac: Proof.context -> thm list -> thm -> int -> int -> thm list list list ->
   37.17 +    tactic
   37.18 +  val mk_primcorec_raw_code_of_ctr_tac: Proof.context -> thm list -> thm list -> thm list ->
   37.19 +    thm list -> int list -> thm list -> tactic
   37.20 +  val mk_primcorec_sel_tac: Proof.context -> thm list -> thm list -> thm list -> thm list ->
   37.21 +    thm list -> thm list -> thm -> int -> int -> thm list list list -> tactic
   37.22 +end;
   37.23 +
   37.24 +structure BNF_GFP_Rec_Sugar_Tactics : BNF_GFP_REC_SUGAR_TACTICS =
   37.25 +struct
   37.26 +
   37.27 +open BNF_Util
   37.28 +open BNF_Tactics
   37.29 +
   37.30 +val falseEs = @{thms not_TrueE FalseE};
   37.31 +val Let_def = @{thm Let_def};
   37.32 +val neq_eq_eq_contradict = @{thm neq_eq_eq_contradict};
   37.33 +val split_if = @{thm split_if};
   37.34 +val split_if_asm = @{thm split_if_asm};
   37.35 +val split_connectI = @{thms allI impI conjI};
   37.36 +
   37.37 +fun mk_primcorec_assumption_tac ctxt discIs =
   37.38 +  SELECT_GOAL (unfold_thms_tac ctxt
   37.39 +      @{thms not_not not_False_eq_True not_True_eq_False de_Morgan_conj de_Morgan_disj} THEN
   37.40 +    SOLVE (HEADGOAL (REPEAT o (rtac refl ORELSE' atac ORELSE' etac conjE ORELSE'
   37.41 +    eresolve_tac falseEs ORELSE'
   37.42 +    resolve_tac @{thms TrueI conjI disjI1 disjI2} ORELSE'
   37.43 +    dresolve_tac discIs THEN' atac ORELSE'
   37.44 +    etac notE THEN' atac ORELSE'
   37.45 +    etac disjE))));
   37.46 +
   37.47 +fun mk_primcorec_same_case_tac m =
   37.48 +  HEADGOAL (if m = 0 then rtac TrueI
   37.49 +    else REPEAT_DETERM_N (m - 1) o (rtac conjI THEN' atac) THEN' atac);
   37.50 +
   37.51 +fun mk_primcorec_different_case_tac ctxt m excl =
   37.52 +  HEADGOAL (if m = 0 then mk_primcorec_assumption_tac ctxt []
   37.53 +    else dtac excl THEN' (REPEAT_DETERM_N (m - 1) o atac) THEN' mk_primcorec_assumption_tac ctxt []);
   37.54 +
   37.55 +fun mk_primcorec_cases_tac ctxt k m exclsss =
   37.56 +  let val n = length exclsss in
   37.57 +    EVERY (map (fn [] => if k = n then all_tac else mk_primcorec_same_case_tac m
   37.58 +        | [excl] => mk_primcorec_different_case_tac ctxt m excl)
   37.59 +      (take k (nth exclsss (k - 1))))
   37.60 +  end;
   37.61 +
   37.62 +fun mk_primcorec_prelude ctxt defs thm =
   37.63 +  unfold_thms_tac ctxt defs THEN HEADGOAL (rtac thm) THEN
   37.64 +  unfold_thms_tac ctxt @{thms Let_def split};
   37.65 +
   37.66 +fun mk_primcorec_disc_tac ctxt defs disc_corec k m exclsss =
   37.67 +  mk_primcorec_prelude ctxt defs disc_corec THEN mk_primcorec_cases_tac ctxt k m exclsss;
   37.68 +
   37.69 +fun mk_primcorec_sel_tac ctxt defs distincts splits split_asms map_idents map_comps f_sel k m
   37.70 +    exclsss =
   37.71 +  mk_primcorec_prelude ctxt defs (f_sel RS trans) THEN
   37.72 +  mk_primcorec_cases_tac ctxt k m exclsss THEN
   37.73 +  HEADGOAL (REPEAT_DETERM o (rtac refl ORELSE' rtac ext ORELSE'
   37.74 +    eresolve_tac falseEs ORELSE'
   37.75 +    resolve_tac split_connectI ORELSE'
   37.76 +    Splitter.split_asm_tac (split_if_asm :: split_asms) ORELSE'
   37.77 +    Splitter.split_tac (split_if :: splits) ORELSE'
   37.78 +    eresolve_tac (map (fn thm => thm RS neq_eq_eq_contradict) distincts) THEN' atac ORELSE'
   37.79 +    etac notE THEN' atac ORELSE'
   37.80 +    (CHANGED o SELECT_GOAL (unfold_thms_tac ctxt
   37.81 +      (@{thms id_def o_def split_def sum.cases} @ map_comps @ map_idents)))));
   37.82 +
   37.83 +fun mk_primcorec_ctr_of_dtr_tac ctxt m collapse maybe_disc_f sel_fs =
   37.84 +  HEADGOAL (rtac ((if null sel_fs then collapse else collapse RS sym) RS trans) THEN'
   37.85 +    (the_default (K all_tac) (Option.map rtac maybe_disc_f)) THEN' REPEAT_DETERM_N m o atac) THEN
   37.86 +  unfold_thms_tac ctxt (Let_def :: sel_fs) THEN HEADGOAL (rtac refl);
   37.87 +
   37.88 +fun inst_split_eq ctxt split =
   37.89 +  (case prop_of split of
   37.90 +    @{const Trueprop} $ (Const (@{const_name HOL.eq}, _) $ (Var (_, Type (_, [T, _])) $ _) $ _) =>
   37.91 +    let
   37.92 +      val s = Name.uu;
   37.93 +      val eq = Abs (Name.uu, T, HOLogic.mk_eq (Free (s, T), Bound 0));
   37.94 +      val split' = Drule.instantiate' [] [SOME (certify ctxt eq)] split;
   37.95 +    in
   37.96 +      Thm.generalize ([], [s]) (Thm.maxidx_of split' + 1) split'
   37.97 +    end
   37.98 +  | _ => split);
   37.99 +
  37.100 +fun distinct_in_prems_tac distincts =
  37.101 +  eresolve_tac (map (fn thm => thm RS neq_eq_eq_contradict) distincts) THEN' atac;
  37.102 +
  37.103 +(* TODO: reduce code duplication with selector tactic above *)
  37.104 +fun mk_primcorec_raw_code_of_ctr_single_tac ctxt distincts discIs splits split_asms m f_ctr =
  37.105 +  let
  37.106 +    val splits' =
  37.107 +      map (fn th => th RS iffD2) (@{thm split_if_eq2} :: map (inst_split_eq ctxt) splits)
  37.108 +  in
  37.109 +    HEADGOAL (REPEAT o (resolve_tac (splits' @ split_connectI))) THEN
  37.110 +    mk_primcorec_prelude ctxt [] (f_ctr RS trans) THEN
  37.111 +    HEADGOAL ((REPEAT_DETERM_N m o mk_primcorec_assumption_tac ctxt discIs) THEN'
  37.112 +      SELECT_GOAL (SOLVE (HEADGOAL (REPEAT_DETERM o
  37.113 +      (rtac refl ORELSE' atac ORELSE'
  37.114 +       resolve_tac (@{thm Code.abort_def} :: split_connectI) ORELSE'
  37.115 +       Splitter.split_tac (split_if :: splits) ORELSE'
  37.116 +       Splitter.split_asm_tac (split_if_asm :: split_asms) ORELSE'
  37.117 +       mk_primcorec_assumption_tac ctxt discIs ORELSE'
  37.118 +       distinct_in_prems_tac distincts ORELSE'
  37.119 +       (TRY o dresolve_tac discIs) THEN' etac notE THEN' atac)))))
  37.120 +  end;
  37.121 +
  37.122 +fun mk_primcorec_raw_code_of_ctr_tac ctxt distincts discIs splits split_asms ms f_ctrs =
  37.123 +  EVERY (map2 (mk_primcorec_raw_code_of_ctr_single_tac ctxt distincts discIs splits split_asms) ms
  37.124 +    f_ctrs) THEN
  37.125 +  IF_UNSOLVED (unfold_thms_tac ctxt @{thms Code.abort_def} THEN
  37.126 +    HEADGOAL (REPEAT_DETERM o resolve_tac (refl :: split_connectI)));
  37.127 +
  37.128 +fun mk_primcorec_code_of_raw_code_tac ctxt distincts splits raw =
  37.129 +  HEADGOAL (rtac raw ORELSE' rtac (raw RS trans) THEN'
  37.130 +    SELECT_GOAL (unfold_thms_tac ctxt [Let_def]) THEN' REPEAT_DETERM o
  37.131 +    (rtac refl ORELSE' atac ORELSE'
  37.132 +     resolve_tac split_connectI ORELSE'
  37.133 +     Splitter.split_tac (split_if :: splits) ORELSE'
  37.134 +     distinct_in_prems_tac distincts ORELSE'
  37.135 +     rtac sym THEN' atac ORELSE'
  37.136 +     etac notE THEN' atac));
  37.137 +
  37.138 +end;
    38.1 --- a/src/HOL/BNF/Tools/bnf_lfp.ML	Mon Nov 11 17:34:44 2013 +0100
    38.2 +++ b/src/HOL/BNF/Tools/bnf_lfp.ML	Mon Nov 11 17:44:21 2013 +0100
    38.3 @@ -22,7 +22,7 @@
    38.4  open BNF_Comp
    38.5  open BNF_FP_Util
    38.6  open BNF_FP_Def_Sugar
    38.7 -open BNF_FP_Rec_Sugar
    38.8 +open BNF_LFP_Rec_Sugar
    38.9  open BNF_LFP_Util
   38.10  open BNF_LFP_Tactics
   38.11  
    39.1 --- a/src/HOL/BNF/Tools/bnf_lfp_compat.ML	Mon Nov 11 17:34:44 2013 +0100
    39.2 +++ b/src/HOL/BNF/Tools/bnf_lfp_compat.ML	Mon Nov 11 17:44:21 2013 +0100
    39.3 @@ -57,8 +57,10 @@
    39.4      val fpTs as fpT1 :: _ = map (fn s => Type (s, As)) fpT_names';
    39.5  
    39.6      fun add_nested_types_of (T as Type (s, _)) seen =
    39.7 -      if member (op =) seen T orelse s = @{type_name fun} then
    39.8 +      if member (op =) seen T then
    39.9          seen
   39.10 +      else if s = @{type_name fun} then
   39.11 +        (warning "Partial support for recursion through functions -- 'primrec' will fail"; seen)
   39.12        else
   39.13          (case try lfp_sugar_of s of
   39.14            SOME ({T = T0, fp_res = {Ts = mutual_Ts0, ...}, ctr_sugars, ...}) =>
   39.15 @@ -91,11 +93,13 @@
   39.16      val nn = length Ts;
   39.17      val get_indices = K [];
   39.18      val fp_sugars0 = if nn = 1 then [fp_sugar0] else map (lfp_sugar_of o fst o dest_Type) Ts;
   39.19 -    val callssss = pad_and_indexify_calls fp_sugars0 nn [];
   39.20 -    val has_nested = nn > nn_fp;
   39.21 +    val callssss = map (fn fp_sugar0 => indexify_callsss fp_sugar0 []) fp_sugars0;
   39.22  
   39.23      val ((fp_sugars, (lfp_sugar_thms, _)), lthy) =
   39.24 -      mutualize_fp_sugars has_nested Least_FP compat_bs Ts get_indices callssss fp_sugars0 lthy;
   39.25 +      if nn > nn_fp then
   39.26 +        mutualize_fp_sugars Least_FP compat_bs Ts get_indices callssss fp_sugars0 lthy
   39.27 +      else
   39.28 +        ((fp_sugars0, (NONE, NONE)), lthy);
   39.29  
   39.30      val {ctr_sugars, co_inducts = [induct], co_iterss, co_iter_thmsss = iter_thmsss, ...} :: _ =
   39.31        fp_sugars;
    40.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    40.2 +++ b/src/HOL/BNF/Tools/bnf_lfp_rec_sugar.ML	Mon Nov 11 17:44:21 2013 +0100
    40.3 @@ -0,0 +1,604 @@
    40.4 +(*  Title:      HOL/BNF/Tools/bnf_lfp_rec_sugar.ML
    40.5 +    Author:     Lorenz Panny, TU Muenchen
    40.6 +    Author:     Jasmin Blanchette, TU Muenchen
    40.7 +    Copyright   2013
    40.8 +
    40.9 +Recursor sugar.
   40.10 +*)
   40.11 +
   40.12 +signature BNF_LFP_REC_SUGAR =
   40.13 +sig
   40.14 +  val add_primrec: (binding * typ option * mixfix) list ->
   40.15 +    (Attrib.binding * term) list -> local_theory -> (term list * thm list list) * local_theory
   40.16 +  val add_primrec_cmd: (binding * string option * mixfix) list ->
   40.17 +    (Attrib.binding * string) list -> local_theory -> (term list * thm list list) * local_theory
   40.18 +  val add_primrec_global: (binding * typ option * mixfix) list ->
   40.19 +    (Attrib.binding * term) list -> theory -> (term list * thm list list) * theory
   40.20 +  val add_primrec_overloaded: (string * (string * typ) * bool) list ->
   40.21 +    (binding * typ option * mixfix) list ->
   40.22 +    (Attrib.binding * term) list -> theory -> (term list * thm list list) * theory
   40.23 +  val add_primrec_simple: ((binding * typ) * mixfix) list -> term list ->
   40.24 +    local_theory -> (string list * (term list * (int list list * thm list list))) * local_theory
   40.25 +end;
   40.26 +
   40.27 +structure BNF_LFP_Rec_Sugar : BNF_LFP_REC_SUGAR =
   40.28 +struct
   40.29 +
   40.30 +open Ctr_Sugar
   40.31 +open BNF_Util
   40.32 +open BNF_Tactics
   40.33 +open BNF_Def
   40.34 +open BNF_FP_Util
   40.35 +open BNF_FP_Def_Sugar
   40.36 +open BNF_FP_N2M_Sugar
   40.37 +open BNF_FP_Rec_Sugar_Util
   40.38 +
   40.39 +val nitpicksimp_attrs = @{attributes [nitpick_simp]};
   40.40 +val simp_attrs = @{attributes [simp]};
   40.41 +val code_nitpicksimp_simp_attrs = Code.add_default_eqn_attrib :: nitpicksimp_attrs @ simp_attrs;
   40.42 +
   40.43 +exception Primrec_Error of string * term list;
   40.44 +
   40.45 +fun primrec_error str = raise Primrec_Error (str, []);
   40.46 +fun primrec_error_eqn str eqn = raise Primrec_Error (str, [eqn]);
   40.47 +fun primrec_error_eqns str eqns = raise Primrec_Error (str, eqns);
   40.48 +
   40.49 +datatype rec_call =
   40.50 +  No_Rec of int * typ |
   40.51 +  Mutual_Rec of (int * typ) * (int * typ) |
   40.52 +  Nested_Rec of int * typ;
   40.53 +
   40.54 +type rec_ctr_spec =
   40.55 +  {ctr: term,
   40.56 +   offset: int,
   40.57 +   calls: rec_call list,
   40.58 +   rec_thm: thm};
   40.59 +
   40.60 +type rec_spec =
   40.61 +  {recx: term,
   40.62 +   nested_map_idents: thm list,
   40.63 +   nested_map_comps: thm list,
   40.64 +   ctr_specs: rec_ctr_spec list};
   40.65 +
   40.66 +exception AINT_NO_MAP of term;
   40.67 +
   40.68 +fun ill_formed_rec_call ctxt t =
   40.69 +  error ("Ill-formed recursive call: " ^ quote (Syntax.string_of_term ctxt t));
   40.70 +fun invalid_map ctxt t =
   40.71 +  error ("Invalid map function in " ^ quote (Syntax.string_of_term ctxt t));
   40.72 +fun unexpected_rec_call ctxt t =
   40.73 +  error ("Unexpected recursive call: " ^ quote (Syntax.string_of_term ctxt t));
   40.74 +
   40.75 +fun massage_nested_rec_call ctxt has_call raw_massage_fun bound_Ts y y' =
   40.76 +  let
   40.77 +    fun check_no_call t = if has_call t then unexpected_rec_call ctxt t else ();
   40.78 +
   40.79 +    val typof = curry fastype_of1 bound_Ts;
   40.80 +    val build_map_fst = build_map ctxt (fst_const o fst);
   40.81 +
   40.82 +    val yT = typof y;
   40.83 +    val yU = typof y';
   40.84 +
   40.85 +    fun y_of_y' () = build_map_fst (yU, yT) $ y';
   40.86 +    val elim_y = Term.map_aterms (fn t => if t = y then y_of_y' () else t);
   40.87 +
   40.88 +    fun massage_mutual_fun U T t =
   40.89 +      (case t of
   40.90 +        Const (@{const_name comp}, _) $ t1 $ t2 =>
   40.91 +        mk_comp bound_Ts (tap check_no_call t1, massage_mutual_fun U T t2)
   40.92 +      | _ =>
   40.93 +        if has_call t then
   40.94 +          (case try HOLogic.dest_prodT U of
   40.95 +            SOME (U1, U2) => if U1 = T then raw_massage_fun T U2 t else invalid_map ctxt t
   40.96 +          | NONE => invalid_map ctxt t)
   40.97 +        else
   40.98 +          mk_comp bound_Ts (t, build_map_fst (U, T)));
   40.99 +
  40.100 +    fun massage_map (Type (_, Us)) (Type (s, Ts)) t =
  40.101 +        (case try (dest_map ctxt s) t of
  40.102 +          SOME (map0, fs) =>
  40.103 +          let
  40.104 +            val Type (_, ran_Ts) = range_type (typof t);
  40.105 +            val map' = mk_map (length fs) Us ran_Ts map0;
  40.106 +            val fs' = map_flattened_map_args ctxt s (map3 massage_map_or_map_arg Us Ts) fs;
  40.107 +          in
  40.108 +            Term.list_comb (map', fs')
  40.109 +          end
  40.110 +        | NONE => raise AINT_NO_MAP t)
  40.111 +      | massage_map _ _ t = raise AINT_NO_MAP t
  40.112 +    and massage_map_or_map_arg U T t =
  40.113 +      if T = U then
  40.114 +        tap check_no_call t
  40.115 +      else
  40.116 +        massage_map U T t
  40.117 +        handle AINT_NO_MAP _ => massage_mutual_fun U T t;
  40.118 +
  40.119 +    fun massage_call (t as t1 $ t2) =
  40.120 +        if has_call t then
  40.121 +          if t2 = y then
  40.122 +            massage_map yU yT (elim_y t1) $ y'
  40.123 +            handle AINT_NO_MAP t' => invalid_map ctxt t'
  40.124 +          else
  40.125 +            let val (g, xs) = Term.strip_comb t2 in
  40.126 +              if g = y then
  40.127 +                if exists has_call xs then unexpected_rec_call ctxt t2
  40.128 +                else Term.list_comb (massage_call (mk_compN (length xs) bound_Ts (t1, y)), xs)
  40.129 +              else
  40.130 +                ill_formed_rec_call ctxt t
  40.131 +            end
  40.132 +        else
  40.133 +          elim_y t
  40.134 +      | massage_call t = if t = y then y_of_y' () else ill_formed_rec_call ctxt t;
  40.135 +  in
  40.136 +    massage_call
  40.137 +  end;
  40.138 +
  40.139 +fun rec_specs_of bs arg_Ts res_Ts get_indices callssss0 lthy =
  40.140 +  let
  40.141 +    val thy = Proof_Context.theory_of lthy;
  40.142 +
  40.143 +    val ((missing_arg_Ts, perm0_kks,
  40.144 +          fp_sugars as {nested_bnfs, fp_res = {xtor_co_iterss = ctor_iters1 :: _, ...},
  40.145 +            co_inducts = [induct_thm], ...} :: _, (lfp_sugar_thms, _)), lthy') =
  40.146 +      nested_to_mutual_fps Least_FP bs arg_Ts get_indices callssss0 lthy;
  40.147 +
  40.148 +    val perm_fp_sugars = sort (int_ord o pairself #index) fp_sugars;
  40.149 +
  40.150 +    val indices = map #index fp_sugars;
  40.151 +    val perm_indices = map #index perm_fp_sugars;
  40.152 +
  40.153 +    val perm_ctrss = map (#ctrs o of_fp_sugar #ctr_sugars) perm_fp_sugars;
  40.154 +    val perm_ctr_Tsss = map (map (binder_types o fastype_of)) perm_ctrss;
  40.155 +    val perm_lfpTs = map (body_type o fastype_of o hd) perm_ctrss;
  40.156 +
  40.157 +    val nn0 = length arg_Ts;
  40.158 +    val nn = length perm_lfpTs;
  40.159 +    val kks = 0 upto nn - 1;
  40.160 +    val perm_ns = map length perm_ctr_Tsss;
  40.161 +    val perm_mss = map (map length) perm_ctr_Tsss;
  40.162 +
  40.163 +    val perm_Cs = map (body_type o fastype_of o co_rec_of o of_fp_sugar (#xtor_co_iterss o #fp_res))
  40.164 +      perm_fp_sugars;
  40.165 +    val perm_fun_arg_Tssss =
  40.166 +      mk_iter_fun_arg_types perm_ctr_Tsss perm_ns perm_mss (co_rec_of ctor_iters1);
  40.167 +
  40.168 +    fun unpermute0 perm0_xs = permute_like (op =) perm0_kks kks perm0_xs;
  40.169 +    fun unpermute perm_xs = permute_like (op =) perm_indices indices perm_xs;
  40.170 +
  40.171 +    val induct_thms = unpermute0 (conj_dests nn induct_thm);
  40.172 +
  40.173 +    val lfpTs = unpermute perm_lfpTs;
  40.174 +    val Cs = unpermute perm_Cs;
  40.175 +
  40.176 +    val As_rho = tvar_subst thy (take nn0 lfpTs) arg_Ts;
  40.177 +    val Cs_rho = map (fst o dest_TVar) Cs ~~ pad_list HOLogic.unitT nn res_Ts;
  40.178 +
  40.179 +    val substA = Term.subst_TVars As_rho;
  40.180 +    val substAT = Term.typ_subst_TVars As_rho;
  40.181 +    val substCT = Term.typ_subst_TVars Cs_rho;
  40.182 +    val substACT = substAT o substCT;
  40.183 +
  40.184 +    val perm_Cs' = map substCT perm_Cs;
  40.185 +
  40.186 +    fun offset_of_ctr 0 _ = 0
  40.187 +      | offset_of_ctr n (({ctrs, ...} : ctr_sugar) :: ctr_sugars) =
  40.188 +        length ctrs + offset_of_ctr (n - 1) ctr_sugars;
  40.189 +
  40.190 +    fun call_of [i] [T] = (if exists_subtype_in Cs T then Nested_Rec else No_Rec) (i, substACT T)
  40.191 +      | call_of [i, i'] [T, T'] = Mutual_Rec ((i, substACT T), (i', substACT T'));
  40.192 +
  40.193 +    fun mk_ctr_spec ctr offset fun_arg_Tss rec_thm =
  40.194 +      let
  40.195 +        val (fun_arg_hss, _) = indexedd fun_arg_Tss 0;
  40.196 +        val fun_arg_hs = flat_rec_arg_args fun_arg_hss;
  40.197 +        val fun_arg_iss = map (map (find_index_eq fun_arg_hs)) fun_arg_hss;
  40.198 +      in
  40.199 +        {ctr = substA ctr, offset = offset, calls = map2 call_of fun_arg_iss fun_arg_Tss,
  40.200 +         rec_thm = rec_thm}
  40.201 +      end;
  40.202 +
  40.203 +    fun mk_ctr_specs index (ctr_sugars : ctr_sugar list) iter_thmsss =
  40.204 +      let
  40.205 +        val ctrs = #ctrs (nth ctr_sugars index);
  40.206 +        val rec_thms = co_rec_of (nth iter_thmsss index);
  40.207 +        val k = offset_of_ctr index ctr_sugars;
  40.208 +        val n = length ctrs;
  40.209 +      in
  40.210 +        map4 mk_ctr_spec ctrs (k upto k + n - 1) (nth perm_fun_arg_Tssss index) rec_thms
  40.211 +      end;
  40.212 +
  40.213 +    fun mk_spec ({T, index, ctr_sugars, co_iterss = iterss, co_iter_thmsss = iter_thmsss, ...}
  40.214 +      : fp_sugar) =
  40.215 +      {recx = mk_co_iter thy Least_FP (substAT T) perm_Cs' (co_rec_of (nth iterss index)),
  40.216 +       nested_map_idents = map (unfold_thms lthy @{thms id_def} o map_id0_of_bnf) nested_bnfs,
  40.217 +       nested_map_comps = map map_comp_of_bnf nested_bnfs,
  40.218 +       ctr_specs = mk_ctr_specs index ctr_sugars iter_thmsss};
  40.219 +  in
  40.220 +    ((is_some lfp_sugar_thms, map mk_spec fp_sugars, missing_arg_Ts, induct_thm, induct_thms),
  40.221 +     lthy')
  40.222 +  end;
  40.223 +
  40.224 +val undef_const = Const (@{const_name undefined}, dummyT);
  40.225 +
  40.226 +fun permute_args n t =
  40.227 +  list_comb (t, map Bound (0 :: (n downto 1))) |> fold (K (Term.abs (Name.uu, dummyT))) (0 upto n);
  40.228 +
  40.229 +type eqn_data = {
  40.230 +  fun_name: string,
  40.231 +  rec_type: typ,
  40.232 +  ctr: term,
  40.233 +  ctr_args: term list,
  40.234 +  left_args: term list,
  40.235 +  right_args: term list,
  40.236 +  res_type: typ,
  40.237 +  rhs_term: term,
  40.238 +  user_eqn: term
  40.239 +};
  40.240 +
  40.241 +fun dissect_eqn lthy fun_names eqn' =
  40.242 +  let
  40.243 +    val eqn = drop_All eqn' |> HOLogic.dest_Trueprop
  40.244 +      handle TERM _ =>
  40.245 +        primrec_error_eqn "malformed function equation (expected \"lhs = rhs\")" eqn';
  40.246 +    val (lhs, rhs) = HOLogic.dest_eq eqn
  40.247 +        handle TERM _ =>
  40.248 +          primrec_error_eqn "malformed function equation (expected \"lhs = rhs\")" eqn';
  40.249 +    val (fun_name, args) = strip_comb lhs
  40.250 +      |>> (fn x => if is_Free x then fst (dest_Free x)
  40.251 +          else primrec_error_eqn "malformed function equation (does not start with free)" eqn);
  40.252 +    val (left_args, rest) = take_prefix is_Free args;
  40.253 +    val (nonfrees, right_args) = take_suffix is_Free rest;
  40.254 +    val num_nonfrees = length nonfrees;
  40.255 +    val _ = num_nonfrees = 1 orelse if num_nonfrees = 0 then
  40.256 +      primrec_error_eqn "constructor pattern missing in left-hand side" eqn else
  40.257 +      primrec_error_eqn "more than one non-variable argument in left-hand side" eqn;
  40.258 +    val _ = member (op =) fun_names fun_name orelse
  40.259 +      primrec_error_eqn "malformed function equation (does not start with function name)" eqn
  40.260 +
  40.261 +    val (ctr, ctr_args) = strip_comb (the_single nonfrees);
  40.262 +    val _ = try (num_binder_types o fastype_of) ctr = SOME (length ctr_args) orelse
  40.263 +      primrec_error_eqn "partially applied constructor in pattern" eqn;
  40.264 +    val _ = let val d = duplicates (op =) (left_args @ ctr_args @ right_args) in null d orelse
  40.265 +      primrec_error_eqn ("duplicate variable \"" ^ Syntax.string_of_term lthy (hd d) ^
  40.266 +        "\" in left-hand side") eqn end;
  40.267 +    val _ = forall is_Free ctr_args orelse
  40.268 +      primrec_error_eqn "non-primitive pattern in left-hand side" eqn;
  40.269 +    val _ =
  40.270 +      let val b = fold_aterms (fn x as Free (v, _) =>
  40.271 +        if (not (member (op =) (left_args @ ctr_args @ right_args) x) andalso
  40.272 +        not (member (op =) fun_names v) andalso
  40.273 +        not (Variable.is_fixed lthy v)) then cons x else I | _ => I) rhs []
  40.274 +      in
  40.275 +        null b orelse
  40.276 +        primrec_error_eqn ("extra variable(s) in right-hand side: " ^
  40.277 +          commas (map (Syntax.string_of_term lthy) b)) eqn
  40.278 +      end;
  40.279 +  in
  40.280 +    {fun_name = fun_name,
  40.281 +     rec_type = body_type (type_of ctr),
  40.282 +     ctr = ctr,
  40.283 +     ctr_args = ctr_args,
  40.284 +     left_args = left_args,
  40.285 +     right_args = right_args,
  40.286 +     res_type = map fastype_of (left_args @ right_args) ---> fastype_of rhs,
  40.287 +     rhs_term = rhs,
  40.288 +     user_eqn = eqn'}
  40.289 +  end;
  40.290 +
  40.291 +fun rewrite_map_arg get_ctr_pos rec_type res_type =
  40.292 +  let
  40.293 +    val pT = HOLogic.mk_prodT (rec_type, res_type);
  40.294 +
  40.295 +    val maybe_suc = Option.map (fn x => x + 1);
  40.296 +    fun subst d (t as Bound d') = t |> d = SOME d' ? curry (op $) (fst_const pT)
  40.297 +      | subst d (Abs (v, T, b)) = Abs (v, if d = SOME ~1 then pT else T, subst (maybe_suc d) b)
  40.298 +      | subst d t =
  40.299 +        let
  40.300 +          val (u, vs) = strip_comb t;
  40.301 +          val ctr_pos = try (get_ctr_pos o fst o dest_Free) u |> the_default ~1;
  40.302 +        in
  40.303 +          if ctr_pos >= 0 then
  40.304 +            if d = SOME ~1 andalso length vs = ctr_pos then
  40.305 +              list_comb (permute_args ctr_pos (snd_const pT), vs)
  40.306 +            else if length vs > ctr_pos andalso is_some d
  40.307 +                andalso d = try (fn Bound n => n) (nth vs ctr_pos) then
  40.308 +              list_comb (snd_const pT $ nth vs ctr_pos, map (subst d) (nth_drop ctr_pos vs))
  40.309 +            else
  40.310 +              primrec_error_eqn ("recursive call not directly applied to constructor argument") t
  40.311 +          else
  40.312 +            list_comb (u, map (subst (d |> d = SOME ~1 ? K NONE)) vs)
  40.313 +        end
  40.314 +  in
  40.315 +    subst (SOME ~1)
  40.316 +  end;
  40.317 +
  40.318 +fun subst_rec_calls lthy get_ctr_pos has_call ctr_args mutual_calls nested_calls =
  40.319 +  let
  40.320 +    fun try_nested_rec bound_Ts y t =
  40.321 +      AList.lookup (op =) nested_calls y
  40.322 +      |> Option.map (fn y' =>
  40.323 +        massage_nested_rec_call lthy has_call (rewrite_map_arg get_ctr_pos) bound_Ts y y' t);
  40.324 +
  40.325 +    fun subst bound_Ts (t as g' $ y) =
  40.326 +        let
  40.327 +          fun subst_rec () = subst bound_Ts g' $ subst bound_Ts y;
  40.328 +          val y_head = head_of y;
  40.329 +        in
  40.330 +          if not (member (op =) ctr_args y_head) then
  40.331 +            subst_rec ()
  40.332 +          else
  40.333 +            (case try_nested_rec bound_Ts y_head t of
  40.334 +              SOME t' => t'
  40.335 +            | NONE =>
  40.336 +              let val (g, g_args) = strip_comb g' in
  40.337 +                (case try (get_ctr_pos o fst o dest_Free) g of
  40.338 +                  SOME ctr_pos =>
  40.339 +                  (length g_args >= ctr_pos orelse
  40.340 +                   primrec_error_eqn "too few arguments in recursive call" t;
  40.341 +                   (case AList.lookup (op =) mutual_calls y of
  40.342 +                     SOME y' => list_comb (y', g_args)
  40.343 +                   | NONE => subst_rec ()))
  40.344 +                | NONE => subst_rec ())
  40.345 +              end)
  40.346 +        end
  40.347 +      | subst bound_Ts (Abs (v, T, b)) = Abs (v, T, subst (T :: bound_Ts) b)
  40.348 +      | subst _ t = t
  40.349 +
  40.350 +    fun subst' t =
  40.351 +      if has_call t then
  40.352 +        (* FIXME detect this case earlier? *)
  40.353 +        primrec_error_eqn "recursive call not directly applied to constructor argument" t
  40.354 +      else
  40.355 +        try_nested_rec [] (head_of t) t |> the_default t
  40.356 +  in
  40.357 +    subst' o subst []
  40.358 +  end;
  40.359 +
  40.360 +fun build_rec_arg lthy (funs_data : eqn_data list list) has_call (ctr_spec : rec_ctr_spec)
  40.361 +    (maybe_eqn_data : eqn_data option) =
  40.362 +  (case maybe_eqn_data of
  40.363 +    NONE => undef_const
  40.364 +  | SOME {ctr_args, left_args, right_args, rhs_term = t, ...} =>
  40.365 +    let
  40.366 +      val calls = #calls ctr_spec;
  40.367 +      val n_args = fold (Integer.add o (fn Mutual_Rec _ => 2 | _ => 1)) calls 0;
  40.368 +
  40.369 +      val no_calls' = tag_list 0 calls
  40.370 +        |> map_filter (try (apsnd (fn No_Rec p => p | Mutual_Rec (p, _) => p)));
  40.371 +      val mutual_calls' = tag_list 0 calls
  40.372 +        |> map_filter (try (apsnd (fn Mutual_Rec (_, p) => p)));
  40.373 +      val nested_calls' = tag_list 0 calls
  40.374 +        |> map_filter (try (apsnd (fn Nested_Rec p => p)));
  40.375 +
  40.376 +      val args = replicate n_args ("", dummyT)
  40.377 +        |> Term.rename_wrt_term t
  40.378 +        |> map Free
  40.379 +        |> fold (fn (ctr_arg_idx, (arg_idx, _)) =>
  40.380 +            nth_map arg_idx (K (nth ctr_args ctr_arg_idx)))
  40.381 +          no_calls'
  40.382 +        |> fold (fn (ctr_arg_idx, (arg_idx, T)) =>
  40.383 +            nth_map arg_idx (K (retype_free T (nth ctr_args ctr_arg_idx))))
  40.384 +          mutual_calls'
  40.385 +        |> fold (fn (ctr_arg_idx, (arg_idx, T)) =>
  40.386 +            nth_map arg_idx (K (retype_free T (nth ctr_args ctr_arg_idx))))
  40.387 +          nested_calls';
  40.388 +
  40.389 +      val fun_name_ctr_pos_list =
  40.390 +        map (fn (x :: _) => (#fun_name x, length (#left_args x))) funs_data;
  40.391 +      val get_ctr_pos = try (the o AList.lookup (op =) fun_name_ctr_pos_list) #> the_default ~1;
  40.392 +      val mutual_calls = map (apfst (nth ctr_args) o apsnd (nth args o fst)) mutual_calls';
  40.393 +      val nested_calls = map (apfst (nth ctr_args) o apsnd (nth args o fst)) nested_calls';
  40.394 +    in
  40.395 +      t
  40.396 +      |> subst_rec_calls lthy get_ctr_pos has_call ctr_args mutual_calls nested_calls
  40.397 +      |> fold_rev lambda (args @ left_args @ right_args)
  40.398 +    end);
  40.399 +
  40.400 +fun build_defs lthy bs mxs (funs_data : eqn_data list list) (rec_specs : rec_spec list) has_call =
  40.401 +  let
  40.402 +    val n_funs = length funs_data;
  40.403 +
  40.404 +    val ctr_spec_eqn_data_list' =
  40.405 +      (take n_funs rec_specs |> map #ctr_specs) ~~ funs_data
  40.406 +      |> maps (uncurry (finds (fn (x, y) => #ctr x = #ctr y))
  40.407 +          ##> (fn x => null x orelse
  40.408 +            primrec_error_eqns "excess equations in definition" (map #rhs_term x)) #> fst);
  40.409 +    val _ = ctr_spec_eqn_data_list' |> map (fn (_, x) => length x <= 1 orelse
  40.410 +      primrec_error_eqns ("multiple equations for constructor") (map #user_eqn x));
  40.411 +
  40.412 +    val ctr_spec_eqn_data_list =
  40.413 +      ctr_spec_eqn_data_list' @ (drop n_funs rec_specs |> maps #ctr_specs |> map (rpair []));
  40.414 +
  40.415 +    val recs = take n_funs rec_specs |> map #recx;
  40.416 +    val rec_args = ctr_spec_eqn_data_list
  40.417 +      |> sort ((op <) o pairself (#offset o fst) |> make_ord)
  40.418 +      |> map (uncurry (build_rec_arg lthy funs_data has_call) o apsnd (try the_single));
  40.419 +    val ctr_poss = map (fn x =>
  40.420 +      if length (distinct ((op =) o pairself (length o #left_args)) x) <> 1 then
  40.421 +        primrec_error ("inconstant constructor pattern position for function " ^
  40.422 +          quote (#fun_name (hd x)))
  40.423 +      else
  40.424 +        hd x |> #left_args |> length) funs_data;
  40.425 +  in
  40.426 +    (recs, ctr_poss)
  40.427 +    |-> map2 (fn recx => fn ctr_pos => list_comb (recx, rec_args) |> permute_args ctr_pos)
  40.428 +    |> Syntax.check_terms lthy
  40.429 +    |> map3 (fn b => fn mx => fn t => ((b, mx), ((Binding.conceal (Thm.def_binding b), []), t)))
  40.430 +      bs mxs
  40.431 +  end;
  40.432 +
  40.433 +fun find_rec_calls has_call ({ctr, ctr_args, rhs_term, ...} : eqn_data) =
  40.434 +  let
  40.435 +    fun find bound_Ts (Abs (_, T, b)) ctr_arg = find (T :: bound_Ts) b ctr_arg
  40.436 +      | find bound_Ts (t as _ $ _) ctr_arg =
  40.437 +        let
  40.438 +          val typof = curry fastype_of1 bound_Ts;
  40.439 +          val (f', args') = strip_comb t;
  40.440 +          val n = find_index (equal ctr_arg o head_of) args';
  40.441 +        in
  40.442 +          if n < 0 then
  40.443 +            find bound_Ts f' ctr_arg @ maps (fn x => find bound_Ts x ctr_arg) args'
  40.444 +          else
  40.445 +            let
  40.446 +              val (f, args as arg :: _) = chop n args' |>> curry list_comb f'
  40.447 +              val (arg_head, arg_args) = Term.strip_comb arg;
  40.448 +            in
  40.449 +              if has_call f then
  40.450 +                mk_partial_compN (length arg_args) (typof arg_head) f ::
  40.451 +                maps (fn x => find bound_Ts x ctr_arg) args
  40.452 +              else
  40.453 +                find bound_Ts f ctr_arg @ maps (fn x => find bound_Ts x ctr_arg) args
  40.454 +            end
  40.455 +        end
  40.456 +      | find _ _ _ = [];
  40.457 +  in
  40.458 +    map (find [] rhs_term) ctr_args
  40.459 +    |> (fn [] => NONE | callss => SOME (ctr, callss))
  40.460 +  end;
  40.461 +
  40.462 +fun mk_primrec_tac ctxt num_extra_args map_idents map_comps fun_defs recx =
  40.463 +  unfold_thms_tac ctxt fun_defs THEN
  40.464 +  HEADGOAL (rtac (funpow num_extra_args (fn thm => thm RS fun_cong) recx RS trans)) THEN
  40.465 +  unfold_thms_tac ctxt (@{thms id_def split o_def fst_conv snd_conv} @ map_comps @ map_idents) THEN
  40.466 +  HEADGOAL (rtac refl);
  40.467 +
  40.468 +fun prepare_primrec fixes specs lthy =
  40.469 +  let
  40.470 +    val thy = Proof_Context.theory_of lthy;
  40.471 +
  40.472 +    val (bs, mxs) = map_split (apfst fst) fixes;
  40.473 +    val fun_names = map Binding.name_of bs;
  40.474 +    val eqns_data = map (dissect_eqn lthy fun_names) specs;
  40.475 +    val funs_data = eqns_data
  40.476 +      |> partition_eq ((op =) o pairself #fun_name)
  40.477 +      |> finds (fn (x, y) => x = #fun_name (hd y)) fun_names |> fst
  40.478 +      |> map (fn (x, y) => the_single y handle List.Empty =>
  40.479 +          primrec_error ("missing equations for function " ^ quote x));
  40.480 +
  40.481 +    val has_call = exists_subterm (map (fst #>> Binding.name_of #> Free) fixes |> member (op =));
  40.482 +    val arg_Ts = map (#rec_type o hd) funs_data;
  40.483 +    val res_Ts = map (#res_type o hd) funs_data;
  40.484 +    val callssss = funs_data
  40.485 +      |> map (partition_eq ((op =) o pairself #ctr))
  40.486 +      |> map (maps (map_filter (find_rec_calls has_call)));
  40.487 +
  40.488 +    val _ = (case filter_out (fn (_, T) => Sign.of_sort thy (T, HOLogic.typeS)) (bs ~~ res_Ts) of
  40.489 +        [] => ()
  40.490 +      | (b, _) :: _ => primrec_error ("type of " ^ Binding.print b ^ " contains top sort"));
  40.491 +
  40.492 +    val ((n2m, rec_specs, _, induct_thm, induct_thms), lthy') =
  40.493 +      rec_specs_of bs arg_Ts res_Ts (get_indices fixes) callssss lthy;
  40.494 +
  40.495 +    val actual_nn = length funs_data;
  40.496 +
  40.497 +    val _ = let val ctrs = (maps (map #ctr o #ctr_specs) rec_specs) in
  40.498 +      map (fn {ctr, user_eqn, ...} => member (op =) ctrs ctr orelse
  40.499 +        primrec_error_eqn ("argument " ^ quote (Syntax.string_of_term lthy' ctr) ^
  40.500 +          " is not a constructor in left-hand side") user_eqn) eqns_data end;
  40.501 +
  40.502 +    val defs = build_defs lthy' bs mxs funs_data rec_specs has_call;
  40.503 +
  40.504 +    fun prove lthy def_thms' ({ctr_specs, nested_map_idents, nested_map_comps, ...} : rec_spec)
  40.505 +        (fun_data : eqn_data list) =
  40.506 +      let
  40.507 +        val def_thms = map (snd o snd) def_thms';
  40.508 +        val simp_thmss = finds (fn (x, y) => #ctr x = #ctr y) fun_data ctr_specs
  40.509 +          |> fst
  40.510 +          |> map_filter (try (fn (x, [y]) =>
  40.511 +            (#user_eqn x, length (#left_args x) + length (#right_args x), #rec_thm y)))
  40.512 +          |> map (fn (user_eqn, num_extra_args, rec_thm) =>
  40.513 +            mk_primrec_tac lthy num_extra_args nested_map_idents nested_map_comps def_thms rec_thm
  40.514 +            |> K |> Goal.prove lthy [] [] user_eqn
  40.515 +            |> Thm.close_derivation);
  40.516 +        val poss = find_indices (fn (x, y) => #ctr x = #ctr y) fun_data eqns_data;
  40.517 +      in
  40.518 +        (poss, simp_thmss)
  40.519 +      end;
  40.520 +
  40.521 +    val notes =
  40.522 +      (if n2m then map2 (fn name => fn thm =>
  40.523 +        (name, inductN, [thm], [])) fun_names (take actual_nn induct_thms) else [])
  40.524 +      |> map (fn (prefix, thmN, thms, attrs) =>
  40.525 +        ((Binding.qualify true prefix (Binding.name thmN), attrs), [(thms, [])]));
  40.526 +
  40.527 +    val common_name = mk_common_name fun_names;
  40.528 +
  40.529 +    val common_notes =
  40.530 +      (if n2m then [(inductN, [induct_thm], [])] else [])
  40.531 +      |> map (fn (thmN, thms, attrs) =>
  40.532 +        ((Binding.qualify true common_name (Binding.name thmN), attrs), [(thms, [])]));
  40.533 +  in
  40.534 +    (((fun_names, defs),
  40.535 +      fn lthy => fn defs =>
  40.536 +        split_list (map2 (prove lthy defs) (take actual_nn rec_specs) funs_data)),
  40.537 +      lthy' |> Local_Theory.notes (notes @ common_notes) |> snd)
  40.538 +  end;
  40.539 +
  40.540 +(* primrec definition *)
  40.541 +
  40.542 +fun add_primrec_simple fixes ts lthy =
  40.543 +  let
  40.544 +    val (((names, defs), prove), lthy) = prepare_primrec fixes ts lthy
  40.545 +      handle ERROR str => primrec_error str;
  40.546 +  in
  40.547 +    lthy
  40.548 +    |> fold_map Local_Theory.define defs
  40.549 +    |-> (fn defs => `(fn lthy => (names, (map fst defs, prove lthy defs))))
  40.550 +  end
  40.551 +  handle Primrec_Error (str, eqns) =>
  40.552 +    if null eqns
  40.553 +    then error ("primrec_new error:\n  " ^ str)
  40.554 +    else error ("primrec_new error:\n  " ^ str ^ "\nin\n  " ^
  40.555 +      space_implode "\n  " (map (quote o Syntax.string_of_term lthy) eqns));
  40.556 +
  40.557 +local
  40.558 +
  40.559 +fun gen_primrec prep_spec (raw_fixes : (binding * 'a option * mixfix) list) raw_spec lthy =
  40.560 +  let
  40.561 +    val d = duplicates (op =) (map (Binding.name_of o #1) raw_fixes)
  40.562 +    val _ = null d orelse primrec_error ("duplicate function name(s): " ^ commas d);
  40.563 +
  40.564 +    val (fixes, specs) = fst (prep_spec raw_fixes raw_spec lthy);
  40.565 +
  40.566 +    val mk_notes =
  40.567 +      flat ooo map3 (fn poss => fn prefix => fn thms =>
  40.568 +        let
  40.569 +          val (bs, attrss) = map_split (fst o nth specs) poss;
  40.570 +          val notes =
  40.571 +            map3 (fn b => fn attrs => fn thm =>
  40.572 +              ((Binding.qualify false prefix b, code_nitpicksimp_simp_attrs @ attrs), [([thm], [])]))
  40.573 +            bs attrss thms;
  40.574 +        in
  40.575 +          ((Binding.qualify true prefix (Binding.name simpsN), []), [(thms, [])]) :: notes
  40.576 +        end);
  40.577 +  in
  40.578 +    lthy
  40.579 +    |> add_primrec_simple fixes (map snd specs)
  40.580 +    |-> (fn (names, (ts, (posss, simpss))) =>
  40.581 +      Spec_Rules.add Spec_Rules.Equational (ts, flat simpss)
  40.582 +      #> Local_Theory.notes (mk_notes posss names simpss)
  40.583 +      #>> pair ts o map snd)
  40.584 +  end;
  40.585 +
  40.586 +in
  40.587 +
  40.588 +val add_primrec = gen_primrec Specification.check_spec;
  40.589 +val add_primrec_cmd = gen_primrec Specification.read_spec;
  40.590 +
  40.591 +end;
  40.592 +
  40.593 +fun add_primrec_global fixes specs thy =
  40.594 +  let
  40.595 +    val lthy = Named_Target.theory_init thy;
  40.596 +    val ((ts, simps), lthy') = add_primrec fixes specs lthy;
  40.597 +    val simps' = burrow (Proof_Context.export lthy' lthy) simps;
  40.598 +  in ((ts, simps'), Local_Theory.exit_global lthy') end;
  40.599 +
  40.600 +fun add_primrec_overloaded ops fixes specs thy =
  40.601 +  let
  40.602 +    val lthy = Overloading.overloading ops thy;
  40.603 +    val ((ts, simps), lthy') = add_primrec fixes specs lthy;
  40.604 +    val simps' = burrow (Proof_Context.export lthy' lthy) simps;
  40.605 +  in ((ts, simps'), Local_Theory.exit_global lthy') end;
  40.606 +
  40.607 +end;
    41.1 --- a/src/HOL/BNF/Tools/ctr_sugar.ML	Mon Nov 11 17:34:44 2013 +0100
    41.2 +++ b/src/HOL/BNF/Tools/ctr_sugar.ML	Mon Nov 11 17:44:21 2013 +0100
    41.3 @@ -33,6 +33,7 @@
    41.4       case_conv_ifs: thm list};
    41.5  
    41.6    val morph_ctr_sugar: morphism -> ctr_sugar -> ctr_sugar
    41.7 +  val transfer_ctr_sugar: Proof.context -> ctr_sugar -> ctr_sugar
    41.8    val ctr_sugar_of: Proof.context -> string -> ctr_sugar option
    41.9    val ctr_sugars_of: Proof.context -> ctr_sugar list
   41.10  
   41.11 @@ -174,10 +175,11 @@
   41.12  val dest_attrs = @{attributes [dest]};
   41.13  val safe_elim_attrs = @{attributes [elim!]};
   41.14  val iff_attrs = @{attributes [iff]};
   41.15 -val induct_simp_attrs = @{attributes [induct_simp]};
   41.16 -val nitpick_attrs = @{attributes [nitpick_simp]};
   41.17 +val inductsimp_attrs = @{attributes [induct_simp]};
   41.18 +val nitpicksimp_attrs = @{attributes [nitpick_simp]};
   41.19  val simp_attrs = @{attributes [simp]};
   41.20 -val code_nitpick_simp_simp_attrs = Code.add_default_eqn_attrib :: nitpick_attrs @ simp_attrs;
   41.21 +val code_nitpicksimp_attrs = Code.add_default_eqn_attrib :: nitpicksimp_attrs;
   41.22 +val code_nitpicksimp_simp_attrs = code_nitpicksimp_attrs @ simp_attrs;
   41.23  
   41.24  fun unflat_lookup eq xs ys = map (fn xs' => permute_like eq xs xs' ys);
   41.25  
   41.26 @@ -391,7 +393,8 @@
   41.27           Term.lambda w (Library.foldr1 HOLogic.mk_disj (map3 mk_case_disj xctrs xfs xss)));
   41.28  
   41.29      val ((raw_case, (_, raw_case_def)), (lthy', lthy)) = no_defs_lthy
   41.30 -      |> Local_Theory.define ((case_binding, NoSyn), ((Thm.def_binding case_binding, []), case_rhs))
   41.31 +      |> Local_Theory.define ((case_binding, NoSyn),
   41.32 +        ((Binding.conceal (Thm.def_binding case_binding), []), case_rhs))
   41.33        ||> `Local_Theory.restore;
   41.34  
   41.35      val phi = Proof_Context.export_morphism lthy lthy';
   41.36 @@ -869,8 +872,15 @@
   41.37          val exhaust_case_names_attr = Attrib.internal (K (Rule_Cases.case_names exhaust_cases));
   41.38          val cases_type_attr = Attrib.internal (K (Induct.cases_type fcT_name));
   41.39  
   41.40 +        val anonymous_notes =
   41.41 +          [(map (fn th => th RS notE) distinct_thms, safe_elim_attrs),
   41.42 +           (map (fn th => th RS @{thm eq_False[THEN iffD2]}
   41.43 +              handle THM _ => th RS @{thm eq_True[THEN iffD2]}) nontriv_disc_thms,
   41.44 +            code_nitpicksimp_attrs)]
   41.45 +          |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])]));
   41.46 +
   41.47          val notes =
   41.48 -          [(caseN, case_thms, code_nitpick_simp_simp_attrs),
   41.49 +          [(caseN, case_thms, code_nitpicksimp_simp_attrs),
   41.50             (case_congN, [case_cong_thm], []),
   41.51             (case_conv_ifN, case_conv_if_thms, []),
   41.52             (collapseN, safe_collapse_thms, simp_attrs),
   41.53 @@ -878,12 +888,12 @@
   41.54             (discIN, nontriv_discI_thms, []),
   41.55             (disc_excludeN, disc_exclude_thms, dest_attrs),
   41.56             (disc_exhaustN, disc_exhaust_thms, [exhaust_case_names_attr]),
   41.57 -           (distinctN, distinct_thms, simp_attrs @ induct_simp_attrs),
   41.58 +           (distinctN, distinct_thms, simp_attrs @ inductsimp_attrs),
   41.59             (exhaustN, [exhaust_thm], [exhaust_case_names_attr, cases_type_attr]),
   41.60             (expandN, expand_thms, []),
   41.61 -           (injectN, inject_thms, iff_attrs @ induct_simp_attrs),
   41.62 +           (injectN, inject_thms, iff_attrs @ inductsimp_attrs),
   41.63             (nchotomyN, [nchotomy_thm], []),
   41.64 -           (selN, all_sel_thms, code_nitpick_simp_simp_attrs),
   41.65 +           (selN, all_sel_thms, code_nitpicksimp_simp_attrs),
   41.66             (sel_exhaustN, sel_exhaust_thms, [exhaust_case_names_attr]),
   41.67             (sel_splitN, sel_split_thms, []),
   41.68             (sel_split_asmN, sel_split_asm_thms, []),
   41.69 @@ -895,10 +905,6 @@
   41.70            |> map (fn (thmN, thms, attrs) =>
   41.71              ((qualify true (Binding.name thmN), attrs), [(thms, [])]));
   41.72  
   41.73 -        val notes' =
   41.74 -          [(map (fn th => th RS notE) distinct_thms, safe_elim_attrs)]
   41.75 -          |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])]));
   41.76 -
   41.77          val ctr_sugar =
   41.78            {ctrs = ctrs, casex = casex, discs = discs, selss = selss, exhaust = exhaust_thm,
   41.79             nchotomy = nchotomy_thm, injects = inject_thms, distincts = distinct_thms,
   41.80 @@ -915,7 +921,7 @@
   41.81              (Local_Theory.declaration {syntax = false, pervasive = true}
   41.82                 (fn phi => Case_Translation.register
   41.83                    (Morphism.term phi casex) (map (Morphism.term phi) ctrs)))
   41.84 -         |> Local_Theory.notes (notes' @ notes) |> snd
   41.85 +         |> Local_Theory.notes (anonymous_notes @ notes) |> snd
   41.86           |> register_ctr_sugar fcT_name ctr_sugar)
   41.87        end;
   41.88    in
    42.1 --- a/src/HOL/Big_Operators.thy	Mon Nov 11 17:34:44 2013 +0100
    42.2 +++ b/src/HOL/Big_Operators.thy	Mon Nov 11 17:44:21 2013 +0100
    42.3 @@ -696,11 +696,7 @@
    42.4  lemma setsum_subtractf:
    42.5    "setsum (%x. ((f x)::'a::ab_group_add) - g x) A =
    42.6      setsum f A - setsum g A"
    42.7 -proof (cases "finite A")
    42.8 -  case True thus ?thesis by (simp add: diff_minus setsum_addf setsum_negf)
    42.9 -next
   42.10 -  case False thus ?thesis by simp
   42.11 -qed
   42.12 +  using setsum_addf [of f "- g" A] by (simp add: setsum_negf)
   42.13  
   42.14  lemma setsum_nonneg:
   42.15    assumes nn: "\<forall>x\<in>A. (0::'a::{ordered_ab_semigroup_add,comm_monoid_add}) \<le> f x"
   42.16 @@ -1999,35 +1995,35 @@
   42.17    assumes fin_nonempty: "finite A" "A \<noteq> {}"
   42.18  begin
   42.19  
   42.20 -lemma Min_ge_iff [simp, no_atp]:
   42.21 +lemma Min_ge_iff [simp]:
   42.22    "x \<le> Min A \<longleftrightarrow> (\<forall>a\<in>A. x \<le> a)"
   42.23    using fin_nonempty by (fact Min.bounded_iff)
   42.24  
   42.25 -lemma Max_le_iff [simp, no_atp]:
   42.26 +lemma Max_le_iff [simp]:
   42.27    "Max A \<le> x \<longleftrightarrow> (\<forall>a\<in>A. a \<le> x)"
   42.28    using fin_nonempty by (fact Max.bounded_iff)
   42.29  
   42.30 -lemma Min_gr_iff [simp, no_atp]:
   42.31 +lemma Min_gr_iff [simp]:
   42.32    "x < Min A \<longleftrightarrow> (\<forall>a\<in>A. x < a)"
   42.33    using fin_nonempty  by (induct rule: finite_ne_induct) simp_all
   42.34  
   42.35 -lemma Max_less_iff [simp, no_atp]:
   42.36 +lemma Max_less_iff [simp]:
   42.37    "Max A < x \<longleftrightarrow> (\<forall>a\<in>A. a < x)"
   42.38    using fin_nonempty by (induct rule: finite_ne_induct) simp_all
   42.39  
   42.40 -lemma Min_le_iff [no_atp]:
   42.41 +lemma Min_le_iff:
   42.42    "Min A \<le> x \<longleftrightarrow> (\<exists>a\<in>A. a \<le> x)"
   42.43    using fin_nonempty by (induct rule: finite_ne_induct) (simp_all add: min_le_iff_disj)
   42.44  
   42.45 -lemma Max_ge_iff [no_atp]:
   42.46 +lemma Max_ge_iff:
   42.47    "x \<le> Max A \<longleftrightarrow> (\<exists>a\<in>A. x \<le> a)"
   42.48    using fin_nonempty by (induct rule: finite_ne_induct) (simp_all add: le_max_iff_disj)
   42.49  
   42.50 -lemma Min_less_iff [no_atp]:
   42.51 +lemma Min_less_iff:
   42.52    "Min A < x \<longleftrightarrow> (\<exists>a\<in>A. a < x)"
   42.53    using fin_nonempty by (induct rule: finite_ne_induct) (simp_all add: min_less_iff_disj)
   42.54  
   42.55 -lemma Max_gr_iff [no_atp]:
   42.56 +lemma Max_gr_iff:
   42.57    "x < Max A \<longleftrightarrow> (\<exists>a\<in>A. x < a)"
   42.58    using fin_nonempty by (induct rule: finite_ne_induct) (simp_all add: less_max_iff_disj)
   42.59  
    43.1 --- a/src/HOL/Codegenerator_Test/Generate_Binary_Nat.thy	Mon Nov 11 17:34:44 2013 +0100
    43.2 +++ b/src/HOL/Codegenerator_Test/Generate_Binary_Nat.thy	Mon Nov 11 17:44:21 2013 +0100
    43.3 @@ -16,6 +16,20 @@
    43.4    by a corresponding @{text export_code} command.
    43.5  *}
    43.6  
    43.7 -export_code _ checking SML OCaml? Haskell? Scala
    43.8 +text {* Formal joining of hierarchy of implicit definitions in Scala *}
    43.9 +
   43.10 +class semiring_numeral_even_odd = semiring_numeral_div + even_odd
   43.11 +
   43.12 +instance nat :: semiring_numeral_even_odd ..
   43.13 +
   43.14 +definition semiring_numeral_even_odd :: "'a itself \<Rightarrow> 'a::semiring_numeral_even_odd"
   43.15 +where
   43.16 +  "semiring_numeral_even_odd TYPE('a) = undefined"
   43.17 +
   43.18 +definition semiring_numeral_even_odd_nat :: "nat itself \<Rightarrow> nat"
   43.19 +where
   43.20 +  "semiring_numeral_even_odd_nat = semiring_numeral_even_odd"
   43.21 +
   43.22 +export_code _ checking  SML OCaml? Haskell? Scala
   43.23  
   43.24  end
    44.1 --- a/src/HOL/Codegenerator_Test/Generate_Efficient_Datastructures.thy	Mon Nov 11 17:34:44 2013 +0100
    44.2 +++ b/src/HOL/Codegenerator_Test/Generate_Efficient_Datastructures.thy	Mon Nov 11 17:44:21 2013 +0100
    44.3 @@ -26,7 +26,7 @@
    44.4    "pred_of_set = pred_of_set" ..
    44.5  
    44.6  lemma [code, code del]:
    44.7 -  "acc = acc" ..
    44.8 +  "Wellfounded.acc = Wellfounded.acc" ..
    44.9  
   44.10  lemma [code, code del]:
   44.11    "Cardinality.card' = Cardinality.card'" ..
    45.1 --- a/src/HOL/Complete_Lattices.thy	Mon Nov 11 17:34:44 2013 +0100
    45.2 +++ b/src/HOL/Complete_Lattices.thy	Mon Nov 11 17:44:21 2013 +0100
    45.3 @@ -15,10 +15,66 @@
    45.4  
    45.5  class Inf =
    45.6    fixes Inf :: "'a set \<Rightarrow> 'a" ("\<Sqinter>_" [900] 900)
    45.7 +begin
    45.8 +
    45.9 +definition INFI :: "'b set \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> 'a" where
   45.10 +  INF_def: "INFI A f = \<Sqinter>(f ` A)"
   45.11 +
   45.12 +lemma INF_image [simp]: "INFI (f`A) g = INFI A (\<lambda>x. g (f x))"
   45.13 +  by (simp add: INF_def image_image)
   45.14 +
   45.15 +lemma INF_cong: "A = B \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> C x = D x) \<Longrightarrow> INFI A C = INFI B D"
   45.16 +  by (simp add: INF_def image_def)
   45.17 +
   45.18 +end
   45.19  
   45.20  class Sup =
   45.21    fixes Sup :: "'a set \<Rightarrow> 'a" ("\<Squnion>_" [900] 900)
   45.22 +begin
   45.23  
   45.24 +definition SUPR :: "'b set \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> 'a" where
   45.25 +  SUP_def: "SUPR A f = \<Squnion>(f ` A)"
   45.26 +
   45.27 +lemma SUP_image [simp]: "SUPR (f`A) g = SUPR A (%x. g (f x))"
   45.28 +  by (simp add: SUP_def image_image)
   45.29 +
   45.30 +lemma SUP_cong: "A = B \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> C x = D x) \<Longrightarrow> SUPR A C = SUPR B D"
   45.31 +  by (simp add: SUP_def image_def)
   45.32 +
   45.33 +end
   45.34 +
   45.35 +text {*
   45.36 +  Note: must use names @{const INFI} and @{const SUPR} here instead of
   45.37 +  @{text INF} and @{text SUP} to allow the following syntax coexist
   45.38 +  with the plain constant names.
   45.39 +*}
   45.40 +
   45.41 +syntax
   45.42 +  "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3INF _./ _)" [0, 10] 10)
   45.43 +  "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3INF _:_./ _)" [0, 0, 10] 10)
   45.44 +  "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3SUP _./ _)" [0, 10] 10)
   45.45 +  "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3SUP _:_./ _)" [0, 0, 10] 10)
   45.46 +
   45.47 +syntax (xsymbols)
   45.48 +  "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Sqinter>_./ _)" [0, 10] 10)
   45.49 +  "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)
   45.50 +  "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Squnion>_./ _)" [0, 10] 10)
   45.51 +  "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)
   45.52 +
   45.53 +translations
   45.54 +  "INF x y. B"   == "INF x. INF y. B"
   45.55 +  "INF x. B"     == "CONST INFI CONST UNIV (%x. B)"
   45.56 +  "INF x. B"     == "INF x:CONST UNIV. B"
   45.57 +  "INF x:A. B"   == "CONST INFI A (%x. B)"
   45.58 +  "SUP x y. B"   == "SUP x. SUP y. B"
   45.59 +  "SUP x. B"     == "CONST SUPR CONST UNIV (%x. B)"
   45.60 +  "SUP x. B"     == "SUP x:CONST UNIV. B"
   45.61 +  "SUP x:A. B"   == "CONST SUPR A (%x. B)"
   45.62 +
   45.63 +print_translation {*
   45.64 +  [Syntax_Trans.preserve_binder_abs2_tr' @{const_syntax INFI} @{syntax_const "_INF"},
   45.65 +    Syntax_Trans.preserve_binder_abs2_tr' @{const_syntax SUPR} @{syntax_const "_SUP"}]
   45.66 +*} -- {* to avoid eta-contraction of body *}
   45.67  
   45.68  subsection {* Abstract complete lattices *}
   45.69  
   45.70 @@ -49,59 +105,17 @@
   45.71      (unfold_locales, (fact Inf_empty Sup_empty
   45.72          Sup_upper Sup_least Inf_lower Inf_greatest)+)
   45.73  
   45.74 -definition INFI :: "'b set \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> 'a" where
   45.75 -  INF_def: "INFI A f = \<Sqinter>(f ` A)"
   45.76 -
   45.77 -definition SUPR :: "'b set \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> 'a" where
   45.78 -  SUP_def: "SUPR A f = \<Squnion>(f ` A)"
   45.79 -
   45.80 -text {*
   45.81 -  Note: must use names @{const INFI} and @{const SUPR} here instead of
   45.82 -  @{text INF} and @{text SUP} to allow the following syntax coexist
   45.83 -  with the plain constant names.
   45.84 -*}
   45.85 -
   45.86  end
   45.87  
   45.88 -syntax
   45.89 -  "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3INF _./ _)" [0, 10] 10)
   45.90 -  "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3INF _:_./ _)" [0, 0, 10] 10)
   45.91 -  "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3SUP _./ _)" [0, 10] 10)
   45.92 -  "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3SUP _:_./ _)" [0, 0, 10] 10)
   45.93 -
   45.94 -syntax (xsymbols)
   45.95 -  "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Sqinter>_./ _)" [0, 10] 10)
   45.96 -  "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)
   45.97 -  "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Squnion>_./ _)" [0, 10] 10)
   45.98 -  "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)
   45.99 -
  45.100 -translations
  45.101 -  "INF x y. B"   == "INF x. INF y. B"
  45.102 -  "INF x. B"     == "CONST INFI CONST UNIV (%x. B)"
  45.103 -  "INF x. B"     == "INF x:CONST UNIV. B"
  45.104 -  "INF x:A. B"   == "CONST INFI A (%x. B)"
  45.105 -  "SUP x y. B"   == "SUP x. SUP y. B"
  45.106 -  "SUP x. B"     == "CONST SUPR CONST UNIV (%x. B)"
  45.107 -  "SUP x. B"     == "SUP x:CONST UNIV. B"
  45.108 -  "SUP x:A. B"   == "CONST SUPR A (%x. B)"
  45.109 -
  45.110 -print_translation {*
  45.111 -  [Syntax_Trans.preserve_binder_abs2_tr' @{const_syntax INFI} @{syntax_const "_INF"},
  45.112 -    Syntax_Trans.preserve_binder_abs2_tr' @{const_syntax SUPR} @{syntax_const "_SUP"}]
  45.113 -*} -- {* to avoid eta-contraction of body *}
  45.114 -
  45.115  context complete_lattice
  45.116  begin
  45.117  
  45.118 -lemma INF_foundation_dual [no_atp]:
  45.119 -  "complete_lattice.SUPR Inf = INFI"
  45.120 -  by (simp add: fun_eq_iff INF_def
  45.121 -    complete_lattice.SUP_def [OF dual_complete_lattice])
  45.122 +lemma INF_foundation_dual:
  45.123 +  "Sup.SUPR Inf = INFI"
  45.124 +  by (simp add: fun_eq_iff INF_def Sup.SUP_def)
  45.125  
  45.126 -lemma SUP_foundation_dual [no_atp]:
  45.127 -  "complete_lattice.INFI Sup = SUPR"
  45.128 -  by (simp add: fun_eq_iff SUP_def
  45.129 -    complete_lattice.INF_def [OF dual_complete_lattice])
  45.130 +lemma SUP_foundation_dual:
  45.131 +  "Inf.INFI Sup = SUPR" by (simp add: fun_eq_iff SUP_def Inf.INF_def)
  45.132  
  45.133  lemma Sup_eqI:
  45.134    "(\<And>y. y \<in> A \<Longrightarrow> y \<le> x) \<Longrightarrow> (\<And>y. (\<And>z. z \<in> A \<Longrightarrow> z \<le> y) \<Longrightarrow> x \<le> y) \<Longrightarrow> \<Squnion>A = x"
  45.135 @@ -181,12 +195,6 @@
  45.136    "\<Squnion>UNIV = \<top>"
  45.137    by (auto intro!: antisym Sup_upper)
  45.138  
  45.139 -lemma INF_image [simp]: "(\<Sqinter>x\<in>f`A. g x) = (\<Sqinter>x\<in>A. g (f x))"
  45.140 -  by (simp add: INF_def image_image)
  45.141 -
  45.142 -lemma SUP_image [simp]: "(\<Squnion>x\<in>f`A. g x) = (\<Squnion>x\<in>A. g (f x))"
  45.143 -  by (simp add: SUP_def image_image)
  45.144 -
  45.145  lemma Inf_Sup: "\<Sqinter>A = \<Squnion>{b. \<forall>a \<in> A. b \<sqsubseteq> a}"
  45.146    by (auto intro: antisym Inf_lower Inf_greatest Sup_upper Sup_least)
  45.147  
  45.148 @@ -199,14 +207,6 @@
  45.149  lemma Sup_subset_mono: "A \<subseteq> B \<Longrightarrow> \<Squnion>A \<sqsubseteq> \<Squnion>B"
  45.150    by (auto intro: Sup_least Sup_upper)
  45.151  
  45.152 -lemma INF_cong:
  45.153 -  "A = B \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> C x = D x) \<Longrightarrow> (\<Sqinter>x\<in>A. C x) = (\<Sqinter>x\<in>B. D x)"
  45.154 -  by (simp add: INF_def image_def)
  45.155 -
  45.156 -lemma SUP_cong:
  45.157 -  "A = B \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> C x = D x) \<Longrightarrow> (\<Squnion>x\<in>A. C x) = (\<Squnion>x\<in>B. D x)"
  45.158 -  by (simp add: SUP_def image_def)
  45.159 -
  45.160  lemma Inf_mono:
  45.161    assumes "\<And>b. b \<in> B \<Longrightarrow> \<exists>a\<in>A. a \<sqsubseteq> b"
  45.162    shows "\<Sqinter>A \<sqsubseteq> \<Sqinter>B"
  45.163 @@ -306,7 +306,7 @@
  45.164    show "?R \<le> ?L" by (rule SUP_least) (auto intro: le_supI1 le_supI2 SUP_upper)
  45.165  qed
  45.166  
  45.167 -lemma Inf_top_conv [simp, no_atp]:
  45.168 +lemma Inf_top_conv [simp]:
  45.169    "\<Sqinter>A = \<top> \<longleftrightarrow> (\<forall>x\<in>A. x = \<top>)"
  45.170    "\<top> = \<Sqinter>A \<longleftrightarrow> (\<forall>x\<in>A. x = \<top>)"
  45.171  proof -
  45.172 @@ -333,7 +333,7 @@
  45.173   "\<top> = (\<Sqinter>x\<in>A. B x) \<longleftrightarrow> (\<forall>x\<in>A. B x = \<top>)"
  45.174    by (auto simp add: INF_def)
  45.175  
  45.176 -lemma Sup_bot_conv [simp, no_atp]:
  45.177 +lemma Sup_bot_conv [simp]:
  45.178    "\<Squnion>A = \<bottom> \<longleftrightarrow> (\<forall>x\<in>A. x = \<bottom>)" (is ?P)
  45.179    "\<bottom> = \<Squnion>A \<longleftrightarrow> (\<forall>x\<in>A. x = \<bottom>)" (is ?Q)
  45.180    using dual_complete_lattice
  45.181 @@ -769,7 +769,7 @@
  45.182      by (simp add: Inf_set_def image_def)
  45.183  qed
  45.184  
  45.185 -lemma Inter_iff [simp,no_atp]: "A \<in> \<Inter>C \<longleftrightarrow> (\<forall>X\<in>C. A \<in> X)"
  45.186 +lemma Inter_iff [simp]: "A \<in> \<Inter>C \<longleftrightarrow> (\<forall>X\<in>C. A \<in> X)"
  45.187    by (unfold Inter_eq) blast
  45.188  
  45.189  lemma InterI [intro!]: "(\<And>X. X \<in> C \<Longrightarrow> A \<in> X) \<Longrightarrow> A \<in> \<Inter>C"
  45.190 @@ -814,7 +814,7 @@
  45.191  lemma Inter_Un_distrib: "\<Inter>(A \<union> B) = \<Inter>A \<inter> \<Inter>B"
  45.192    by (fact Inf_union_distrib)
  45.193  
  45.194 -lemma Inter_UNIV_conv [simp, no_atp]:
  45.195 +lemma Inter_UNIV_conv [simp]:
  45.196    "\<Inter>A = UNIV \<longleftrightarrow> (\<forall>x\<in>A. x = UNIV)"
  45.197    "UNIV = \<Inter>A \<longleftrightarrow> (\<forall>x\<in>A. x = UNIV)"
  45.198    by (fact Inf_top_conv)+
  45.199 @@ -952,7 +952,7 @@
  45.200      by (simp add: Sup_set_def image_def)
  45.201  qed
  45.202  
  45.203 -lemma Union_iff [simp, no_atp]:
  45.204 +lemma Union_iff [simp]:
  45.205    "A \<in> \<Union>C \<longleftrightarrow> (\<exists>X\<in>C. A\<in>X)"
  45.206    by (unfold Union_eq) blast
  45.207  
  45.208 @@ -987,10 +987,10 @@
  45.209  lemma Union_Int_subset: "\<Union>(A \<inter> B) \<subseteq> \<Union>A \<inter> \<Union>B"
  45.210    by (fact Sup_inter_less_eq)
  45.211  
  45.212 -lemma Union_empty_conv [no_atp]: "(\<Union>A = {}) \<longleftrightarrow> (\<forall>x\<in>A. x = {})"
  45.213 +lemma Union_empty_conv: "(\<Union>A = {}) \<longleftrightarrow> (\<forall>x\<in>A. x = {})"
  45.214    by (fact Sup_bot_conv) (* already simp *)
  45.215  
  45.216 -lemma empty_Union_conv [no_atp]: "({} = \<Union>A) \<longleftrightarrow> (\<forall>x\<in>A. x = {})"
  45.217 +lemma empty_Union_conv: "({} = \<Union>A) \<longleftrightarrow> (\<forall>x\<in>A. x = {})"
  45.218    by (fact Sup_bot_conv) (* already simp *)
  45.219  
  45.220  lemma subset_Pow_Union: "A \<subseteq> Pow (\<Union>A)"
  45.221 @@ -1044,7 +1044,7 @@
  45.222    [Syntax_Trans.preserve_binder_abs2_tr' @{const_syntax UNION} @{syntax_const "_UNION"}]
  45.223  *} -- {* to avoid eta-contraction of body *}
  45.224  
  45.225 -lemma UNION_eq [no_atp]:
  45.226 +lemma UNION_eq:
  45.227    "(\<Union>x\<in>A. B x) = {y. \<exists>x\<in>A. y \<in> B x}"
  45.228    by (auto simp add: SUP_def)
  45.229  
  45.230 @@ -1088,13 +1088,13 @@
  45.231  lemma UN_least: "(\<And>x. x \<in> A \<Longrightarrow> B x \<subseteq> C) \<Longrightarrow> (\<Union>x\<in>A. B x) \<subseteq> C"
  45.232    by (fact SUP_least)
  45.233  
  45.234 -lemma Collect_bex_eq [no_atp]: "{x. \<exists>y\<in>A. P x y} = (\<Union>y\<in>A. {x. P x y})"
  45.235 +lemma Collect_bex_eq: "{x. \<exists>y\<in>A. P x y} = (\<Union>y\<in>A. {x. P x y})"
  45.236    by blast
  45.237  
  45.238  lemma UN_insert_distrib: "u \<in> A \<Longrightarrow> (\<Union>x\<in>A. insert a (B x)) = insert a (\<Union>x\<in>A. B x)"
  45.239    by blast
  45.240  
  45.241 -lemma UN_empty [no_atp]: "(\<Union>x\<in>{}. B x) = {}"
  45.242 +lemma UN_empty: "(\<Union>x\<in>{}. B x) = {}"
  45.243    by (fact SUP_empty)
  45.244  
  45.245  lemma UN_empty2: "(\<Union>x\<in>A. {}) = {}"
  45.246 @@ -1126,7 +1126,7 @@
  45.247    "(\<Union>x\<in>A. B x) = {} \<longleftrightarrow> (\<forall>x\<in>A. B x = {})"
  45.248    by (fact SUP_bot_conv)+ (* already simp *)
  45.249  
  45.250 -lemma Collect_ex_eq [no_atp]: "{x. \<exists>y. P x y} = (\<Union>y. {x. P x y})"
  45.251 +lemma Collect_ex_eq: "{x. \<exists>y. P x y} = (\<Union>y. {x. P x y})"
  45.252    by blast
  45.253  
  45.254  lemma ball_UN: "(\<forall>z \<in> UNION A B. P z) \<longleftrightarrow> (\<forall>x\<in>A. \<forall>z \<in> B x. P z)"
  45.255 @@ -1248,7 +1248,7 @@
  45.256    "\<And>A B f. (\<Inter>x\<in>f`A. B x) = (\<Inter>a\<in>A. B (f a))"
  45.257    by auto
  45.258  
  45.259 -lemma UN_ball_bex_simps [simp, no_atp]:
  45.260 +lemma UN_ball_bex_simps [simp]:
  45.261    "\<And>A P. (\<forall>x\<in>\<Union>A. P x) \<longleftrightarrow> (\<forall>y\<in>A. \<forall>x\<in>y. P x)"
  45.262    "\<And>A B P. (\<forall>x\<in>UNION A B. P x) = (\<forall>a\<in>A. \<forall>x\<in> B a. P x)"
  45.263    "\<And>A P. (\<exists>x\<in>\<Union>A. P x) \<longleftrightarrow> (\<exists>y\<in>A. \<exists>x\<in>y. P x)"
    46.1 --- a/src/HOL/Complex.thy	Mon Nov 11 17:34:44 2013 +0100
    46.2 +++ b/src/HOL/Complex.thy	Mon Nov 11 17:44:21 2013 +0100
    46.3 @@ -587,7 +587,7 @@
    46.4    by (simp add: cis_def)
    46.5  
    46.6  lemma cis_divide: "cis a / cis b = cis (a - b)"
    46.7 -  by (simp add: complex_divide_def cis_mult diff_minus)
    46.8 +  by (simp add: complex_divide_def cis_mult)
    46.9  
   46.10  lemma cos_n_Re_cis_pow_n: "cos (real n * a) = Re(cis a ^ n)"
   46.11    by (auto simp add: DeMoivre)
    47.1 --- a/src/HOL/Conditionally_Complete_Lattices.thy	Mon Nov 11 17:34:44 2013 +0100
    47.2 +++ b/src/HOL/Conditionally_Complete_Lattices.thy	Mon Nov 11 17:44:21 2013 +0100
    47.3 @@ -1,19 +1,160 @@
    47.4  (*  Title:      HOL/Conditionally_Complete_Lattices.thy
    47.5      Author:     Amine Chaieb and L C Paulson, University of Cambridge
    47.6      Author:     Johannes Hölzl, TU München
    47.7 +    Author:     Luke S. Serafin, Carnegie Mellon University
    47.8  *)
    47.9  
   47.10  header {* Conditionally-complete Lattices *}
   47.11  
   47.12  theory Conditionally_Complete_Lattices
   47.13 -imports Main Lubs
   47.14 +imports Main
   47.15 +begin
   47.16 +
   47.17 +lemma (in linorder) Sup_fin_eq_Max: "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Sup_fin X = Max X"
   47.18 +  by (induct X rule: finite_ne_induct) (simp_all add: sup_max)
   47.19 +
   47.20 +lemma (in linorder) Inf_fin_eq_Min: "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Inf_fin X = Min X"
   47.21 +  by (induct X rule: finite_ne_induct) (simp_all add: inf_min)
   47.22 +
   47.23 +context preorder
   47.24  begin
   47.25  
   47.26 -lemma Sup_fin_eq_Max: "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Sup_fin X = Max X"
   47.27 -  by (induct X rule: finite_ne_induct) (simp_all add: sup_max)
   47.28 +definition "bdd_above A \<longleftrightarrow> (\<exists>M. \<forall>x \<in> A. x \<le> M)"
   47.29 +definition "bdd_below A \<longleftrightarrow> (\<exists>m. \<forall>x \<in> A. m \<le> x)"
   47.30 +
   47.31 +lemma bdd_aboveI[intro]: "(\<And>x. x \<in> A \<Longrightarrow> x \<le> M) \<Longrightarrow> bdd_above A"
   47.32 +  by (auto simp: bdd_above_def)
   47.33 +
   47.34 +lemma bdd_belowI[intro]: "(\<And>x. x \<in> A \<Longrightarrow> m \<le> x) \<Longrightarrow> bdd_below A"
   47.35 +  by (auto simp: bdd_below_def)
   47.36 +
   47.37 +lemma bdd_aboveI2: "(\<And>x. x \<in> A \<Longrightarrow> f x \<le> M) \<Longrightarrow> bdd_above (f`A)"
   47.38 +  by force
   47.39 +
   47.40 +lemma bdd_belowI2: "(\<And>x. x \<in> A \<Longrightarrow> m \<le> f x) \<Longrightarrow> bdd_below (f`A)"
   47.41 +  by force
   47.42 +
   47.43 +lemma bdd_above_empty [simp, intro]: "bdd_above {}"
   47.44 +  unfolding bdd_above_def by auto
   47.45 +
   47.46 +lemma bdd_below_empty [simp, intro]: "bdd_below {}"
   47.47 +  unfolding bdd_below_def by auto
   47.48 +
   47.49 +lemma bdd_above_mono: "bdd_above B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> bdd_above A"
   47.50 +  by (metis (full_types) bdd_above_def order_class.le_neq_trans psubsetD)
   47.51 +
   47.52 +lemma bdd_below_mono: "bdd_below B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> bdd_below A"
   47.53 +  by (metis bdd_below_def order_class.le_neq_trans psubsetD)
   47.54 +
   47.55 +lemma bdd_above_Int1 [simp]: "bdd_above A \<Longrightarrow> bdd_above (A \<inter> B)"
   47.56 +  using bdd_above_mono by auto
   47.57 +
   47.58 +lemma bdd_above_Int2 [simp]: "bdd_above B \<Longrightarrow> bdd_above (A \<inter> B)"
   47.59 +  using bdd_above_mono by auto
   47.60 +
   47.61 +lemma bdd_below_Int1 [simp]: "bdd_below A \<Longrightarrow> bdd_below (A \<inter> B)"
   47.62 +  using bdd_below_mono by auto
   47.63 +
   47.64 +lemma bdd_below_Int2 [simp]: "bdd_below B \<Longrightarrow> bdd_below (A \<inter> B)"
   47.65 +  using bdd_below_mono by auto
   47.66 +
   47.67 +lemma bdd_above_Ioo [simp, intro]: "bdd_above {a <..< b}"
   47.68 +  by (auto simp add: bdd_above_def intro!: exI[of _ b] less_imp_le)
   47.69 +
   47.70 +lemma bdd_above_Ico [simp, intro]: "bdd_above {a ..< b}"
   47.71 +  by (auto simp add: bdd_above_def intro!: exI[of _ b] less_imp_le)
   47.72 +
   47.73 +lemma bdd_above_Iio [simp, intro]: "bdd_above {..< b}"
   47.74 +  by (auto simp add: bdd_above_def intro: exI[of _ b] less_imp_le)
   47.75 +
   47.76 +lemma bdd_above_Ioc [simp, intro]: "bdd_above {a <.. b}"
   47.77 +  by (auto simp add: bdd_above_def intro: exI[of _ b] less_imp_le)
   47.78 +
   47.79 +lemma bdd_above_Icc [simp, intro]: "bdd_above {a .. b}"
   47.80 +  by (auto simp add: bdd_above_def intro: exI[of _ b] less_imp_le)
   47.81 +
   47.82 +lemma bdd_above_Iic [simp, intro]: "bdd_above {.. b}"
   47.83 +  by (auto simp add: bdd_above_def intro: exI[of _ b] less_imp_le)
   47.84 +
   47.85 +lemma bdd_below_Ioo [simp, intro]: "bdd_below {a <..< b}"
   47.86 +  by (auto simp add: bdd_below_def intro!: exI[of _ a] less_imp_le)
   47.87 +
   47.88 +lemma bdd_below_Ioc [simp, intro]: "bdd_below {a <.. b}"
   47.89 +  by (auto simp add: bdd_below_def intro!: exI[of _ a] less_imp_le)
   47.90 +
   47.91 +lemma bdd_below_Ioi [simp, intro]: "bdd_below {a <..}"
   47.92 +  by (auto simp add: bdd_below_def intro: exI[of _ a] less_imp_le)
   47.93  
   47.94 -lemma Inf_fin_eq_Min: "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Inf_fin X = Min X"
   47.95 -  by (induct X rule: finite_ne_induct) (simp_all add: inf_min)
   47.96 +lemma bdd_below_Ico [simp, intro]: "bdd_below {a ..< b}"
   47.97 +  by (auto simp add: bdd_below_def intro: exI[of _ a] less_imp_le)
   47.98 +
   47.99 +lemma bdd_below_Icc [simp, intro]: "bdd_below {a .. b}"
  47.100 +  by (auto simp add: bdd_below_def intro: exI[of _ a] less_imp_le)
  47.101 +
  47.102 +lemma bdd_below_Ici [simp, intro]: "bdd_below {a ..}"
  47.103 +  by (auto simp add: bdd_below_def intro: exI[of _ a] less_imp_le)
  47.104 +
  47.105 +end
  47.106 +
  47.107 +lemma (in order_top) bdd_above_top[simp, intro!]: "bdd_above A"
  47.108 +  by (rule bdd_aboveI[of _ top]) simp
  47.109 +
  47.110 +lemma (in order_bot) bdd_above_bot[simp, intro!]: "bdd_below A"
  47.111 +  by (rule bdd_belowI[of _ bot]) simp
  47.112 +
  47.113 +lemma bdd_above_uminus[simp]:
  47.114 +  fixes X :: "'a::ordered_ab_group_add set"
  47.115 +  shows "bdd_above (uminus ` X) \<longleftrightarrow> bdd_below X"
  47.116 +  by (auto simp: bdd_above_def bdd_below_def intro: le_imp_neg_le) (metis le_imp_neg_le minus_minus)
  47.117 +
  47.118 +lemma bdd_below_uminus[simp]:
  47.119 +  fixes X :: "'a::ordered_ab_group_add set"
  47.120 +  shows"bdd_below (uminus ` X) \<longleftrightarrow> bdd_above X"
  47.121 +  by (auto simp: bdd_above_def bdd_below_def intro: le_imp_neg_le) (metis le_imp_neg_le minus_minus)
  47.122 +
  47.123 +context lattice
  47.124 +begin
  47.125 +
  47.126 +lemma bdd_above_insert [simp]: "bdd_above (insert a A) = bdd_above A"
  47.127 +  by (auto simp: bdd_above_def intro: le_supI2 sup_ge1)
  47.128 +
  47.129 +lemma bdd_below_insert [simp]: "bdd_below (insert a A) = bdd_below A"
  47.130 +  by (auto simp: bdd_below_def intro: le_infI2 inf_le1)
  47.131 +
  47.132 +lemma bdd_finite [simp]:
  47.133 +  assumes "finite A" shows bdd_above_finite: "bdd_above A" and bdd_below_finite: "bdd_below A"
  47.134 +  using assms by (induct rule: finite_induct, auto)
  47.135 +
  47.136 +lemma bdd_above_Un [simp]: "bdd_above (A \<union> B) = (bdd_above A \<and> bdd_above B)"
  47.137 +proof
  47.138 +  assume "bdd_above (A \<union> B)"
  47.139 +  thus "bdd_above A \<and> bdd_above B" unfolding bdd_above_def by auto
  47.140 +next
  47.141 +  assume "bdd_above A \<and> bdd_above B"
  47.142 +  then obtain a b where "\<forall>x\<in>A. x \<le> a" "\<forall>x\<in>B. x \<le> b" unfolding bdd_above_def by auto
  47.143 +  hence "\<forall>x \<in> A \<union> B. x \<le> sup a b" by (auto intro: Un_iff le_supI1 le_supI2)
  47.144 +  thus "bdd_above (A \<union> B)" unfolding bdd_above_def ..
  47.145 +qed
  47.146 +
  47.147 +lemma bdd_below_Un [simp]: "bdd_below (A \<union> B) = (bdd_below A \<and> bdd_below B)"
  47.148 +proof
  47.149 +  assume "bdd_below (A \<union> B)"
  47.150 +  thus "bdd_below A \<and> bdd_below B" unfolding bdd_below_def by auto
  47.151 +next
  47.152 +  assume "bdd_below A \<and> bdd_below B"
  47.153 +  then obtain a b where "\<forall>x\<in>A. a \<le> x" "\<forall>x\<in>B. b \<le> x" unfolding bdd_below_def by auto
  47.154 +  hence "\<forall>x \<in> A \<union> B. inf a b \<le> x" by (auto intro: Un_iff le_infI1 le_infI2)
  47.155 +  thus "bdd_below (A \<union> B)" unfolding bdd_below_def ..
  47.156 +qed
  47.157 +
  47.158 +lemma bdd_above_sup[simp]: "bdd_above ((\<lambda>x. sup (f x) (g x)) ` A) \<longleftrightarrow> bdd_above (f`A) \<and> bdd_above (g`A)"
  47.159 +  by (auto simp: bdd_above_def intro: le_supI1 le_supI2)
  47.160 +
  47.161 +lemma bdd_below_inf[simp]: "bdd_below ((\<lambda>x. inf (f x) (g x)) ` A) \<longleftrightarrow> bdd_below (f`A) \<and> bdd_below (g`A)"
  47.162 +  by (auto simp: bdd_below_def intro: le_infI1 le_infI2)
  47.163 +
  47.164 +end
  47.165 +
  47.166  
  47.167  text {*
  47.168  
  47.169 @@ -23,46 +164,42 @@
  47.170  *}
  47.171  
  47.172  class conditionally_complete_lattice = lattice + Sup + Inf +
  47.173 -  assumes cInf_lower: "x \<in> X \<Longrightarrow> (\<And>a. a \<in> X \<Longrightarrow> z \<le> a) \<Longrightarrow> Inf X \<le> x"
  47.174 +  assumes cInf_lower: "x \<in> X \<Longrightarrow> bdd_below X \<Longrightarrow> Inf X \<le> x"
  47.175      and cInf_greatest: "X \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> z \<le> x) \<Longrightarrow> z \<le> Inf X"
  47.176 -  assumes cSup_upper: "x \<in> X \<Longrightarrow> (\<And>a. a \<in> X \<Longrightarrow> a \<le> z) \<Longrightarrow> x \<le> Sup X"
  47.177 +  assumes cSup_upper: "x \<in> X \<Longrightarrow> bdd_above X \<Longrightarrow> x \<le> Sup X"
  47.178      and cSup_least: "X \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> x \<le> z) \<Longrightarrow> Sup X \<le> z"
  47.179  begin
  47.180  
  47.181 -lemma cSup_eq_maximum: (*REAL_SUP_MAX in HOL4*)
  47.182 -  "z \<in> X \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> x \<le> z) \<Longrightarrow> Sup X = z"
  47.183 -  by (blast intro: antisym cSup_upper cSup_least)
  47.184 +lemma cSup_upper2: "x \<in> X \<Longrightarrow> y \<le> x \<Longrightarrow> bdd_above X \<Longrightarrow> y \<le> Sup X"
  47.185 +  by (metis cSup_upper order_trans)
  47.186 +
  47.187 +lemma cInf_lower2: "x \<in> X \<Longrightarrow> x \<le> y \<Longrightarrow> bdd_below X \<Longrightarrow> Inf X \<le> y"
  47.188 +  by (metis cInf_lower order_trans)
  47.189 +
  47.190 +lemma cSup_mono: "B \<noteq> {} \<Longrightarrow> bdd_above A \<Longrightarrow> (\<And>b. b \<in> B \<Longrightarrow> \<exists>a\<in>A. b \<le> a) \<Longrightarrow> Sup B \<le> Sup A"
  47.191 +  by (metis cSup_least cSup_upper2)
  47.192 +
  47.193 +lemma cInf_mono: "B \<noteq> {} \<Longrightarrow> bdd_below A \<Longrightarrow> (\<And>b. b \<in> B \<Longrightarrow> \<exists>a\<in>A. a \<le> b) \<Longrightarrow> Inf A \<le> Inf B"
  47.194 +  by (metis cInf_greatest cInf_lower2)
  47.195  
  47.196 -lemma cInf_eq_minimum: (*REAL_INF_MIN in HOL4*)
  47.197 -  "z \<in> X \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> z \<le> x) \<Longrightarrow> Inf X = z"
  47.198 -  by (intro antisym cInf_lower[of z X z] cInf_greatest[of X z]) auto
  47.199 +lemma cSup_subset_mono: "A \<noteq> {} \<Longrightarrow> bdd_above B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> Sup A \<le> Sup B"
  47.200 +  by (metis cSup_least cSup_upper subsetD)
  47.201 +
  47.202 +lemma cInf_superset_mono: "A \<noteq> {} \<Longrightarrow> bdd_below B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> Inf B \<le> Inf A"
  47.203 +  by (metis cInf_greatest cInf_lower subsetD)
  47.204  
  47.205 -lemma cSup_le_iff: "S \<noteq> {} \<Longrightarrow> (\<And>a. a \<in> S \<Longrightarrow> a \<le> z) \<Longrightarrow> Sup S \<le> a \<longleftrightarrow> (\<forall>x\<in>S. x \<le> a)"
  47.206 +lemma cSup_eq_maximum: "z \<in> X \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> x \<le> z) \<Longrightarrow> Sup X = z"
  47.207 +  by (intro antisym cSup_upper[of z X] cSup_least[of X z]) auto
  47.208 +
  47.209 +lemma cInf_eq_minimum: "z \<in> X \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> z \<le> x) \<Longrightarrow> Inf X = z"
  47.210 +  by (intro antisym cInf_lower[of z X] cInf_greatest[of X z]) auto
  47.211 +
  47.212 +lemma cSup_le_iff: "S \<noteq> {} \<Longrightarrow> bdd_above S \<Longrightarrow> Sup S \<le> a \<longleftrightarrow> (\<forall>x\<in>S. x \<le> a)"
  47.213    by (metis order_trans cSup_upper cSup_least)
  47.214  
  47.215 -lemma le_cInf_iff: "S \<noteq> {} \<Longrightarrow> (\<And>a. a \<in> S \<Longrightarrow> z \<le> a) \<Longrightarrow> a \<le> Inf S \<longleftrightarrow> (\<forall>x\<in>S. a \<le> x)"
  47.216 +lemma le_cInf_iff: "S \<noteq> {} \<Longrightarrow> bdd_below S \<Longrightarrow> a \<le> Inf S \<longleftrightarrow> (\<forall>x\<in>S. a \<le> x)"
  47.217    by (metis order_trans cInf_lower cInf_greatest)
  47.218  
  47.219 -lemma cSup_singleton [simp]: "Sup {x} = x"
  47.220 -  by (intro cSup_eq_maximum) auto
  47.221 -
  47.222 -lemma cInf_singleton [simp]: "Inf {x} = x"
  47.223 -  by (intro cInf_eq_minimum) auto
  47.224 -
  47.225 -lemma cSup_upper2: (*REAL_IMP_LE_SUP in HOL4*)
  47.226 -  "x \<in> X \<Longrightarrow> y \<le> x \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> x \<le> z) \<Longrightarrow> y \<le> Sup X"
  47.227 -  by (metis cSup_upper order_trans)
  47.228 - 
  47.229 -lemma cInf_lower2:
  47.230 -  "x \<in> X \<Longrightarrow> x \<le> y \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> z \<le> x) \<Longrightarrow> Inf X \<le> y"
  47.231 -  by (metis cInf_lower order_trans)
  47.232 -
  47.233 -lemma cSup_upper_EX: "x \<in> X \<Longrightarrow> \<exists>z. \<forall>x. x \<in> X \<longrightarrow> x \<le> z \<Longrightarrow> x \<le> Sup X"
  47.234 -  by (blast intro: cSup_upper)
  47.235 -
  47.236 -lemma cInf_lower_EX:  "x \<in> X \<Longrightarrow> \<exists>z. \<forall>x. x \<in> X \<longrightarrow> z \<le> x \<Longrightarrow> Inf X \<le> x"
  47.237 -  by (blast intro: cInf_lower)
  47.238 -
  47.239  lemma cSup_eq_non_empty:
  47.240    assumes 1: "X \<noteq> {}"
  47.241    assumes 2: "\<And>x. x \<in> X \<Longrightarrow> x \<le> a"
  47.242 @@ -77,67 +214,47 @@
  47.243    shows "Inf X = a"
  47.244    by (intro 3 1 antisym cInf_greatest) (auto intro: 2 1 cInf_lower)
  47.245  
  47.246 -lemma cInf_cSup: "S \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> S \<Longrightarrow> z \<le> x) \<Longrightarrow> Inf S = Sup {x. \<forall>s\<in>S. x \<le> s}"
  47.247 -  by (rule cInf_eq_non_empty) (auto intro: cSup_upper cSup_least)
  47.248 +lemma cInf_cSup: "S \<noteq> {} \<Longrightarrow> bdd_below S \<Longrightarrow> Inf S = Sup {x. \<forall>s\<in>S. x \<le> s}"
  47.249 +  by (rule cInf_eq_non_empty) (auto intro!: cSup_upper cSup_least simp: bdd_below_def)
  47.250  
  47.251 -lemma cSup_cInf: "S \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> S \<Longrightarrow> x \<le> z) \<Longrightarrow> Sup S = Inf {x. \<forall>s\<in>S. s \<le> x}"
  47.252 -  by (rule cSup_eq_non_empty) (auto intro: cInf_lower cInf_greatest)
  47.253 +lemma cSup_cInf: "S \<noteq> {} \<Longrightarrow> bdd_above S \<Longrightarrow> Sup S = Inf {x. \<forall>s\<in>S. s \<le> x}"
  47.254 +  by (rule cSup_eq_non_empty) (auto intro!: cInf_lower cInf_greatest simp: bdd_above_def)
  47.255  
  47.256 -lemma cSup_insert: 
  47.257 -  assumes x: "X \<noteq> {}"
  47.258 -      and z: "\<And>x. x \<in> X \<Longrightarrow> x \<le> z"
  47.259 -  shows "Sup (insert a X) = sup a (Sup X)"
  47.260 -proof (intro cSup_eq_non_empty)
  47.261 -  fix y assume "\<And>x. x \<in> insert a X \<Longrightarrow> x \<le> y" with x show "sup a (Sup X) \<le> y" by (auto intro: cSup_least)
  47.262 -qed (auto intro: le_supI2 z cSup_upper)
  47.263 +lemma cSup_insert: "X \<noteq> {} \<Longrightarrow> bdd_above X \<Longrightarrow> Sup (insert a X) = sup a (Sup X)"
  47.264 +  by (intro cSup_eq_non_empty) (auto intro: le_supI2 cSup_upper cSup_least)
  47.265 +
  47.266 +lemma cInf_insert: "X \<noteq> {} \<Longrightarrow> bdd_below X \<Longrightarrow> Inf (insert a X) = inf a (Inf X)"
  47.267 +  by (intro cInf_eq_non_empty) (auto intro: le_infI2 cInf_lower cInf_greatest)
  47.268  
  47.269 -lemma cInf_insert: 
  47.270 -  assumes x: "X \<noteq> {}"
  47.271 -      and z: "\<And>x. x \<in> X \<Longrightarrow> z \<le> x"
  47.272 -  shows "Inf (insert a X) = inf a (Inf X)"
  47.273 -proof (intro cInf_eq_non_empty)
  47.274 -  fix y assume "\<And>x. x \<in> insert a X \<Longrightarrow> y \<le> x" with x show "y \<le> inf a (Inf X)" by (auto intro: cInf_greatest)
  47.275 -qed (auto intro: le_infI2 z cInf_lower)
  47.276 +lemma cSup_singleton [simp]: "Sup {x} = x"
  47.277 +  by (intro cSup_eq_maximum) auto
  47.278 +
  47.279 +lemma cInf_singleton [simp]: "Inf {x} = x"
  47.280 +  by (intro cInf_eq_minimum) auto
  47.281  
  47.282 -lemma cSup_insert_If: 
  47.283 -  "(\<And>x. x \<in> X \<Longrightarrow> x \<le> z) \<Longrightarrow> Sup (insert a X) = (if X = {} then a else sup a (Sup X))"
  47.284 -  using cSup_insert[of X z] by simp
  47.285 +lemma cSup_insert_If:  "bdd_above X \<Longrightarrow> Sup (insert a X) = (if X = {} then a else sup a (Sup X))"
  47.286 +  using cSup_insert[of X] by simp
  47.287  
  47.288 -lemma cInf_insert_if: 
  47.289 -  "(\<And>x. x \<in> X \<Longrightarrow> z \<le> x) \<Longrightarrow> Inf (insert a X) = (if X = {} then a else inf a (Inf X))"
  47.290 -  using cInf_insert[of X z] by simp
  47.291 +lemma cInf_insert_If: "bdd_below X \<Longrightarrow> Inf (insert a X) = (if X = {} then a else inf a (Inf X))"
  47.