added predicate transformation function for code generation

--- a/Admin/mirror-website	Fri May 15 15:29:34 2009 +0200
+++ b/Admin/mirror-website	Fri May 15 15:56:28 2009 +0200
@@ -12,7 +12,7 @@
     ;;
   *.cl.cam.ac.uk)
     USER=paulson
-    DEST=/anfs/www/html/Research/HVG/Isabelle
+    DEST=/anfs/www/html/research/hvg/Isabelle
     ;;
   *)
     echo "Unknown destination directory for ${HOST}"

--- a/CONTRIBUTORS	Fri May 15 15:29:34 2009 +0200
+++ b/CONTRIBUTORS	Fri May 15 15:56:28 2009 +0200
@@ -7,6 +7,10 @@
 Contributions to this Isabelle version
 --------------------------------------
 
+
+Contributions to Isabelle2009
+-----------------------------
+
 * March 2009: Robert Himmelmann, TUM and Amine Chaieb, University of
   Cambridge
   Elementary topology in Euclidean space.

--- a/NEWS	Fri May 15 15:29:34 2009 +0200
+++ b/NEWS	Fri May 15 15:56:28 2009 +0200
@@ -4,6 +4,26 @@
 New in this Isabelle version
 ----------------------------
 
+*** Pure ***
+
+* On instantiation of classes, remaining undefined class parameters are
+formally declared.  INCOMPATIBILITY.
+
+
+*** HOL ***
+
+* Class semiring_div requires superclass no_zero_divisors and proof of div_mult_mult1;
+theorems div_mult_mult1, div_mult_mult2, div_mult_mult1_if, div_mult_mult1 and
+div_mult_mult2 have been generalized to class semiring_div, subsuming former
+theorems zdiv_zmult_zmult1, zdiv_zmult_zmult1_if, zdiv_zmult_zmult1 and zdiv_zmult_zmult2.
+div_mult_mult1 is now [simp] by default.  INCOMPATIBILITY.
+
+* Power operations on relations and functions are now one dedicate constant compow with
+infix syntax "^^".  Power operations on multiplicative monoids retains syntax "^"
+and is now defined generic in class power.  INCOMPATIBILITY.
+
+* ML antiquotation @{code_datatype} inserts definition of a datatype generated
+by the code generator; see Predicate.thy for an example.
 
 
 New in Isabelle2009 (April 2009)
@@ -187,7 +207,7 @@
 
 * Keyword 'code_exception' now named 'code_abort'.  INCOMPATIBILITY.
 
-* Unified theorem tables for both code code generators.  Thus [code
+* Unified theorem tables for both code generators.  Thus [code
 func] has disappeared and only [code] remains.  INCOMPATIBILITY.
 
 * Command 'find_consts' searches for constants based on type and name

--- a/contrib/SystemOnTPTP/remote	Fri May 15 15:29:34 2009 +0200
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,120 +0,0 @@
-#!/usr/bin/env perl
-#
-# Wrapper for custom remote provers on SystemOnTPTP
-# Author: Fabian Immler, TU Muenchen
-#
-
-use warnings;
-use strict;
-use Getopt::Std;
-use HTTP::Request::Common;
-use LWP;
-
-my $SystemOnTPTPFormReplyURL = "http://www.cs.miami.edu/~tptp/cgi-bin/SystemOnTPTPFormReply";
-
-# default parameters
-my %URLParameters = (
-    "NoHTML" => 1,
-    "QuietFlag" => "-q01",
-    "X2TPTP" => "-S",
-    "SubmitButton" => "RunSelectedSystems",
-    "ProblemSource" => "UPLOAD",
-    );
-
-#----Get format and transform options if specified
-my %Options;
-getopts("hws:t:c:",\%Options);
-
-#----Usage
-sub usage() {
-  print("Usage: remote [<options>] <File name>\n");
-  print("    <options> are ...\n");
-  print("    -h            - print this help\n");
-  print("    -w            - list available ATP systems\n");
-  print("    -s<system>    - specified system to use\n");
-  print("    -t<timelimit> - CPU time limit for system\n");
-  print("    -c<command>   - custom command for system\n");
-  print("    <File name>   - TPTP problem file\n");
-  exit(0);
-}
-if (exists($Options{'h'})) {
-  usage();
-}
-#----What systems flag
-if (exists($Options{'w'})) {
-    $URLParameters{"SubmitButton"} = "ListSystems";
-    delete($URLParameters{"ProblemSource"});
-}
-#----Selected system
-my $System;
-if (exists($Options{'s'})) {
-    $System = $Options{'s'};
-} else {
-    # use Vampire as default
-    $System = "Vampire---9.0";
-}
-$URLParameters{"System___$System"} = $System;
-
-#----Time limit
-if (exists($Options{'t'})) {
-    $URLParameters{"TimeLimit___$System"} = $Options{'t'};
-}
-#----Custom command
-if (exists($Options{'c'})) {
-    $URLParameters{"Command___$System"} = $Options{'c'};
-}
-
-#----Get single file name
-if (exists($URLParameters{"ProblemSource"})) {
-    if (scalar(@ARGV) >= 1) {
-        $URLParameters{"UPLOADProblem"} = [shift(@ARGV)];
-    } else {
-      print("Missing problem file\n");
-      usage();
-      die;
-    }
-}
-
-# Query Server
-my $Agent = LWP::UserAgent->new;
-if (exists($Options{'t'})) {
-  # give server more time to respond
-  $Agent->timeout($Options{'t'} + 10);
-}
-my $Request = POST($SystemOnTPTPFormReplyURL,
-	Content_Type => 'form-data',Content => \%URLParameters);
-my $Response = $Agent->request($Request);
-
-#catch errors / failure
-if(! $Response->is_success){
-  print "HTTP-Error: " . $Response->message . "\n";
-  exit(-1);
-} elsif (exists($Options{'w'})) {
-  print $Response->content;
-  exit (0);
-} elsif ($Response->content =~ /WARNING: (\S*) does not exist/) {
-  print "Specified System $1 does not exist\n";
-  exit(-1);
-} elsif ($Response->content =~ /%\s*Result\s*:\s*Unsatisfiable.*\n%\s*Output\s*:\s*(CNF)?Refutation.*\n%/) {
-  my @lines = split( /\n/, $Response->content);
-  my $extract = "";
-  foreach my $line (@lines){
-      #ignore comments
-      if ($line !~ /^%/ && !($line eq "")) {
-          $extract .= "$line";
-      }
-  }
-  # insert newlines after ').'
-  $extract =~ s/\s//g;
-  $extract =~ s/\)\.cnf/\)\.\ncnf/g;
-
-  # orientation for res_reconstruct.ML
-  print "# SZS output start CNFRefutation.\n";
-  print "$extract\n";
-  print "# SZS output end CNFRefutation.\n";
-  exit(0);
-} else {
-  print "Remote-script could not extract proof:\n".$Response->content;
-  exit(-1);
-}
-

--- a/doc-src/Codegen/Makefile	Fri May 15 15:29:34 2009 +0200
+++ b/doc-src/Codegen/Makefile	Fri May 15 15:56:28 2009 +0200
@@ -17,7 +17,7 @@
 
 dvi: $(NAME).dvi
 
-$(NAME).dvi: $(FILES) isabelle_isar.eps architecture.eps adaption.eps
+$(NAME).dvi: $(FILES) isabelle_isar.eps architecture.eps adaptation.eps
 	$(LATEX) $(NAME)
 	$(BIBTEX) $(NAME)
 	$(LATEX) $(NAME)
@@ -25,7 +25,7 @@
 
 pdf: $(NAME).pdf
 
-$(NAME).pdf: $(FILES) isabelle_isar.pdf architecture.pdf adaption.pdf
+$(NAME).pdf: $(FILES) isabelle_isar.pdf architecture.pdf adaptation.pdf
 	$(PDFLATEX) $(NAME)
 	$(BIBTEX) $(NAME)
 	$(PDFLATEX) $(NAME)
@@ -37,17 +37,17 @@
 architecture.dvi: Thy/pictures/architecture.tex
 	latex -output-directory=$(dir $@) $<
 
-adaption.dvi: Thy/pictures/adaption.tex
+adaptation.dvi: Thy/pictures/adaptation.tex
 	latex -output-directory=$(dir $@) $<
 
 architecture.eps: architecture.dvi
 	dvips -E -o $@ $<
 
-adaption.eps: adaption.dvi
+adaptation.eps: adaptation.dvi
 	dvips -E -o $@ $<
 
 architecture.pdf: architecture.eps
 	epstopdf --outfile=$@ $<
 
-adaption.pdf: adaption.eps
+adaptation.pdf: adaptation.eps
 	epstopdf --outfile=$@ $<

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/doc-src/Codegen/Thy/Adaptation.thy	Fri May 15 15:56:28 2009 +0200
@@ -0,0 +1,326 @@
+theory Adaptation
+imports Setup
+begin
+
+setup %invisible {* Code_Target.extend_target ("\<SML>", ("SML", K I)) *}
+
+section {* Adaptation to target languages \label{sec:adaptation} *}
+
+subsection {* Adapting code generation *}
+
+text {*
+  The aspects of code generation introduced so far have two aspects
+  in common:
+
+  \begin{itemize}
+    \item They act uniformly, without reference to a specific
+       target language.
+    \item They are \emph{safe} in the sense that as long as you trust
+       the code generator meta theory and implementation, you cannot
+       produce programs that yield results which are not derivable
+       in the logic.
+  \end{itemize}
+
+  \noindent In this section we will introduce means to \emph{adapt} the serialiser
+  to a specific target language, i.e.~to print program fragments
+  in a way which accommodates \qt{already existing} ingredients of
+  a target language environment, for three reasons:
+
+  \begin{itemize}
+    \item improving readability and aesthetics of generated code
+    \item gaining efficiency
+    \item interface with language parts which have no direct counterpart
+      in @{text "HOL"} (say, imperative data structures)
+  \end{itemize}
+
+  \noindent Generally, you should avoid using those features yourself
+  \emph{at any cost}:
+
+  \begin{itemize}
+    \item The safe configuration methods act uniformly on every target language,
+      whereas for adaptation you have to treat each target language separate.
+    \item Application is extremely tedious since there is no abstraction
+      which would allow for a static check, making it easy to produce garbage.
+    \item More or less subtle errors can be introduced unconsciously.
+  \end{itemize}
+
+  \noindent However, even if you ought refrain from setting up adaptation
+  yourself, already the @{text "HOL"} comes with some reasonable default
+  adaptations (say, using target language list syntax).  There also some
+  common adaptation cases which you can setup by importing particular
+  library theories.  In order to understand these, we provide some clues here;
+  these however are not supposed to replace a careful study of the sources.
+*}
+
+subsection {* The adaptation principle *}
+
+text {*
+  Figure \ref{fig:adaptation} illustrates what \qt{adaptation} is conceptually
+  supposed to be:
+
+  \begin{figure}[here]
+    \includegraphics{adaptation}
+    \caption{The adaptation principle}
+    \label{fig:adaptation}
+  \end{figure}
+
+  \noindent In the tame view, code generation acts as broker between
+  @{text logic}, @{text "intermediate language"} and
+  @{text "target language"} by means of @{text translation} and
+  @{text serialisation};  for the latter, the serialiser has to observe
+  the structure of the @{text language} itself plus some @{text reserved}
+  keywords which have to be avoided for generated code.
+  However, if you consider @{text adaptation} mechanisms, the code generated
+  by the serializer is just the tip of the iceberg:
+
+  \begin{itemize}
+    \item @{text serialisation} can be \emph{parametrised} such that
+      logical entities are mapped to target-specific ones
+      (e.g. target-specific list syntax,
+        see also \secref{sec:adaptation_mechanisms})
+    \item Such parametrisations can involve references to a
+      target-specific standard @{text library} (e.g. using
+      the @{text Haskell} @{verbatim Maybe} type instead
+      of the @{text HOL} @{type "option"} type);
+      if such are used, the corresponding identifiers
+      (in our example, @{verbatim Maybe}, @{verbatim Nothing}
+      and @{verbatim Just}) also have to be considered @{text reserved}.
+    \item Even more, the user can enrich the library of the
+      target-language by providing code snippets
+      (\qt{@{text "includes"}}) which are prepended to
+      any generated code (see \secref{sec:include});  this typically
+      also involves further @{text reserved} identifiers.
+  \end{itemize}
+
+  \noindent As figure \ref{fig:adaptation} illustrates, all these adaptation mechanisms
+  have to act consistently;  it is at the discretion of the user
+  to take care for this.
+*}
+
+subsection {* Common adaptation patterns *}
+
+text {*
+  The @{theory HOL} @{theory Main} theory already provides a code
+  generator setup
+  which should be suitable for most applications.  Common extensions
+  and modifications are available by certain theories of the @{text HOL}
+  library; beside being useful in applications, they may serve
+  as a tutorial for customising the code generator setup (see below
+  \secref{sec:adaptation_mechanisms}).
+
+  \begin{description}
+
+    \item[@{theory "Code_Integer"}] represents @{text HOL} integers by big
+       integer literals in target languages.
+    \item[@{theory "Code_Char"}] represents @{text HOL} characters by 
+       character literals in target languages.
+    \item[@{theory "Code_Char_chr"}] like @{text "Code_Char"},
+       but also offers treatment of character codes; includes
+       @{theory "Code_Char"}.
+    \item[@{theory "Efficient_Nat"}] \label{eff_nat} implements natural numbers by integers,
+       which in general will result in higher efficiency; pattern
+       matching with @{term "0\<Colon>nat"} / @{const "Suc"}
+       is eliminated;  includes @{theory "Code_Integer"}
+       and @{theory "Code_Index"}.
+    \item[@{theory "Code_Index"}] provides an additional datatype
+       @{typ index} which is mapped to target-language built-in integers.
+       Useful for code setups which involve e.g. indexing of
+       target-language arrays.
+    \item[@{theory "String"}] provides an additional datatype
+       @{typ message_string} which is isomorphic to strings;
+       @{typ message_string}s are mapped to target-language strings.
+       Useful for code setups which involve e.g. printing (error) messages.
+
+  \end{description}
+
+  \begin{warn}
+    When importing any of these theories, they should form the last
+    items in an import list.  Since these theories adapt the
+    code generator setup in a non-conservative fashion,
+    strange effects may occur otherwise.
+  \end{warn}
+*}
+
+
+subsection {* Parametrising serialisation \label{sec:adaptation_mechanisms} *}
+
+text {*
+  Consider the following function and its corresponding
+  SML code:
+*}
+
+primrec %quote in_interval :: "nat \<times> nat \<Rightarrow> nat \<Rightarrow> bool" where
+  "in_interval (k, l) n \<longleftrightarrow> k \<le> n \<and> n \<le> l"
+(*<*)
+code_type %invisible bool
+  (SML)
+code_const %invisible True and False and "op \<and>" and Not
+  (SML and and and)
+(*>*)
+text %quote {*@{code_stmts in_interval (SML)}*}
+
+text {*
+  \noindent Though this is correct code, it is a little bit unsatisfactory:
+  boolean values and operators are materialised as distinguished
+  entities with have nothing to do with the SML-built-in notion
+  of \qt{bool}.  This results in less readable code;
+  additionally, eager evaluation may cause programs to
+  loop or break which would perfectly terminate when
+  the existing SML @{verbatim "bool"} would be used.  To map
+  the HOL @{typ bool} on SML @{verbatim "bool"}, we may use
+  \qn{custom serialisations}:
+*}
+
+code_type %quotett bool
+  (SML "bool")
+code_const %quotett True and False and "op \<and>"
+  (SML "true" and "false" and "_ andalso _")
+
+text {*
+  \noindent The @{command code_type} command takes a type constructor
+  as arguments together with a list of custom serialisations.
+  Each custom serialisation starts with a target language
+  identifier followed by an expression, which during
+  code serialisation is inserted whenever the type constructor
+  would occur.  For constants, @{command code_const} implements
+  the corresponding mechanism.  Each ``@{verbatim "_"}'' in
+  a serialisation expression is treated as a placeholder
+  for the type constructor's (the constant's) arguments.
+*}
+
+text %quote {*@{code_stmts in_interval (SML)}*}
+
+text {*
+  \noindent This still is not perfect: the parentheses
+  around the \qt{andalso} expression are superfluous.
+  Though the serialiser
+  by no means attempts to imitate the rich Isabelle syntax
+  framework, it provides some common idioms, notably
+  associative infixes with precedences which may be used here:
+*}
+
+code_const %quotett "op \<and>"
+  (SML infixl 1 "andalso")
+
+text %quote {*@{code_stmts in_interval (SML)}*}
+
+text {*
+  \noindent The attentive reader may ask how we assert that no generated
+  code will accidentally overwrite.  For this reason the serialiser has
+  an internal table of identifiers which have to be avoided to be used
+  for new declarations.  Initially, this table typically contains the
+  keywords of the target language.  It can be extended manually, thus avoiding
+  accidental overwrites, using the @{command "code_reserved"} command:
+*}
+
+code_reserved %quote "\<SML>" bool true false andalso
+
+text {*
+  \noindent Next, we try to map HOL pairs to SML pairs, using the
+  infix ``@{verbatim "*"}'' type constructor and parentheses:
+*}
+(*<*)
+code_type %invisible *
+  (SML)
+code_const %invisible Pair
+  (SML)
+(*>*)
+code_type %quotett *
+  (SML infix 2 "*")
+code_const %quotett Pair
+  (SML "!((_),/ (_))")
+
+text {*
+  \noindent The initial bang ``@{verbatim "!"}'' tells the serialiser
+  never to put
+  parentheses around the whole expression (they are already present),
+  while the parentheses around argument place holders
+  tell not to put parentheses around the arguments.
+  The slash ``@{verbatim "/"}'' (followed by arbitrary white space)
+  inserts a space which may be used as a break if necessary
+  during pretty printing.
+
+  These examples give a glimpse what mechanisms
+  custom serialisations provide; however their usage
+  requires careful thinking in order not to introduce
+  inconsistencies -- or, in other words:
+  custom serialisations are completely axiomatic.
+
+  A further noteworthy details is that any special
+  character in a custom serialisation may be quoted
+  using ``@{verbatim "'"}''; thus, in
+  ``@{verbatim "fn '_ => _"}'' the first
+  ``@{verbatim "_"}'' is a proper underscore while the
+  second ``@{verbatim "_"}'' is a placeholder.
+*}
+
+
+subsection {* @{text Haskell} serialisation *}
+
+text {*
+  For convenience, the default
+  @{text HOL} setup for @{text Haskell} maps the @{class eq} class to
+  its counterpart in @{text Haskell}, giving custom serialisations
+  for the class @{class eq} (by command @{command code_class}) and its operation
+  @{const HOL.eq}
+*}
+
+code_class %quotett eq
+  (Haskell "Eq")
+
+code_const %quotett "op ="
+  (Haskell infixl 4 "==")
+
+text {*
+  \noindent A problem now occurs whenever a type which
+  is an instance of @{class eq} in @{text HOL} is mapped
+  on a @{text Haskell}-built-in type which is also an instance
+  of @{text Haskell} @{text Eq}:
+*}
+
+typedecl %quote bar
+
+instantiation %quote bar :: eq
+begin
+
+definition %quote "eq_class.eq (x\<Colon>bar) y \<longleftrightarrow> x = y"
+
+instance %quote by default (simp add: eq_bar_def)
+
+end %quote (*<*)
+
+(*>*) code_type %quotett bar
+  (Haskell "Integer")
+
+text {*
+  \noindent The code generator would produce
+  an additional instance, which of course is rejected by the @{text Haskell}
+  compiler.
+  To suppress this additional instance, use
+  @{text "code_instance"}:
+*}
+
+code_instance %quotett bar :: eq
+  (Haskell -)
+
+
+subsection {* Enhancing the target language context \label{sec:include} *}
+
+text {*
+  In rare cases it is necessary to \emph{enrich} the context of a
+  target language;  this is accomplished using the @{command "code_include"}
+  command:
+*}
+
+code_include %quotett Haskell "Errno"
+{*errno i = error ("Error number: " ++ show i)*}
+
+code_reserved %quotett Haskell Errno
+
+text {*
+  \noindent Such named @{text include}s are then prepended to every generated code.
+  Inspect such code in order to find out how @{command "code_include"} behaves
+  with respect to a particular target language.
+*}
+
+end

--- a/doc-src/Codegen/Thy/Adaption.thy	Fri May 15 15:29:34 2009 +0200
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,326 +0,0 @@
-theory Adaption
-imports Setup
-begin
-
-setup %invisible {* Code_Target.extend_target ("\<SML>", ("SML", K I)) *}
-
-section {* Adaption to target languages \label{sec:adaption} *}
-
-subsection {* Adapting code generation *}
-
-text {*
-  The aspects of code generation introduced so far have two aspects
-  in common:
-
-  \begin{itemize}
-    \item They act uniformly, without reference to a specific
-       target language.
-    \item They are \emph{safe} in the sense that as long as you trust
-       the code generator meta theory and implementation, you cannot
-       produce programs that yield results which are not derivable
-       in the logic.
-  \end{itemize}
-
-  \noindent In this section we will introduce means to \emph{adapt} the serialiser
-  to a specific target language, i.e.~to print program fragments
-  in a way which accommodates \qt{already existing} ingredients of
-  a target language environment, for three reasons:
-
-  \begin{itemize}
-    \item improving readability and aesthetics of generated code
-    \item gaining efficiency
-    \item interface with language parts which have no direct counterpart
-      in @{text "HOL"} (say, imperative data structures)
-  \end{itemize}
-
-  \noindent Generally, you should avoid using those features yourself
-  \emph{at any cost}:
-
-  \begin{itemize}
-    \item The safe configuration methods act uniformly on every target language,
-      whereas for adaption you have to treat each target language separate.
-    \item Application is extremely tedious since there is no abstraction
-      which would allow for a static check, making it easy to produce garbage.
-    \item More or less subtle errors can be introduced unconsciously.
-  \end{itemize}
-
-  \noindent However, even if you ought refrain from setting up adaption
-  yourself, already the @{text "HOL"} comes with some reasonable default
-  adaptions (say, using target language list syntax).  There also some
-  common adaption cases which you can setup by importing particular
-  library theories.  In order to understand these, we provide some clues here;
-  these however are not supposed to replace a careful study of the sources.
-*}
-
-subsection {* The adaption principle *}
-
-text {*
-  Figure \ref{fig:adaption} illustrates what \qt{adaption} is conceptually
-  supposed to be:
-
-  \begin{figure}[here]
-    \includegraphics{adaption}
-    \caption{The adaption principle}
-    \label{fig:adaption}
-  \end{figure}
-
-  \noindent In the tame view, code generation acts as broker between
-  @{text logic}, @{text "intermediate language"} and
-  @{text "target language"} by means of @{text translation} and
-  @{text serialisation};  for the latter, the serialiser has to observe
-  the structure of the @{text language} itself plus some @{text reserved}
-  keywords which have to be avoided for generated code.
-  However, if you consider @{text adaption} mechanisms, the code generated
-  by the serializer is just the tip of the iceberg:
-
-  \begin{itemize}
-    \item @{text serialisation} can be \emph{parametrised} such that
-      logical entities are mapped to target-specific ones
-      (e.g. target-specific list syntax,
-        see also \secref{sec:adaption_mechanisms})
-    \item Such parametrisations can involve references to a
-      target-specific standard @{text library} (e.g. using
-      the @{text Haskell} @{verbatim Maybe} type instead
-      of the @{text HOL} @{type "option"} type);
-      if such are used, the corresponding identifiers
-      (in our example, @{verbatim Maybe}, @{verbatim Nothing}
-      and @{verbatim Just}) also have to be considered @{text reserved}.
-    \item Even more, the user can enrich the library of the
-      target-language by providing code snippets
-      (\qt{@{text "includes"}}) which are prepended to
-      any generated code (see \secref{sec:include});  this typically
-      also involves further @{text reserved} identifiers.
-  \end{itemize}
-
-  \noindent As figure \ref{fig:adaption} illustrates, all these adaption mechanisms
-  have to act consistently;  it is at the discretion of the user
-  to take care for this.
-*}
-
-subsection {* Common adaption patterns *}
-
-text {*
-  The @{theory HOL} @{theory Main} theory already provides a code
-  generator setup
-  which should be suitable for most applications.  Common extensions
-  and modifications are available by certain theories of the @{text HOL}
-  library; beside being useful in applications, they may serve
-  as a tutorial for customising the code generator setup (see below
-  \secref{sec:adaption_mechanisms}).
-
-  \begin{description}
-
-    \item[@{theory "Code_Integer"}] represents @{text HOL} integers by big
-       integer literals in target languages.
-    \item[@{theory "Code_Char"}] represents @{text HOL} characters by 
-       character literals in target languages.
-    \item[@{theory "Code_Char_chr"}] like @{text "Code_Char"},
-       but also offers treatment of character codes; includes
-       @{theory "Code_Char"}.
-    \item[@{theory "Efficient_Nat"}] \label{eff_nat} implements natural numbers by integers,
-       which in general will result in higher efficiency; pattern
-       matching with @{term "0\<Colon>nat"} / @{const "Suc"}
-       is eliminated;  includes @{theory "Code_Integer"}
-       and @{theory "Code_Index"}.
-    \item[@{theory "Code_Index"}] provides an additional datatype
-       @{typ index} which is mapped to target-language built-in integers.
-       Useful for code setups which involve e.g. indexing of
-       target-language arrays.
-    \item[@{theory "Code_Message"}] provides an additional datatype
-       @{typ message_string} which is isomorphic to strings;
-       @{typ message_string}s are mapped to target-language strings.
-       Useful for code setups which involve e.g. printing (error) messages.
-
-  \end{description}
-
-  \begin{warn}
-    When importing any of these theories, they should form the last
-    items in an import list.  Since these theories adapt the
-    code generator setup in a non-conservative fashion,
-    strange effects may occur otherwise.
-  \end{warn}
-*}
-
-
-subsection {* Parametrising serialisation \label{sec:adaption_mechanisms} *}
-
-text {*
-  Consider the following function and its corresponding
-  SML code:
-*}
-
-primrec %quote in_interval :: "nat \<times> nat \<Rightarrow> nat \<Rightarrow> bool" where
-  "in_interval (k, l) n \<longleftrightarrow> k \<le> n \<and> n \<le> l"
-(*<*)
-code_type %invisible bool
-  (SML)
-code_const %invisible True and False and "op \<and>" and Not
-  (SML and and and)
-(*>*)
-text %quote {*@{code_stmts in_interval (SML)}*}
-
-text {*
-  \noindent Though this is correct code, it is a little bit unsatisfactory:
-  boolean values and operators are materialised as distinguished
-  entities with have nothing to do with the SML-built-in notion
-  of \qt{bool}.  This results in less readable code;
-  additionally, eager evaluation may cause programs to
-  loop or break which would perfectly terminate when
-  the existing SML @{verbatim "bool"} would be used.  To map
-  the HOL @{typ bool} on SML @{verbatim "bool"}, we may use
-  \qn{custom serialisations}:
-*}
-
-code_type %quotett bool
-  (SML "bool")
-code_const %quotett True and False and "op \<and>"
-  (SML "true" and "false" and "_ andalso _")
-
-text {*
-  \noindent The @{command code_type} command takes a type constructor
-  as arguments together with a list of custom serialisations.
-  Each custom serialisation starts with a target language
-  identifier followed by an expression, which during
-  code serialisation is inserted whenever the type constructor
-  would occur.  For constants, @{command code_const} implements
-  the corresponding mechanism.  Each ``@{verbatim "_"}'' in
-  a serialisation expression is treated as a placeholder
-  for the type constructor's (the constant's) arguments.
-*}
-
-text %quote {*@{code_stmts in_interval (SML)}*}
-
-text {*
-  \noindent This still is not perfect: the parentheses
-  around the \qt{andalso} expression are superfluous.
-  Though the serialiser
-  by no means attempts to imitate the rich Isabelle syntax
-  framework, it provides some common idioms, notably
-  associative infixes with precedences which may be used here:
-*}
-
-code_const %quotett "op \<and>"
-  (SML infixl 1 "andalso")
-
-text %quote {*@{code_stmts in_interval (SML)}*}
-
-text {*
-  \noindent The attentive reader may ask how we assert that no generated
-  code will accidentally overwrite.  For this reason the serialiser has
-  an internal table of identifiers which have to be avoided to be used
-  for new declarations.  Initially, this table typically contains the
-  keywords of the target language.  It can be extended manually, thus avoiding
-  accidental overwrites, using the @{command "code_reserved"} command:
-*}
-
-code_reserved %quote "\<SML>" bool true false andalso
-
-text {*
-  \noindent Next, we try to map HOL pairs to SML pairs, using the
-  infix ``@{verbatim "*"}'' type constructor and parentheses:
-*}
-(*<*)
-code_type %invisible *
-  (SML)
-code_const %invisible Pair
-  (SML)
-(*>*)
-code_type %quotett *
-  (SML infix 2 "*")
-code_const %quotett Pair
-  (SML "!((_),/ (_))")
-
-text {*
-  \noindent The initial bang ``@{verbatim "!"}'' tells the serialiser
-  never to put
-  parentheses around the whole expression (they are already present),
-  while the parentheses around argument place holders
-  tell not to put parentheses around the arguments.
-  The slash ``@{verbatim "/"}'' (followed by arbitrary white space)
-  inserts a space which may be used as a break if necessary
-  during pretty printing.
-
-  These examples give a glimpse what mechanisms
-  custom serialisations provide; however their usage
-  requires careful thinking in order not to introduce
-  inconsistencies -- or, in other words:
-  custom serialisations are completely axiomatic.
-
-  A further noteworthy details is that any special
-  character in a custom serialisation may be quoted
-  using ``@{verbatim "'"}''; thus, in
-  ``@{verbatim "fn '_ => _"}'' the first
-  ``@{verbatim "_"}'' is a proper underscore while the
-  second ``@{verbatim "_"}'' is a placeholder.
-*}
-
-
-subsection {* @{text Haskell} serialisation *}
-
-text {*
-  For convenience, the default
-  @{text HOL} setup for @{text Haskell} maps the @{class eq} class to
-  its counterpart in @{text Haskell}, giving custom serialisations
-  for the class @{class eq} (by command @{command code_class}) and its operation
-  @{const HOL.eq}
-*}
-
-code_class %quotett eq
-  (Haskell "Eq")
-
-code_const %quotett "op ="
-  (Haskell infixl 4 "==")
-
-text {*
-  \noindent A problem now occurs whenever a type which
-  is an instance of @{class eq} in @{text HOL} is mapped
-  on a @{text Haskell}-built-in type which is also an instance
-  of @{text Haskell} @{text Eq}:
-*}
-
-typedecl %quote bar
-
-instantiation %quote bar :: eq
-begin
-
-definition %quote "eq_class.eq (x\<Colon>bar) y \<longleftrightarrow> x = y"
-
-instance %quote by default (simp add: eq_bar_def)
-
-end %quote (*<*)
-
-(*>*) code_type %quotett bar
-  (Haskell "Integer")
-
-text {*
-  \noindent The code generator would produce
-  an additional instance, which of course is rejected by the @{text Haskell}
-  compiler.
-  To suppress this additional instance, use
-  @{text "code_instance"}:
-*}
-
-code_instance %quotett bar :: eq
-  (Haskell -)
-
-
-subsection {* Enhancing the target language context \label{sec:include} *}
-
-text {*
-  In rare cases it is necessary to \emph{enrich} the context of a
-  target language;  this is accomplished using the @{command "code_include"}
-  command:
-*}
-
-code_include %quotett Haskell "Errno"
-{*errno i = error ("Error number: " ++ show i)*}
-
-code_reserved %quotett Haskell Errno
-
-text {*
-  \noindent Such named @{text include}s are then prepended to every generated code.
-  Inspect such code in order to find out how @{command "code_include"} behaves
-  with respect to a particular target language.
-*}
-
-end

--- a/doc-src/Codegen/Thy/Further.thy	Fri May 15 15:29:34 2009 +0200
+++ b/doc-src/Codegen/Thy/Further.thy	Fri May 15 15:56:28 2009 +0200
@@ -66,7 +66,7 @@
 text {*
   \noindent The soundness of the @{method eval} method depends crucially 
   on the correctness of the code generator;  this is one of the reasons
-  why you should not use adaption (see \secref{sec:adaption}) frivolously.
+  why you should not use adaptation (see \secref{sec:adaptation}) frivolously.
 *}
 
 subsection {* Code antiquotation *}

--- a/doc-src/Codegen/Thy/Introduction.thy	Fri May 15 15:29:34 2009 +0200
+++ b/doc-src/Codegen/Thy/Introduction.thy	Fri May 15 15:56:28 2009 +0200
@@ -28,8 +28,8 @@
   This manifests in the structure of this tutorial: after a short
   conceptual introduction with an example (\secref{sec:intro}),
   we discuss the generic customisation facilities (\secref{sec:program}).
-  A further section (\secref{sec:adaption}) is dedicated to the matter of
-  \qn{adaption} to specific target language environments.  After some
+  A further section (\secref{sec:adaptation}) is dedicated to the matter of
+  \qn{adaptation} to specific target language environments.  After some
   further issues (\secref{sec:further}) we conclude with an overview
   of some ML programming interfaces (\secref{sec:ml}).
 

--- a/doc-src/Codegen/Thy/ML.thy	Fri May 15 15:29:34 2009 +0200
+++ b/doc-src/Codegen/Thy/ML.thy	Fri May 15 15:56:28 2009 +0200
@@ -25,11 +25,11 @@
   @{index_ML Code.add_eqn: "thm -> theory -> theory"} \\
   @{index_ML Code.del_eqn: "thm -> theory -> theory"} \\
   @{index_ML Code.add_eqnl: "string * (thm * bool) list lazy -> theory -> theory"} \\
-  @{index_ML Code.map_pre: "(simpset -> simpset) -> theory -> theory"} \\
-  @{index_ML Code.map_post: "(simpset -> simpset) -> theory -> theory"} \\
-  @{index_ML Code.add_functrans: "string * (theory -> (thm * bool) list -> (thm * bool) list option)
+  @{index_ML Code_Preproc.map_pre: "(simpset -> simpset) -> theory -> theory"} \\
+  @{index_ML Code_Preproc.map_post: "(simpset -> simpset) -> theory -> theory"} \\
+  @{index_ML Code_Preproc.add_functrans: "string * (theory -> (thm * bool) list -> (thm * bool) list option)
     -> theory -> theory"} \\
-  @{index_ML Code.del_functrans: "string -> theory -> theory"} \\
+  @{index_ML Code_Preproc.del_functrans: "string -> theory -> theory"} \\
   @{index_ML Code.add_datatype: "(string * typ) list -> theory -> theory"} \\
   @{index_ML Code.get_datatype: "theory -> string
     -> (string * sort) list * (string * typ list) list"} \\
@@ -48,10 +48,10 @@
      suspended code equations @{text lthms} for constant
      @{text const} to executable content.
 
-  \item @{ML Code.map_pre}~@{text "f"}~@{text "thy"} changes
+  \item @{ML Code_Preproc.map_pre}~@{text "f"}~@{text "thy"} changes
      the preprocessor simpset.
 
-  \item @{ML Code.add_functrans}~@{text "(name, f)"}~@{text "thy"} adds
+  \item @{ML Code_Preproc.add_functrans}~@{text "(name, f)"}~@{text "thy"} adds
      function transformer @{text f} (named @{text name}) to executable content;
      @{text f} is a transformer of the code equations belonging
      to a certain function definition, depending on the
@@ -59,7 +59,7 @@
      transformation took place;  otherwise, the whole process will be iterated
      with the new code equations.
 
-  \item @{ML Code.del_functrans}~@{text "name"}~@{text "thy"} removes
+  \item @{ML Code_Preproc.del_functrans}~@{text "name"}~@{text "thy"} removes
      function transformer named @{text name} from executable content.
 
   \item @{ML Code.add_datatype}~@{text cs}~@{text thy} adds
@@ -78,20 +78,16 @@
 
 text %mlref {*
   \begin{mldecls}
-  @{index_ML Code_Unit.read_const: "theory -> string -> string"} \\
-  @{index_ML Code_Unit.head_eqn: "theory -> thm -> string * ((string * sort) list * typ)"} \\
-  @{index_ML Code_Unit.rewrite_eqn: "simpset -> thm -> thm"} \\
+  @{index_ML Code.read_const: "theory -> string -> string"} \\
+  @{index_ML Code.rewrite_eqn: "simpset -> thm -> thm"} \\
   \end{mldecls}
 
   \begin{description}
 
-  \item @{ML Code_Unit.read_const}~@{text thy}~@{text s}
+  \item @{ML Code.read_const}~@{text thy}~@{text s}
      reads a constant as a concrete term expression @{text s}.
 
-  \item @{ML Code_Unit.head_eqn}~@{text thy}~@{text thm}
-     extracts the constant and its type from a code equation @{text thm}.
-
-  \item @{ML Code_Unit.rewrite_eqn}~@{text ss}~@{text thm}
+  \item @{ML Code.rewrite_eqn}~@{text ss}~@{text thm}
      rewrites a code equation @{text thm} with a simpset @{text ss};
      only arguments and right hand side are rewritten,
      not the head of the code equation.

--- a/doc-src/Codegen/Thy/Program.thy	Fri May 15 15:29:34 2009 +0200
+++ b/doc-src/Codegen/Thy/Program.thy	Fri May 15 15:56:28 2009 +0200
@@ -323,7 +323,7 @@
 *}
 
 
-subsection {* Equality and wellsortedness *}
+subsection {* Equality *}
 
 text {*
   Surely you have already noticed how equality is treated
@@ -358,60 +358,7 @@
   manually like any other type class.
 
   Though this @{text eq} class is designed to get rarely in
-  the way, a subtlety
-  enters the stage when definitions of overloaded constants
-  are dependent on operational equality.  For example, let
-  us define a lexicographic ordering on tuples
-  (also see theory @{theory Product_ord}):
-*}
-
-instantiation %quote "*" :: (order, order) order
-begin
-
-definition %quote [code del]:
-  "x \<le> y \<longleftrightarrow> fst x < fst y \<or> fst x = fst y \<and> snd x \<le> snd y"
-
-definition %quote [code del]:
-  "x < y \<longleftrightarrow> fst x < fst y \<or> fst x = fst y \<and> snd x < snd y"
-
-instance %quote proof
-qed (auto simp: less_eq_prod_def less_prod_def intro: order_less_trans)
-
-end %quote
-
-lemma %quote order_prod [code]:
-  "(x1 \<Colon> 'a\<Colon>order, y1 \<Colon> 'b\<Colon>order) < (x2, y2) \<longleftrightarrow>
-     x1 < x2 \<or> x1 = x2 \<and> y1 < y2"
-  "(x1 \<Colon> 'a\<Colon>order, y1 \<Colon> 'b\<Colon>order) \<le> (x2, y2) \<longleftrightarrow>
-     x1 < x2 \<or> x1 = x2 \<and> y1 \<le> y2"
-  by (simp_all add: less_prod_def less_eq_prod_def)
-
-text {*
-  \noindent Then code generation will fail.  Why?  The definition
-  of @{term "op \<le>"} depends on equality on both arguments,
-  which are polymorphic and impose an additional @{class eq}
-  class constraint, which the preprocessor does not propagate
-  (for technical reasons).
-
-  The solution is to add @{class eq} explicitly to the first sort arguments in the
-  code theorems:
-*}
-
-lemma %quote order_prod_code [code]:
-  "(x1 \<Colon> 'a\<Colon>{order, eq}, y1 \<Colon> 'b\<Colon>order) < (x2, y2) \<longleftrightarrow>
-     x1 < x2 \<or> x1 = x2 \<and> y1 < y2"
-  "(x1 \<Colon> 'a\<Colon>{order, eq}, y1 \<Colon> 'b\<Colon>order) \<le> (x2, y2) \<longleftrightarrow>
-     x1 < x2 \<or> x1 = x2 \<and> y1 \<le> y2"
-  by (simp_all add: less_prod_def less_eq_prod_def)
-
-text {*
-  \noindent Then code generation succeeds:
-*}
-
-text %quote {*@{code_stmts "op \<le> \<Colon> _ \<times> _ \<Rightarrow> _ \<times> _ \<Rightarrow> bool" (SML)}*}
-
-text {*
-  In some cases, the automatically derived code equations
+  the way, in some cases the automatically derived code equations
   for equality on a particular type may not be appropriate.
   As example, watch the following datatype representing
   monomorphic parametric types (where type constructors

--- a/doc-src/Codegen/Thy/ROOT.ML	Fri May 15 15:29:34 2009 +0200
+++ b/doc-src/Codegen/Thy/ROOT.ML	Fri May 15 15:56:28 2009 +0200
@@ -4,6 +4,6 @@
 
 use_thy "Introduction";
 use_thy "Program";
-use_thy "Adaption";
+use_thy "Adaptation";
 use_thy "Further";
 use_thy "ML";

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/doc-src/Codegen/Thy/document/Adaptation.tex	Fri May 15 15:56:28 2009 +0200
@@ -0,0 +1,642 @@
+%
+\begin{isabellebody}%
+\def\isabellecontext{Adaptation}%
+%
+\isadelimtheory
+%
+\endisadelimtheory
+%
+\isatagtheory
+\isacommand{theory}\isamarkupfalse%
+\ Adaptation\isanewline
+\isakeyword{imports}\ Setup\isanewline
+\isakeyword{begin}%
+\endisatagtheory
+{\isafoldtheory}%
+%
+\isadelimtheory
+\isanewline
+%
+\endisadelimtheory
+%
+\isadeliminvisible
+\isanewline
+%
+\endisadeliminvisible
+%
+\isataginvisible
+\isacommand{setup}\isamarkupfalse%
+\ {\isacharverbatimopen}\ Code{\isacharunderscore}Target{\isachardot}extend{\isacharunderscore}target\ {\isacharparenleft}{\isachardoublequote}{\isasymSML}{\isachardoublequote}{\isacharcomma}\ {\isacharparenleft}{\isachardoublequote}SML{\isachardoublequote}{\isacharcomma}\ K\ I{\isacharparenright}{\isacharparenright}\ {\isacharverbatimclose}%
+\endisataginvisible
+{\isafoldinvisible}%
+%
+\isadeliminvisible
+%
+\endisadeliminvisible
+%
+\isamarkupsection{Adaptation to target languages \label{sec:adaptation}%
+}
+\isamarkuptrue%
+%
+\isamarkupsubsection{Adapting code generation%
+}
+\isamarkuptrue%
+%
+\begin{isamarkuptext}%
+The aspects of code generation introduced so far have two aspects
+  in common:
+
+  \begin{itemize}
+    \item They act uniformly, without reference to a specific
+       target language.
+    \item They are \emph{safe} in the sense that as long as you trust
+       the code generator meta theory and implementation, you cannot
+       produce programs that yield results which are not derivable
+       in the logic.
+  \end{itemize}
+
+  \noindent In this section we will introduce means to \emph{adapt} the serialiser
+  to a specific target language, i.e.~to print program fragments
+  in a way which accommodates \qt{already existing} ingredients of
+  a target language environment, for three reasons:
+
+  \begin{itemize}
+    \item improving readability and aesthetics of generated code
+    \item gaining efficiency
+    \item interface with language parts which have no direct counterpart
+      in \isa{HOL} (say, imperative data structures)
+  \end{itemize}
+
+  \noindent Generally, you should avoid using those features yourself
+  \emph{at any cost}:
+
+  \begin{itemize}
+    \item The safe configuration methods act uniformly on every target language,
+      whereas for adaptation you have to treat each target language separate.
+    \item Application is extremely tedious since there is no abstraction
+      which would allow for a static check, making it easy to produce garbage.
+    \item More or less subtle errors can be introduced unconsciously.
+  \end{itemize}
+
+  \noindent However, even if you ought refrain from setting up adaptation
+  yourself, already the \isa{HOL} comes with some reasonable default
+  adaptations (say, using target language list syntax).  There also some
+  common adaptation cases which you can setup by importing particular
+  library theories.  In order to understand these, we provide some clues here;
+  these however are not supposed to replace a careful study of the sources.%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isamarkupsubsection{The adaptation principle%
+}
+\isamarkuptrue%
+%
+\begin{isamarkuptext}%
+Figure \ref{fig:adaptation} illustrates what \qt{adaptation} is conceptually
+  supposed to be:
+
+  \begin{figure}[here]
+    \includegraphics{adaptation}
+    \caption{The adaptation principle}
+    \label{fig:adaptation}
+  \end{figure}
+
+  \noindent In the tame view, code generation acts as broker between
+  \isa{logic}, \isa{intermediate\ language} and
+  \isa{target\ language} by means of \isa{translation} and
+  \isa{serialisation};  for the latter, the serialiser has to observe
+  the structure of the \isa{language} itself plus some \isa{reserved}
+  keywords which have to be avoided for generated code.
+  However, if you consider \isa{adaptation} mechanisms, the code generated
+  by the serializer is just the tip of the iceberg:
+
+  \begin{itemize}
+    \item \isa{serialisation} can be \emph{parametrised} such that
+      logical entities are mapped to target-specific ones
+      (e.g. target-specific list syntax,
+        see also \secref{sec:adaptation_mechanisms})
+    \item Such parametrisations can involve references to a
+      target-specific standard \isa{library} (e.g. using
+      the \isa{Haskell} \verb|Maybe| type instead
+      of the \isa{HOL} \isa{option} type);
+      if such are used, the corresponding identifiers
+      (in our example, \verb|Maybe|, \verb|Nothing|
+      and \verb|Just|) also have to be considered \isa{reserved}.
+    \item Even more, the user can enrich the library of the
+      target-language by providing code snippets
+      (\qt{\isa{includes}}) which are prepended to
+      any generated code (see \secref{sec:include});  this typically
+      also involves further \isa{reserved} identifiers.
+  \end{itemize}
+
+  \noindent As figure \ref{fig:adaptation} illustrates, all these adaptation mechanisms
+  have to act consistently;  it is at the discretion of the user
+  to take care for this.%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isamarkupsubsection{Common adaptation patterns%
+}
+\isamarkuptrue%
+%
+\begin{isamarkuptext}%
+The \hyperlink{theory.HOL}{\mbox{\isa{HOL}}} \hyperlink{theory.Main}{\mbox{\isa{Main}}} theory already provides a code
+  generator setup
+  which should be suitable for most applications.  Common extensions
+  and modifications are available by certain theories of the \isa{HOL}
+  library; beside being useful in applications, they may serve
+  as a tutorial for customising the code generator setup (see below
+  \secref{sec:adaptation_mechanisms}).
+
+  \begin{description}
+
+    \item[\hyperlink{theory.Code-Integer}{\mbox{\isa{Code{\isacharunderscore}Integer}}}] represents \isa{HOL} integers by big
+       integer literals in target languages.
+    \item[\hyperlink{theory.Code-Char}{\mbox{\isa{Code{\isacharunderscore}Char}}}] represents \isa{HOL} characters by 
+       character literals in target languages.
+    \item[\hyperlink{theory.Code-Char-chr}{\mbox{\isa{Code{\isacharunderscore}Char{\isacharunderscore}chr}}}] like \isa{Code{\isacharunderscore}Char},
+       but also offers treatment of character codes; includes
+       \hyperlink{theory.Code-Char}{\mbox{\isa{Code{\isacharunderscore}Char}}}.
+    \item[\hyperlink{theory.Efficient-Nat}{\mbox{\isa{Efficient{\isacharunderscore}Nat}}}] \label{eff_nat} implements natural numbers by integers,
+       which in general will result in higher efficiency; pattern
+       matching with \isa{{\isadigit{0}}} / \isa{Suc}
+       is eliminated;  includes \hyperlink{theory.Code-Integer}{\mbox{\isa{Code{\isacharunderscore}Integer}}}
+       and \hyperlink{theory.Code-Index}{\mbox{\isa{Code{\isacharunderscore}Index}}}.
+    \item[\hyperlink{theory.Code-Index}{\mbox{\isa{Code{\isacharunderscore}Index}}}] provides an additional datatype
+       \isa{index} which is mapped to target-language built-in integers.
+       Useful for code setups which involve e.g. indexing of
+       target-language arrays.
+    \item[\hyperlink{theory.String}{\mbox{\isa{String}}}] provides an additional datatype
+       \isa{message{\isacharunderscore}string} which is isomorphic to strings;
+       \isa{message{\isacharunderscore}string}s are mapped to target-language strings.
+       Useful for code setups which involve e.g. printing (error) messages.
+
+  \end{description}
+
+  \begin{warn}
+    When importing any of these theories, they should form the last
+    items in an import list.  Since these theories adapt the
+    code generator setup in a non-conservative fashion,
+    strange effects may occur otherwise.
+  \end{warn}%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isamarkupsubsection{Parametrising serialisation \label{sec:adaptation_mechanisms}%
+}
+\isamarkuptrue%
+%
+\begin{isamarkuptext}%
+Consider the following function and its corresponding
+  SML code:%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\isatagquote
+\isacommand{primrec}\isamarkupfalse%
+\ in{\isacharunderscore}interval\ {\isacharcolon}{\isacharcolon}\ {\isachardoublequoteopen}nat\ {\isasymtimes}\ nat\ {\isasymRightarrow}\ nat\ {\isasymRightarrow}\ bool{\isachardoublequoteclose}\ \isakeyword{where}\isanewline
+\ \ {\isachardoublequoteopen}in{\isacharunderscore}interval\ {\isacharparenleft}k{\isacharcomma}\ l{\isacharparenright}\ n\ {\isasymlongleftrightarrow}\ k\ {\isasymle}\ n\ {\isasymand}\ n\ {\isasymle}\ l{\isachardoublequoteclose}%
+\endisatagquote
+{\isafoldquote}%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\isadeliminvisible
+%
+\endisadeliminvisible
+%
+\isataginvisible
+%
+\endisataginvisible
+{\isafoldinvisible}%
+%
+\isadeliminvisible
+%
+\endisadeliminvisible
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\isatagquote
+%
+\begin{isamarkuptext}%
+\isatypewriter%
+\noindent%
+\hspace*{0pt}structure Example = \\
+\hspace*{0pt}struct\\
+\hspace*{0pt}\\
+\hspace*{0pt}datatype nat = Zero{\char95}nat | Suc of nat;\\
+\hspace*{0pt}\\
+\hspace*{0pt}datatype boola = True | False;\\
+\hspace*{0pt}\\
+\hspace*{0pt}fun anda x True = x\\
+\hspace*{0pt} ~| anda x False = False\\
+\hspace*{0pt} ~| anda True x = x\\
+\hspace*{0pt} ~| anda False x = False;\\
+\hspace*{0pt}\\
+\hspace*{0pt}fun less{\char95}nat m (Suc n) = less{\char95}eq{\char95}nat m n\\
+\hspace*{0pt} ~| less{\char95}nat n Zero{\char95}nat = False\\
+\hspace*{0pt}and less{\char95}eq{\char95}nat (Suc m) n = less{\char95}nat m n\\
+\hspace*{0pt} ~| less{\char95}eq{\char95}nat Zero{\char95}nat n = True;\\
+\hspace*{0pt}\\
+\hspace*{0pt}fun in{\char95}interval (k,~l) n = anda (less{\char95}eq{\char95}nat k n) (less{\char95}eq{\char95}nat n l);\\
+\hspace*{0pt}\\
+\hspace*{0pt}end;~(*struct Example*)%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\endisatagquote
+{\isafoldquote}%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\begin{isamarkuptext}%
+\noindent Though this is correct code, it is a little bit unsatisfactory:
+  boolean values and operators are materialised as distinguished
+  entities with have nothing to do with the SML-built-in notion
+  of \qt{bool}.  This results in less readable code;
+  additionally, eager evaluation may cause programs to
+  loop or break which would perfectly terminate when
+  the existing SML \verb|bool| would be used.  To map
+  the HOL \isa{bool} on SML \verb|bool|, we may use
+  \qn{custom serialisations}:%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isadelimquotett
+%
+\endisadelimquotett
+%
+\isatagquotett
+\isacommand{code{\isacharunderscore}type}\isamarkupfalse%
+\ bool\isanewline
+\ \ {\isacharparenleft}SML\ {\isachardoublequoteopen}bool{\isachardoublequoteclose}{\isacharparenright}\isanewline
+\isacommand{code{\isacharunderscore}const}\isamarkupfalse%
+\ True\ \isakeyword{and}\ False\ \isakeyword{and}\ {\isachardoublequoteopen}op\ {\isasymand}{\isachardoublequoteclose}\isanewline
+\ \ {\isacharparenleft}SML\ {\isachardoublequoteopen}true{\isachardoublequoteclose}\ \isakeyword{and}\ {\isachardoublequoteopen}false{\isachardoublequoteclose}\ \isakeyword{and}\ {\isachardoublequoteopen}{\isacharunderscore}\ andalso\ {\isacharunderscore}{\isachardoublequoteclose}{\isacharparenright}%
+\endisatagquotett
+{\isafoldquotett}%
+%
+\isadelimquotett
+%
+\endisadelimquotett
+%
+\begin{isamarkuptext}%
+\noindent The \hyperlink{command.code-type}{\mbox{\isa{\isacommand{code{\isacharunderscore}type}}}} command takes a type constructor
+  as arguments together with a list of custom serialisations.
+  Each custom serialisation starts with a target language
+  identifier followed by an expression, which during
+  code serialisation is inserted whenever the type constructor
+  would occur.  For constants, \hyperlink{command.code-const}{\mbox{\isa{\isacommand{code{\isacharunderscore}const}}}} implements
+  the corresponding mechanism.  Each ``\verb|_|'' in
+  a serialisation expression is treated as a placeholder
+  for the type constructor's (the constant's) arguments.%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\isatagquote
+%
+\begin{isamarkuptext}%
+\isatypewriter%
+\noindent%
+\hspace*{0pt}structure Example = \\
+\hspace*{0pt}struct\\
+\hspace*{0pt}\\
+\hspace*{0pt}datatype nat = Zero{\char95}nat | Suc of nat;\\
+\hspace*{0pt}\\
+\hspace*{0pt}fun less{\char95}nat m (Suc n) = less{\char95}eq{\char95}nat m n\\
+\hspace*{0pt} ~| less{\char95}nat n Zero{\char95}nat = false\\
+\hspace*{0pt}and less{\char95}eq{\char95}nat (Suc m) n = less{\char95}nat m n\\
+\hspace*{0pt} ~| less{\char95}eq{\char95}nat Zero{\char95}nat n = true;\\
+\hspace*{0pt}\\
+\hspace*{0pt}fun in{\char95}interval (k,~l) n = (less{\char95}eq{\char95}nat k n) andalso (less{\char95}eq{\char95}nat n l);\\
+\hspace*{0pt}\\
+\hspace*{0pt}end;~(*struct Example*)%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\endisatagquote
+{\isafoldquote}%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\begin{isamarkuptext}%
+\noindent This still is not perfect: the parentheses
+  around the \qt{andalso} expression are superfluous.
+  Though the serialiser
+  by no means attempts to imitate the rich Isabelle syntax
+  framework, it provides some common idioms, notably
+  associative infixes with precedences which may be used here:%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isadelimquotett
+%
+\endisadelimquotett
+%
+\isatagquotett
+\isacommand{code{\isacharunderscore}const}\isamarkupfalse%
+\ {\isachardoublequoteopen}op\ {\isasymand}{\isachardoublequoteclose}\isanewline
+\ \ {\isacharparenleft}SML\ \isakeyword{infixl}\ {\isadigit{1}}\ {\isachardoublequoteopen}andalso{\isachardoublequoteclose}{\isacharparenright}%
+\endisatagquotett
+{\isafoldquotett}%
+%
+\isadelimquotett
+%
+\endisadelimquotett
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\isatagquote
+%
+\begin{isamarkuptext}%
+\isatypewriter%
+\noindent%
+\hspace*{0pt}structure Example = \\
+\hspace*{0pt}struct\\
+\hspace*{0pt}\\
+\hspace*{0pt}datatype nat = Zero{\char95}nat | Suc of nat;\\
+\hspace*{0pt}\\
+\hspace*{0pt}fun less{\char95}nat m (Suc n) = less{\char95}eq{\char95}nat m n\\
+\hspace*{0pt} ~| less{\char95}nat n Zero{\char95}nat = false\\
+\hspace*{0pt}and less{\char95}eq{\char95}nat (Suc m) n = less{\char95}nat m n\\
+\hspace*{0pt} ~| less{\char95}eq{\char95}nat Zero{\char95}nat n = true;\\
+\hspace*{0pt}\\
+\hspace*{0pt}fun in{\char95}interval (k,~l) n = less{\char95}eq{\char95}nat k n andalso less{\char95}eq{\char95}nat n l;\\
+\hspace*{0pt}\\
+\hspace*{0pt}end;~(*struct Example*)%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\endisatagquote
+{\isafoldquote}%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\begin{isamarkuptext}%
+\noindent The attentive reader may ask how we assert that no generated
+  code will accidentally overwrite.  For this reason the serialiser has
+  an internal table of identifiers which have to be avoided to be used
+  for new declarations.  Initially, this table typically contains the
+  keywords of the target language.  It can be extended manually, thus avoiding
+  accidental overwrites, using the \hyperlink{command.code-reserved}{\mbox{\isa{\isacommand{code{\isacharunderscore}reserved}}}} command:%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\isatagquote
+\isacommand{code{\isacharunderscore}reserved}\isamarkupfalse%
+\ {\isachardoublequoteopen}{\isasymSML}{\isachardoublequoteclose}\ bool\ true\ false\ andalso%
+\endisatagquote
+{\isafoldquote}%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\begin{isamarkuptext}%
+\noindent Next, we try to map HOL pairs to SML pairs, using the
+  infix ``\verb|*|'' type constructor and parentheses:%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isadeliminvisible
+%
+\endisadeliminvisible
+%
+\isataginvisible
+%
+\endisataginvisible
+{\isafoldinvisible}%
+%
+\isadeliminvisible
+%
+\endisadeliminvisible
+%
+\isadelimquotett
+%
+\endisadelimquotett
+%
+\isatagquotett
+\isacommand{code{\isacharunderscore}type}\isamarkupfalse%
+\ {\isacharasterisk}\isanewline
+\ \ {\isacharparenleft}SML\ \isakeyword{infix}\ {\isadigit{2}}\ {\isachardoublequoteopen}{\isacharasterisk}{\isachardoublequoteclose}{\isacharparenright}\isanewline
+\isacommand{code{\isacharunderscore}const}\isamarkupfalse%
+\ Pair\isanewline
+\ \ {\isacharparenleft}SML\ {\isachardoublequoteopen}{\isacharbang}{\isacharparenleft}{\isacharparenleft}{\isacharunderscore}{\isacharparenright}{\isacharcomma}{\isacharslash}\ {\isacharparenleft}{\isacharunderscore}{\isacharparenright}{\isacharparenright}{\isachardoublequoteclose}{\isacharparenright}%
+\endisatagquotett
+{\isafoldquotett}%
+%
+\isadelimquotett
+%
+\endisadelimquotett
+%
+\begin{isamarkuptext}%
+\noindent The initial bang ``\verb|!|'' tells the serialiser
+  never to put
+  parentheses around the whole expression (they are already present),
+  while the parentheses around argument place holders
+  tell not to put parentheses around the arguments.
+  The slash ``\verb|/|'' (followed by arbitrary white space)
+  inserts a space which may be used as a break if necessary
+  during pretty printing.
+
+  These examples give a glimpse what mechanisms
+  custom serialisations provide; however their usage
+  requires careful thinking in order not to introduce
+  inconsistencies -- or, in other words:
+  custom serialisations are completely axiomatic.
+
+  A further noteworthy details is that any special
+  character in a custom serialisation may be quoted
+  using ``\verb|'|''; thus, in
+  ``\verb|fn '_ => _|'' the first
+  ``\verb|_|'' is a proper underscore while the
+  second ``\verb|_|'' is a placeholder.%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isamarkupsubsection{\isa{Haskell} serialisation%
+}
+\isamarkuptrue%
+%
+\begin{isamarkuptext}%
+For convenience, the default
+  \isa{HOL} setup for \isa{Haskell} maps the \isa{eq} class to
+  its counterpart in \isa{Haskell}, giving custom serialisations
+  for the class \isa{eq} (by command \hyperlink{command.code-class}{\mbox{\isa{\isacommand{code{\isacharunderscore}class}}}}) and its operation
+  \isa{eq{\isacharunderscore}class{\isachardot}eq}%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isadelimquotett
+%
+\endisadelimquotett
+%
+\isatagquotett
+\isacommand{code{\isacharunderscore}class}\isamarkupfalse%
+\ eq\isanewline
+\ \ {\isacharparenleft}Haskell\ {\isachardoublequoteopen}Eq{\isachardoublequoteclose}{\isacharparenright}\isanewline
+\isanewline
+\isacommand{code{\isacharunderscore}const}\isamarkupfalse%
+\ {\isachardoublequoteopen}op\ {\isacharequal}{\isachardoublequoteclose}\isanewline
+\ \ {\isacharparenleft}Haskell\ \isakeyword{infixl}\ {\isadigit{4}}\ {\isachardoublequoteopen}{\isacharequal}{\isacharequal}{\isachardoublequoteclose}{\isacharparenright}%
+\endisatagquotett
+{\isafoldquotett}%
+%
+\isadelimquotett
+%
+\endisadelimquotett
+%
+\begin{isamarkuptext}%
+\noindent A problem now occurs whenever a type which
+  is an instance of \isa{eq} in \isa{HOL} is mapped
+  on a \isa{Haskell}-built-in type which is also an instance
+  of \isa{Haskell} \isa{Eq}:%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\isatagquote
+\isacommand{typedecl}\isamarkupfalse%
+\ bar\isanewline
+\isanewline
+\isacommand{instantiation}\isamarkupfalse%
+\ bar\ {\isacharcolon}{\isacharcolon}\ eq\isanewline
+\isakeyword{begin}\isanewline
+\isanewline
+\isacommand{definition}\isamarkupfalse%
+\ {\isachardoublequoteopen}eq{\isacharunderscore}class{\isachardot}eq\ {\isacharparenleft}x{\isasymColon}bar{\isacharparenright}\ y\ {\isasymlongleftrightarrow}\ x\ {\isacharequal}\ y{\isachardoublequoteclose}\isanewline
+\isanewline
+\isacommand{instance}\isamarkupfalse%
+\ \isacommand{by}\isamarkupfalse%
+\ default\ {\isacharparenleft}simp\ add{\isacharcolon}\ eq{\isacharunderscore}bar{\isacharunderscore}def{\isacharparenright}\isanewline
+\isanewline
+\isacommand{end}\isamarkupfalse%
+%
+\endisatagquote
+{\isafoldquote}%
+%
+\isadelimquote
+%
+\endisadelimquote
+%
+\isadelimquotett
+\ %
+\endisadelimquotett
+%
+\isatagquotett
+\isacommand{code{\isacharunderscore}type}\isamarkupfalse%
+\ bar\isanewline
+\ \ {\isacharparenleft}Haskell\ {\isachardoublequoteopen}Integer{\isachardoublequoteclose}{\isacharparenright}%
+\endisatagquotett
+{\isafoldquotett}%
+%
+\isadelimquotett
+%
+\endisadelimquotett
+%
+\begin{isamarkuptext}%
+\noindent The code generator would produce
+  an additional instance, which of course is rejected by the \isa{Haskell}
+  compiler.
+  To suppress this additional instance, use
+  \isa{code{\isacharunderscore}instance}:%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isadelimquotett
+%
+\endisadelimquotett
+%
+\isatagquotett
+\isacommand{code{\isacharunderscore}instance}\isamarkupfalse%
+\ bar\ {\isacharcolon}{\isacharcolon}\ eq\isanewline
+\ \ {\isacharparenleft}Haskell\ {\isacharminus}{\isacharparenright}%
+\endisatagquotett
+{\isafoldquotett}%
+%
+\isadelimquotett
+%
+\endisadelimquotett
+%
+\isamarkupsubsection{Enhancing the target language context \label{sec:include}%
+}
+\isamarkuptrue%
+%
+\begin{isamarkuptext}%
+In rare cases it is necessary to \emph{enrich} the context of a
+  target language;  this is accomplished using the \hyperlink{command.code-include}{\mbox{\isa{\isacommand{code{\isacharunderscore}include}}}}
+  command:%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isadelimquotett
+%
+\endisadelimquotett
+%
+\isatagquotett
+\isacommand{code{\isacharunderscore}include}\isamarkupfalse%
+\ Haskell\ {\isachardoublequoteopen}Errno{\isachardoublequoteclose}\isanewline
+{\isacharverbatimopen}errno\ i\ {\isacharequal}\ error\ {\isacharparenleft}{\isachardoublequote}Error\ number{\isacharcolon}\ {\isachardoublequote}\ {\isacharplus}{\isacharplus}\ show\ i{\isacharparenright}{\isacharverbatimclose}\isanewline
+\isanewline
+\isacommand{code{\isacharunderscore}reserved}\isamarkupfalse%
+\ Haskell\ Errno%
+\endisatagquotett
+{\isafoldquotett}%
+%
+\isadelimquotett
+%
+\endisadelimquotett
+%
+\begin{isamarkuptext}%
+\noindent Such named \isa{include}s are then prepended to every generated code.
+  Inspect such code in order to find out how \hyperlink{command.code-include}{\mbox{\isa{\isacommand{code{\isacharunderscore}include}}}} behaves
+  with respect to a particular target language.%
+\end{isamarkuptext}%
+\isamarkuptrue%
+%
+\isadelimtheory
+%
+\endisadelimtheory
+%
+\isatagtheory
+\isacommand{end}\isamarkupfalse%
+%
+\endisatagtheory
+{\isafoldtheory}%
+%
+\isadelimtheory
+%
+\endisadelimtheory
+\isanewline
+\end{isabellebody}%
+%%% Local Variables:
+%%% mode: latex
+%%% TeX-master: "root"
+%%% End:

--- a/doc-src/Codegen/Thy/document/Adaption.tex	Fri May 15 15:29:34 2009 +0200
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,642 +0,0 @@
-%
-\begin{isabellebody}%
-\def\isabellecontext{Adaption}%
-%
-\isadelimtheory
-%
-\endisadelimtheory
-%
-\isatagtheory
-\isacommand{theory}\isamarkupfalse%
-\ Adaption\isanewline
-\isakeyword{imports}\ Setup\isanewline
-\isakeyword{begin}%
-\endisatagtheory
-{\isafoldtheory}%
-%
-\isadelimtheory
-\isanewline
-%
-\endisadelimtheory
-%
-\isadeliminvisible
-\isanewline
-%
-\endisadeliminvisible
-%
-\isataginvisible
-\isacommand{setup}\isamarkupfalse%
-\ {\isacharverbatimopen}\ Code{\isacharunderscore}Target{\isachardot}extend{\isacharunderscore}target\ {\isacharparenleft}{\isachardoublequote}{\isasymSML}{\isachardoublequote}{\isacharcomma}\ {\isacharparenleft}{\isachardoublequote}SML{\isachardoublequote}{\isacharcomma}\ K\ I{\isacharparenright}{\isacharparenright}\ {\isacharverbatimclose}%
-\endisataginvisible
-{\isafoldinvisible}%
-%
-\isadeliminvisible
-%
-\endisadeliminvisible
-%
-\isamarkupsection{Adaption to target languages \label{sec:adaption}%
-}
-\isamarkuptrue%
-%
-\isamarkupsubsection{Adapting code generation%
-}
-\isamarkuptrue%
-%
-\begin{isamarkuptext}%
-The aspects of code generation introduced so far have two aspects
-  in common:
-
-  \begin{itemize}
-    \item They act uniformly, without reference to a specific
-       target language.
-    \item They are \emph{safe} in the sense that as long as you trust
-       the code generator meta theory and implementation, you cannot
-       produce programs that yield results which are not derivable
-       in the logic.
-  \end{itemize}
-
-  \noindent In this section we will introduce means to \emph{adapt} the serialiser
-  to a specific target language, i.e.~to print program fragments
-  in a way which accommodates \qt{already existing} ingredients of
-  a target language environment, for three reasons:
-
-  \begin{itemize}
-    \item improving readability and aesthetics of generated code
-    \item gaining efficiency
-    \item interface with language parts which have no direct counterpart
-      in \isa{HOL} (say, imperative data structures)
-  \end{itemize}
-
-  \noindent Generally, you should avoid using those features yourself
-  \emph{at any cost}:
-
-  \begin{itemize}
-    \item The safe configuration methods act uniformly on every target language,
-      whereas for adaption you have to treat each target language separate.
-    \item Application is extremely tedious since there is no abstraction
-      which would allow for a static check, making it easy to produce garbage.
-    \item More or less subtle errors can be introduced unconsciously.
-  \end{itemize}
-
-  \noindent However, even if you ought refrain from setting up adaption
-  yourself, already the \isa{HOL} comes with some reasonable default
-  adaptions (say, using target language list syntax).  There also some
-  common adaption cases which you can setup by importing particular
-  library theories.  In order to understand these, we provide some clues here;
-  these however are not supposed to replace a careful study of the sources.%
-\end{isamarkuptext}%
-\isamarkuptrue%
-%
-\isamarkupsubsection{The adaption principle%
-}
-\isamarkuptrue%
-%
-\begin{isamarkuptext}%
-Figure \ref{fig:adaption} illustrates what \qt{adaption} is conceptually
-  supposed to be:
-
-  \begin{figure}[here]
-    \includegraphics{adaption}
-    \caption{The adaption principle}
-    \label{fig:adaption}
-  \end{figure}
-
-  \noindent In the tame view, code generation acts as broker between
-  \isa{logic}, \isa{intermediate\ language} and
-  \isa{target\ language} by means of \isa{translation} and
-  \isa{serialisation};  for the latter, the serialiser has to observe
-  the structure of the \isa{language} itself plus some \isa{reserved}
-  keywords which have to be avoided for generated code.
-  However, if you consider \isa{adaption} mechanisms, the code generated
-  by the serializer is just the tip of the iceberg:
-
-  \begin{itemize}
-    \item \isa{serialisation} can be \emph{parametrised} such that
-      logical entities are mapped to target-specific ones
-      (e.g. target-specific list syntax,
-        see also \secref{sec:adaption_mechanisms})
-    \item Such parametrisations can involve references to a
-      target-specific standard \isa{library} (e.g. using
-      the \isa{Haskell} \verb|Maybe| type instead
-      of the \isa{HOL} \isa{option} type);
-      if such are used, the corresponding identifiers
-      (in our example, \verb|Maybe|, \verb|Nothing|
-      and \verb|Just|) also have to be considered \isa{reserved}.
-    \item Even more, the user can enrich the library of the
-      target-language by providing code snippets
-      (\qt{\isa{includes}}) which are prepended to
-      any generated code (see \secref{sec:include});  this typically
-      also involves further \isa{reserved} identifiers.
-  \end{itemize}
-
-  \noindent As figure \ref{fig:adaption} illustrates, all these adaption mechanisms
-  have to act consistently;  it is at the discretion of the user
-  to take care for this.%
-\end{isamarkuptext}%
-\isamarkuptrue%
-%
-\isamarkupsubsection{Common adaption patterns%
-}
-\isamarkuptrue%
-%
-\begin{isamarkuptext}%
-The \hyperlink{theory.HOL}{\mbox{\isa{HOL}}} \hyperlink{theory.Main}{\mbox{\isa{Main}}} theory already provides a code
-  generator setup
-  which should be suitable for most applications.  Common extensions
-  and modifications are available by certain theories of the \isa{HOL}
-  library; beside being useful in applications, they may serve
-  as a tutorial for customising the code generator setup (see below
-  \secref{sec:adaption_mechanisms}).
-
-  \begin{description}
-
-    \item[\hyperlink{theory.Code-Integer}{\mbox{\isa{Code{\isacharunderscore}Integer}}}] represents \isa{HOL} integers by big
-       integer literals in target languages.
-    \item[\hyperlink{theory.Code-Char}{\mbox{\isa{Code{\isacharunderscore}Char}}}] represents \isa{HOL} characters by 
-       character literals in target languages.
-    \item[\hyperlink{theory.Code-Char-chr}{\mbox{\isa{Code{\isacharunderscore}Char{\isacharunderscore}chr}}}] like \isa{Code{\isacharunderscore}Char},
-       but also offers treatment of character codes; includes
-       \hyperlink{theory.Code-Char}{\mbox{\isa{Code{\isacharunderscore}Char}}}.
-    \item[\hyperlink{theory.Efficient-Nat}{\mbox{\isa{Efficient{\isacharunderscore}Nat}}}] \label{eff_nat} implements natural numbers by integers,
-       which in general will result in higher efficiency; pattern
-       matching with \isa{{\isadigit{0}}} / \isa{Suc}
-       is eliminated;  includes \hyperlink{theory.Code-Integer}{\mbox{\isa{Code{\isacharunderscore}Integer}}}
-       and \hyperlink{theory.Code-Index}{\mbox{\isa{Code{\isacharunderscore}Index}}}.
-    \item[\hyperlink{theory.Code-Index}{\mbox{\isa{Code{\isacharunderscore}Index}}}] provides an additional datatype
-       \isa{index} which is mapped to target-language built-in integers.
-       Useful for code setups which involve e.g. indexing of
-       target-language arrays.
-    \item[\hyperlink{theory.Code-Message}{\mbox{\isa{Code{\isacharunderscore}Message}}}] provides an additional datatype
-       \isa{message{\isacharunderscore}string} which is isomorphic to strings;
-       \isa{message{\isacharunderscore}string}s are mapped to target-language strings.
-       Useful for code setups which involve e.g. printing (error) messages.
-
-  \end{description}
-
-  \begin{warn}
-    When importing any of these theories, they should form the last
-    items in an import list.  Since these theories adapt the
-    code generator setup in a non-conservative fashion,
-    strange effects may occur otherwise.
-  \end{warn}%
-\end{isamarkuptext}%
-\isamarkuptrue%
-%
-\isamarkupsubsection{Parametrising serialisation \label{sec:adaption_mechanisms}%
-}
-\isamarkuptrue%
-%
-\begin{isamarkuptext}%
-Consider the following function and its corresponding
-  SML code:%
-\end{isamarkuptext}%
-\isamarkuptrue%
-%
-\isadelimquote
-%
-\endisadelimquote
-%
-\isatagquote
-\isacommand{primrec}\isamarkupfalse%
-\ in{\isacharunderscore}interval\ {\isacharcolon}{\isacharcolon}\ {\isachardoublequoteopen}nat\ {\isasymtimes}\ nat\ {\isasymRightarrow}\ nat\ {\isasymRightarrow}\ bool{\isachardoublequoteclose}\ \isakeyword{where}\isanewline
-\ \ {\isachardoublequoteopen}in{\isacharunderscore}interval\ {\isacharparenleft}k{\isacharcomma}\ l{\isacharparenright}\ n\ {\isasymlongleftrightarrow}\ k\ {\isasymle}\ n\ {\isasymand}\ n\ {\isasymle}\ l{\isachardoublequoteclose}%
-\endisatagquote
-{\isafoldquote}%
-%
-\isadelimquote
-%
-\endisadelimquote
-%
-\isadeliminvisible
-%
-\endisadeliminvisible
-%
-\isataginvisible
-%
-\endisataginvisible
-{\isafoldinvisible}%
-%
-\isadeliminvisible
-%
-\endisadeliminvisible
-%
-\isadelimquote
-%
-\endisadelimquote
-%
-\isatagquote
-%
-\begin{isamarkuptext}%
-\isatypewriter%
-\noindent%
-\hspace*{0pt}structure Example = \\
-\hspace*{0pt}struct\\
-\hspace*{0pt}\\
-\hspace*{0pt}datatype nat = Zero{\char95}nat | Suc of nat;\\
-\hspace*{0pt}\\
-\hspace*{0pt}datatype boola = True | False;\\
-\hspace*{0pt}\\
-\hspace*{0pt}fun anda x True = x\\
-\hspace*{0pt} ~| anda x False = False\\
-\hspace*{0pt} ~| anda True x = x\\
-\hspace*{0pt} ~| anda False x = False;\\
-\hspace*{0pt}\\
-\hspace*{0pt}fun less{\char95}nat m (Suc n) = less{\char95}eq{\char95}nat m n\\
-\hspace*{0pt} ~| less{\char95}nat n Zero{\char95}nat = False\\
-\hspace*{0pt}and less{\char95}eq{\char95}nat (Suc m) n = less{\char95}nat m n\\
-\hspace*{0pt} ~| less{\char95}eq{\char95}nat Zero{\char95}nat n = True;\\
-\hspace*{0pt}\\
-\hspace*{0pt}fun in{\char95}interval (k,~l) n = anda (less{\char95}eq{\char95}nat k n) (less{\char95}eq{\char95}nat n l);\\
-\hspace*{0pt}\\
-\hspace*{0pt}end;~(*struct Example*)%
-\end{isamarkuptext}%
-\isamarkuptrue%
-%
-\endisatagquote
-{\isafoldquote}%
-%
-\isadelimquote
-%
-\endisadelimquote
-%
-\begin{isamarkuptext}%
-\noindent Though this is correct code, it is a little bit unsatisfactory:
-  boolean values and operators are materialised as distinguished
-  entities with have nothing to do with the SML-built-in notion
-  of \qt{bool}.  This results in less readable code;
-  additionally, eager evaluation may cause programs to
-  loop or break which would perfectly terminate when
-  the existing SML \verb|bool| would be used.  To map
-  the HOL \isa{bool} on SML \verb|bool|, we may use
-  \qn{custom serialisations}:%
-\end{isamarkuptext}%
-\isamarkuptrue%
-%
-\isadelimquotett
-%
-\endisadelimquotett
-%
-\isatagquotett
-\isacommand{code{\isacharunderscore}type}\isamarkupfalse%
-\ bool\isanewline
-\ \ {\isacharparenleft}SML\ {\isachardoublequoteopen}bool{\isachardoublequoteclose}{\isacharparenright}\isanewline
-\isacommand{code{\isacharunderscore}const}\isamarkupfalse%
-\ True\ \isakeyword{and}\ False\ \isakeyword{and}\ {\isachardoublequoteopen}op\ {\isasymand}{\isachardoublequoteclose}\isanewline
-\ \ {\isacharparenleft}SML\ {\isachardoublequoteopen}true{\isachardoublequoteclose}\ \isakeyword{and}\ {\isachardoublequoteopen}false{\isachardoublequoteclose}\ \isakeyword{and}\ {\isachardoublequoteopen}{\isacharunderscore}\ andalso\ {\isacharunderscore}{\isachardoublequoteclose}{\isacharparenright}%
-\endisatagquotett
-{\isafoldquotett}%
-%
-\isadelimquotett
-%
-\endisadelimquotett
-%
-\begin{isamarkuptext}%
-\noindent The \hyperlink{command.code-type}{\mbox{\isa{\isacommand{code{\isacharunderscore}type}}}} command takes a type constructor
-  as arguments together with a list of custom serialisations.
-  Each custom serialisation starts with a target language
-  identifier followed by an expression, which during
-  code serialisation is inserted whenever the type constructor
-  would occur.  For constants, \hyperlink{command.code-const}{\mbox{\isa{\isacommand{code{\isacharunderscore}const}}}} implements
-  the corresponding mechanism.  Each ``\verb|_|'' in
-  a serialisation expression is treated as a placeholder
-  for the type constructor's (the constant's) arguments.%
-\end{isamarkuptext}%
-\isamarkuptrue%
-%
-\isadelimquote
-%
-\endisadelimquote
-%
-\isatagquote
-%
-\begin{isamarkuptext}%
-\isatypewriter%
-\noindent%
-\hspace*{0pt}structure Example = \\
-\hspace*{0pt}struct\\
-\hspace*{0pt}\\
-\hspace*{0pt}datatype nat = Zero{\char95}nat | Suc of nat;\\
-\hspace*{0pt}\\
-\hspace*{0pt}fun less{\char95}nat m (Suc n) = less{\char95}eq{\char95}nat m n\\
-\hspace*{0pt} ~| less{\char95}nat n Zero{\char95}nat = false\\
-\hspace*{0pt}and less{\char95}eq{\char95}nat (Suc m) n = less{\char95}nat m n\\
-\hspace*{0pt} ~| less{\char95}eq{\char95}nat Zero{\char95}nat n = true;\\
-\hspace*{0pt}\\
-\hspace*{0pt}fun in{\char95}interval (k,~l) n = (less{\char95}eq{\char95}nat k n) andalso (less{\char95}eq{\char95}nat n l);\\
-\hspace*{0pt}\\
-\hspace*{0pt}end;~(*struct Example*)%
-\end{isamarkuptext}%
-\isamarkuptrue%
-%
-\endisatagquote
-{\isafoldquote}%
-%
-\isadelimquote
-%
-\endisadelimquote
-%
-\begin{isamarkuptext}%
-\noindent This still is not perfect: the parentheses
-  around the \qt{andalso} expression are superfluous.
-  Though the serialiser
-  by no means attempts to imitate the rich Isabelle syntax
-  framework, it provides some common idioms, notably
-  associative infixes with precedences which may be used here:%
-\end{isamarkuptext}%
-\isamarkuptrue%
-%
-\isadelimquotett
-%
-\endisadelimquotett
-%
-\isatagquotett
-\isacommand{code{\isacharunderscore}const}\isamarkupfalse%
-\ {\isachardoublequoteopen}op\ {\isasymand}{\isachardoublequoteclose}\isanewline
-\ \ {\isacharparenleft}SML\ \isakeyword{infixl}\ {\isadigit{1}}\ {\isachardoublequoteopen}andalso{\isachardoublequoteclose}{\isacharparenright}%
-\endisatagquotett
-{\isafoldquotett}%
-%
-\isadelimquotett
-%
-\endisadelimquotett
-%
-\isadelimquote
-%
-\endisadelimquote
-%
-\isatagquote
-%
-\begin{isamarkuptext}%
-\isatypewriter%
-\noindent%
-\hspace*{0pt}structure Example = \\
-\hspace*{0pt}struct\\
-\hspace*{0pt}\\
-\hspace*{0pt}datatype nat = Zero{\char95}nat | Suc of nat;\\
-\hspace*{0pt}\\
-\hspace*{0pt}fun less{\char95}nat m (Suc n) = less{\char95}eq{\char95}nat m n\\
-\hspace*{0pt} ~| less{\char95}nat n Zero{\char95}nat = false\\
-\hspace*{0pt}and less{\char95}eq{\char95}nat (Suc m) n = less{\char95}nat m n\\
-\hspace*{0pt} ~| less{\char95}eq{\char95}nat Zero{\char95}nat n = true;\\
-\hspace*{0pt}\\
-\hspace*{0pt}fun in{\char95}interval (k,~l) n = less{\char95}eq{\char95}nat k n andalso less{\char95}eq{\char95}nat n l;\\
-\hspace*{0pt}\\
-\hspace*{0pt}end;~(*struct Example*)%
-\end{isamarkuptext}%
-\isamarkuptrue%
-%
-\endisatagquote
-{\isafoldquote}%
-%
-\isadelimquote
-%
-\endisadelimquote
-%
-\begin{isamarkuptext}%
-\noindent The attentive reader may ask how we assert that no generated
-  code will accidentally overwrite.  For this reason the serialiser has
-  an internal table of identifiers which have to be avoided to be used
-  for new declarations.  Initially, this table typically contains the
-  keywords of the target language.  It can be extended manually, thus avoiding
-  accidental overwrites, using the \hyperlink{command.code-reserved}{\mbox{\isa{\isacommand{code{\isacharunderscore}reserved}}}} command:%
-\end{isamarkuptext}%
-\isamarkuptrue%
-%
-\isadelimquote
-%
-\endisadelimquote
-%
-\isatagquote
-\isacommand{code{\isacharunderscore}reserved}\isamarkupfalse%
-\ {\isachardoublequoteopen}{\isasymSML}{\isachardoublequoteclose}\ bool\ true\ false\ andalso%
-\endisatagquote
-{\isafoldquote}%
-%
-\isadelimquote
-%
-\endisadelimquote
-%
-\begin{isamarkuptext}%
-\noindent Next, we try to map HOL pairs to SML pairs, using the
-  infix ``\verb|*|'' type constructor and parentheses:%
-\end{isamarkuptext}%
-\isamarkuptrue%
-%
-\isadeliminvisible
-%
-\endisadeliminvisible
-%
-\isataginvisible
-%
-\endisataginvisible
-{\isafoldinvisible}%
-%
-\isadeliminvisible
-%
-\endisadeliminvisible
-%
-\isadelimquotett
-%
-\endisadelimquotett
-%
-\isatagquotett
-\isacommand{code{\isacharunderscore}type}\isamarkupfalse%
-\ {\isacharasterisk}\isanewline
-\ \ {\isacharparenleft}SML\ \isakeyword{infix}\ {\isadigit{2}}\ {\isachardoublequoteopen}{\isacharasterisk}{\isachardoublequoteclose}{\isacharparenright}\isanewline
-\isacommand{code{\isacharunderscore}const}\isamarkupfalse%
-\ Pair\isanewline
-\ \ {\isacharparenleft}SML\ {\isachardoublequoteopen}{\isacharbang}{\isacharparenleft}{\isacharparenleft}{\isacharunderscore}{\isacharparenright}{\isacharcomma}{\isacharslash}\ {\isacharparenleft}{\isacharunderscore}{\isacharparenright}{\isacharparenright}{\isachardoublequoteclose}{\isacharparenright}%
-\endisatagquotett
-{\isafoldquotett}%
-%
-\isadelimquotett
-%
-\endisadelimquotett
-%
-\begin{isamarkuptext}%
-\noindent The initial bang ``\verb|!|'' tells the serialiser
-  never to put
-  parentheses around the whole expression (they are already present),
-  while the parentheses around argument place holders
-  tell not to put parentheses around the arguments.
-  The slash ``\verb|/|'' (followed by arbitrary white space)
-  inserts a space which may be used as a break if necessary
-  during pretty printing.
-
-  These examples give a glimpse what mechanisms
-  custom serialisations provide; however their usage
-  requires careful thinking in order not to introduce
-  inconsistencies -- or, in other words:
-  custom serialisations are completely axiomatic.
-
-  A further noteworthy details is that any special
-  character in a custom serialisation may be quoted
-  using ``\verb|'|''; thus, in
-  ``\verb|fn '_ => _|'' the first
-  ``\verb|_|'' is a proper underscore while the
-  second ``\verb|_|'' is a placeholder.%
-\end{isamarkuptext}%
-\isamarkuptrue%
-%
-\isamarkupsubsection{\isa{Haskell} serialisation%
-}
-\isamarkuptrue%
-%
-\begin{isamarkuptext}%
-For convenience, the default
-  \isa{HOL} setup for \isa{Haskell} maps the \isa{eq} class to
-  its counterpart in \isa{Haskell}, giving custom serialisations
-  for the class \isa{eq} (by command \hyperlink{command.code-class}{\mbox{\isa{\isacommand{code{\isacharunderscore}class}}}}) and its operation
-  \isa{eq{\isacharunderscore}class{\isachardot}eq}%
-\end{isamarkuptext}%
-\isamarkuptrue%
-%
-\isadelimquotett
-%
-\endisadelimquotett
-%
-\isatagquotett
-\isacommand{code{\isacharunderscore}class}\isamarkupfalse%
-\ eq\isanewline
-\ \ {\isacharparenleft}Haskell\ {\isachardoublequoteopen}Eq{\isachardoublequoteclose}{\isacharparenright}\isanewline
-\isanewline
-\isacommand{code{\isacharunderscore}const}\isamarkupfalse%
-\ {\isachardoublequoteopen}op\ {\isacharequal}{\isachardoublequoteclose}\isanewline
-\ \ {\isacharparenleft}Haskell\ \isakeyword{infixl}\ {\isadigit{4}}\ {\isachardoublequoteopen}{\isacharequal}{\isacharequal}{\isachardoublequoteclose}{\isacharparenright}%
-\endisatagquotett
-{\isafoldquotett}%
-%
-\isadelimquotett
-%
-\endisadelimquotett
-%
-\begin{isamarkuptext}%
-\noindent A problem now occurs whenever a type which
-  is an instance of \isa{eq} in \isa{HOL} is mapped
-  on a \isa{Haskell}-built-in type which is also an instance
-  of \isa{Haskell} \isa{Eq}:%
-\end{isamarkuptext}%
-\isamarkuptrue%
-%
-\isadelimquote
-%
-\endisadelimquote
-%
-\isatagquote
-\isacommand{typedecl}\isamarkupfalse%
-\ bar\isanewline
-\isanewline
-\isacommand{instantiation}\isamarkupfalse%
-\ bar\ {\isacharcolon}{\isacharcolon}\ eq\isanewline
-\isakeyword{begin}\isanewline
-\isanewline
-\isacommand{definition}\isamarkupfalse%
-\ {\isachardoublequoteopen}eq{\isacharunderscore}class{\isachardot}eq\ {\isacharparenleft}x{\isasymColon}bar{\isacharparenright}\ y\ {\isasymlongleftrightarrow}\ x\ {\isacharequal}\ y{\isachardoublequoteclose}\isanewline
-\isanewline
-\isacommand{instance}\isamarkupfalse%
-\ \isacommand{by}\isamarkupfalse%
-\ default\ {\isacharparenleft}simp\ add{\isacharcolon}\ eq{\isacharunderscore}bar{\isacharunderscore}def{\isacharparenright}\isanewline
-\isanewline
-\isacommand{end}\isamarkupfalse%
-%
-\endisatagquote
-{\isafoldquote}%
-%
-\isadelimquote
-%
-\endisadelimquote
-%
-\isadelimquotett
-\ %
-\endisadelimquotett
-%
-\isatagquotett
-\isacommand{code{\isacharunderscore}type}\isamarkupfalse%
-\ bar\isanewline
-\ \ {\isacharparenleft}Haskell\ {\isachardoublequoteopen}Integer{\isachardoublequoteclose}{\isacharparenright}%
-\endisatagquotett
-{\isafoldquotett}%
-%
-\isadelimquotett
-%
-\endisadelimquotett
-%
-\begin{isamarkuptext}%
-\noindent The code generator would produce
-  an additional instance, which of course is rejected by the \isa{Haskell}
-  compiler.
-  To suppress this additional instance, use
-  \isa{code{\isacharunderscore}instance}:%
-\end{isamarkuptext}%
-\isamarkuptrue%
-%
-\isadelimquotett
-%
-\endisadelimquotett
-%
-\isatagquotett
-\isacommand{code{\isacharunderscore}instance}\isamarkupfalse%
-\ bar\ {\isacharcolon}{\isacharcolon}\ eq\isanewline
-\ \ {\isacharparenleft}Haskell\ {\isacharminus}{\isacharparenright}%
-\endisatagquotett
-{\isafoldquotett}%
-%
-\isadelimquotett
-%
-\endisadelimquotett
-%
-\isamarkupsubsection{Enhancing the target language context \label{sec:include}%
-}
-\isamarkuptrue%
-%
-\begin{isamarkuptext}%
-In rare cases it is necessary to \emph{enrich} the context of a
-  target language;  this is accomplished using the \hyperlink{command.code-include}{\mbox{\isa{\isacommand{code{\isacharunderscore}include}}}}
-  command:%
-\end{isamarkuptext}%
-\isamarkuptrue%
-%
-\isadelimquotett
-%
-\endisadelimquotett
-%
-\isatagquotett
-\isacommand{code{\isacharunderscore}include}\isamarkupfalse%
-\ Haskell\ {\isachardoublequoteopen}Errno{\isachardoublequoteclose}\isanewline
-{\isacharverbatimopen}errno\ i\ {\isacharequal}\ error\ {\isacharparenleft}{\isachardoublequote}Error\ number{\isacharcolon}\ {\isachardoublequote}\ {\isacharplus}{\isacharplus}\ show\ i{\isacharparenright}{\isacharverbatimclose}\isanewline
-\isanewline
-\isacommand{code{\isacharunderscore}reserved}\isamarkupfalse%
-\ Haskell\ Errno%
-\endisatagquotett
-{\isafoldquotett}%
-%
-\isadelimquotett
-%
-\endisadelimquotett
-%
-\begin{isamarkuptext}%
-\noindent Such named \isa{include}s are then prepended to every generated code.
-  Inspect such code in order to find out how \hyperlink{command.code-include}{\mbox{\isa{\isacommand{code{\isacharunderscore}include}}}} behaves
-  with respect to a particular target language.%
-\end{isamarkuptext}%
-\isamarkuptrue%
-%
-\isadelimtheory
-%
-\endisadelimtheory
-%
-\isatagtheory
-\isacommand{end}\isamarkupfalse%
-%
-\endisatagtheory
-{\isafoldtheory}%
-%
-\isadelimtheory
-%
-\endisadelimtheory
-\isanewline
-\end{isabellebody}%
-%%% Local Variables:
-%%% mode: latex
-%%% TeX-master: "root"
-%%% End:

--- a/doc-src/Codegen/Thy/document/Codegen.tex	Fri May 15 15:29:34 2009 +0200
+++ b/doc-src/Codegen/Thy/document/Codegen.tex	Fri May 15 15:56:28 2009 +0200
@@ -1550,20 +1550,20 @@
 %
 \begin{isamarkuptext}%
 \begin{mldecls}
-  \indexml{Code\_Unit.read\_const}\verb|Code_Unit.read_const: theory -> string -> string| \\
-  \indexml{Code\_Unit.head\_func}\verb|Code_Unit.head_func: thm -> string * ((string * sort) list * typ)| \\
-  \indexml{Code\_Unit.rewrite\_func}\verb|Code_Unit.rewrite_func: MetaSimplifier.simpset -> thm -> thm| \\
+  \indexml{Code\_Unit.read\_const}\verb|Code.read_const: theory -> string -> string| \\
+  \indexml{Code\_Unit.head\_func}\verb|Code.head_func: thm -> string * ((string * sort) list * typ)| \\
+  \indexml{Code\_Unit.rewrite\_func}\verb|Code.rewrite_func: MetaSimplifier.simpset -> thm -> thm| \\
   \end{mldecls}
 
   \begin{description}
 
-  \item \verb|Code_Unit.read_const|~\isa{thy}~\isa{s}
+  \item \verb|Code.read_const|~\isa{thy}~\isa{s}
      reads a constant as a concrete term expression \isa{s}.
 
-  \item \verb|Code_Unit.head_func|~\isa{thm}
+  \item \verb|Code.head_func|~\isa{thm}
      extracts the constant and its type from a defining equation \isa{thm}.
 
-  \item \verb|Code_Unit.rewrite_func|~\isa{ss}~\isa{thm}
+  \item \verb|Code.rewrite_func|~\isa{ss}~\isa{thm}
      rewrites a defining equation \isa{thm} with a simpset \isa{ss};
      only arguments and right hand side are rewritten,
      not the head of the defining equation.

--- a/doc-src/Codegen/Thy/document/Further.tex	Fri May 15 15:29:34 2009 +0200
+++ b/doc-src/Codegen/Thy/document/Further.tex	Fri May 15 15:56:28 2009 +0200
@@ -132,7 +132,7 @@
 \begin{isamarkuptext}%
 \noindent The soundness of the \hyperlink{method.eval}{\mbox{\isa{eval}}} method depends crucially 
   on the correctness of the code generator;  this is one of the reasons
-  why you should not use adaption (see \secref{sec:adaption}) frivolously.%
+  why you should not use adaptation (see \secref{sec:adaptation}) frivolously.%
 \end{isamarkuptext}%
 \isamarkuptrue%
 %

--- a/doc-src/Codegen/Thy/document/Introduction.tex	Fri May 15 15:29:34 2009 +0200
+++ b/doc-src/Codegen/Thy/document/Introduction.tex	Fri May 15 15:56:28 2009 +0200
@@ -46,8 +46,8 @@
   This manifests in the structure of this tutorial: after a short
   conceptual introduction with an example (\secref{sec:intro}),
   we discuss the generic customisation facilities (\secref{sec:program}).
-  A further section (\secref{sec:adaption}) is dedicated to the matter of
-  \qn{adaption} to specific target language environments.  After some
+  A further section (\secref{sec:adaptation}) is dedicated to the matter of
+  \qn{adaptation} to specific target language environments.  After some
   further issues (\secref{sec:further}) we conclude with an overview
   of some ML programming interfaces (\secref{sec:ml}).
 
@@ -229,7 +229,7 @@
 \hspace*{0pt}module Example where {\char123}\\
 \hspace*{0pt}\\
 \hspace*{0pt}\\
-\hspace*{0pt}foldla ::~forall a b.~(a -> b -> a) -> a -> [b] -> a;\\
+\hspace*{0pt}foldla ::~forall a{\char95}1 b{\char95}1.~(a{\char95}1 -> b{\char95}1 -> a{\char95}1) -> a{\char95}1 -> [b{\char95}1] -> a{\char95}1;\\
 \hspace*{0pt}foldla f a [] = a;\\
 \hspace*{0pt}foldla f a (x :~xs) = foldla f (f a x) xs;\\
 \hspace*{0pt}\\

--- a/doc-src/Codegen/Thy/document/ML.tex	Fri May 15 15:29:34 2009 +0200
+++ b/doc-src/Codegen/Thy/document/ML.tex	Fri May 15 15:56:28 2009 +0200
@@ -55,11 +55,11 @@
   \indexdef{}{ML}{Code.add\_eqn}\verb|Code.add_eqn: thm -> theory -> theory| \\
   \indexdef{}{ML}{Code.del\_eqn}\verb|Code.del_eqn: thm -> theory -> theory| \\
   \indexdef{}{ML}{Code.add\_eqnl}\verb|Code.add_eqnl: string * (thm * bool) list lazy -> theory -> theory| \\
-  \indexdef{}{ML}{Code.map\_pre}\verb|Code.map_pre: (simpset -> simpset) -> theory -> theory| \\
-  \indexdef{}{ML}{Code.map\_post}\verb|Code.map_post: (simpset -> simpset) -> theory -> theory| \\
-  \indexdef{}{ML}{Code.add\_functrans}\verb|Code.add_functrans: string * (theory -> (thm * bool) list -> (thm * bool) list option)|\isasep\isanewline%
+  \indexdef{}{ML}{Code\_Preproc.map\_pre}\verb|Code_Preproc.map_pre: (simpset -> simpset) -> theory -> theory| \\
+  \indexdef{}{ML}{Code\_Preproc.map\_post}\verb|Code_Preproc.map_post: (simpset -> simpset) -> theory -> theory| \\
+  \indexdef{}{ML}{Code\_Preproc.add\_functrans}\verb|Code_Preproc.add_functrans: string * (theory -> (thm * bool) list -> (thm * bool) list option)|\isasep\isanewline%
 \verb|    -> theory -> theory| \\
-  \indexdef{}{ML}{Code.del\_functrans}\verb|Code.del_functrans: string -> theory -> theory| \\
+  \indexdef{}{ML}{Code\_Preproc.del\_functrans}\verb|Code_Preproc.del_functrans: string -> theory -> theory| \\
   \indexdef{}{ML}{Code.add\_datatype}\verb|Code.add_datatype: (string * typ) list -> theory -> theory| \\
   \indexdef{}{ML}{Code.get\_datatype}\verb|Code.get_datatype: theory -> string|\isasep\isanewline%
 \verb|    -> (string * sort) list * (string * typ list) list| \\
@@ -78,10 +78,10 @@
      suspended code equations \isa{lthms} for constant
      \isa{const} to executable content.
 
-  \item \verb|Code.map_pre|~\isa{f}~\isa{thy} changes
+  \item \verb|Code_Preproc.map_pre|~\isa{f}~\isa{thy} changes
      the preprocessor simpset.
 
-  \item \verb|Code.add_functrans|~\isa{{\isacharparenleft}name{\isacharcomma}\ f{\isacharparenright}}~\isa{thy} adds
+  \item \verb|Code_Preproc.add_functrans|~\isa{{\isacharparenleft}name{\isacharcomma}\ f{\isacharparenright}}~\isa{thy} adds
      function transformer \isa{f} (named \isa{name}) to executable content;
      \isa{f} is a transformer of the code equations belonging
      to a certain function definition, depending on the
@@ -89,7 +89,7 @@
      transformation took place;  otherwise, the whole process will be iterated
      with the new code equations.
 
-  \item \verb|Code.del_functrans|~\isa{name}~\isa{thy} removes
+  \item \verb|Code_Preproc.del_functrans|~\isa{name}~\isa{thy} removes
      function transformer named \isa{name} from executable content.
 
   \item \verb|Code.add_datatype|~\isa{cs}~\isa{thy} adds
@@ -124,20 +124,16 @@
 %
 \begin{isamarkuptext}%
 \begin{mldecls}
-  \indexdef{}{ML}{Code\_Unit.read\_const}\verb|Code_Unit.read_const: theory -> string -> string| \\
-  \indexdef{}{ML}{Code\_Unit.head\_eqn}\verb|Code_Unit.head_eqn: theory -> thm -> string * ((string * sort) list * typ)| \\
-  \indexdef{}{ML}{Code\_Unit.rewrite\_eqn}\verb|Code_Unit.rewrite_eqn: simpset -> thm -> thm| \\
+  \indexdef{}{ML}{Code\_Unit.read\_const}\verb|Code.read_const: theory -> string -> string| \\
+  \indexdef{}{ML}{Code\_Unit.rewrite\_eqn}\verb|Code.rewrite_eqn: simpset -> thm -> thm| \\
   \end{mldecls}
 
   \begin{description}
 
-  \item \verb|Code_Unit.read_const|~\isa{thy}~\isa{s}
+  \item \verb|Code.read_const|~\isa{thy}~\isa{s}
      reads a constant as a concrete term expression \isa{s}.
 
-  \item \verb|Code_Unit.head_eqn|~\isa{thy}~\isa{thm}
-     extracts the constant and its type from a code equation \isa{thm}.
-
-  \item \verb|Code_Unit.rewrite_eqn|~\isa{ss}~\isa{thm}
+  \item \verb|Code.rewrite_eqn|~\isa{ss}~\isa{thm}
      rewrites a code equation \isa{thm} with a simpset \isa{ss};
      only arguments and right hand side are rewritten,
      not the head of the code equation.

--- a/doc-src/Codegen/Thy/document/Program.tex	Fri May 15 15:29:34 2009 +0200
+++ b/doc-src/Codegen/Thy/document/Program.tex	Fri May 15 15:56:28 2009 +0200
@@ -714,7 +714,7 @@
 \end{isamarkuptext}%
 \isamarkuptrue%
 %
-\isamarkupsubsection{Equality and wellsortedness%
+\isamarkupsubsection{Equality%
 }
 \isamarkuptrue%
 %
@@ -766,10 +766,10 @@
 \hspace*{0pt}type 'a eq = {\char123}eq :~'a -> 'a -> bool{\char125};\\
 \hspace*{0pt}fun eq (A{\char95}:'a eq) = {\char35}eq A{\char95};\\
 \hspace*{0pt}\\
-\hspace*{0pt}fun eqop A{\char95}~a b = eq A{\char95}~a b;\\
+\hspace*{0pt}fun eqa A{\char95}~a b = eq A{\char95}~a b;\\
 \hspace*{0pt}\\
 \hspace*{0pt}fun member A{\char95}~x [] = false\\
-\hspace*{0pt} ~| member A{\char95}~x (y ::~ys) = eqop A{\char95}~x y orelse member A{\char95}~x ys;\\
+\hspace*{0pt} ~| member A{\char95}~x (y ::~ys) = eqa A{\char95}~x y orelse member A{\char95}~x ys;\\
 \hspace*{0pt}\\
 \hspace*{0pt}fun collect{\char95}duplicates A{\char95}~xs ys [] = xs\\
 \hspace*{0pt} ~| collect{\char95}duplicates A{\char95}~xs ys (z ::~zs) =\\
@@ -801,141 +801,7 @@
   manually like any other type class.
 
   Though this \isa{eq} class is designed to get rarely in
-  the way, a subtlety
-  enters the stage when definitions of overloaded constants
-  are dependent on operational equality.  For example, let
-  us define a lexicographic ordering on tuples
-  (also see theory \hyperlink{theory.Product-ord}{\mbox{\isa{Product{\isacharunderscore}ord}}}):%
-\end{isamarkuptext}%
-\isamarkuptrue%
-%
-\isadelimquote
-%
-\endisadelimquote
-%
-\isatagquote
-\isacommand{instantiation}\isamarkupfalse%
-\ {\isachardoublequoteopen}{\isacharasterisk}{\isachardoublequoteclose}\ {\isacharcolon}{\isacharcolon}\ {\isacharparenleft}order{\isacharcomma}\ order{\isacharparenright}\ order\isanewline
-\isakeyword{begin}\isanewline
-\isanewline
-\isacommand{definition}\isamarkupfalse%
-\ {\isacharbrackleft}code\ del{\isacharbrackright}{\isacharcolon}\isanewline
-\ \ {\isachardoublequoteopen}x\ {\isasymle}\ y\ {\isasymlongleftrightarrow}\ fst\ x\ {\isacharless}\ fst\ y\ {\isasymor}\ fst\ x\ {\isacharequal}\ fst\ y\ {\isasymand}\ snd\ x\ {\isasymle}\ snd\ y{\isachardoublequoteclose}\isanewline
-\isanewline
-\isacommand{definition}\isamarkupfalse%
-\ {\isacharbrackleft}code\ del{\isacharbrackright}{\isacharcolon}\isanewline
-\ \ {\isachardoublequoteopen}x\ {\isacharless}\ y\ {\isasymlongleftrightarrow}\ fst\ x\ {\isacharless}\ fst\ y\ {\isasymor}\ fst\ x\ {\isacharequal}\ fst\ y\ {\isasymand}\ snd\ x\ {\isacharless}\ snd\ y{\isachardoublequoteclose}\isanewline
-\isanewline
-\isacommand{instance}\isamarkupfalse%
-\ \isacommand{proof}\isamarkupfalse%
-\isanewline
-\isacommand{qed}\isamarkupfalse%
-\ {\isacharparenleft}auto\ simp{\isacharcolon}\ less{\isacharunderscore}eq{\isacharunderscore}prod{\isacharunderscore}def\ less{\isacharunderscore}prod{\isacharunderscore}def\ intro{\isacharcolon}\ order{\isacharunderscore}less{\isacharunderscore}trans{\isacharparenright}\isanewline
-\isanewline
-\isacommand{end}\isamarkupfalse%
-\isanewline
-\isanewline
-\isacommand{lemma}\isamarkupfalse%
-\ order{\isacharunderscore}prod\ {\isacharbrackleft}code{\isacharbrackright}{\isacharcolon}\isanewline
-\ \ {\isachardoublequoteopen}{\isacharparenleft}x{\isadigit{1}}\ {\isasymColon}\ {\isacharprime}a{\isasymColon}order{\isacharcomma}\ y{\isadigit{1}}\ {\isasymColon}\ {\isacharprime}b{\isasymColon}order{\isacharparenright}\ {\isacharless}\ {\isacharparenleft}x{\isadigit{2}}{\isacharcomma}\ y{\isadigit{2}}{\isacharparenright}\ {\isasymlongleftrightarrow}\isanewline
-\ \ \ \ \ x{\isadigit{1}}\ {\isacharless}\ x{\isadigit{2}}\ {\isasymor}\ x{\isadigit{1}}\ {\isacharequal}\ x{\isadigit{2}}\ {\isasymand}\ y{\isadigit{1}}\ {\isacharless}\ y{\isadigit{2}}{\isachardoublequoteclose}\isanewline
-\ \ {\isachardoublequoteopen}{\isacharparenleft}x{\isadigit{1}}\ {\isasymColon}\ {\isacharprime}a{\isasymColon}order{\isacharcomma}\ y{\isadigit{1}}\ {\isasymColon}\ {\isacharprime}b{\isasymColon}order{\isacharparenright}\ {\isasymle}\ {\isacharparenleft}x{\isadigit{2}}{\isacharcomma}\ y{\isadigit{2}}{\isacharparenright}\ {\isasymlongleftrightarrow}\isanewline
-\ \ \ \ \ x{\isadigit{1}}\ {\isacharless}\ x{\isadigit{2}}\ {\isasymor}\ x{\isadigit{1}}\ {\isacharequal}\ x{\isadigit{2}}\ {\isasymand}\ y{\isadigit{1}}\ {\isasymle}\ y{\isadigit{2}}{\isachardoublequoteclose}\isanewline
-\ \ \isacommand{by}\isamarkupfalse%
-\ {\isacharparenleft}simp{\isacharunderscore}all\ add{\isacharcolon}\ less{\isacharunderscore}prod{\isacharunderscore}def\ less{\isacharunderscore}eq{\isacharunderscore}prod{\isacharunderscore}def{\isacharparenright}%
-\endisatagquote
-{\isafoldquote}%
-%
-\isadelimquote
-%
-\endisadelimquote
-%
-\begin{isamarkuptext}%
-\noindent Then code generation will fail.  Why?  The definition
-  of \isa{op\ {\isasymle}} depends on equality on both arguments,
-  which are polymorphic and impose an additional \isa{eq}
-  class constraint, which the preprocessor does not propagate
-  (for technical reasons).
-
-  The solution is to add \isa{eq} explicitly to the first sort arguments in the
-  code theorems:%
-\end{isamarkuptext}%
-\isamarkuptrue%
-%
-\isadelimquote
-%
-\endisadelimquote
-%
-\isatagquote
-\isacommand{lemma}\isamarkupfalse%
-\ order{\isacharunderscore}prod{\isacharunderscore}code\ {\isacharbrackleft}code{\isacharbrackright}{\isacharcolon}\isanewline
-\ \ {\isachardoublequoteopen}{\isacharparenleft}x{\isadigit{1}}\ {\isasymColon}\ {\isacharprime}a{\isasymColon}{\isacharbraceleft}order{\isacharcomma}\ eq{\isacharbraceright}{\isacharcomma}\ y{\isadigit{1}}\ {\isasymColon}\ {\isacharprime}b{\isasymColon}order{\isacharparenright}\ {\isacharless}\ {\isacharparenleft}x{\isadigit{2}}{\isacharcomma}\ y{\isadigit{2}}{\isacharparenright}\ {\isasymlongleftrightarrow}\isanewline
-\ \ \ \ \ x{\isadigit{1}}\ {\isacharless}\ x{\isadigit{2}}\ {\isasymor}\ x{\isadigit{1}}\ {\isacharequal}\ x{\isadigit{2}}\ {\isasymand}\ y{\isadigit{1}}\ {\isacharless}\ y{\isadigit{2}}{\isachardoublequoteclose}\isanewline
-\ \ {\isachardoublequoteopen}{\isacharparenleft}x{\isadigit{1}}\ {\isasymColon}\ {\isacharprime}a{\isasymColon}{\isacharbraceleft}order{\isacharcomma}\ eq{\isacharbraceright}{\isacharcomma}\ y{\isadigit{1}}\ {\isasymColon}\ {\isacharprime}b{\isasymColon}order{\isacharparenright}\ {\isasymle}\ {\isacharparenleft}x{\isadigit{2}}{\isacharcomma}\ y{\isadigit{2}}{\isacharparenright}\ {\isasymlongleftrightarrow}\isanewline
-\ \ \ \ \ x{\isadigit{1}}\ {\isacharless}\ x{\isadigit{2}}\ {\isasymor}\ x{\isadigit{1}}\ {\isacharequal}\ x{\isadigit{2}}\ {\isasymand}\ y{\isadigit{1}}\ {\isasymle}\ y{\isadigit{2}}{\isachardoublequoteclose}\isanewline
-\ \ \isacommand{by}\isamarkupfalse%
-\ {\isacharparenleft}simp{\isacharunderscore}all\ add{\isacharcolon}\ less{\isacharunderscore}prod{\isacharunderscore}def\ less{\isacharunderscore}eq{\isacharunderscore}prod{\isacharunderscore}def{\isacharparenright}%
-\endisatagquote
-{\isafoldquote}%
-%
-\isadelimquote
-%
-\endisadelimquote
-%
-\begin{isamarkuptext}%
-\noindent Then code generation succeeds:%
-\end{isamarkuptext}%
-\isamarkuptrue%
-%
-\isadelimquote
-%
-\endisadelimquote
-%
-\isatagquote
-%
-\begin{isamarkuptext}%
-\isatypewriter%
-\noindent%
-\hspace*{0pt}structure Example = \\
-\hspace*{0pt}struct\\
-\hspace*{0pt}\\
-\hspace*{0pt}type 'a eq = {\char123}eq :~'a -> 'a -> bool{\char125};\\
-\hspace*{0pt}fun eq (A{\char95}:'a eq) = {\char35}eq A{\char95};\\
-\hspace*{0pt}\\
-\hspace*{0pt}type 'a ord = {\char123}less{\char95}eq :~'a -> 'a -> bool,~less :~'a -> 'a -> bool{\char125};\\
-\hspace*{0pt}fun less{\char95}eq (A{\char95}:'a ord) = {\char35}less{\char95}eq A{\char95};\\
-\hspace*{0pt}fun less (A{\char95}:'a ord) = {\char35}less A{\char95};\\
-\hspace*{0pt}\\
-\hspace*{0pt}fun eqop A{\char95}~a b = eq A{\char95}~a b;\\
-\hspace*{0pt}\\
-\hspace*{0pt}type 'a preorder = {\char123}Orderings{\char95}{\char95}ord{\char95}preorder :~'a ord{\char125};\\
-\hspace*{0pt}fun ord{\char95}preorder (A{\char95}:'a preorder) = {\char35}Orderings{\char95}{\char95}ord{\char95}preorder A{\char95};\\
-\hspace*{0pt}\\
-\hspace*{0pt}type 'a order = {\char123}Orderings{\char95}{\char95}preorder{\char95}order :~'a preorder{\char125};\\
-\hspace*{0pt}fun preorder{\char95}order (A{\char95}:'a order) = {\char35}Orderings{\char95}{\char95}preorder{\char95}order A{\char95};\\
-\hspace*{0pt}\\
-\hspace*{0pt}fun less{\char95}eqa (A1{\char95},~A2{\char95}) B{\char95}~(x1,~y1) (x2,~y2) =\\
-\hspace*{0pt} ~less ((ord{\char95}preorder o preorder{\char95}order) A2{\char95}) x1 x2 orelse\\
-\hspace*{0pt} ~~~eqop A1{\char95}~x1 x2 andalso\\
-\hspace*{0pt} ~~~~~less{\char95}eq ((ord{\char95}preorder o preorder{\char95}order) B{\char95}) y1 y2\\
-\hspace*{0pt} ~| less{\char95}eqa (A1{\char95},~A2{\char95}) B{\char95}~(x1,~y1) (x2,~y2) =\\
-\hspace*{0pt} ~~~less ((ord{\char95}preorder o preorder{\char95}order) A2{\char95}) x1 x2 orelse\\
-\hspace*{0pt} ~~~~~eqop A1{\char95}~x1 x2 andalso\\
-\hspace*{0pt} ~~~~~~~less{\char95}eq ((ord{\char95}preorder o preorder{\char95}order) B{\char95}) y1 y2;\\
-\hspace*{0pt}\\
-\hspace*{0pt}end;~(*struct Example*)%
-\end{isamarkuptext}%
-\isamarkuptrue%
-%
-\endisatagquote
-{\isafoldquote}%
-%
-\isadelimquote
-%
-\endisadelimquote
-%
-\begin{isamarkuptext}%
-In some cases, the automatically derived code equations
+  the way, in some cases the automatically derived code equations
   for equality on a particular type may not be appropriate.
   As example, watch the following datatype representing
   monomorphic parametric types (where type constructors
@@ -1025,8 +891,8 @@
 \hspace*{0pt}fun null [] = true\\
 \hspace*{0pt} ~| null (x ::~xs) = false;\\
 \hspace*{0pt}\\
-\hspace*{0pt}fun eq{\char95}nat (Suc a) Zero{\char95}nat = false\\
-\hspace*{0pt} ~| eq{\char95}nat Zero{\char95}nat (Suc a) = false\\
+\hspace*{0pt}fun eq{\char95}nat (Suc nat') Zero{\char95}nat = false\\
+\hspace*{0pt} ~| eq{\char95}nat Zero{\char95}nat (Suc nat') = false\\
 \hspace*{0pt} ~| eq{\char95}nat (Suc nat) (Suc nat') = eq{\char95}nat nat nat'\\
 \hspace*{0pt} ~| eq{\char95}nat Zero{\char95}nat Zero{\char95}nat = true;\\
 \hspace*{0pt}\\

--- a/doc-src/Codegen/Thy/examples/Example.hs	Fri May 15 15:29:34 2009 +0200
+++ b/doc-src/Codegen/Thy/examples/Example.hs	Fri May 15 15:56:28 2009 +0200
@@ -3,7 +3,7 @@
 module Example where {
 
 
-foldla :: forall a b. (a -> b -> a) -> a -> [b] -> a;
+foldla :: forall a_1 b_1. (a_1 -> b_1 -> a_1) -> a_1 -> [b_1] -> a_1;
 foldla f a [] = a;
 foldla f a (x : xs) = foldla f (f a x) xs;
 

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/doc-src/Codegen/Thy/pictures/adaptation.tex	Fri May 15 15:56:28 2009 +0200
@@ -0,0 +1,52 @@
+
+\documentclass[12pt]{article}
+\usepackage{tikz}
+
+\begin{document}
+
+\thispagestyle{empty}
+\setlength{\fboxrule}{0.01pt}
+\setlength{\fboxsep}{4pt}
+
+\fcolorbox{white}{white}{
+
+\begin{tikzpicture}[scale = 0.5]
+  \tikzstyle water=[color = blue, thick]
+  \tikzstyle ice=[color = black, very thick, cap = round, join = round, fill = white]
+  \tikzstyle process=[color = green, semithick, ->]
+  \tikzstyle adaptation=[color = red, semithick, ->]
+  \tikzstyle target=[color = black]
+  \foreach \x in {0, ..., 24}
+    \draw[style=water] (\x, 0.25) sin + (0.25, 0.25) cos + (0.25, -0.25) sin
+      + (0.25, -0.25) cos + (0.25, 0.25);
+  \draw[style=ice] (1, 0) --
+    (3, 6) node[above, fill=white] {logic} -- (5, 0) -- cycle;
+  \draw[style=ice] (9, 0) --
+    (11, 6) node[above, fill=white] {intermediate language} -- (13, 0) -- cycle;
+  \draw[style=ice] (15, -6) --
+    (19, 6) node[above, fill=white] {target language} -- (23, -6) -- cycle;
+  \draw[style=process]
+    (3.5, 3) .. controls (7, 5) .. node[fill=white] {translation} (10.5, 3);
+  \draw[style=process]
+    (11.5, 3) .. controls (15, 5) .. node[fill=white] (serialisation) {serialisation} (18.5, 3);
+  \node (adaptation) at (11, -2) [style=adaptation] {adaptation};
+  \node at (19, 3) [rotate=90] {generated};
+  \node at (19.5, -5) {language};
+  \node at (19.5, -3) {library};
+  \node (includes) at (19.5, -1) {includes};
+  \node (reserved) at (16.5, -3) [rotate=72] {reserved}; % proper 71.57
+  \draw[style=process]
+    (includes) -- (serialisation);
+  \draw[style=process]
+    (reserved) -- (serialisation);
+  \draw[style=adaptation]
+    (adaptation) -- (serialisation);
+  \draw[style=adaptation]
+    (adaptation) -- (includes);
+  \draw[style=adaptation]
+    (adaptation) -- (reserved);
+\end{tikzpicture}
+
+}
+
+\end{document}

--- a/doc-src/Codegen/Thy/pictures/adaption.tex	Fri May 15 15:29:34 2009 +0200
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,52 +0,0 @@
-
-\documentclass[12pt]{article}
-\usepackage{tikz}
-
-\begin{document}
-
-\thispagestyle{empty}
-\setlength{\fboxrule}{0.01pt}
-\setlength{\fboxsep}{4pt}
-
-\fcolorbox{white}{white}{
-
-\begin{tikzpicture}[scale = 0.5]
-  \tikzstyle water=[color = blue, thick]
-  \tikzstyle ice=[color = black, very thick, cap = round, join = round, fill = white]
-  \tikzstyle process=[color = green, semithick, ->]
-  \tikzstyle adaption=[color = red, semithick, ->]
-  \tikzstyle target=[color = black]
-  \foreach \x in {0, ..., 24}
-    \draw[style=water] (\x, 0.25) sin + (0.25, 0.25) cos + (0.25, -0.25) sin
-      + (0.25, -0.25) cos + (0.25, 0.25);
-  \draw[style=ice] (1, 0) --
-    (3, 6) node[above, fill=white] {logic} -- (5, 0) -- cycle;
-  \draw[style=ice] (9, 0) --
-    (11, 6) node[above, fill=white] {intermediate language} -- (13, 0) -- cycle;
-  \draw[style=ice] (15, -6) --
-    (19, 6) node[above, fill=white] {target language} -- (23, -6) -- cycle;
-  \draw[style=process]
-    (3.5, 3) .. controls (7, 5) .. node[fill=white] {translation} (10.5, 3);
-  \draw[style=process]
-    (11.5, 3) .. controls (15, 5) .. node[fill=white] (serialisation) {serialisation} (18.5, 3);
-  \node (adaption) at (11, -2) [style=adaption] {adaption};
-  \node at (19, 3) [rotate=90] {generated};
-  \node at (19.5, -5) {language};
-  \node at (19.5, -3) {library};
-  \node (includes) at (19.5, -1) {includes};
-  \node (reserved) at (16.5, -3) [rotate=72] {reserved}; % proper 71.57
-  \draw[style=process]
-    (includes) -- (serialisation);
-  \draw[style=process]
-    (reserved) -- (serialisation);
-  \draw[style=adaption]
-    (adaption) -- (serialisation);
-  \draw[style=adaption]
-    (adaption) -- (includes);
-  \draw[style=adaption]
-    (adaption) -- (reserved);
-\end{tikzpicture}
-
-}
-
-\end{document}

--- a/doc-src/Codegen/codegen.tex	Fri May 15 15:29:34 2009 +0200
+++ b/doc-src/Codegen/codegen.tex	Fri May 15 15:56:28 2009 +0200
@@ -32,7 +32,7 @@
 
 \input{Thy/document/Introduction.tex}
 \input{Thy/document/Program.tex}
-\input{Thy/document/Adaption.tex}
+\input{Thy/document/Adaptation.tex}
 \input{Thy/document/Further.tex}
 \input{Thy/document/ML.tex}
 

--- a/doc-src/HOL/HOL.tex	Fri May 15 15:29:34 2009 +0200
+++ b/doc-src/HOL/HOL.tex	Fri May 15 15:56:28 2009 +0200
@@ -1427,7 +1427,7 @@
 provides a decision procedure for \emph{linear arithmetic}: formulae involving
 addition and subtraction. The simplifier invokes a weak version of this
 decision procedure automatically. If this is not sufficent, you can invoke the
-full procedure \ttindex{linear_arith_tac} explicitly.  It copes with arbitrary
+full procedure \ttindex{Lin_Arith.tac} explicitly.  It copes with arbitrary
 formulae involving {\tt=}, {\tt<}, {\tt<=}, {\tt+}, {\tt-}, {\tt Suc}, {\tt
   min}, {\tt max} and numerical constants. Other subterms are treated as
 atomic, while subformulae not involving numerical types are ignored. Quantified
@@ -1438,10 +1438,10 @@
 If {\tt k} is a numeral, then {\tt div k}, {\tt mod k} and
 {\tt k dvd} are also supported. The former two are eliminated
 by case distinctions, again blowing up the running time.
-If the formula involves explicit quantifiers, \texttt{linear_arith_tac} may take
+If the formula involves explicit quantifiers, \texttt{Lin_Arith.tac} may take
 super-exponential time and space.
 
-If \texttt{linear_arith_tac} fails, try to find relevant arithmetic results in
+If \texttt{Lin_Arith.tac} fails, try to find relevant arithmetic results in
 the library.  The theories \texttt{Nat} and \texttt{NatArith} contain
 theorems about {\tt<}, {\tt<=}, \texttt{+}, \texttt{-} and \texttt{*}.
 Theory \texttt{Divides} contains theorems about \texttt{div} and

--- a/doc-src/IsarRef/Thy/Spec.thy	Fri May 15 15:29:34 2009 +0200
+++ b/doc-src/IsarRef/Thy/Spec.thy	Fri May 15 15:56:28 2009 +0200
@@ -752,7 +752,11 @@
 
 text {*
   Isabelle/Pure's definitional schemes support certain forms of
-  overloading (see \secref{sec:consts}).  At most occassions
+  overloading (see \secref{sec:consts}).  Overloading means that a
+  constant being declared as @{text "c :: \<alpha> decl"} may be
+  defined separately on type instances
+  @{text "c :: (\<beta>\<^sub>1, \<dots>, \<beta>\<^sub>n) t decl"}
+  for each type constructor @{text t}.  At most occassions
   overloading will be used in a Haskell-like fashion together with
   type classes by means of @{command "instantiation"} (see
   \secref{sec:class}).  Sometimes low-level overloading is desirable.
@@ -782,7 +786,8 @@
 
   A @{text "(unchecked)"} option disables global dependency checks for
   the corresponding definition, which is occasionally useful for
-  exotic overloading.  It is at the discretion of the user to avoid
+  exotic overloading (see \secref{sec:consts} for a precise description).
+  It is at the discretion of the user to avoid
   malformed theory specifications!
 
   \end{description}
@@ -1065,10 +1070,7 @@
 
   \end{itemize}
 
-  Overloading means that a constant being declared as @{text "c :: \<alpha>
-  decl"} may be defined separately on type instances @{text "c ::
-  (\<beta>\<^sub>1, \<dots>, \<beta>\<^sub>n) t decl"} for each type constructor @{text
-  t}.  The right-hand side may mention overloaded constants
+  The right-hand side of overloaded definitions may mention overloaded constants
   recursively at type instances corresponding to the immediate
   argument types @{text "\<beta>\<^sub>1, \<dots>, \<beta>\<^sub>n"}.  Incomplete
   specification patterns impose global constraints on all occurrences,

--- a/doc-src/IsarRef/Thy/document/Spec.tex	Fri May 15 15:29:34 2009 +0200
+++ b/doc-src/IsarRef/Thy/document/Spec.tex	Fri May 15 15:56:28 2009 +0200
@@ -759,7 +759,11 @@
 %
 \begin{isamarkuptext}%
 Isabelle/Pure's definitional schemes support certain forms of
-  overloading (see \secref{sec:consts}).  At most occassions
+  overloading (see \secref{sec:consts}).  Overloading means that a
+  constant being declared as \isa{{\isachardoublequote}c\ {\isacharcolon}{\isacharcolon}\ {\isasymalpha}\ decl{\isachardoublequote}} may be
+  defined separately on type instances
+  \isa{{\isachardoublequote}c\ {\isacharcolon}{\isacharcolon}\ {\isacharparenleft}{\isasymbeta}\isactrlsub {\isadigit{1}}{\isacharcomma}\ {\isasymdots}{\isacharcomma}\ {\isasymbeta}\isactrlsub n{\isacharparenright}\ t\ decl{\isachardoublequote}}
+  for each type constructor \isa{t}.  At most occassions
   overloading will be used in a Haskell-like fashion together with
   type classes by means of \hyperlink{command.instantiation}{\mbox{\isa{\isacommand{instantiation}}}} (see
   \secref{sec:class}).  Sometimes low-level overloading is desirable.
@@ -788,7 +792,8 @@
 
   A \isa{{\isachardoublequote}{\isacharparenleft}unchecked{\isacharparenright}{\isachardoublequote}} option disables global dependency checks for
   the corresponding definition, which is occasionally useful for
-  exotic overloading.  It is at the discretion of the user to avoid
+  exotic overloading (see \secref{sec:consts} for a precise description).
+  It is at the discretion of the user to avoid
   malformed theory specifications!
 
   \end{description}%
@@ -1092,7 +1097,7 @@
 
   \end{itemize}
 
-  Overloading means that a constant being declared as \isa{{\isachardoublequote}c\ {\isacharcolon}{\isacharcolon}\ {\isasymalpha}\ decl{\isachardoublequote}} may be defined separately on type instances \isa{{\isachardoublequote}c\ {\isacharcolon}{\isacharcolon}\ {\isacharparenleft}{\isasymbeta}\isactrlsub {\isadigit{1}}{\isacharcomma}\ {\isasymdots}{\isacharcomma}\ {\isasymbeta}\isactrlsub n{\isacharparenright}\ t\ decl{\isachardoublequote}} for each type constructor \isa{t}.  The right-hand side may mention overloaded constants
+  The right-hand side of overloaded definitions may mention overloaded constants
   recursively at type instances corresponding to the immediate
   argument types \isa{{\isachardoublequote}{\isasymbeta}\isactrlsub {\isadigit{1}}{\isacharcomma}\ {\isasymdots}{\isacharcomma}\ {\isasymbeta}\isactrlsub n{\isachardoublequote}}.  Incomplete
   specification patterns impose global constraints on all occurrences,

--- a/doc-src/Main/Docs/Main_Doc.thy	Fri May 15 15:29:34 2009 +0200
+++ b/doc-src/Main/Docs/Main_Doc.thy	Fri May 15 15:56:28 2009 +0200
@@ -268,6 +268,7 @@
 @{const Transitive_Closure.rtrancl} & @{term_type_only Transitive_Closure.rtrancl "('a*'a)set\<Rightarrow>('a*'a)set"}\\
 @{const Transitive_Closure.trancl} & @{term_type_only Transitive_Closure.trancl "('a*'a)set\<Rightarrow>('a*'a)set"}\\
 @{const Transitive_Closure.reflcl} & @{term_type_only Transitive_Closure.reflcl "('a*'a)set\<Rightarrow>('a*'a)set"}\\
+@{const compower} & @{term_type_only "op ^^ :: ('a*'a)set\<Rightarrow>nat\<Rightarrow>('a*'a)set" "('a*'a)set\<Rightarrow>nat\<Rightarrow>('a*'a)set"}\\
 \end{tabular}
 
 \subsubsection*{Syntax}
@@ -318,7 +319,6 @@
 @{term "op + :: nat \<Rightarrow> nat \<Rightarrow> nat"} &
 @{term "op - :: nat \<Rightarrow> nat \<Rightarrow> nat"} &
 @{term "op * :: nat \<Rightarrow> nat \<Rightarrow> nat"} &
-@{term "op ^ :: nat \<Rightarrow> nat \<Rightarrow> nat"} &
 @{term "op div :: nat \<Rightarrow> nat \<Rightarrow> nat"}&
 @{term "op mod :: nat \<Rightarrow> nat \<Rightarrow> nat"}&
 @{term "op dvd :: nat \<Rightarrow> nat \<Rightarrow> bool"}\\
@@ -331,7 +331,9 @@
 \end{tabular}
 
 \begin{tabular}{@ {} l @ {~::~} l @ {}}
-@{const Nat.of_nat} & @{typeof Nat.of_nat}
+@{const Nat.of_nat} & @{typeof Nat.of_nat}\\
+@{term "op ^^ :: ('a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a"} &
+  @{term_type_only "op ^^ :: ('a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a" "('a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a"}
 \end{tabular}
 
 \section{Int}
@@ -450,14 +452,6 @@
 \end{tabular}
 
 
-\section{Iterated Functions and Relations}
-
-Theory: @{theory Relation_Power}
-
-Iterated functions \ @{term[source]"(f::'a\<Rightarrow>'a) ^ n"} \
-and relations \ @{term[source]"(r::('a\<times>'a)set) ^ n"}.
-
-
 \section{Option}
 
 @{datatype option}

--- a/doc-src/Main/Docs/document/Main_Doc.tex	Fri May 15 15:29:34 2009 +0200
+++ b/doc-src/Main/Docs/document/Main_Doc.tex	Fri May 15 15:56:28 2009 +0200
@@ -279,6 +279,7 @@
 \isa{rtrancl} & \isa{{\isacharparenleft}{\isacharprime}a\ {\isasymtimes}\ {\isacharprime}a{\isacharparenright}\ set\ {\isasymRightarrow}\ {\isacharparenleft}{\isacharprime}a\ {\isasymtimes}\ {\isacharprime}a{\isacharparenright}\ set}\\
 \isa{trancl} & \isa{{\isacharparenleft}{\isacharprime}a\ {\isasymtimes}\ {\isacharprime}a{\isacharparenright}\ set\ {\isasymRightarrow}\ {\isacharparenleft}{\isacharprime}a\ {\isasymtimes}\ {\isacharprime}a{\isacharparenright}\ set}\\
 \isa{reflcl} & \isa{{\isacharparenleft}{\isacharprime}a\ {\isasymtimes}\ {\isacharprime}a{\isacharparenright}\ set\ {\isasymRightarrow}\ {\isacharparenleft}{\isacharprime}a\ {\isasymtimes}\ {\isacharprime}a{\isacharparenright}\ set}\\
+\isa{op\ {\isacharcircum}{\isacharcircum}} & \isa{{\isacharparenleft}{\isacharprime}a\ {\isasymtimes}\ {\isacharprime}a{\isacharparenright}\ set\ {\isasymRightarrow}\ nat\ {\isasymRightarrow}\ {\isacharparenleft}{\isacharprime}a\ {\isasymtimes}\ {\isacharprime}a{\isacharparenright}\ set}\\
 \end{tabular}
 
 \subsubsection*{Syntax}
@@ -328,7 +329,6 @@
 \isa{op\ {\isacharplus}} &
 \isa{op\ {\isacharminus}} &
 \isa{op\ {\isacharasterisk}} &
-\isa{op\ {\isacharcircum}} &
 \isa{op\ div}&
 \isa{op\ mod}&
 \isa{op\ dvd}\\
@@ -341,7 +341,9 @@
 \end{tabular}
 
 \begin{tabular}{@ {} l @ {~::~} l @ {}}
-\isa{of{\isacharunderscore}nat} & \isa{nat\ {\isasymRightarrow}\ {\isacharprime}a}
+\isa{of{\isacharunderscore}nat} & \isa{nat\ {\isasymRightarrow}\ {\isacharprime}a}\\
+\isa{op\ {\isacharcircum}{\isacharcircum}} &
+  \isa{{\isacharparenleft}{\isacharprime}a\ {\isasymRightarrow}\ {\isacharprime}a{\isacharparenright}\ {\isasymRightarrow}\ nat\ {\isasymRightarrow}\ {\isacharprime}a\ {\isasymRightarrow}\ {\isacharprime}a}
 \end{tabular}
 
 \section{Int}
@@ -460,14 +462,6 @@
 \end{tabular}
 
 
-\section{Iterated Functions and Relations}
-
-Theory: \isa{Relation{\isacharunderscore}Power}
-
-Iterated functions \ \isa{{\isachardoublequote}{\isacharparenleft}f{\isacharcolon}{\isacharcolon}{\isacharprime}a{\isasymRightarrow}{\isacharprime}a{\isacharparenright}\ {\isacharcircum}\ n{\isachardoublequote}} \
-and relations \ \isa{{\isachardoublequote}{\isacharparenleft}r{\isacharcolon}{\isacharcolon}{\isacharparenleft}{\isacharprime}a{\isasymtimes}{\isacharprime}a{\isacharparenright}set{\isacharparenright}\ {\isacharcircum}\ n{\isachardoublequote}}.
-
-
 \section{Option}
 
 \isa{\isacommand{datatype}\ {\isacharprime}a\ option\ {\isacharequal}\ None\ {\isacharbar}\ Some\ {\isacharprime}a}

--- a/doc-src/TutorialI/tutorial.tex	Fri May 15 15:29:34 2009 +0200
+++ b/doc-src/TutorialI/tutorial.tex	Fri May 15 15:56:28 2009 +0200
@@ -39,10 +39,11 @@
 %University of Cambridge\\
 %Computer Laboratory
 }
+\pagenumbering{roman}
 \maketitle
+\newpage
 
-\pagenumbering{roman}
-\setcounter{page}{5}
+%\setcounter{page}{5}
 %\vspace*{\fill}
 %\begin{center}
 %\LARGE In memoriam \\[1ex]
@@ -52,6 +53,7 @@
 %\vspace*{\fill}
 %\vspace*{\fill}
 %\newpage
+
 \include{preface}
 
 \tableofcontents

--- a/doc-src/more_antiquote.ML	Fri May 15 15:29:34 2009 +0200
+++ b/doc-src/more_antiquote.ML	Fri May 15 15:56:28 2009 +0200
@@ -87,10 +87,10 @@
 fun pretty_code_thm src ctxt raw_const =
   let
     val thy = ProofContext.theory_of ctxt;
-    val const = Code_Unit.check_const thy raw_const;
-    val (_, funcgr) = Code_Wellsorted.make thy [const];
+    val const = Code.check_const thy raw_const;
+    val (_, funcgr) = Code_Preproc.obtain thy [const] [];
     fun holize thm = @{thm meta_eq_to_obj_eq} OF [thm];
-    val thms = Code_Wellsorted.eqns funcgr const
+    val thms = Code_Preproc.eqns funcgr const
       |> map_filter (fn (thm, linear) => if linear then SOME thm else NONE)
       |> map (holize o no_vars ctxt o AxClass.overload thy);
   in ThyOutput.output (ThyOutput.maybe_pretty_source (pretty_thm ctxt) src thms) end;
@@ -108,7 +108,7 @@
 local
 
   val parse_const_terms = Scan.repeat1 Args.term
-    >> (fn ts => fn thy => map (Code_Unit.check_const thy) ts);
+    >> (fn ts => fn thy => map (Code.check_const thy) ts);
   val parse_consts = Scan.lift (Args.parens (Args.$$$ "consts")) |-- parse_const_terms
     >> (fn mk_cs => fn thy => fn naming => map_filter (Code_Thingol.lookup_const naming) (mk_cs thy));
   val parse_types = Scan.lift (Args.parens (Args.$$$ "types") |-- Scan.repeat1 Args.name)

--- a/etc/isar-keywords-ZF.el	Fri May 15 15:29:34 2009 +0200
+++ b/etc/isar-keywords-ZF.el	Fri May 15 15:56:28 2009 +0200
@@ -155,8 +155,6 @@
     "prop"
     "pwd"
     "qed"
-    "quickcheck"
-    "quickcheck_params"
     "quit"
     "realizability"
     "realizers"
@@ -319,7 +317,6 @@
     "print_trans_rules"
     "prop"
     "pwd"
-    "quickcheck"
     "remove_thy"
     "term"
     "thm"
@@ -397,7 +394,6 @@
     "primrec"
     "print_ast_translation"
     "print_translation"
-    "quickcheck_params"
     "realizability"
     "realizers"
     "rep_datatype"

--- a/etc/isar-keywords.el	Fri May 15 15:29:34 2009 +0200
+++ b/etc/isar-keywords.el	Fri May 15 15:56:28 2009 +0200
@@ -35,6 +35,7 @@
     "atp_info"
     "atp_kill"
     "atp_messages"
+    "atp_minimize"
     "attribute_setup"
     "automaton"
     "ax_specification"
@@ -167,6 +168,7 @@
     "print_cases"
     "print_claset"
     "print_classes"
+    "print_codeproc"
     "print_codesetup"
     "print_commands"
     "print_configs"
@@ -249,6 +251,7 @@
     "use_thy"
     "using"
     "value"
+    "values"
     "welcome"
     "with"
     "{"
@@ -340,6 +343,7 @@
     "atp_info"
     "atp_kill"
     "atp_messages"
+    "atp_minimize"
     "cd"
     "class_deps"
     "code_deps"
@@ -367,6 +371,7 @@
     "print_cases"
     "print_claset"
     "print_classes"
+    "print_codeproc"
     "print_codesetup"
     "print_commands"
     "print_configs"
@@ -400,6 +405,7 @@
     "unused_thms"
     "use_thy"
     "value"
+    "values"
     "welcome"))
 
 (defconst isar-keywords-theory-begin

--- a/lib/jedit/isabelle.xml	Fri May 15 15:29:34 2009 +0200
+++ b/lib/jedit/isabelle.xml	Fri May 15 15:56:28 2009 +0200
@@ -60,6 +60,7 @@
       <LABEL>atp_info</LABEL>
       <LABEL>atp_kill</LABEL>
       <LABEL>atp_messages</LABEL>
+      <LABEL>atp_minimize</LABEL>
       <KEYWORD4>attach</KEYWORD4>
       <OPERATOR>attribute_setup</OPERATOR>
       <OPERATOR>automaton</OPERATOR>
@@ -237,6 +238,7 @@
       <LABEL>print_cases</LABEL>
       <LABEL>print_claset</LABEL>
       <LABEL>print_classes</LABEL>
+      <LABEL>print_codeproc</LABEL>
       <LABEL>print_codesetup</LABEL>
       <LABEL>print_commands</LABEL>
       <LABEL>print_configs</LABEL>
@@ -334,6 +336,7 @@
       <KEYWORD4>uses</KEYWORD4>
       <OPERATOR>using</OPERATOR>
       <LABEL>value</LABEL>
+      <LABEL>values</LABEL>
       <LABEL>welcome</LABEL>
       <KEYWORD4>where</KEYWORD4>
       <OPERATOR>with</OPERATOR>

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lib/scripts/SystemOnTPTP	Fri May 15 15:56:28 2009 +0200
@@ -0,0 +1,120 @@
+#!/usr/bin/env perl
+#
+# Wrapper for custom remote provers on SystemOnTPTP
+# Author: Fabian Immler, TU Muenchen
+#
+
+use warnings;
+use strict;
+use Getopt::Std;
+use HTTP::Request::Common;
+use LWP;
+
+my $SystemOnTPTPFormReplyURL = "http://www.cs.miami.edu/~tptp/cgi-bin/SystemOnTPTPFormReply";
+
+# default parameters
+my %URLParameters = (
+    "NoHTML" => 1,
+    "QuietFlag" => "-q01",
+    "X2TPTP" => "-S",
+    "SubmitButton" => "RunSelectedSystems",
+    "ProblemSource" => "UPLOAD",
+    );
+
+#----Get format and transform options if specified
+my %Options;
+getopts("hws:t:c:",\%Options);
+
+#----Usage
+sub usage() {
+  print("Usage: remote [<options>] <File name>\n");
+  print("    <options> are ...\n");
+  print("    -h            - print this help\n");
+  print("    -w            - list available ATP systems\n");
+  print("    -s<system>    - specified system to use\n");
+  print("    -t<timelimit> - CPU time limit for system\n");
+  print("    -c<command>   - custom command for system\n");
+  print("    <File name>   - TPTP problem file\n");
+  exit(0);
+}
+if (exists($Options{'h'})) {
+  usage();
+}
+#----What systems flag
+if (exists($Options{'w'})) {
+    $URLParameters{"SubmitButton"} = "ListSystems";
+    delete($URLParameters{"ProblemSource"});
+}
+#----Selected system
+my $System;
+if (exists($Options{'s'})) {
+    $System = $Options{'s'};
+} else {
+    # use Vampire as default
+    $System = "Vampire---9.0";
+}
+$URLParameters{"System___$System"} = $System;
+
+#----Time limit
+if (exists($Options{'t'})) {
+    $URLParameters{"TimeLimit___$System"} = $Options{'t'};
+}
+#----Custom command
+if (exists($Options{'c'})) {
+    $URLParameters{"Command___$System"} = $Options{'c'};
+}
+
+#----Get single file name
+if (exists($URLParameters{"ProblemSource"})) {
+    if (scalar(@ARGV) >= 1) {
+        $URLParameters{"UPLOADProblem"} = [shift(@ARGV)];
+    } else {
+      print("Missing problem file\n");
+      usage();
+      die;
+    }
+}
+
+# Query Server
+my $Agent = LWP::UserAgent->new;
+if (exists($Options{'t'})) {
+  # give server more time to respond
+  $Agent->timeout($Options{'t'} + 10);
+}
+my $Request = POST($SystemOnTPTPFormReplyURL,
+	Content_Type => 'form-data',Content => \%URLParameters);
+my $Response = $Agent->request($Request);
+
+#catch errors / failure
+if(! $Response->is_success){
+  print "HTTP-Error: " . $Response->message . "\n";
+  exit(-1);
+} elsif (exists($Options{'w'})) {
+  print $Response->content;
+  exit (0);
+} elsif ($Response->content =~ /WARNING: (\S*) does not exist/) {
+  print "Specified System $1 does not exist\n";
+  exit(-1);
+} elsif ($Response->content =~ /%\s*Result\s*:\s*Unsatisfiable.*\n%\s*Output\s*:\s*(CNF)?Refutation.*\n%/) {
+  my @lines = split( /\n/, $Response->content);
+  my $extract = "";
+  foreach my $line (@lines){
+      #ignore comments
+      if ($line !~ /^%/ && !($line eq "")) {
+          $extract .= "$line";
+      }
+  }
+  # insert newlines after ').'
+  $extract =~ s/\s//g;
+  $extract =~ s/\)\.cnf/\)\.\ncnf/g;
+
+  # orientation for res_reconstruct.ML
+  print "# SZS output start CNFRefutation.\n";
+  print "$extract\n";
+  print "# SZS output end CNFRefutation.\n";
+  exit(0);
+} else {
+  print "Remote-script could not extract proof:\n".$Response->content;
+  exit(-1);
+}
+

--- a/src/HOL/ATP_Linkup.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/ATP_Linkup.thy	Fri May 15 15:56:28 2009 +0200
@@ -17,6 +17,7 @@
   ("Tools/res_atp.ML")
   ("Tools/atp_manager.ML")
   ("Tools/atp_wrapper.ML")
+  ("Tools/atp_minimal.ML")
   "~~/src/Tools/Metis/metis.ML"
   ("Tools/metis_tools.ML")
 begin
@@ -98,6 +99,8 @@
 use "Tools/atp_manager.ML"
 use "Tools/atp_wrapper.ML"
 
+use "Tools/atp_minimal.ML"
+
 text {* basic provers *}
 setup {* AtpManager.add_prover "spass" AtpWrapper.spass *}
 setup {* AtpManager.add_prover "vampire" AtpWrapper.vampire *}

--- a/src/HOL/Algebra/abstract/Ring2.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Algebra/abstract/Ring2.thy	Fri May 15 15:56:28 2009 +0200
@@ -12,7 +12,7 @@
 
 subsection {* Ring axioms *}
 
-class ring = zero + one + plus + minus + uminus + times + inverse + power + Ring_and_Field.dvd +
+class ring = zero + one + plus + minus + uminus + times + inverse + power + dvd +
   assumes a_assoc:      "(a + b) + c = a + (b + c)"
   and l_zero:           "0 + a = a"
   and l_neg:            "(-a) + a = 0"
@@ -28,8 +28,6 @@
   assumes minus_def:    "a - b = a + (-b)"
   and inverse_def:      "inverse a = (if a dvd 1 then THE x. a*x = 1 else 0)"
   and divide_def:       "a / b = a * inverse b"
-  and power_0 [simp]:   "a ^ 0 = 1"
-  and power_Suc [simp]: "a ^ Suc n = a ^ n * a"
 begin
 
 definition assoc :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "assoc" 50) where

--- a/src/HOL/Algebra/poly/LongDiv.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Algebra/poly/LongDiv.thy	Fri May 15 15:56:28 2009 +0200
@@ -1,6 +1,5 @@
 (*
     Experimental theory: long division of polynomials
-    $Id$
     Author: Clemens Ballarin, started 23 June 1999
 *)
 
@@ -133,9 +132,9 @@
     delsimprocs [ring_simproc]) 1 *})
   apply (tactic {* asm_simp_tac (@{simpset} delsimprocs [ring_simproc]) 1 *})
   apply (tactic {* simp_tac (@{simpset} addsimps [thm "minus_def", thm "smult_r_distr",
-    thm "smult_r_minus", thm "monom_mult_smult", thm "smult_assoc1", thm "smult_assoc2"]
+    thm "smult_r_minus", thm "monom_mult_smult", thm "smult_assoc2"]
     delsimprocs [ring_simproc]) 1 *})
-  apply simp
+  apply (simp add: smult_assoc1 [symmetric])
   done
 
 ML {*

--- a/src/HOL/Algebra/poly/UnivPoly2.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Algebra/poly/UnivPoly2.thy	Fri May 15 15:56:28 2009 +0200
@@ -155,16 +155,6 @@
 
 end
 
-instantiation up :: ("{times, one, comm_monoid_add}") power
-begin
-
-primrec power_up where
-  "(a \<Colon> 'a up) ^ 0 = 1"
-  | "(a \<Colon> 'a up) ^ Suc n = a ^ n * a"
-
-instance ..
-
-end
 
 subsection {* Effect of operations on coefficients *}
 
@@ -328,8 +318,9 @@
   qed
   show "(p + q) * r = p * r + q * r"
     by (rule up_eqI) simp
-  show "p * q = q * p"
+  show "\<And>q. p * q = q * p"
   proof (rule up_eqI)
+    fix q
     fix n 
     {
       fix k
@@ -354,9 +345,6 @@
     by (simp add: up_inverse_def)
   show "p / q = p * inverse q"
     by (simp add: up_divide_def)
-  fix n
-  show "p ^ 0 = 1" by simp
-  show "p ^ Suc n = p ^ n * p" by simp
 qed
 
 (* Further properties of monom *)

--- a/src/HOL/Bali/State.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Bali/State.thy	Fri May 15 15:56:28 2009 +0200
@@ -29,7 +29,7 @@
 types	vn   = "fspec + int"                    --{* variable name      *}
 record	obj  = 
           tag :: "obj_tag"                      --{* generalized object *}
-          values :: "(vn, val) table"      
+          "values" :: "(vn, val) table"      
 
 translations 
   "fspec" <= (type) "vname \<times> qtname" 

--- a/src/HOL/Bali/Trans.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Bali/Trans.thy	Fri May 15 15:56:28 2009 +0200
@@ -359,7 +359,7 @@
 
 abbreviation
   stepn:: "[prog, term \<times> state,nat,term \<times> state] \<Rightarrow> bool" ("_\<turnstile>_ \<mapsto>_ _"[61,82,82] 81)
-  where "G\<turnstile>p \<mapsto>n p' \<equiv> (p,p') \<in> {(x, y). step G x y}^n"
+  where "G\<turnstile>p \<mapsto>n p' \<equiv> (p,p') \<in> {(x, y). step G x y}^^n"
 
 abbreviation
   steptr:: "[prog,term \<times> state,term \<times> state] \<Rightarrow> bool" ("_\<turnstile>_ \<mapsto>* _"[61,82,82] 81)
@@ -370,25 +370,6 @@
   Smallstep zu Bigstep, nur wenn nicht die Ausdrücke Callee, FinA ,\<dots>
 *)
 
-lemma rtrancl_imp_rel_pow: "p \<in> R^* \<Longrightarrow> \<exists>n. p \<in> R^n"
-proof -
-  assume "p \<in> R\<^sup>*"
-  moreover obtain x y where p: "p = (x,y)" by (cases p)
-  ultimately have "(x,y) \<in> R\<^sup>*" by hypsubst
-  hence "\<exists>n. (x,y) \<in> R^n"
-  proof induct
-    fix a have "(a,a) \<in> R^0" by simp
-    thus "\<exists>n. (a,a) \<in> R ^ n" ..
-  next
-    fix a b c assume "\<exists>n. (a,b) \<in> R ^ n"
-    then obtain n where "(a,b) \<in> R^n" ..
-    moreover assume "(b,c) \<in> R"
-    ultimately have "(a,c) \<in> R^(Suc n)" by auto
-    thus "\<exists>n. (a,c) \<in> R^n" ..
-  qed
-  with p show ?thesis by hypsubst
-qed  
-
 (*
 lemma imp_eval_trans:
   assumes eval: "G\<turnstile>s0 \<midarrow>t\<succ>\<rightarrow> (v,s1)" 

--- a/src/HOL/Code_Eval.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Code_Eval.thy	Fri May 15 15:56:28 2009 +0200
@@ -23,35 +23,20 @@
 code_datatype Const App
 
 class term_of = typerep +
-  fixes term_of :: "'a::{} \<Rightarrow> term"
+  fixes term_of :: "'a \<Rightarrow> term"
 
 lemma term_of_anything: "term_of x \<equiv> t"
   by (rule eq_reflection) (cases "term_of x", cases t, simp)
 
-ML {*
-structure Eval =
-struct
-
-fun mk_term f g (Const (c, ty)) =
-      @{term Const} $ Message_String.mk c $ g ty
-  | mk_term f g (t1 $ t2) =
-      @{term App} $ mk_term f g t1 $ mk_term f g t2
-  | mk_term f g (Free v) = f v
-  | mk_term f g (Bound i) = Bound i
-  | mk_term f g (Abs (v, _, t)) = Abs (v, @{typ term}, mk_term f g t);
-
-fun mk_term_of ty t = Const (@{const_name term_of}, ty --> @{typ term}) $ t;
-
-end;
-*}
-
 
 subsubsection {* @{text term_of} instances *}
 
 setup {*
 let
-  fun add_term_of_def ty vs tyco thy =
+  fun add_term_of tyco raw_vs thy =
     let
+      val vs = map (fn (v, _) => (v, @{sort typerep})) raw_vs;
+      val ty = Type (tyco, map TFree vs);
       val lhs = Const (@{const_name term_of}, ty --> @{typ term})
         $ Free ("x", ty);
       val rhs = @{term "undefined \<Colon> term"};
@@ -64,64 +49,57 @@
       |> `(fn lthy => Syntax.check_term lthy eq)
       |-> (fn eq => Specification.definition (NONE, ((Binding.name (triv_name_of eq), []), eq)))
       |> snd
-      |> Class.prove_instantiation_instance (K (Class.intro_classes_tac []))
-      |> LocalTheory.exit_global
+      |> Class.prove_instantiation_exit (K (Class.intro_classes_tac []))
     end;
-  fun interpretator (tyco, (raw_vs, _)) thy =
+  fun ensure_term_of (tyco, (raw_vs, _)) thy =
     let
-      val has_inst = can (Sorts.mg_domain (Sign.classes_of thy) tyco) @{sort term_of};
-      val constrain_sort =
-        curry (Sorts.inter_sort (Sign.classes_of thy)) @{sort term_of};
-      val vs = (map o apsnd) constrain_sort raw_vs;
-      val ty = Type (tyco, map TFree vs);
+      val need_inst = not (can (Sorts.mg_domain (Sign.classes_of thy) tyco) @{sort term_of})
+        andalso can (Sorts.mg_domain (Sign.classes_of thy) tyco) @{sort typerep};
     in
       thy
-      |> Typerep.perhaps_add_def tyco
-      |> not has_inst ? add_term_of_def ty vs tyco
+      |> need_inst ? add_term_of tyco raw_vs
     end;
 in
-  Code.type_interpretation interpretator
+  Code.type_interpretation ensure_term_of
 end
 *}
 
 setup {*
 let
-  fun mk_term_of_eq ty vs tyco (c, tys) =
+  fun mk_term_of_eq thy ty vs tyco (c, tys) =
     let
       val t = list_comb (Const (c, tys ---> ty),
         map Free (Name.names Name.context "a" tys));
-    in (map_aterms (fn Free (v, ty) => Var ((v, 0), ty) | t => t) t, Eval.mk_term
-      (fn (v, ty) => Eval.mk_term_of ty (Var ((v, 0), ty)))
-      (Typerep.mk (fn (v, sort) => Typerep.typerep (TFree (v, sort)))) t)
+      val (arg, rhs) = pairself (Thm.cterm_of thy o map_types Logic.unvarifyT o Logic.varify)
+        (t, (map_aterms (fn t as Free (v, ty) => HOLogic.mk_term_of ty t | t => t) o HOLogic.reflect_term) t)
+      val cty = Thm.ctyp_of thy ty;
+    in
+      @{thm term_of_anything}
+      |> Drule.instantiate' [SOME cty] [SOME arg, SOME rhs]
+      |> Thm.varifyT
     end;
-  fun prove_term_of_eq ty eq thy =
+  fun add_term_of_code tyco raw_vs raw_cs thy =
     let
-      val cty = Thm.ctyp_of thy ty;
-      val (arg, rhs) = pairself (Thm.cterm_of thy) eq;
-      val thm = @{thm term_of_anything}
-        |> Drule.instantiate' [SOME cty] [SOME arg, SOME rhs]
-        |> Thm.varifyT;
+      val vs = map (fn (v, _) => (v, @{sort typerep})) raw_vs;
+      val ty = Type (tyco, map TFree vs);
+      val cs = (map o apsnd o map o map_atyps)
+        (fn TFree (v, _) => TFree (v, (the o AList.lookup (op =) vs) v)) raw_cs;
+      val const = AxClass.param_of_inst thy (@{const_name term_of}, tyco);
+      val eqs = map (mk_term_of_eq thy ty vs tyco) cs;
+   in
+      thy
+      |> Code.del_eqns const
+      |> fold Code.add_eqn eqs
+    end;
+  fun ensure_term_of_code (tyco, (raw_vs, cs)) thy =
+    let
+      val has_inst = can (Sorts.mg_domain (Sign.classes_of thy) tyco) @{sort term_of};
     in
       thy
-      |> Code.add_eqn thm
-    end;
-  fun interpretator (tyco, (raw_vs, raw_cs)) thy =
-    let
-      val constrain_sort =
-        curry (Sorts.inter_sort (Sign.classes_of thy)) @{sort term_of};
-      val vs = (map o apsnd) constrain_sort raw_vs;
-      val cs = (map o apsnd o map o map_atyps)
-        (fn TFree (v, sort) => TFree (v, constrain_sort sort)) raw_cs;
-      val ty = Type (tyco, map TFree vs);
-      val eqs = map (mk_term_of_eq ty vs tyco) cs;
-      val const = AxClass.param_of_inst thy (@{const_name term_of}, tyco);
-    in
-      thy
-      |> Code.del_eqns const
-      |> fold (prove_term_of_eq ty) eqs
+      |> has_inst ? add_term_of_code tyco raw_vs cs
     end;
 in
-  Code.type_interpretation interpretator
+  Code.type_interpretation ensure_term_of_code
 end
 *}
 
@@ -146,13 +124,15 @@
   by (subst term_of_anything) rule 
 
 code_type "term"
-  (SML "Term.term")
+  (Eval "Term.term")
 
 code_const Const and App
-  (SML "Term.Const/ (_, _)" and "Term.$/ (_, _)")
+  (Eval "Term.Const/ (_, _)" and "Term.$/ (_, _)")
 
 code_const "term_of \<Colon> message_string \<Rightarrow> term"
-  (SML "Message'_String.mk")
+  (Eval "HOLogic.mk'_message'_string")
+
+code_reserved Eval HOLogic
 
 
 subsection {* Evaluation setup *}
@@ -160,7 +140,6 @@
 ML {*
 signature EVAL =
 sig
-  val mk_term: ((string * typ) -> term) -> (typ -> term) -> term -> term
   val eval_ref: (unit -> term) option ref
   val eval_term: theory -> term -> term
 end;
@@ -168,15 +147,10 @@
 structure Eval : EVAL =
 struct
 
-open Eval;
-
 val eval_ref = ref (NONE : (unit -> term) option);
 
 fun eval_term thy t =
-  t 
-  |> Eval.mk_term_of (fastype_of t)
-  |> (fn t => Code_ML.eval_term ("Eval.eval_ref", eval_ref) thy t [])
-  |> Code.postprocess_term thy;
+  Code_ML.eval NONE ("Eval.eval_ref", eval_ref) I thy (HOLogic.mk_term_of (fastype_of t) t) [];
 
 end;
 *}

--- a/src/HOL/Code_Message.thy	Fri May 15 15:29:34 2009 +0200
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,58 +0,0 @@
-(*  ID:         $Id$
-    Author:     Florian Haftmann, TU Muenchen
-*)
-
-header {* Monolithic strings (message strings) for code generation *}
-
-theory Code_Message
-imports Plain "~~/src/HOL/List"
-begin
-
-subsection {* Datatype of messages *}
-
-datatype message_string = STR string
-
-lemmas [code del] = message_string.recs message_string.cases
-
-lemma [code]: "size (s\<Colon>message_string) = 0"
-  by (cases s) simp_all
-
-lemma [code]: "message_string_size (s\<Colon>message_string) = 0"
-  by (cases s) simp_all
-
-subsection {* ML interface *}
-
-ML {*
-structure Message_String =
-struct
-
-fun mk s = @{term STR} $ HOLogic.mk_string s;
-
-end;
-*}
-
-
-subsection {* Code serialization *}
-
-code_type message_string
-  (SML "string")
-  (OCaml "string")
-  (Haskell "String")
-
-setup {*
-  fold (fn target => add_literal_message @{const_name STR} target)
-    ["SML", "OCaml", "Haskell"]
-*}
-
-code_reserved SML string
-code_reserved OCaml string
-
-code_instance message_string :: eq
-  (Haskell -)
-
-code_const "eq_class.eq \<Colon> message_string \<Rightarrow> message_string \<Rightarrow> bool"
-  (SML "!((_ : string) = _)")
-  (OCaml "!((_ : string) = _)")
-  (Haskell infixl 4 "==")
-
-end

--- a/src/HOL/Code_Setup.thy	Fri May 15 15:29:34 2009 +0200
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,253 +0,0 @@
-(*  Title:      HOL/Code_Setup.thy
-    ID:         $Id$
-    Author:     Florian Haftmann
-*)
-
-header {* Setup of code generators and related tools *}
-
-theory Code_Setup
-imports HOL
-begin
-
-subsection {* Generic code generator foundation *}
-
-text {* Datatypes *}
-
-code_datatype True False
-
-code_datatype "TYPE('a\<Colon>{})"
-
-code_datatype Trueprop "prop"
-
-text {* Code equations *}
-
-lemma [code]:
-  shows "(True \<Longrightarrow> PROP P) \<equiv> PROP P" 
-    and "(False \<Longrightarrow> Q) \<equiv> Trueprop True" 
-    and "(PROP P \<Longrightarrow> True) \<equiv> Trueprop True" 
-    and "(Q \<Longrightarrow> False) \<equiv> Trueprop (\<not> Q)" by (auto intro!: equal_intr_rule)
-
-lemma [code]:
-  shows "False \<and> x \<longleftrightarrow> False"
-    and "True \<and> x \<longleftrightarrow> x"
-    and "x \<and> False \<longleftrightarrow> False"
-    and "x \<and> True \<longleftrightarrow> x" by simp_all
-
-lemma [code]:
-  shows "False \<or> x \<longleftrightarrow> x"
-    and "True \<or> x \<longleftrightarrow> True"
-    and "x \<or> False \<longleftrightarrow> x"
-    and "x \<or> True \<longleftrightarrow> True" by simp_all
-
-lemma [code]:
-  shows "\<not> True \<longleftrightarrow> False"
-    and "\<not> False \<longleftrightarrow> True" by (rule HOL.simp_thms)+
-
-lemmas [code] = Let_def if_True if_False
-
-lemmas [code, code unfold, symmetric, code post] = imp_conv_disj
-
-text {* Equality *}
-
-context eq
-begin
-
-lemma equals_eq [code inline, code]: "op = \<equiv> eq"
-  by (rule eq_reflection) (rule ext, rule ext, rule sym, rule eq_equals)
-
-declare eq [code unfold, code inline del]
-
-declare equals_eq [symmetric, code post]
-
-end
-
-declare simp_thms(6) [code nbe]
-
-hide (open) const eq
-hide const eq
-
-setup {*
-  Code_Unit.add_const_alias @{thm equals_eq}
-*}
-
-text {* Cases *}
-
-lemma Let_case_cert:
-  assumes "CASE \<equiv> (\<lambda>x. Let x f)"
-  shows "CASE x \<equiv> f x"
-  using assms by simp_all
-
-lemma If_case_cert:
-  assumes "CASE \<equiv> (\<lambda>b. If b f g)"
-  shows "(CASE True \<equiv> f) &&& (CASE False \<equiv> g)"
-  using assms by simp_all
-
-setup {*
-  Code.add_case @{thm Let_case_cert}
-  #> Code.add_case @{thm If_case_cert}
-  #> Code.add_undefined @{const_name undefined}
-*}
-
-code_abort undefined
-
-
-subsection {* Generic code generator preprocessor *}
-
-setup {*
-  Code.map_pre (K HOL_basic_ss)
-  #> Code.map_post (K HOL_basic_ss)
-*}
-
-
-subsection {* Generic code generator target languages *}
-
-text {* type bool *}
-
-code_type bool
-  (SML "bool")
-  (OCaml "bool")
-  (Haskell "Bool")
-
-code_const True and False and Not and "op &" and "op |" and If
-  (SML "true" and "false" and "not"
-    and infixl 1 "andalso" and infixl 0 "orelse"
-    and "!(if (_)/ then (_)/ else (_))")
-  (OCaml "true" and "false" and "not"
-    and infixl 4 "&&" and infixl 2 "||"
-    and "!(if (_)/ then (_)/ else (_))")
-  (Haskell "True" and "False" and "not"
-    and infixl 3 "&&" and infixl 2 "||"
-    and "!(if (_)/ then (_)/ else (_))")
-
-code_reserved SML
-  bool true false not
-
-code_reserved OCaml
-  bool not
-
-text {* using built-in Haskell equality *}
-
-code_class eq
-  (Haskell "Eq")
-
-code_const "eq_class.eq"
-  (Haskell infixl 4 "==")
-
-code_const "op ="
-  (Haskell infixl 4 "==")
-
-text {* undefined *}
-
-code_const undefined
-  (SML "!(raise/ Fail/ \"undefined\")")
-  (OCaml "failwith/ \"undefined\"")
-  (Haskell "error/ \"undefined\"")
-
-
-subsection {* SML code generator setup *}
-
-types_code
-  "bool"  ("bool")
-attach (term_of) {*
-fun term_of_bool b = if b then HOLogic.true_const else HOLogic.false_const;
-*}
-attach (test) {*
-fun gen_bool i =
-  let val b = one_of [false, true]
-  in (b, fn () => term_of_bool b) end;
-*}
-  "prop"  ("bool")
-attach (term_of) {*
-fun term_of_prop b =
-  HOLogic.mk_Trueprop (if b then HOLogic.true_const else HOLogic.false_const);
-*}
-
-consts_code
-  "Trueprop" ("(_)")
-  "True"    ("true")
-  "False"   ("false")
-  "Not"     ("Bool.not")
-  "op |"    ("(_ orelse/ _)")
-  "op &"    ("(_ andalso/ _)")
-  "If"      ("(if _/ then _/ else _)")
-
-setup {*
-let
-
-fun eq_codegen thy defs dep thyname b t gr =
-    (case strip_comb t of
-       (Const ("op =", Type (_, [Type ("fun", _), _])), _) => NONE
-     | (Const ("op =", _), [t, u]) =>
-          let
-            val (pt, gr') = Codegen.invoke_codegen thy defs dep thyname false t gr;
-            val (pu, gr'') = Codegen.invoke_codegen thy defs dep thyname false u gr';
-            val (_, gr''') = Codegen.invoke_tycodegen thy defs dep thyname false HOLogic.boolT gr'';
-          in
-            SOME (Codegen.parens
-              (Pretty.block [pt, Codegen.str " =", Pretty.brk 1, pu]), gr''')
-          end
-     | (t as Const ("op =", _), ts) => SOME (Codegen.invoke_codegen
-         thy defs dep thyname b (Codegen.eta_expand t ts 2) gr)
-     | _ => NONE);
-
-in
-  Codegen.add_codegen "eq_codegen" eq_codegen
-end
-*}
-
-
-subsection {* Evaluation and normalization by evaluation *}
-
-setup {*
-  Value.add_evaluator ("SML", Codegen.eval_term o ProofContext.theory_of)
-*}
-
-ML {*
-structure Eval_Method =
-struct
-
-val eval_ref : (unit -> bool) option ref = ref NONE;
-
-end;
-*}
-
-oracle eval_oracle = {* fn ct =>
-  let
-    val thy = Thm.theory_of_cterm ct;
-    val t = Thm.term_of ct;
-    val dummy = @{cprop True};
-  in case try HOLogic.dest_Trueprop t
-   of SOME t' => if Code_ML.eval_term
-         ("Eval_Method.eval_ref", Eval_Method.eval_ref) thy t' [] 
-       then Thm.capply (Thm.capply @{cterm "op \<equiv> \<Colon> prop \<Rightarrow> prop \<Rightarrow> prop"} ct) dummy
-       else dummy
-    | NONE => dummy
-  end
-*}
-
-ML {*
-fun gen_eval_method conv ctxt = SIMPLE_METHOD'
-  (CONVERSION (Conv.params_conv (~1) (K (Conv.concl_conv (~1) conv)) ctxt)
-    THEN' rtac TrueI)
-*}
-
-method_setup eval = {* Scan.succeed (gen_eval_method eval_oracle) *}
-  "solve goal by evaluation"
-
-method_setup evaluation = {* Scan.succeed (gen_eval_method Codegen.evaluation_conv) *}
-  "solve goal by evaluation"
-
-method_setup normalization = {*
-  Scan.succeed (K (SIMPLE_METHOD' (CONVERSION Nbe.norm_conv THEN' (fn k => TRY (rtac TrueI k)))))
-*} "solve goal by normalization"
-
-
-subsection {* Quickcheck *}
-
-setup {*
-  Quickcheck.add_generator ("SML", Codegen.test_term)
-*}
-
-quickcheck_params [size = 5, iterations = 50]
-
-end

--- a/src/HOL/Complex.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Complex.thy	Fri May 15 15:56:28 2009 +0200
@@ -157,23 +157,6 @@
 end
 
 
-subsection {* Exponentiation *}
-
-instantiation complex :: recpower
-begin
-
-primrec power_complex where
-  "z ^ 0     = (1\<Colon>complex)"
-| "z ^ Suc n = (z\<Colon>complex) * z ^ n"
-
-instance proof
-qed simp_all
-
-declare power_complex.simps [simp del]
-
-end
-
-
 subsection {* Numerals and Arithmetic *}
 
 instantiation complex :: number_ring

--- a/src/HOL/Decision_Procs/Approximation.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Decision_Procs/Approximation.thy	Fri May 15 15:56:28 2009 +0200
@@ -10,7 +10,7 @@
 
 subsection {* Define auxiliary helper @{text horner} function *}
 
-fun horner :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> real \<Rightarrow> real" where
+primrec horner :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> real \<Rightarrow> real" where
 "horner F G 0 i k x       = 0" |
 "horner F G (Suc n) i k x = 1 / real k - x * horner F G n (F i) (G i k) x"
 
@@ -23,8 +23,8 @@
 qed
 
 lemma horner_schema: fixes f :: "nat \<Rightarrow> nat" and G :: "nat \<Rightarrow> nat \<Rightarrow> nat" and F :: "nat \<Rightarrow> nat"
-  assumes f_Suc: "\<And>n. f (Suc n) = G ((F^n) s) (f n)"
-  shows "horner F G n ((F^j') s) (f j') x = (\<Sum> j = 0..< n. -1^j * (1 / real (f (j' + j))) * x^j)"
+  assumes f_Suc: "\<And>n. f (Suc n) = G ((F ^^ n) s) (f n)"
+  shows "horner F G n ((F ^^ j') s) (f j') x = (\<Sum> j = 0..< n. -1 ^ j * (1 / real (f (j' + j))) * x ^ j)"
 proof (induct n arbitrary: i k j')
   case (Suc n)
 
@@ -33,32 +33,32 @@
 qed auto
 
 lemma horner_bounds':
-  assumes "0 \<le> Ifloat x" and f_Suc: "\<And>n. f (Suc n) = G ((F^n) s) (f n)"
+  assumes "0 \<le> real x" and f_Suc: "\<And>n. f (Suc n) = G ((F ^^ n) s) (f n)"
   and lb_0: "\<And> i k x. lb 0 i k x = 0"
   and lb_Suc: "\<And> n i k x. lb (Suc n) i k x = lapprox_rat prec 1 (int k) - x * (ub n (F i) (G i k) x)"
   and ub_0: "\<And> i k x. ub 0 i k x = 0"
   and ub_Suc: "\<And> n i k x. ub (Suc n) i k x = rapprox_rat prec 1 (int k) - x * (lb n (F i) (G i k) x)"
-  shows "Ifloat (lb n ((F^j') s) (f j') x) \<le> horner F G n ((F^j') s) (f j') (Ifloat x) \<and> 
-         horner F G n ((F^j') s) (f j') (Ifloat x) \<le> Ifloat (ub n ((F^j') s) (f j') x)"
+  shows "real (lb n ((F ^^ j') s) (f j') x) \<le> horner F G n ((F ^^ j') s) (f j') (real x) \<and> 
+         horner F G n ((F ^^ j') s) (f j') (real x) \<le> real (ub n ((F ^^ j') s) (f j') x)"
   (is "?lb n j' \<le> ?horner n j' \<and> ?horner n j' \<le> ?ub n j'")
 proof (induct n arbitrary: j')
   case 0 thus ?case unfolding lb_0 ub_0 horner.simps by auto
 next
   case (Suc n)
-  have "?lb (Suc n) j' \<le> ?horner (Suc n) j'" unfolding lb_Suc ub_Suc horner.simps Ifloat_sub diff_def
+  have "?lb (Suc n) j' \<le> ?horner (Suc n) j'" unfolding lb_Suc ub_Suc horner.simps real_of_float_sub diff_def
   proof (rule add_mono)
-    show "Ifloat (lapprox_rat prec 1 (int (f j'))) \<le> 1 / real (f j')" using lapprox_rat[of prec 1  "int (f j')"] by auto
-    from Suc[where j'="Suc j'", unfolded funpow.simps comp_def f_Suc, THEN conjunct2] `0 \<le> Ifloat x`
-    show "- Ifloat (x * ub n (F ((F ^ j') s)) (G ((F ^ j') s) (f j')) x) \<le> - (Ifloat x * horner F G n (F ((F ^ j') s)) (G ((F ^ j') s) (f j')) (Ifloat x))"
-      unfolding Ifloat_mult neg_le_iff_le by (rule mult_left_mono)
+    show "real (lapprox_rat prec 1 (int (f j'))) \<le> 1 / real (f j')" using lapprox_rat[of prec 1  "int (f j')"] by auto
+    from Suc[where j'="Suc j'", unfolded funpow.simps comp_def f_Suc, THEN conjunct2] `0 \<le> real x`
+    show "- real (x * ub n (F ((F ^^ j') s)) (G ((F ^^ j') s) (f j')) x) \<le> - (real x * horner F G n (F ((F ^^ j') s)) (G ((F ^^ j') s) (f j')) (real x))"
+      unfolding real_of_float_mult neg_le_iff_le by (rule mult_left_mono)
   qed
-  moreover have "?horner (Suc n) j' \<le> ?ub (Suc n) j'" unfolding ub_Suc ub_Suc horner.simps Ifloat_sub diff_def
+  moreover have "?horner (Suc n) j' \<le> ?ub (Suc n) j'" unfolding ub_Suc ub_Suc horner.simps real_of_float_sub diff_def
   proof (rule add_mono)
-    show "1 / real (f j') \<le> Ifloat (rapprox_rat prec 1 (int (f j')))" using rapprox_rat[of 1 "int (f j')" prec] by auto
-    from Suc[where j'="Suc j'", unfolded funpow.simps comp_def f_Suc, THEN conjunct1] `0 \<le> Ifloat x`
-    show "- (Ifloat x * horner F G n (F ((F ^ j') s)) (G ((F ^ j') s) (f j')) (Ifloat x)) \<le> 
-          - Ifloat (x * lb n (F ((F ^ j') s)) (G ((F ^ j') s) (f j')) x)"
-      unfolding Ifloat_mult neg_le_iff_le by (rule mult_left_mono)
+    show "1 / real (f j') \<le> real (rapprox_rat prec 1 (int (f j')))" using rapprox_rat[of 1 "int (f j')" prec] by auto
+    from Suc[where j'="Suc j'", unfolded funpow.simps comp_def f_Suc, THEN conjunct1] `0 \<le> real x`
+    show "- (real x * horner F G n (F ((F ^^ j') s)) (G ((F ^^ j') s) (f j')) (real x)) \<le> 
+          - real (x * lb n (F ((F ^^ j') s)) (G ((F ^^ j') s) (f j')) x)"
+      unfolding real_of_float_mult neg_le_iff_le by (rule mult_left_mono)
   qed
   ultimately show ?case by blast
 qed
@@ -73,48 +73,48 @@
 *}
 
 lemma horner_bounds: fixes F :: "nat \<Rightarrow> nat" and G :: "nat \<Rightarrow> nat \<Rightarrow> nat"
-  assumes "0 \<le> Ifloat x" and f_Suc: "\<And>n. f (Suc n) = G ((F^n) s) (f n)"
+  assumes "0 \<le> real x" and f_Suc: "\<And>n. f (Suc n) = G ((F ^^ n) s) (f n)"
   and lb_0: "\<And> i k x. lb 0 i k x = 0"
   and lb_Suc: "\<And> n i k x. lb (Suc n) i k x = lapprox_rat prec 1 (int k) - x * (ub n (F i) (G i k) x)"
   and ub_0: "\<And> i k x. ub 0 i k x = 0"
   and ub_Suc: "\<And> n i k x. ub (Suc n) i k x = rapprox_rat prec 1 (int k) - x * (lb n (F i) (G i k) x)"
-  shows "Ifloat (lb n ((F^j') s) (f j') x) \<le> (\<Sum>j=0..<n. -1^j * (1 / real (f (j' + j))) * (Ifloat x)^j)" (is "?lb") and 
-        "(\<Sum>j=0..<n. -1^j * (1 / real (f (j' + j))) * (Ifloat x)^j) \<le> Ifloat (ub n ((F^j') s) (f j') x)" (is "?ub")
+  shows "real (lb n ((F ^^ j') s) (f j') x) \<le> (\<Sum>j=0..<n. -1 ^ j * (1 / real (f (j' + j))) * real x ^ j)" (is "?lb") and 
+    "(\<Sum>j=0..<n. -1 ^ j * (1 / real (f (j' + j))) * (real x ^ j)) \<le> real (ub n ((F ^^ j') s) (f j') x)" (is "?ub")
 proof -
   have "?lb  \<and> ?ub" 
-    using horner_bounds'[where lb=lb, OF `0 \<le> Ifloat x` f_Suc lb_0 lb_Suc ub_0 ub_Suc]
+    using horner_bounds'[where lb=lb, OF `0 \<le> real x` f_Suc lb_0 lb_Suc ub_0 ub_Suc]
     unfolding horner_schema[where f=f, OF f_Suc] .
   thus "?lb" and "?ub" by auto
 qed
 
 lemma horner_bounds_nonpos: fixes F :: "nat \<Rightarrow> nat" and G :: "nat \<Rightarrow> nat \<Rightarrow> nat"
-  assumes "Ifloat x \<le> 0" and f_Suc: "\<And>n. f (Suc n) = G ((F^n) s) (f n)"
+  assumes "real x \<le> 0" and f_Suc: "\<And>n. f (Suc n) = G ((F ^^ n) s) (f n)"
   and lb_0: "\<And> i k x. lb 0 i k x = 0"
   and lb_Suc: "\<And> n i k x. lb (Suc n) i k x = lapprox_rat prec 1 (int k) + x * (ub n (F i) (G i k) x)"
   and ub_0: "\<And> i k x. ub 0 i k x = 0"
   and ub_Suc: "\<And> n i k x. ub (Suc n) i k x = rapprox_rat prec 1 (int k) + x * (lb n (F i) (G i k) x)"
-  shows "Ifloat (lb n ((F^j') s) (f j') x) \<le> (\<Sum>j=0..<n. (1 / real (f (j' + j))) * (Ifloat x)^j)" (is "?lb") and 
-        "(\<Sum>j=0..<n. (1 / real (f (j' + j))) * (Ifloat x)^j) \<le> Ifloat (ub n ((F^j') s) (f j') x)" (is "?ub")
+  shows "real (lb n ((F ^^ j') s) (f j') x) \<le> (\<Sum>j=0..<n. (1 / real (f (j' + j))) * real x ^ j)" (is "?lb") and 
+    "(\<Sum>j=0..<n. (1 / real (f (j' + j))) * (real x ^ j)) \<le> real (ub n ((F ^^ j') s) (f j') x)" (is "?ub")
 proof -
   { fix x y z :: float have "x - y * z = x + - y * z"
-      by (cases x, cases y, cases z, simp add: plus_float.simps minus_float.simps uminus_float.simps times_float.simps algebra_simps)
+      by (cases x, cases y, cases z, simp add: plus_float.simps minus_float_def uminus_float.simps times_float.simps algebra_simps)
   } note diff_mult_minus = this
 
   { fix x :: float have "- (- x) = x" by (cases x, auto simp add: uminus_float.simps) } note minus_minus = this
 
-  have move_minus: "Ifloat (-x) = -1 * Ifloat x" by auto
+  have move_minus: "real (-x) = -1 * real x" by auto
 
-  have sum_eq: "(\<Sum>j=0..<n. (1 / real (f (j' + j))) * (Ifloat x)^j) = 
-    (\<Sum>j = 0..<n. -1 ^ j * (1 / real (f (j' + j))) * Ifloat (- x) ^ j)"
+  have sum_eq: "(\<Sum>j=0..<n. (1 / real (f (j' + j))) * real x ^ j) = 
+    (\<Sum>j = 0..<n. -1 ^ j * (1 / real (f (j' + j))) * real (- x) ^ j)"
   proof (rule setsum_cong, simp)
     fix j assume "j \<in> {0 ..< n}"
-    show "1 / real (f (j' + j)) * Ifloat x ^ j = -1 ^ j * (1 / real (f (j' + j))) * Ifloat (- x) ^ j"
+    show "1 / real (f (j' + j)) * real x ^ j = -1 ^ j * (1 / real (f (j' + j))) * real (- x) ^ j"
       unfolding move_minus power_mult_distrib real_mult_assoc[symmetric]
-      unfolding real_mult_commute unfolding real_mult_assoc[of "-1^j", symmetric] power_mult_distrib[symmetric]
+      unfolding real_mult_commute unfolding real_mult_assoc[of "-1 ^ j", symmetric] power_mult_distrib[symmetric]
       by auto
   qed
 
-  have "0 \<le> Ifloat (-x)" using assms by auto
+  have "0 \<le> real (-x)" using assms by auto
   from horner_bounds[where G=G and F=F and f=f and s=s and prec=prec
     and lb="\<lambda> n i k x. lb n i k (-x)" and ub="\<lambda> n i k x. ub n i k (-x)", unfolded lb_Suc ub_Suc diff_mult_minus,
     OF this f_Suc lb_0 refl ub_0 refl]
@@ -159,34 +159,34 @@
                       else if u < 0         then (u ^ n, l ^ n)
                                             else (0, (max (-l) u) ^ n))"
 
-lemma float_power_bnds: assumes "(l1, u1) = float_power_bnds n l u" and "x \<in> {Ifloat l .. Ifloat u}"
-  shows "x^n \<in> {Ifloat l1..Ifloat u1}"
+lemma float_power_bnds: assumes "(l1, u1) = float_power_bnds n l u" and "x \<in> {real l .. real u}"
+  shows "x ^ n \<in> {real l1..real u1}"
 proof (cases "even n")
   case True 
   show ?thesis
   proof (cases "0 < l")
-    case True hence "odd n \<or> 0 < l" and "0 \<le> Ifloat l" unfolding less_float_def by auto
+    case True hence "odd n \<or> 0 < l" and "0 \<le> real l" unfolding less_float_def by auto
     have u1: "u1 = u ^ n" and l1: "l1 = l ^ n" using assms unfolding float_power_bnds_def if_P[OF `odd n \<or> 0 < l`] by auto
-    have "Ifloat l^n \<le> x^n" and "x^n \<le> Ifloat u^n " using `0 \<le> Ifloat l` and assms unfolding atLeastAtMost_iff using power_mono[of "Ifloat l" x] power_mono[of x "Ifloat u"] by auto
+    have "real l ^ n \<le> x ^ n" and "x ^ n \<le> real u ^ n " using `0 \<le> real l` and assms unfolding atLeastAtMost_iff using power_mono[of "real l" x] power_mono[of x "real u"] by auto
     thus ?thesis using assms `0 < l` unfolding atLeastAtMost_iff l1 u1 float_power less_float_def by auto
   next
     case False hence P: "\<not> (odd n \<or> 0 < l)" using `even n` by auto
     show ?thesis
     proof (cases "u < 0")
-      case True hence "0 \<le> - Ifloat u" and "- Ifloat u \<le> - x" and "0 \<le> - x" and "-x \<le> - Ifloat l" using assms unfolding less_float_def by auto
-      hence "Ifloat u^n \<le> x^n" and "x^n \<le> Ifloat l^n" using power_mono[of  "-x" "-Ifloat l" n] power_mono[of "-Ifloat u" "-x" n] 
+      case True hence "0 \<le> - real u" and "- real u \<le> - x" and "0 \<le> - x" and "-x \<le> - real l" using assms unfolding less_float_def by auto
+      hence "real u ^ n \<le> x ^ n" and "x ^ n \<le> real l ^ n" using power_mono[of  "-x" "-real l" n] power_mono[of "-real u" "-x" n] 
 	unfolding power_minus_even[OF `even n`] by auto
       moreover have u1: "u1 = l ^ n" and l1: "l1 = u ^ n" using assms unfolding float_power_bnds_def if_not_P[OF P] if_P[OF True] by auto
       ultimately show ?thesis using float_power by auto
     next
       case False 
-      have "\<bar>x\<bar> \<le> Ifloat (max (-l) u)"
+      have "\<bar>x\<bar> \<le> real (max (-l) u)"
       proof (cases "-l \<le> u")
 	case True thus ?thesis unfolding max_def if_P[OF True] using assms unfolding le_float_def by auto
       next
 	case False thus ?thesis unfolding max_def if_not_P[OF False] using assms unfolding le_float_def by auto
       qed
-      hence x_abs: "\<bar>x\<bar> \<le> \<bar>Ifloat (max (-l) u)\<bar>" by auto
+      hence x_abs: "\<bar>x\<bar> \<le> \<bar>real (max (-l) u)\<bar>" by auto
       have u1: "u1 = (max (-l) u) ^ n" and l1: "l1 = 0" using assms unfolding float_power_bnds_def if_not_P[OF P] if_not_P[OF False] by auto
       show ?thesis unfolding atLeastAtMost_iff l1 u1 float_power using zero_le_even_power[OF `even n`] power_mono_even[OF `even n` x_abs] by auto
     qed
@@ -194,11 +194,11 @@
 next
   case False hence "odd n \<or> 0 < l" by auto
   have u1: "u1 = u ^ n" and l1: "l1 = l ^ n" using assms unfolding float_power_bnds_def if_P[OF `odd n \<or> 0 < l`] by auto
-  have "Ifloat l^n \<le> x^n" and "x^n \<le> Ifloat u^n " using assms unfolding atLeastAtMost_iff using power_mono_odd[OF False] by auto
+  have "real l ^ n \<le> x ^ n" and "x ^ n \<le> real u ^ n " using assms unfolding atLeastAtMost_iff using power_mono_odd[OF False] by auto
   thus ?thesis unfolding atLeastAtMost_iff l1 u1 float_power less_float_def by auto
 qed
 
-lemma bnds_power: "\<forall> x l u. (l1, u1) = float_power_bnds n l u \<and> x \<in> {Ifloat l .. Ifloat u} \<longrightarrow> Ifloat l1 \<le> x^n \<and> x^n \<le> Ifloat u1"
+lemma bnds_power: "\<forall> x l u. (l1, u1) = float_power_bnds n l u \<and> x \<in> {real l .. real u} \<longrightarrow> real l1 \<le> x ^ n \<and> x ^ n \<le> real u1"
   using float_power_bnds by auto
 
 section "Square root"
@@ -234,8 +234,8 @@
   thus ?thesis by (simp add: field_simps)
 qed
 
-lemma sqrt_iteration_bound: assumes "0 < Ifloat x"
-  shows "sqrt (Ifloat x) < Ifloat (sqrt_iteration prec n x)"
+lemma sqrt_iteration_bound: assumes "0 < real x"
+  shows "sqrt (real x) < real (sqrt_iteration prec n x)"
 proof (induct n)
   case 0
   show ?case
@@ -246,14 +246,14 @@
 
     have int_nat_bl: "int (nat (bitlen m)) = bitlen m" using bitlen_ge0 by auto
 
-    have "Ifloat x = (real m / 2^nat (bitlen m)) * pow2 (e + int (nat (bitlen m)))"
-      unfolding pow2_add pow2_int Float Ifloat.simps by auto
+    have "real x = (real m / 2^nat (bitlen m)) * pow2 (e + int (nat (bitlen m)))"
+      unfolding pow2_add pow2_int Float real_of_float_simp by auto
     also have "\<dots> < 1 * pow2 (e + int (nat (bitlen m)))"
     proof (rule mult_strict_right_mono, auto)
       show "real m < 2^nat (bitlen m)" using bitlen_bounds[OF `0 < m`, THEN conjunct2] 
 	unfolding real_of_int_less_iff[of m, symmetric] by auto
     qed
-    finally have "sqrt (Ifloat x) < sqrt (pow2 (e + bitlen m))" unfolding int_nat_bl by auto
+    finally have "sqrt (real x) < sqrt (pow2 (e + bitlen m))" unfolding int_nat_bl by auto
     also have "\<dots> \<le> pow2 ((e + bitlen m) div 2 + 1)"
     proof -
       let ?E = "e + bitlen m"
@@ -283,110 +283,110 @@
       finally show ?thesis by auto
     qed
     finally show ?thesis 
-      unfolding Float sqrt_iteration.simps Ifloat.simps by auto
+      unfolding Float sqrt_iteration.simps real_of_float_simp by auto
   qed
 next
   case (Suc n)
   let ?b = "sqrt_iteration prec n x"
-  have "0 < sqrt (Ifloat x)" using `0 < Ifloat x` by auto
-  also have "\<dots> < Ifloat ?b" using Suc .
-  finally have "sqrt (Ifloat x) < (Ifloat ?b + Ifloat x / Ifloat ?b)/2" using sqrt_ub_pos_pos_1[OF Suc _ `0 < Ifloat x`] by auto
-  also have "\<dots> \<le> (Ifloat ?b + Ifloat (float_divr prec x ?b))/2" by (rule divide_right_mono, auto simp add: float_divr)
-  also have "\<dots> = Ifloat (Float 1 -1) * (Ifloat ?b + Ifloat (float_divr prec x ?b))" by auto
-  finally show ?case unfolding sqrt_iteration.simps Let_def Ifloat_mult Ifloat_add right_distrib .
+  have "0 < sqrt (real x)" using `0 < real x` by auto
+  also have "\<dots> < real ?b" using Suc .
+  finally have "sqrt (real x) < (real ?b + real x / real ?b)/2" using sqrt_ub_pos_pos_1[OF Suc _ `0 < real x`] by auto
+  also have "\<dots> \<le> (real ?b + real (float_divr prec x ?b))/2" by (rule divide_right_mono, auto simp add: float_divr)
+  also have "\<dots> = real (Float 1 -1) * (real ?b + real (float_divr prec x ?b))" by auto
+  finally show ?case unfolding sqrt_iteration.simps Let_def real_of_float_mult real_of_float_add right_distrib .
 qed
 
-lemma sqrt_iteration_lower_bound: assumes "0 < Ifloat x"
-  shows "0 < Ifloat (sqrt_iteration prec n x)" (is "0 < ?sqrt")
+lemma sqrt_iteration_lower_bound: assumes "0 < real x"
+  shows "0 < real (sqrt_iteration prec n x)" (is "0 < ?sqrt")
 proof -
-  have "0 < sqrt (Ifloat x)" using assms by auto
+  have "0 < sqrt (real x)" using assms by auto
   also have "\<dots> < ?sqrt" using sqrt_iteration_bound[OF assms] .
   finally show ?thesis .
 qed
 
-lemma lb_sqrt_lower_bound: assumes "0 \<le> Ifloat x"
-  shows "0 \<le> Ifloat (the (lb_sqrt prec x))"
+lemma lb_sqrt_lower_bound: assumes "0 \<le> real x"
+  shows "0 \<le> real (the (lb_sqrt prec x))"
 proof (cases "0 < x")
-  case True hence "0 < Ifloat x" and "0 \<le> x" using `0 \<le> Ifloat x` unfolding less_float_def le_float_def by auto
+  case True hence "0 < real x" and "0 \<le> x" using `0 \<le> real x` unfolding less_float_def le_float_def by auto
   hence "0 < sqrt_iteration prec prec x" unfolding less_float_def using sqrt_iteration_lower_bound by auto 
-  hence "0 \<le> Ifloat (float_divl prec x (sqrt_iteration prec prec x))" using float_divl_lower_bound[OF `0 \<le> x`] unfolding le_float_def by auto
+  hence "0 \<le> real (float_divl prec x (sqrt_iteration prec prec x))" using float_divl_lower_bound[OF `0 \<le> x`] unfolding le_float_def by auto
   thus ?thesis unfolding lb_sqrt_def using True by auto
 next
-  case False with `0 \<le> Ifloat x` have "Ifloat x = 0" unfolding less_float_def by auto
+  case False with `0 \<le> real x` have "real x = 0" unfolding less_float_def by auto
   thus ?thesis unfolding lb_sqrt_def less_float_def by auto
 qed
 
-lemma lb_sqrt_upper_bound: assumes "0 \<le> Ifloat x"
-  shows "Ifloat (the (lb_sqrt prec x)) \<le> sqrt (Ifloat x)"
+lemma lb_sqrt_upper_bound: assumes "0 \<le> real x"
+  shows "real (the (lb_sqrt prec x)) \<le> sqrt (real x)"
 proof (cases "0 < x")
-  case True hence "0 < Ifloat x" and "0 \<le> Ifloat x" unfolding less_float_def by auto
-  hence sqrt_gt0: "0 < sqrt (Ifloat x)" by auto
-  hence sqrt_ub: "sqrt (Ifloat x) < Ifloat (sqrt_iteration prec prec x)" using sqrt_iteration_bound by auto
+  case True hence "0 < real x" and "0 \<le> real x" unfolding less_float_def by auto
+  hence sqrt_gt0: "0 < sqrt (real x)" by auto
+  hence sqrt_ub: "sqrt (real x) < real (sqrt_iteration prec prec x)" using sqrt_iteration_bound by auto
   
-  have "Ifloat (float_divl prec x (sqrt_iteration prec prec x)) \<le> Ifloat x / Ifloat (sqrt_iteration prec prec x)" by (rule float_divl)
-  also have "\<dots> < Ifloat x / sqrt (Ifloat x)" 
-    by (rule divide_strict_left_mono[OF sqrt_ub `0 < Ifloat x` mult_pos_pos[OF order_less_trans[OF sqrt_gt0 sqrt_ub] sqrt_gt0]])
-  also have "\<dots> = sqrt (Ifloat x)" unfolding inverse_eq_iff_eq[of _ "sqrt (Ifloat x)", symmetric] sqrt_divide_self_eq[OF `0 \<le> Ifloat x`, symmetric] by auto
+  have "real (float_divl prec x (sqrt_iteration prec prec x)) \<le> real x / real (sqrt_iteration prec prec x)" by (rule float_divl)
+  also have "\<dots> < real x / sqrt (real x)" 
+    by (rule divide_strict_left_mono[OF sqrt_ub `0 < real x` mult_pos_pos[OF order_less_trans[OF sqrt_gt0 sqrt_ub] sqrt_gt0]])
+  also have "\<dots> = sqrt (real x)" unfolding inverse_eq_iff_eq[of _ "sqrt (real x)", symmetric] sqrt_divide_self_eq[OF `0 \<le> real x`, symmetric] by auto
   finally show ?thesis unfolding lb_sqrt_def if_P[OF `0 < x`] by auto
 next
-  case False with `0 \<le> Ifloat x`
+  case False with `0 \<le> real x`
   have "\<not> x < 0" unfolding less_float_def le_float_def by auto
   show ?thesis unfolding lb_sqrt_def if_not_P[OF False] if_not_P[OF `\<not> x < 0`] using assms by auto
 qed
 
 lemma lb_sqrt: assumes "Some y = lb_sqrt prec x"
-  shows "Ifloat y \<le> sqrt (Ifloat x)" and "0 \<le> Ifloat x"
+  shows "real y \<le> sqrt (real x)" and "0 \<le> real x"
 proof -
-  show "0 \<le> Ifloat x"
+  show "0 \<le> real x"
   proof (rule ccontr)
-    assume "\<not> 0 \<le> Ifloat x"
+    assume "\<not> 0 \<le> real x"
     hence "lb_sqrt prec x = None" unfolding lb_sqrt_def less_float_def by auto
     thus False using assms by auto
   qed
   from lb_sqrt_upper_bound[OF this, of prec]
-  show "Ifloat y \<le> sqrt (Ifloat x)" unfolding assms[symmetric] by auto
+  show "real y \<le> sqrt (real x)" unfolding assms[symmetric] by auto
 qed
 
-lemma ub_sqrt_lower_bound: assumes "0 \<le> Ifloat x"
-  shows "sqrt (Ifloat x) \<le> Ifloat (the (ub_sqrt prec x))"
+lemma ub_sqrt_lower_bound: assumes "0 \<le> real x"
+  shows "sqrt (real x) \<le> real (the (ub_sqrt prec x))"
 proof (cases "0 < x")
-  case True hence "0 < Ifloat x" unfolding less_float_def by auto
-  hence "0 < sqrt (Ifloat x)" by auto
-  hence "sqrt (Ifloat x) < Ifloat (sqrt_iteration prec prec x)" using sqrt_iteration_bound by auto
+  case True hence "0 < real x" unfolding less_float_def by auto
+  hence "0 < sqrt (real x)" by auto
+  hence "sqrt (real x) < real (sqrt_iteration prec prec x)" using sqrt_iteration_bound by auto
   thus ?thesis unfolding ub_sqrt_def if_P[OF `0 < x`] by auto
 next
-  case False with `0 \<le> Ifloat x`
-  have "Ifloat x = 0" unfolding less_float_def le_float_def by auto
+  case False with `0 \<le> real x`
+  have "real x = 0" unfolding less_float_def le_float_def by auto
   thus ?thesis unfolding ub_sqrt_def less_float_def le_float_def by auto
 qed
 
 lemma ub_sqrt: assumes "Some y = ub_sqrt prec x"
-  shows "sqrt (Ifloat x) \<le> Ifloat y" and "0 \<le> Ifloat x"
+  shows "sqrt (real x) \<le> real y" and "0 \<le> real x"
 proof -
-  show "0 \<le> Ifloat x"
+  show "0 \<le> real x"
   proof (rule ccontr)
-    assume "\<not> 0 \<le> Ifloat x"
+    assume "\<not> 0 \<le> real x"
     hence "ub_sqrt prec x = None" unfolding ub_sqrt_def less_float_def by auto
     thus False using assms by auto
   qed
   from ub_sqrt_lower_bound[OF this, of prec]
-  show "sqrt (Ifloat x) \<le> Ifloat y" unfolding assms[symmetric] by auto
+  show "sqrt (real x) \<le> real y" unfolding assms[symmetric] by auto
 qed
 
-lemma bnds_sqrt: "\<forall> x lx ux. (Some l, Some u) = (lb_sqrt prec lx, ub_sqrt prec ux) \<and> x \<in> {Ifloat lx .. Ifloat ux} \<longrightarrow> Ifloat l \<le> sqrt x \<and> sqrt x \<le> Ifloat u"
+lemma bnds_sqrt: "\<forall> x lx ux. (Some l, Some u) = (lb_sqrt prec lx, ub_sqrt prec ux) \<and> x \<in> {real lx .. real ux} \<longrightarrow> real l \<le> sqrt x \<and> sqrt x \<le> real u"
 proof (rule allI, rule allI, rule allI, rule impI)
   fix x lx ux
-  assume "(Some l, Some u) = (lb_sqrt prec lx, ub_sqrt prec ux) \<and> x \<in> {Ifloat lx .. Ifloat ux}"
-  hence l: "Some l = lb_sqrt prec lx " and u: "Some u = ub_sqrt prec ux" and x: "x \<in> {Ifloat lx .. Ifloat ux}" by auto
+  assume "(Some l, Some u) = (lb_sqrt prec lx, ub_sqrt prec ux) \<and> x \<in> {real lx .. real ux}"
+  hence l: "Some l = lb_sqrt prec lx " and u: "Some u = ub_sqrt prec ux" and x: "x \<in> {real lx .. real ux}" by auto
   
-  have "Ifloat lx \<le> x" and "x \<le> Ifloat ux" using x by auto
+  have "real lx \<le> x" and "x \<le> real ux" using x by auto
 
-  from lb_sqrt(1)[OF l] real_sqrt_le_mono[OF `Ifloat lx \<le> x`]
-  have "Ifloat l \<le> sqrt x" by (rule order_trans)
+  from lb_sqrt(1)[OF l] real_sqrt_le_mono[OF `real lx \<le> x`]
+  have "real l \<le> sqrt x" by (rule order_trans)
   moreover
-  from real_sqrt_le_mono[OF `x \<le> Ifloat ux`] ub_sqrt(1)[OF u]
-  have "sqrt x \<le> Ifloat u" by (rule order_trans)
-  ultimately show "Ifloat l \<le> sqrt x \<and> sqrt x \<le> Ifloat u" ..
+  from real_sqrt_le_mono[OF `x \<le> real ux`] ub_sqrt(1)[OF u]
+  have "sqrt x \<le> real u" by (rule order_trans)
+  ultimately show "real l \<le> sqrt x \<and> sqrt x \<le> real u" ..
 qed
 
 section "Arcus tangens and \<pi>"
@@ -409,24 +409,24 @@
 | "lb_arctan_horner prec (Suc n) k x = 
     (lapprox_rat prec 1 (int k)) - x * (ub_arctan_horner prec n (k + 2) x)"
 
-lemma arctan_0_1_bounds': assumes "0 \<le> Ifloat x" "Ifloat x \<le> 1" and "even n"
-  shows "arctan (Ifloat x) \<in> {Ifloat (x * lb_arctan_horner prec n 1 (x * x)) .. Ifloat (x * ub_arctan_horner prec (Suc n) 1 (x * x))}"
+lemma arctan_0_1_bounds': assumes "0 \<le> real x" "real x \<le> 1" and "even n"
+  shows "arctan (real x) \<in> {real (x * lb_arctan_horner prec n 1 (x * x)) .. real (x * ub_arctan_horner prec (Suc n) 1 (x * x))}"
 proof -
-  let "?c i" = "-1^i * (1 / real (i * 2 + 1) * Ifloat x ^ (i * 2 + 1))"
+  let "?c i" = "-1^i * (1 / real (i * 2 + 1) * real x ^ (i * 2 + 1))"
   let "?S n" = "\<Sum> i=0..<n. ?c i"
 
-  have "0 \<le> Ifloat (x * x)" by auto
+  have "0 \<le> real (x * x)" by auto
   from `even n` obtain m where "2 * m = n" unfolding even_mult_two_ex by auto
   
-  have "arctan (Ifloat x) \<in> { ?S n .. ?S (Suc n) }"
-  proof (cases "Ifloat x = 0")
+  have "arctan (real x) \<in> { ?S n .. ?S (Suc n) }"
+  proof (cases "real x = 0")
     case False
-    hence "0 < Ifloat x" using `0 \<le> Ifloat x` by auto
-    hence prem: "0 < 1 / real (0 * 2 + (1::nat)) * Ifloat x ^ (0 * 2 + 1)" by auto 
+    hence "0 < real x" using `0 \<le> real x` by auto
+    hence prem: "0 < 1 / real (0 * 2 + (1::nat)) * real x ^ (0 * 2 + 1)" by auto 
 
-    have "\<bar> Ifloat x \<bar> \<le> 1"  using `0 \<le> Ifloat x` `Ifloat x \<le> 1` by auto
+    have "\<bar> real x \<bar> \<le> 1"  using `0 \<le> real x` `real x \<le> 1` by auto
     from mp[OF summable_Leibniz(2)[OF zeroseq_arctan_series[OF this] monoseq_arctan_series[OF this]] prem, THEN spec, of m, unfolded `2 * m = n`]
-    show ?thesis unfolding arctan_series[OF `\<bar> Ifloat x \<bar> \<le> 1`] Suc_plus1  .
+    show ?thesis unfolding arctan_series[OF `\<bar> real x \<bar> \<le> 1`] Suc_plus1  .
   qed auto
   note arctan_bounds = this[unfolded atLeastAtMost_iff]
 
@@ -435,50 +435,50 @@
   note bounds = horner_bounds[where s=1 and f="\<lambda>i. 2 * i + 1" and j'=0 
     and lb="\<lambda>n i k x. lb_arctan_horner prec n k x"
     and ub="\<lambda>n i k x. ub_arctan_horner prec n k x", 
-    OF `0 \<le> Ifloat (x*x)` F lb_arctan_horner.simps ub_arctan_horner.simps]
+    OF `0 \<le> real (x*x)` F lb_arctan_horner.simps ub_arctan_horner.simps]
 
-  { have "Ifloat (x * lb_arctan_horner prec n 1 (x*x)) \<le> ?S n"
-      using bounds(1) `0 \<le> Ifloat x`
-      unfolding Ifloat_mult power_add power_one_right real_mult_assoc[symmetric] setsum_left_distrib[symmetric]
-      unfolding real_mult_commute mult_commute[of _ "2::nat"] power_mult power2_eq_square[of "Ifloat x"]
+  { have "real (x * lb_arctan_horner prec n 1 (x*x)) \<le> ?S n"
+      using bounds(1) `0 \<le> real x`
+      unfolding real_of_float_mult power_add power_one_right real_mult_assoc[symmetric] setsum_left_distrib[symmetric]
+      unfolding real_mult_commute mult_commute[of _ "2::nat"] power_mult power2_eq_square[of "real x"]
       by (auto intro!: mult_left_mono)
-    also have "\<dots> \<le> arctan (Ifloat x)" using arctan_bounds ..
-    finally have "Ifloat (x * lb_arctan_horner prec n 1 (x*x)) \<le> arctan (Ifloat x)" . }
+    also have "\<dots> \<le> arctan (real x)" using arctan_bounds ..
+    finally have "real (x * lb_arctan_horner prec n 1 (x*x)) \<le> arctan (real x)" . }
   moreover
-  { have "arctan (Ifloat x) \<le> ?S (Suc n)" using arctan_bounds ..
-    also have "\<dots> \<le> Ifloat (x * ub_arctan_horner prec (Suc n) 1 (x*x))"
-      using bounds(2)[of "Suc n"] `0 \<le> Ifloat x`
-      unfolding Ifloat_mult power_add power_one_right real_mult_assoc[symmetric] setsum_left_distrib[symmetric]
-      unfolding real_mult_commute mult_commute[of _ "2::nat"] power_mult power2_eq_square[of "Ifloat x"]
+  { have "arctan (real x) \<le> ?S (Suc n)" using arctan_bounds ..
+    also have "\<dots> \<le> real (x * ub_arctan_horner prec (Suc n) 1 (x*x))"
+      using bounds(2)[of "Suc n"] `0 \<le> real x`
+      unfolding real_of_float_mult power_add power_one_right real_mult_assoc[symmetric] setsum_left_distrib[symmetric]
+      unfolding real_mult_commute mult_commute[of _ "2::nat"] power_mult power2_eq_square[of "real x"]
       by (auto intro!: mult_left_mono)
-    finally have "arctan (Ifloat x) \<le> Ifloat (x * ub_arctan_horner prec (Suc n) 1 (x*x))" . }
+    finally have "arctan (real x) \<le> real (x * ub_arctan_horner prec (Suc n) 1 (x*x))" . }
   ultimately show ?thesis by auto
 qed
 
-lemma arctan_0_1_bounds: assumes "0 \<le> Ifloat x" "Ifloat x \<le> 1"
-  shows "arctan (Ifloat x) \<in> {Ifloat (x * lb_arctan_horner prec (get_even n) 1 (x * x)) .. Ifloat (x * ub_arctan_horner prec (get_odd n) 1 (x * x))}"
+lemma arctan_0_1_bounds: assumes "0 \<le> real x" "real x \<le> 1"
+  shows "arctan (real x) \<in> {real (x * lb_arctan_horner prec (get_even n) 1 (x * x)) .. real (x * ub_arctan_horner prec (get_odd n) 1 (x * x))}"
 proof (cases "even n")
   case True
   obtain n' where "Suc n' = get_odd n" and "odd (Suc n')" using get_odd_ex by auto
-  hence "even n'" unfolding even_nat_Suc by auto
-  have "arctan (Ifloat x) \<le> Ifloat (x * ub_arctan_horner prec (get_odd n) 1 (x * x))"
-    unfolding `Suc n' = get_odd n`[symmetric] using arctan_0_1_bounds'[OF `0 \<le> Ifloat x` `Ifloat x \<le> 1` `even n'`] by auto
+  hence "even n'" unfolding even_Suc by auto
+  have "arctan (real x) \<le> real (x * ub_arctan_horner prec (get_odd n) 1 (x * x))"
+    unfolding `Suc n' = get_odd n`[symmetric] using arctan_0_1_bounds'[OF `0 \<le> real x` `real x \<le> 1` `even n'`] by auto
   moreover
-  have "Ifloat (x * lb_arctan_horner prec (get_even n) 1 (x * x)) \<le> arctan (Ifloat x)"
-    unfolding get_even_def if_P[OF True] using arctan_0_1_bounds'[OF `0 \<le> Ifloat x` `Ifloat x \<le> 1` `even n`] by auto
+  have "real (x * lb_arctan_horner prec (get_even n) 1 (x * x)) \<le> arctan (real x)"
+    unfolding get_even_def if_P[OF True] using arctan_0_1_bounds'[OF `0 \<le> real x` `real x \<le> 1` `even n`] by auto
   ultimately show ?thesis by auto
 next
   case False hence "0 < n" by (rule odd_pos)
   from gr0_implies_Suc[OF this] obtain n' where "n = Suc n'" ..
-  from False[unfolded this even_nat_Suc]
+  from False[unfolded this even_Suc]
   have "even n'" and "even (Suc (Suc n'))" by auto
   have "get_odd n = Suc n'" unfolding get_odd_def if_P[OF False] using `n = Suc n'` .
 
-  have "arctan (Ifloat x) \<le> Ifloat (x * ub_arctan_horner prec (get_odd n) 1 (x * x))"
-    unfolding `get_odd n = Suc n'` using arctan_0_1_bounds'[OF `0 \<le> Ifloat x` `Ifloat x \<le> 1` `even n'`] by auto
+  have "arctan (real x) \<le> real (x * ub_arctan_horner prec (get_odd n) 1 (x * x))"
+    unfolding `get_odd n = Suc n'` using arctan_0_1_bounds'[OF `0 \<le> real x` `real x \<le> 1` `even n'`] by auto
   moreover
-  have "Ifloat (x * lb_arctan_horner prec (get_even n) 1 (x * x)) \<le> arctan (Ifloat x)"
-    unfolding get_even_def if_not_P[OF False] unfolding `n = Suc n'` using arctan_0_1_bounds'[OF `0 \<le> Ifloat x` `Ifloat x \<le> 1` `even (Suc (Suc n'))`] by auto
+  have "real (x * lb_arctan_horner prec (get_even n) 1 (x * x)) \<le> arctan (real x)"
+    unfolding get_even_def if_not_P[OF False] unfolding `n = Suc n'` using arctan_0_1_bounds'[OF `0 \<le> real x` `real x \<le> 1` `even (Suc (Suc n'))`] by auto
   ultimately show ?thesis by auto
 qed
 
@@ -496,7 +496,7 @@
                  in ((Float 1 2) * ((Float 1 2) * A * (lb_arctan_horner prec (get_even (prec div 4 + 1)) 1 (A * A)) - 
                                                   B * (ub_arctan_horner prec (get_odd (prec div 14 + 1)) 1 (B * B)))))"
 
-lemma pi_boundaries: "pi \<in> {Ifloat (lb_pi n) .. Ifloat (ub_pi n)}"
+lemma pi_boundaries: "pi \<in> {real (lb_pi n) .. real (ub_pi n)}"
 proof -
   have machin_pi: "pi = 4 * (4 * arctan (1 / 5) - arctan (1 / 239))" unfolding machin[symmetric] by auto
 
@@ -504,15 +504,15 @@
     let ?k = "rapprox_rat prec 1 k"
     have "1 div k = 0" using div_pos_pos_trivial[OF _ `1 < k`] by auto
       
-    have "0 \<le> Ifloat ?k" by (rule order_trans[OF _ rapprox_rat], auto simp add: `0 \<le> k`)
-    have "Ifloat ?k \<le> 1" unfolding rapprox_rat.simps(2)[OF zero_le_one `0 < k`]
+    have "0 \<le> real ?k" by (rule order_trans[OF _ rapprox_rat], auto simp add: `0 \<le> k`)
+    have "real ?k \<le> 1" unfolding rapprox_rat.simps(2)[OF zero_le_one `0 < k`]
       by (rule rapprox_posrat_le1, auto simp add: `0 < k` `1 \<le> k`)
 
-    have "1 / real k \<le> Ifloat ?k" using rapprox_rat[where x=1 and y=k] by auto
-    hence "arctan (1 / real k) \<le> arctan (Ifloat ?k)" by (rule arctan_monotone')
-    also have "\<dots> \<le> Ifloat (?k * ub_arctan_horner prec (get_odd n) 1 (?k * ?k))"
-      using arctan_0_1_bounds[OF `0 \<le> Ifloat ?k` `Ifloat ?k \<le> 1`] by auto
-    finally have "arctan (1 / (real k)) \<le> Ifloat (?k * ub_arctan_horner prec (get_odd n) 1 (?k * ?k))" .
+    have "1 / real k \<le> real ?k" using rapprox_rat[where x=1 and y=k] by auto
+    hence "arctan (1 / real k) \<le> arctan (real ?k)" by (rule arctan_monotone')
+    also have "\<dots> \<le> real (?k * ub_arctan_horner prec (get_odd n) 1 (?k * ?k))"
+      using arctan_0_1_bounds[OF `0 \<le> real ?k` `real ?k \<le> 1`] by auto
+    finally have "arctan (1 / (real k)) \<le> real (?k * ub_arctan_horner prec (get_odd n) 1 (?k * ?k))" .
   } note ub_arctan = this
 
   { fix prec n :: nat fix k :: int assume "1 < k" hence "0 \<le> k" and "0 < k" by auto
@@ -520,24 +520,24 @@
     have "1 div k = 0" using div_pos_pos_trivial[OF _ `1 < k`] by auto
     have "1 / real k \<le> 1" using `1 < k` by auto
 
-    have "\<And>n. 0 \<le> Ifloat ?k" using lapprox_rat_bottom[where x=1 and y=k, OF zero_le_one `0 < k`] by (auto simp add: `1 div k = 0`)
-    have "\<And>n. Ifloat ?k \<le> 1" using lapprox_rat by (rule order_trans, auto simp add: `1 / real k \<le> 1`)
+    have "\<And>n. 0 \<le> real ?k" using lapprox_rat_bottom[where x=1 and y=k, OF zero_le_one `0 < k`] by (auto simp add: `1 div k = 0`)
+    have "\<And>n. real ?k \<le> 1" using lapprox_rat by (rule order_trans, auto simp add: `1 / real k \<le> 1`)
 
-    have "Ifloat ?k \<le> 1 / real k" using lapprox_rat[where x=1 and y=k] by auto
+    have "real ?k \<le> 1 / real k" using lapprox_rat[where x=1 and y=k] by auto
 
-    have "Ifloat (?k * lb_arctan_horner prec (get_even n) 1 (?k * ?k)) \<le> arctan (Ifloat ?k)"
-      using arctan_0_1_bounds[OF `0 \<le> Ifloat ?k` `Ifloat ?k \<le> 1`] by auto
-    also have "\<dots> \<le> arctan (1 / real k)" using `Ifloat ?k \<le> 1 / real k` by (rule arctan_monotone')
-    finally have "Ifloat (?k * lb_arctan_horner prec (get_even n) 1 (?k * ?k)) \<le> arctan (1 / (real k))" .
+    have "real (?k * lb_arctan_horner prec (get_even n) 1 (?k * ?k)) \<le> arctan (real ?k)"
+      using arctan_0_1_bounds[OF `0 \<le> real ?k` `real ?k \<le> 1`] by auto
+    also have "\<dots> \<le> arctan (1 / real k)" using `real ?k \<le> 1 / real k` by (rule arctan_monotone')
+    finally have "real (?k * lb_arctan_horner prec (get_even n) 1 (?k * ?k)) \<le> arctan (1 / (real k))" .
   } note lb_arctan = this
 
-  have "pi \<le> Ifloat (ub_pi n)"
-    unfolding ub_pi_def machin_pi Let_def Ifloat_mult Ifloat_sub unfolding Float_num
+  have "pi \<le> real (ub_pi n)"
+    unfolding ub_pi_def machin_pi Let_def real_of_float_mult real_of_float_sub unfolding Float_num
     using lb_arctan[of 239] ub_arctan[of 5]
     by (auto intro!: mult_left_mono add_mono simp add: diff_minus simp del: lapprox_rat.simps rapprox_rat.simps)
   moreover
-  have "Ifloat (lb_pi n) \<le> pi"
-    unfolding lb_pi_def machin_pi Let_def Ifloat_mult Ifloat_sub Float_num
+  have "real (lb_pi n) \<le> pi"
+    unfolding lb_pi_def machin_pi Let_def real_of_float_mult real_of_float_sub Float_num
     using lb_arctan[of 5] ub_arctan[of 239]
     by (auto intro!: mult_left_mono add_mono simp add: diff_minus simp del: lapprox_rat.simps rapprox_rat.simps)
   ultimately show ?thesis by auto
@@ -569,35 +569,35 @@
 declare ub_arctan_horner.simps[simp del]
 declare lb_arctan_horner.simps[simp del]
 
-lemma lb_arctan_bound': assumes "0 \<le> Ifloat x"
-  shows "Ifloat (lb_arctan prec x) \<le> arctan (Ifloat x)"
+lemma lb_arctan_bound': assumes "0 \<le> real x"
+  shows "real (lb_arctan prec x) \<le> arctan (real x)"
 proof -
-  have "\<not> x < 0" and "0 \<le> x" unfolding less_float_def le_float_def using `0 \<le> Ifloat x` by auto
+  have "\<not> x < 0" and "0 \<le> x" unfolding less_float_def le_float_def using `0 \<le> real x` by auto
   let "?ub_horner x" = "x * ub_arctan_horner prec (get_odd (prec div 4 + 1)) 1 (x * x)"
     and "?lb_horner x" = "x * lb_arctan_horner prec (get_even (prec div 4 + 1)) 1 (x * x)"
 
   show ?thesis
   proof (cases "x \<le> Float 1 -1")
-    case True hence "Ifloat x \<le> 1" unfolding le_float_def Float_num by auto
+    case True hence "real x \<le> 1" unfolding le_float_def Float_num by auto
     show ?thesis unfolding lb_arctan.simps Let_def if_not_P[OF `\<not> x < 0`] if_P[OF True]
-      using arctan_0_1_bounds[OF `0 \<le> Ifloat x` `Ifloat x \<le> 1`] by auto
+      using arctan_0_1_bounds[OF `0 \<le> real x` `real x \<le> 1`] by auto
   next
-    case False hence "0 < Ifloat x" unfolding le_float_def Float_num by auto
-    let ?R = "1 + sqrt (1 + Ifloat x * Ifloat x)"
+    case False hence "0 < real x" unfolding le_float_def Float_num by auto
+    let ?R = "1 + sqrt (1 + real x * real x)"
     let ?fR = "1 + the (ub_sqrt prec (1 + x * x))"
     let ?DIV = "float_divl prec x ?fR"
     
-    have sqr_ge0: "0 \<le> 1 + Ifloat x * Ifloat x" using sum_power2_ge_zero[of 1 "Ifloat x", unfolded numeral_2_eq_2] by auto
+    have sqr_ge0: "0 \<le> 1 + real x * real x" using sum_power2_ge_zero[of 1 "real x", unfolded numeral_2_eq_2] by auto
     hence divisor_gt0: "0 < ?R" by (auto intro: add_pos_nonneg)
 
-    have "sqrt (Ifloat (1 + x * x)) \<le> Ifloat (the (ub_sqrt prec (1 + x * x)))" by (rule ub_sqrt_lower_bound, auto simp add: sqr_ge0)
-    hence "?R \<le> Ifloat ?fR" by auto
-    hence "0 < ?fR" and "0 < Ifloat ?fR" unfolding less_float_def using `0 < ?R` by auto
+    have "sqrt (real (1 + x * x)) \<le> real (the (ub_sqrt prec (1 + x * x)))" by (rule ub_sqrt_lower_bound, auto simp add: sqr_ge0)
+    hence "?R \<le> real ?fR" by auto
+    hence "0 < ?fR" and "0 < real ?fR" unfolding less_float_def using `0 < ?R` by auto
 
-    have monotone: "Ifloat (float_divl prec x ?fR) \<le> Ifloat x / ?R"
+    have monotone: "real (float_divl prec x ?fR) \<le> real x / ?R"
     proof -
-      have "Ifloat ?DIV \<le> Ifloat x / Ifloat ?fR" by (rule float_divl)
-      also have "\<dots> \<le> Ifloat x / ?R" by (rule divide_left_mono[OF `?R \<le> Ifloat ?fR` `0 \<le> Ifloat x` mult_pos_pos[OF order_less_le_trans[OF divisor_gt0 `?R \<le> Ifloat ?fR`] divisor_gt0]])
+      have "real ?DIV \<le> real x / real ?fR" by (rule float_divl)
+      also have "\<dots> \<le> real x / ?R" by (rule divide_left_mono[OF `?R \<le> real ?fR` `0 \<le> real x` mult_pos_pos[OF order_less_le_trans[OF divisor_gt0 `?R \<le> real ?fR`] divisor_gt0]])
       finally show ?thesis .
     qed
 
@@ -605,47 +605,47 @@
     proof (cases "x \<le> Float 1 1")
       case True
       
-      have "Ifloat x \<le> sqrt (Ifloat (1 + x * x))" using real_sqrt_sum_squares_ge2[where x=1, unfolded numeral_2_eq_2] by auto
-      also have "\<dots> \<le> Ifloat (the (ub_sqrt prec (1 + x * x)))" by (rule ub_sqrt_lower_bound, auto simp add: sqr_ge0)
-      finally have "Ifloat x \<le> Ifloat ?fR" by auto
-      moreover have "Ifloat ?DIV \<le> Ifloat x / Ifloat ?fR" by (rule float_divl)
-      ultimately have "Ifloat ?DIV \<le> 1" unfolding divide_le_eq_1_pos[OF `0 < Ifloat ?fR`, symmetric] by auto
+      have "real x \<le> sqrt (real (1 + x * x))" using real_sqrt_sum_squares_ge2[where x=1, unfolded numeral_2_eq_2] by auto
+      also have "\<dots> \<le> real (the (ub_sqrt prec (1 + x * x)))" by (rule ub_sqrt_lower_bound, auto simp add: sqr_ge0)
+      finally have "real x \<le> real ?fR" by auto
+      moreover have "real ?DIV \<le> real x / real ?fR" by (rule float_divl)
+      ultimately have "real ?DIV \<le> 1" unfolding divide_le_eq_1_pos[OF `0 < real ?fR`, symmetric] by auto
 
-      have "0 \<le> Ifloat ?DIV" using float_divl_lower_bound[OF `0 \<le> x` `0 < ?fR`] unfolding le_float_def by auto
+      have "0 \<le> real ?DIV" using float_divl_lower_bound[OF `0 \<le> x` `0 < ?fR`] unfolding le_float_def by auto
 
-      have "Ifloat (Float 1 1 * ?lb_horner ?DIV) \<le> 2 * arctan (Ifloat (float_divl prec x ?fR))" unfolding Ifloat_mult[of "Float 1 1"] Float_num
-	using arctan_0_1_bounds[OF `0 \<le> Ifloat ?DIV` `Ifloat ?DIV \<le> 1`] by auto
-      also have "\<dots> \<le> 2 * arctan (Ifloat x / ?R)"
+      have "real (Float 1 1 * ?lb_horner ?DIV) \<le> 2 * arctan (real (float_divl prec x ?fR))" unfolding real_of_float_mult[of "Float 1 1"] Float_num
+	using arctan_0_1_bounds[OF `0 \<le> real ?DIV` `real ?DIV \<le> 1`] by auto
+      also have "\<dots> \<le> 2 * arctan (real x / ?R)"
 	using arctan_monotone'[OF monotone] by (auto intro!: mult_left_mono)
-      also have "2 * arctan (Ifloat x / ?R) = arctan (Ifloat x)" using arctan_half[symmetric] unfolding numeral_2_eq_2 power_Suc2 power_0 real_mult_1 . 
+      also have "2 * arctan (real x / ?R) = arctan (real x)" using arctan_half[symmetric] unfolding numeral_2_eq_2 power_Suc2 power_0 real_mult_1 . 
       finally show ?thesis unfolding lb_arctan.simps Let_def if_not_P[OF `\<not> x < 0`] if_not_P[OF `\<not> x \<le> Float 1 -1`] if_P[OF True] .
     next
       case False
-      hence "2 < Ifloat x" unfolding le_float_def Float_num by auto
-      hence "1 \<le> Ifloat x" by auto
+      hence "2 < real x" unfolding le_float_def Float_num by auto
+      hence "1 \<le> real x" by auto
 
       let "?invx" = "float_divr prec 1 x"
-      have "0 \<le> arctan (Ifloat x)" using arctan_monotone'[OF `0 \<le> Ifloat x`] using arctan_tan[of 0, unfolded tan_zero] by auto
+      have "0 \<le> arctan (real x)" using arctan_monotone'[OF `0 \<le> real x`] using arctan_tan[of 0, unfolded tan_zero] by auto
 
       show ?thesis
       proof (cases "1 < ?invx")
 	case True
 	show ?thesis unfolding lb_arctan.simps Let_def if_not_P[OF `\<not> x < 0`] if_not_P[OF `\<not> x \<le> Float 1 -1`] if_not_P[OF False] if_P[OF True] 
-	  using `0 \<le> arctan (Ifloat x)` by auto
+	  using `0 \<le> arctan (real x)` by auto
       next
 	case False
-	hence "Ifloat ?invx \<le> 1" unfolding less_float_def by auto
-	have "0 \<le> Ifloat ?invx" by (rule order_trans[OF _ float_divr], auto simp add: `0 \<le> Ifloat x`)
+	hence "real ?invx \<le> 1" unfolding less_float_def by auto
+	have "0 \<le> real ?invx" by (rule order_trans[OF _ float_divr], auto simp add: `0 \<le> real x`)
 
-	have "1 / Ifloat x \<noteq> 0" and "0 < 1 / Ifloat x" using `0 < Ifloat x` by auto
+	have "1 / real x \<noteq> 0" and "0 < 1 / real x" using `0 < real x` by auto
 	
-	have "arctan (1 / Ifloat x) \<le> arctan (Ifloat ?invx)" unfolding Ifloat_1[symmetric] by (rule arctan_monotone', rule float_divr)
-	also have "\<dots> \<le> Ifloat (?ub_horner ?invx)" using arctan_0_1_bounds[OF `0 \<le> Ifloat ?invx` `Ifloat ?invx \<le> 1`] by auto
-	finally have "pi / 2 - Ifloat (?ub_horner ?invx) \<le> arctan (Ifloat x)" 
-	  using `0 \<le> arctan (Ifloat x)` arctan_inverse[OF `1 / Ifloat x \<noteq> 0`] 
-	  unfolding real_sgn_pos[OF `0 < 1 / Ifloat x`] le_diff_eq by auto
+	have "arctan (1 / real x) \<le> arctan (real ?invx)" unfolding real_of_float_1[symmetric] by (rule arctan_monotone', rule float_divr)
+	also have "\<dots> \<le> real (?ub_horner ?invx)" using arctan_0_1_bounds[OF `0 \<le> real ?invx` `real ?invx \<le> 1`] by auto
+	finally have "pi / 2 - real (?ub_horner ?invx) \<le> arctan (real x)" 
+	  using `0 \<le> arctan (real x)` arctan_inverse[OF `1 / real x \<noteq> 0`] 
+	  unfolding real_sgn_pos[OF `0 < 1 / real x`] le_diff_eq by auto
 	moreover
-	have "Ifloat (lb_pi prec * Float 1 -1) \<le> pi / 2" unfolding Ifloat_mult Float_num times_divide_eq_right real_mult_1 using pi_boundaries by auto
+	have "real (lb_pi prec * Float 1 -1) \<le> pi / 2" unfolding real_of_float_mult Float_num times_divide_eq_right real_mult_1 using pi_boundaries by auto
 	ultimately
 	show ?thesis unfolding lb_arctan.simps Let_def if_not_P[OF `\<not> x < 0`] if_not_P[OF `\<not> x \<le> Float 1 -1`] if_not_P[OF `\<not> x \<le> Float 1 1`] if_not_P[OF False]
 	  by auto
@@ -654,39 +654,39 @@
   qed
 qed
 
-lemma ub_arctan_bound': assumes "0 \<le> Ifloat x"
-  shows "arctan (Ifloat x) \<le> Ifloat (ub_arctan prec x)"
+lemma ub_arctan_bound': assumes "0 \<le> real x"
+  shows "arctan (real x) \<le> real (ub_arctan prec x)"
 proof -
-  have "\<not> x < 0" and "0 \<le> x" unfolding less_float_def le_float_def using `0 \<le> Ifloat x` by auto
+  have "\<not> x < 0" and "0 \<le> x" unfolding less_float_def le_float_def using `0 \<le> real x` by auto
 
   let "?ub_horner x" = "x * ub_arctan_horner prec (get_odd (prec div 4 + 1)) 1 (x * x)"
     and "?lb_horner x" = "x * lb_arctan_horner prec (get_even (prec div 4 + 1)) 1 (x * x)"
 
   show ?thesis
   proof (cases "x \<le> Float 1 -1")
-    case True hence "Ifloat x \<le> 1" unfolding le_float_def Float_num by auto
+    case True hence "real x \<le> 1" unfolding le_float_def Float_num by auto
     show ?thesis unfolding ub_arctan.simps Let_def if_not_P[OF `\<not> x < 0`] if_P[OF True]
-      using arctan_0_1_bounds[OF `0 \<le> Ifloat x` `Ifloat x \<le> 1`] by auto
+      using arctan_0_1_bounds[OF `0 \<le> real x` `real x \<le> 1`] by auto
   next
-    case False hence "0 < Ifloat x" unfolding le_float_def Float_num by auto
-    let ?R = "1 + sqrt (1 + Ifloat x * Ifloat x)"
+    case False hence "0 < real x" unfolding le_float_def Float_num by auto
+    let ?R = "1 + sqrt (1 + real x * real x)"
     let ?fR = "1 + the (lb_sqrt prec (1 + x * x))"
     let ?DIV = "float_divr prec x ?fR"
     
-    have sqr_ge0: "0 \<le> 1 + Ifloat x * Ifloat x" using sum_power2_ge_zero[of 1 "Ifloat x", unfolded numeral_2_eq_2] by auto
-    hence "0 \<le> Ifloat (1 + x*x)" by auto
+    have sqr_ge0: "0 \<le> 1 + real x * real x" using sum_power2_ge_zero[of 1 "real x", unfolded numeral_2_eq_2] by auto
+    hence "0 \<le> real (1 + x*x)" by auto
     
     hence divisor_gt0: "0 < ?R" by (auto intro: add_pos_nonneg)
 
-    have "Ifloat (the (lb_sqrt prec (1 + x * x))) \<le> sqrt (Ifloat (1 + x * x))" by (rule lb_sqrt_upper_bound, auto simp add: sqr_ge0)
-    hence "Ifloat ?fR \<le> ?R" by auto
-    have "0 < Ifloat ?fR" unfolding Ifloat_add Ifloat_1 by (rule order_less_le_trans[OF zero_less_one], auto simp add: lb_sqrt_lower_bound[OF `0 \<le> Ifloat (1 + x*x)`])
+    have "real (the (lb_sqrt prec (1 + x * x))) \<le> sqrt (real (1 + x * x))" by (rule lb_sqrt_upper_bound, auto simp add: sqr_ge0)
+    hence "real ?fR \<le> ?R" by auto
+    have "0 < real ?fR" unfolding real_of_float_add real_of_float_1 by (rule order_less_le_trans[OF zero_less_one], auto simp add: lb_sqrt_lower_bound[OF `0 \<le> real (1 + x*x)`])
 
-    have monotone: "Ifloat x / ?R \<le> Ifloat (float_divr prec x ?fR)"
+    have monotone: "real x / ?R \<le> real (float_divr prec x ?fR)"
     proof -
-      from divide_left_mono[OF `Ifloat ?fR \<le> ?R` `0 \<le> Ifloat x` mult_pos_pos[OF divisor_gt0 `0 < Ifloat ?fR`]]
-      have "Ifloat x / ?R \<le> Ifloat x / Ifloat ?fR" .
-      also have "\<dots> \<le> Ifloat ?DIV" by (rule float_divr)
+      from divide_left_mono[OF `real ?fR \<le> ?R` `0 \<le> real x` mult_pos_pos[OF divisor_gt0 `0 < real ?fR`]]
+      have "real x / ?R \<le> real x / real ?fR" .
+      also have "\<dots> \<le> real ?DIV" by (rule float_divr)
       finally show ?thesis .
     qed
 
@@ -696,45 +696,45 @@
       show ?thesis
       proof (cases "?DIV > 1")
 	case True
-	have "pi / 2 \<le> Ifloat (ub_pi prec * Float 1 -1)" unfolding Ifloat_mult Float_num times_divide_eq_right real_mult_1 using pi_boundaries by auto
+	have "pi / 2 \<le> real (ub_pi prec * Float 1 -1)" unfolding real_of_float_mult Float_num times_divide_eq_right real_mult_1 using pi_boundaries by auto
 	from order_less_le_trans[OF arctan_ubound this, THEN less_imp_le]
 	show ?thesis unfolding ub_arctan.simps Let_def if_not_P[OF `\<not> x < 0`] if_not_P[OF `\<not> x \<le> Float 1 -1`] if_P[OF `x \<le> Float 1 1`] if_P[OF True] .
       next
 	case False
-	hence "Ifloat ?DIV \<le> 1" unfolding less_float_def by auto
+	hence "real ?DIV \<le> 1" unfolding less_float_def by auto
       
-	have "0 \<le> Ifloat x / ?R" using `0 \<le> Ifloat x` `0 < ?R` unfolding real_0_le_divide_iff by auto
-	hence "0 \<le> Ifloat ?DIV" using monotone by (rule order_trans)
+	have "0 \<le> real x / ?R" using `0 \<le> real x` `0 < ?R` unfolding real_0_le_divide_iff by auto
+	hence "0 \<le> real ?DIV" using monotone by (rule order_trans)
 
-	have "arctan (Ifloat x) = 2 * arctan (Ifloat x / ?R)" using arctan_half unfolding numeral_2_eq_2 power_Suc2 power_0 real_mult_1 .
-	also have "\<dots> \<le> 2 * arctan (Ifloat ?DIV)"
+	have "arctan (real x) = 2 * arctan (real x / ?R)" using arctan_half unfolding numeral_2_eq_2 power_Suc2 power_0 real_mult_1 .
+	also have "\<dots> \<le> 2 * arctan (real ?DIV)"
 	  using arctan_monotone'[OF monotone] by (auto intro!: mult_left_mono)
-	also have "\<dots> \<le> Ifloat (Float 1 1 * ?ub_horner ?DIV)" unfolding Ifloat_mult[of "Float 1 1"] Float_num
-	  using arctan_0_1_bounds[OF `0 \<le> Ifloat ?DIV` `Ifloat ?DIV \<le> 1`] by auto
+	also have "\<dots> \<le> real (Float 1 1 * ?ub_horner ?DIV)" unfolding real_of_float_mult[of "Float 1 1"] Float_num
+	  using arctan_0_1_bounds[OF `0 \<le> real ?DIV` `real ?DIV \<le> 1`] by auto
 	finally show ?thesis unfolding ub_arctan.simps Let_def if_not_P[OF `\<not> x < 0`] if_not_P[OF `\<not> x \<le> Float 1 -1`] if_P[OF `x \<le> Float 1 1`] if_not_P[OF False] .
       qed
     next
       case False
-      hence "2 < Ifloat x" unfolding le_float_def Float_num by auto
-      hence "1 \<le> Ifloat x" by auto
-      hence "0 < Ifloat x" by auto
+      hence "2 < real x" unfolding le_float_def Float_num by auto
+      hence "1 \<le> real x" by auto
+      hence "0 < real x" by auto
       hence "0 < x" unfolding less_float_def by auto
 
       let "?invx" = "float_divl prec 1 x"
-      have "0 \<le> arctan (Ifloat x)" using arctan_monotone'[OF `0 \<le> Ifloat x`] using arctan_tan[of 0, unfolded tan_zero] by auto
+      have "0 \<le> arctan (real x)" using arctan_monotone'[OF `0 \<le> real x`] using arctan_tan[of 0, unfolded tan_zero] by auto
 
-      have "Ifloat ?invx \<le> 1" unfolding less_float_def by (rule order_trans[OF float_divl], auto simp add: `1 \<le> Ifloat x` divide_le_eq_1_pos[OF `0 < Ifloat x`])
-      have "0 \<le> Ifloat ?invx" unfolding Ifloat_0[symmetric] by (rule float_divl_lower_bound[unfolded le_float_def], auto simp add: `0 < x`)
+      have "real ?invx \<le> 1" unfolding less_float_def by (rule order_trans[OF float_divl], auto simp add: `1 \<le> real x` divide_le_eq_1_pos[OF `0 < real x`])
+      have "0 \<le> real ?invx" unfolding real_of_float_0[symmetric] by (rule float_divl_lower_bound[unfolded le_float_def], auto simp add: `0 < x`)
 	
-      have "1 / Ifloat x \<noteq> 0" and "0 < 1 / Ifloat x" using `0 < Ifloat x` by auto
+      have "1 / real x \<noteq> 0" and "0 < 1 / real x" using `0 < real x` by auto
       
-      have "Ifloat (?lb_horner ?invx) \<le> arctan (Ifloat ?invx)" using arctan_0_1_bounds[OF `0 \<le> Ifloat ?invx` `Ifloat ?invx \<le> 1`] by auto
-      also have "\<dots> \<le> arctan (1 / Ifloat x)" unfolding Ifloat_1[symmetric] by (rule arctan_monotone', rule float_divl)
-      finally have "arctan (Ifloat x) \<le> pi / 2 - Ifloat (?lb_horner ?invx)"
-	using `0 \<le> arctan (Ifloat x)` arctan_inverse[OF `1 / Ifloat x \<noteq> 0`] 
-	unfolding real_sgn_pos[OF `0 < 1 / Ifloat x`] le_diff_eq by auto
+      have "real (?lb_horner ?invx) \<le> arctan (real ?invx)" using arctan_0_1_bounds[OF `0 \<le> real ?invx` `real ?invx \<le> 1`] by auto
+      also have "\<dots> \<le> arctan (1 / real x)" unfolding real_of_float_1[symmetric] by (rule arctan_monotone', rule float_divl)
+      finally have "arctan (real x) \<le> pi / 2 - real (?lb_horner ?invx)"
+	using `0 \<le> arctan (real x)` arctan_inverse[OF `1 / real x \<noteq> 0`] 
+	unfolding real_sgn_pos[OF `0 < 1 / real x`] le_diff_eq by auto
       moreover
-      have "pi / 2 \<le> Ifloat (ub_pi prec * Float 1 -1)" unfolding Ifloat_mult Float_num times_divide_eq_right mult_1_right using pi_boundaries by auto
+      have "pi / 2 \<le> real (ub_pi prec * Float 1 -1)" unfolding real_of_float_mult Float_num times_divide_eq_right mult_1_right using pi_boundaries by auto
       ultimately
       show ?thesis unfolding ub_arctan.simps Let_def if_not_P[OF `\<not> x < 0`] if_not_P[OF `\<not> x \<le> Float 1 -1`] if_not_P[OF `\<not> x \<le> Float 1 1`] if_not_P[OF False]
 	by auto
@@ -743,34 +743,34 @@
 qed
 
 lemma arctan_boundaries:
-  "arctan (Ifloat x) \<in> {Ifloat (lb_arctan prec x) .. Ifloat (ub_arctan prec x)}"
+  "arctan (real x) \<in> {real (lb_arctan prec x) .. real (ub_arctan prec x)}"
 proof (cases "0 \<le> x")
-  case True hence "0 \<le> Ifloat x" unfolding le_float_def by auto
-  show ?thesis using ub_arctan_bound'[OF `0 \<le> Ifloat x`] lb_arctan_bound'[OF `0 \<le> Ifloat x`] unfolding atLeastAtMost_iff by auto
+  case True hence "0 \<le> real x" unfolding le_float_def by auto
+  show ?thesis using ub_arctan_bound'[OF `0 \<le> real x`] lb_arctan_bound'[OF `0 \<le> real x`] unfolding atLeastAtMost_iff by auto
 next
   let ?mx = "-x"
-  case False hence "x < 0" and "0 \<le> Ifloat ?mx" unfolding le_float_def less_float_def by auto
-  hence bounds: "Ifloat (lb_arctan prec ?mx) \<le> arctan (Ifloat ?mx) \<and> arctan (Ifloat ?mx) \<le> Ifloat (ub_arctan prec ?mx)"
-    using ub_arctan_bound'[OF `0 \<le> Ifloat ?mx`] lb_arctan_bound'[OF `0 \<le> Ifloat ?mx`] by auto
-  show ?thesis unfolding Ifloat_minus arctan_minus lb_arctan.simps[where x=x] ub_arctan.simps[where x=x] Let_def if_P[OF `x < 0`]
-    unfolding atLeastAtMost_iff using bounds[unfolded Ifloat_minus arctan_minus] by auto
+  case False hence "x < 0" and "0 \<le> real ?mx" unfolding le_float_def less_float_def by auto
+  hence bounds: "real (lb_arctan prec ?mx) \<le> arctan (real ?mx) \<and> arctan (real ?mx) \<le> real (ub_arctan prec ?mx)"
+    using ub_arctan_bound'[OF `0 \<le> real ?mx`] lb_arctan_bound'[OF `0 \<le> real ?mx`] by auto
+  show ?thesis unfolding real_of_float_minus arctan_minus lb_arctan.simps[where x=x] ub_arctan.simps[where x=x] Let_def if_P[OF `x < 0`]
+    unfolding atLeastAtMost_iff using bounds[unfolded real_of_float_minus arctan_minus] by auto
 qed
 
-lemma bnds_arctan: "\<forall> x lx ux. (l, u) = (lb_arctan prec lx, ub_arctan prec ux) \<and> x \<in> {Ifloat lx .. Ifloat ux} \<longrightarrow> Ifloat l \<le> arctan x \<and> arctan x \<le> Ifloat u"
+lemma bnds_arctan: "\<forall> x lx ux. (l, u) = (lb_arctan prec lx, ub_arctan prec ux) \<and> x \<in> {real lx .. real ux} \<longrightarrow> real l \<le> arctan x \<and> arctan x \<le> real u"
 proof (rule allI, rule allI, rule allI, rule impI)
   fix x lx ux
-  assume "(l, u) = (lb_arctan prec lx, ub_arctan prec ux) \<and> x \<in> {Ifloat lx .. Ifloat ux}"
-  hence l: "lb_arctan prec lx = l " and u: "ub_arctan prec ux = u" and x: "x \<in> {Ifloat lx .. Ifloat ux}" by auto
+  assume "(l, u) = (lb_arctan prec lx, ub_arctan prec ux) \<and> x \<in> {real lx .. real ux}"
+  hence l: "lb_arctan prec lx = l " and u: "ub_arctan prec ux = u" and x: "x \<in> {real lx .. real ux}" by auto
 
   { from arctan_boundaries[of lx prec, unfolded l]
-    have "Ifloat l \<le> arctan (Ifloat lx)" by (auto simp del: lb_arctan.simps)
+    have "real l \<le> arctan (real lx)" by (auto simp del: lb_arctan.simps)
     also have "\<dots> \<le> arctan x" using x by (auto intro: arctan_monotone')
-    finally have "Ifloat l \<le> arctan x" .
+    finally have "real l \<le> arctan x" .
   } moreover
-  { have "arctan x \<le> arctan (Ifloat ux)" using x by (auto intro: arctan_monotone')
-    also have "\<dots> \<le> Ifloat u" using arctan_boundaries[of ux prec, unfolded u] by (auto simp del: ub_arctan.simps)
-    finally have "arctan x \<le> Ifloat u" .
-  } ultimately show "Ifloat l \<le> arctan x \<and> arctan x \<le> Ifloat u" ..
+  { have "arctan x \<le> arctan (real ux)" using x by (auto intro: arctan_monotone')
+    also have "\<dots> \<le> real u" using arctan_boundaries[of ux prec, unfolded u] by (auto simp del: ub_arctan.simps)
+    finally have "arctan x \<le> real u" .
+  } ultimately show "real l \<le> arctan x \<and> arctan x \<le> real u" ..
 qed
 
 section "Sinus and Cosinus"
@@ -787,31 +787,31 @@
     (lapprox_rat prec 1 (int k)) - x * (ub_sin_cos_aux prec n (i + 2) (k * i * (i + 1)) x)"
 
 lemma cos_aux:
-  shows "Ifloat (lb_sin_cos_aux prec n 1 1 (x * x)) \<le> (\<Sum> i=0..<n. -1^i * (1/real (fact (2 * i))) * (Ifloat x)^(2 * i))" (is "?lb")
-  and "(\<Sum> i=0..<n. -1^i * (1/real (fact (2 * i))) * (Ifloat x)^(2 * i)) \<le> Ifloat (ub_sin_cos_aux prec n 1 1 (x * x))" (is "?ub")
+  shows "real (lb_sin_cos_aux prec n 1 1 (x * x)) \<le> (\<Sum> i=0..<n. -1^i * (1/real (fact (2 * i))) * (real x)^(2 * i))" (is "?lb")
+  and "(\<Sum> i=0..<n. -1^i * (1/real (fact (2 * i))) * (real x)^(2 * i)) \<le> real (ub_sin_cos_aux prec n 1 1 (x * x))" (is "?ub")
 proof -
-  have "0 \<le> Ifloat (x * x)" unfolding Ifloat_mult by auto
+  have "0 \<le> real (x * x)" unfolding real_of_float_mult by auto
   let "?f n" = "fact (2 * n)"
 
   { fix n 
-    have F: "\<And>m. ((\<lambda>i. i + 2) ^ n) m = m + 2 * n" by (induct n arbitrary: m, auto)
-    have "?f (Suc n) = ?f n * ((\<lambda>i. i + 2) ^ n) 1 * (((\<lambda>i. i + 2) ^ n) 1 + 1)"
+    have F: "\<And>m. ((\<lambda>i. i + 2) ^^ n) m = m + 2 * n" by (induct n arbitrary: m, auto)
+    have "?f (Suc n) = ?f n * ((\<lambda>i. i + 2) ^^ n) 1 * (((\<lambda>i. i + 2) ^^ n) 1 + 1)"
       unfolding F by auto } note f_eq = this
     
   from horner_bounds[where lb="lb_sin_cos_aux prec" and ub="ub_sin_cos_aux prec" and j'=0, 
-    OF `0 \<le> Ifloat (x * x)` f_eq lb_sin_cos_aux.simps ub_sin_cos_aux.simps]
-  show "?lb" and "?ub" by (auto simp add: power_mult power2_eq_square[of "Ifloat x"])
+    OF `0 \<le> real (x * x)` f_eq lb_sin_cos_aux.simps ub_sin_cos_aux.simps]
+  show "?lb" and "?ub" by (auto simp add: power_mult power2_eq_square[of "real x"])
 qed
 
-lemma cos_boundaries: assumes "0 \<le> Ifloat x" and "Ifloat x \<le> pi / 2"
-  shows "cos (Ifloat x) \<in> {Ifloat (lb_sin_cos_aux prec (get_even n) 1 1 (x * x)) .. Ifloat (ub_sin_cos_aux prec (get_odd n) 1 1 (x * x))}"
-proof (cases "Ifloat x = 0")
-  case False hence "Ifloat x \<noteq> 0" by auto
-  hence "0 < x" and "0 < Ifloat x" using `0 \<le> Ifloat x` unfolding less_float_def by auto
-  have "0 < x * x" using `0 < x` unfolding less_float_def Ifloat_mult Ifloat_0
-    using mult_pos_pos[where a="Ifloat x" and b="Ifloat x"] by auto
+lemma cos_boundaries: assumes "0 \<le> real x" and "real x \<le> pi / 2"
+  shows "cos (real x) \<in> {real (lb_sin_cos_aux prec (get_even n) 1 1 (x * x)) .. real (ub_sin_cos_aux prec (get_odd n) 1 1 (x * x))}"
+proof (cases "real x = 0")
+  case False hence "real x \<noteq> 0" by auto
+  hence "0 < x" and "0 < real x" using `0 \<le> real x` unfolding less_float_def by auto
+  have "0 < x * x" using `0 < x` unfolding less_float_def real_of_float_mult real_of_float_0
+    using mult_pos_pos[where a="real x" and b="real x"] by auto
 
-  { fix x n have "(\<Sum> i=0..<n. -1^i * (1/real (fact (2 * i))) * x^(2 * i))
+  { fix x n have "(\<Sum> i=0..<n. -1^i * (1/real (fact (2 * i))) * x ^ (2 * i))
     = (\<Sum> i = 0 ..< 2 * n. (if even(i) then (-1 ^ (i div 2))/(real (fact i)) else 0) * x ^ i)" (is "?sum = ?ifsum")
   proof -
     have "?sum = ?sum + (\<Sum> j = 0 ..< n. 0)" by auto
@@ -827,62 +827,62 @@
 
   { fix n :: nat assume "0 < n"
     hence "0 < 2 * n" by auto
-    obtain t where "0 < t" and "t < Ifloat x" and
-      cos_eq: "cos (Ifloat x) = (\<Sum> i = 0 ..< 2 * n. (if even(i) then (-1 ^ (i div 2))/(real (fact i)) else 0) * (Ifloat x) ^ i) 
-      + (cos (t + 1/2 * real (2 * n) * pi) / real (fact (2*n))) * (Ifloat x)^(2*n)" 
+    obtain t where "0 < t" and "t < real x" and
+      cos_eq: "cos (real x) = (\<Sum> i = 0 ..< 2 * n. (if even(i) then (-1 ^ (i div 2))/(real (fact i)) else 0) * (real x) ^ i) 
+      + (cos (t + 1/2 * real (2 * n) * pi) / real (fact (2*n))) * (real x)^(2*n)" 
       (is "_ = ?SUM + ?rest / ?fact * ?pow")
-      using Maclaurin_cos_expansion2[OF `0 < Ifloat x` `0 < 2 * n`] by auto
+      using Maclaurin_cos_expansion2[OF `0 < real x` `0 < 2 * n`] by auto
 
     have "cos t * -1^n = cos t * cos (real n * pi) + sin t * sin (real n * pi)" by auto
     also have "\<dots> = cos (t + real n * pi)"  using cos_add by auto
     also have "\<dots> = ?rest" by auto
     finally have "cos t * -1^n = ?rest" .
     moreover
-    have "t \<le> pi / 2" using `t < Ifloat x` and `Ifloat x \<le> pi / 2` by auto
+    have "t \<le> pi / 2" using `t < real x` and `real x \<le> pi / 2` by auto
     hence "0 \<le> cos t" using `0 < t` and cos_ge_zero by auto
     ultimately have even: "even n \<Longrightarrow> 0 \<le> ?rest" and odd: "odd n \<Longrightarrow> 0 \<le> - ?rest " by auto
 
     have "0 < ?fact" by auto
-    have "0 < ?pow" using `0 < Ifloat x` by auto
+    have "0 < ?pow" using `0 < real x` by auto
 
     {
       assume "even n"
-      have "Ifloat (lb_sin_cos_aux prec n 1 1 (x * x)) \<le> ?SUM"
+      have "real (lb_sin_cos_aux prec n 1 1 (x * x)) \<le> ?SUM"
 	unfolding morph_to_if_power[symmetric] using cos_aux by auto 
-      also have "\<dots> \<le> cos (Ifloat x)"
+      also have "\<dots> \<le> cos (real x)"
       proof -
 	from even[OF `even n`] `0 < ?fact` `0 < ?pow`
 	have "0 \<le> (?rest / ?fact) * ?pow" by (metis mult_nonneg_nonneg divide_nonneg_pos less_imp_le)
 	thus ?thesis unfolding cos_eq by auto
       qed
-      finally have "Ifloat (lb_sin_cos_aux prec n 1 1 (x * x)) \<le> cos (Ifloat x)" .
+      finally have "real (lb_sin_cos_aux prec n 1 1 (x * x)) \<le> cos (real x)" .
     } note lb = this
 
     {
       assume "odd n"
-      have "cos (Ifloat x) \<le> ?SUM"
+      have "cos (real x) \<le> ?SUM"
       proof -
 	from `0 < ?fact` and `0 < ?pow` and odd[OF `odd n`]
 	have "0 \<le> (- ?rest) / ?fact * ?pow"
 	  by (metis mult_nonneg_nonneg divide_nonneg_pos less_imp_le)
 	thus ?thesis unfolding cos_eq by auto
       qed
-      also have "\<dots> \<le> Ifloat (ub_sin_cos_aux prec n 1 1 (x * x))"
+      also have "\<dots> \<le> real (ub_sin_cos_aux prec n 1 1 (x * x))"
 	unfolding morph_to_if_power[symmetric] using cos_aux by auto
-      finally have "cos (Ifloat x) \<le> Ifloat (ub_sin_cos_aux prec n 1 1 (x * x))" .
+      finally have "cos (real x) \<le> real (ub_sin_cos_aux prec n 1 1 (x * x))" .
     } note ub = this and lb
   } note ub = this(1) and lb = this(2)
 
-  have "cos (Ifloat x) \<le> Ifloat (ub_sin_cos_aux prec (get_odd n) 1 1 (x * x))" using ub[OF odd_pos[OF get_odd] get_odd] .
-  moreover have "Ifloat (lb_sin_cos_aux prec (get_even n) 1 1 (x * x)) \<le> cos (Ifloat x)" 
+  have "cos (real x) \<le> real (ub_sin_cos_aux prec (get_odd n) 1 1 (x * x))" using ub[OF odd_pos[OF get_odd] get_odd] .
+  moreover have "real (lb_sin_cos_aux prec (get_even n) 1 1 (x * x)) \<le> cos (real x)" 
   proof (cases "0 < get_even n")
     case True show ?thesis using lb[OF True get_even] .
   next
     case False
     hence "get_even n = 0" by auto
-    have "- (pi / 2) \<le> Ifloat x" by (rule order_trans[OF _ `0 < Ifloat x`[THEN less_imp_le]], auto)
-    with `Ifloat x \<le> pi / 2`
-    show ?thesis unfolding `get_even n = 0` lb_sin_cos_aux.simps Ifloat_minus Ifloat_0 using cos_ge_zero by auto
+    have "- (pi / 2) \<le> real x" by (rule order_trans[OF _ `0 < real x`[THEN less_imp_le]], auto)
+    with `real x \<le> pi / 2`
+    show ?thesis unfolding `get_even n = 0` lb_sin_cos_aux.simps real_of_float_minus real_of_float_0 using cos_ge_zero by auto
   qed
   ultimately show ?thesis by auto
 next
@@ -890,40 +890,40 @@
   show ?thesis
   proof (cases "n = 0")
     case True 
-    thus ?thesis unfolding `n = 0` get_even_def get_odd_def using `Ifloat x = 0` lapprox_rat[where x="-1" and y=1] by auto
+    thus ?thesis unfolding `n = 0` get_even_def get_odd_def using `real x = 0` lapprox_rat[where x="-1" and y=1] by auto
   next
     case False with not0_implies_Suc obtain m where "n = Suc m" by blast
-    thus ?thesis unfolding `n = Suc m` get_even_def get_odd_def using `Ifloat x = 0` rapprox_rat[where x=1 and y=1] lapprox_rat[where x=1 and y=1] by (cases "even (Suc m)", auto)
+    thus ?thesis unfolding `n = Suc m` get_even_def get_odd_def using `real x = 0` rapprox_rat[where x=1 and y=1] lapprox_rat[where x=1 and y=1] by (cases "even (Suc m)", auto)
   qed
 qed
 
-lemma sin_aux: assumes "0 \<le> Ifloat x"
-  shows "Ifloat (x * lb_sin_cos_aux prec n 2 1 (x * x)) \<le> (\<Sum> i=0..<n. -1^i * (1/real (fact (2 * i + 1))) * (Ifloat x)^(2 * i + 1))" (is "?lb")
-  and "(\<Sum> i=0..<n. -1^i * (1/real (fact (2 * i + 1))) * (Ifloat x)^(2 * i + 1)) \<le> Ifloat (x * ub_sin_cos_aux prec n 2 1 (x * x))" (is "?ub")
+lemma sin_aux: assumes "0 \<le> real x"
+  shows "real (x * lb_sin_cos_aux prec n 2 1 (x * x)) \<le> (\<Sum> i=0..<n. -1^i * (1/real (fact (2 * i + 1))) * (real x)^(2 * i + 1))" (is "?lb")
+  and "(\<Sum> i=0..<n. -1^i * (1/real (fact (2 * i + 1))) * (real x)^(2 * i + 1)) \<le> real (x * ub_sin_cos_aux prec n 2 1 (x * x))" (is "?ub")
 proof -
-  have "0 \<le> Ifloat (x * x)" unfolding Ifloat_mult by auto
+  have "0 \<le> real (x * x)" unfolding real_of_float_mult by auto
   let "?f n" = "fact (2 * n + 1)"
 
   { fix n 
-    have F: "\<And>m. ((\<lambda>i. i + 2) ^ n) m = m + 2 * n" by (induct n arbitrary: m, auto)
-    have "?f (Suc n) = ?f n * ((\<lambda>i. i + 2) ^ n) 2 * (((\<lambda>i. i + 2) ^ n) 2 + 1)"
+    have F: "\<And>m. ((\<lambda>i. i + 2) ^^ n) m = m + 2 * n" by (induct n arbitrary: m, auto)
+    have "?f (Suc n) = ?f n * ((\<lambda>i. i + 2) ^^ n) 2 * (((\<lambda>i. i + 2) ^^ n) 2 + 1)"
       unfolding F by auto } note f_eq = this
     
   from horner_bounds[where lb="lb_sin_cos_aux prec" and ub="ub_sin_cos_aux prec" and j'=0,
-    OF `0 \<le> Ifloat (x * x)` f_eq lb_sin_cos_aux.simps ub_sin_cos_aux.simps]
-  show "?lb" and "?ub" using `0 \<le> Ifloat x` unfolding Ifloat_mult
+    OF `0 \<le> real (x * x)` f_eq lb_sin_cos_aux.simps ub_sin_cos_aux.simps]
+  show "?lb" and "?ub" using `0 \<le> real x` unfolding real_of_float_mult
     unfolding power_add power_one_right real_mult_assoc[symmetric] setsum_left_distrib[symmetric]
     unfolding real_mult_commute
-    by (auto intro!: mult_left_mono simp add: power_mult power2_eq_square[of "Ifloat x"])
+    by (auto intro!: mult_left_mono simp add: power_mult power2_eq_square[of "real x"])
 qed
 
-lemma sin_boundaries: assumes "0 \<le> Ifloat x" and "Ifloat x \<le> pi / 2"
-  shows "sin (Ifloat x) \<in> {Ifloat (x * lb_sin_cos_aux prec (get_even n) 2 1 (x * x)) .. Ifloat (x * ub_sin_cos_aux prec (get_odd n) 2 1 (x * x))}"
-proof (cases "Ifloat x = 0")
-  case False hence "Ifloat x \<noteq> 0" by auto
-  hence "0 < x" and "0 < Ifloat x" using `0 \<le> Ifloat x` unfolding less_float_def by auto
-  have "0 < x * x" using `0 < x` unfolding less_float_def Ifloat_mult Ifloat_0
-    using mult_pos_pos[where a="Ifloat x" and b="Ifloat x"] by auto
+lemma sin_boundaries: assumes "0 \<le> real x" and "real x \<le> pi / 2"
+  shows "sin (real x) \<in> {real (x * lb_sin_cos_aux prec (get_even n) 2 1 (x * x)) .. real (x * ub_sin_cos_aux prec (get_odd n) 2 1 (x * x))}"
+proof (cases "real x = 0")
+  case False hence "real x \<noteq> 0" by auto
+  hence "0 < x" and "0 < real x" using `0 \<le> real x` unfolding less_float_def by auto
+  have "0 < x * x" using `0 < x` unfolding less_float_def real_of_float_mult real_of_float_0
+    using mult_pos_pos[where a="real x" and b="real x"] by auto
 
   { fix x n have "(\<Sum> j = 0 ..< n. -1 ^ (((2 * j + 1) - Suc 0) div 2) / (real (fact (2 * j + 1))) * x ^(2 * j + 1))
     = (\<Sum> i = 0 ..< 2 * n. (if even(i) then 0 else (-1 ^ ((i - Suc 0) div 2))/(real (fact i))) * x ^ i)" (is "?SUM = _")
@@ -939,62 +939,62 @@
 
   { fix n :: nat assume "0 < n"
     hence "0 < 2 * n + 1" by auto
-    obtain t where "0 < t" and "t < Ifloat x" and
-      sin_eq: "sin (Ifloat x) = (\<Sum> i = 0 ..< 2 * n + 1. (if even(i) then 0 else (-1 ^ ((i - Suc 0) div 2))/(real (fact i))) * (Ifloat x) ^ i) 
-      + (sin (t + 1/2 * real (2 * n + 1) * pi) / real (fact (2*n + 1))) * (Ifloat x)^(2*n + 1)" 
+    obtain t where "0 < t" and "t < real x" and
+      sin_eq: "sin (real x) = (\<Sum> i = 0 ..< 2 * n + 1. (if even(i) then 0 else (-1 ^ ((i - Suc 0) div 2))/(real (fact i))) * (real x) ^ i) 
+      + (sin (t + 1/2 * real (2 * n + 1) * pi) / real (fact (2*n + 1))) * (real x)^(2*n + 1)" 
       (is "_ = ?SUM + ?rest / ?fact * ?pow")
-      using Maclaurin_sin_expansion3[OF `0 < 2 * n + 1` `0 < Ifloat x`] by auto
+      using Maclaurin_sin_expansion3[OF `0 < 2 * n + 1` `0 < real x`] by auto
 
     have "?rest = cos t * -1^n" unfolding sin_add cos_add real_of_nat_add left_distrib right_distrib by auto
     moreover
-    have "t \<le> pi / 2" using `t < Ifloat x` and `Ifloat x \<le> pi / 2` by auto
+    have "t \<le> pi / 2" using `t < real x` and `real x \<le> pi / 2` by auto
     hence "0 \<le> cos t" using `0 < t` and cos_ge_zero by auto
     ultimately have even: "even n \<Longrightarrow> 0 \<le> ?rest" and odd: "odd n \<Longrightarrow> 0 \<le> - ?rest " by auto
 
     have "0 < ?fact" by (rule real_of_nat_fact_gt_zero)
-    have "0 < ?pow" using `0 < Ifloat x` by (rule zero_less_power)
+    have "0 < ?pow" using `0 < real x` by (rule zero_less_power)
 
     {
       assume "even n"
-      have "Ifloat (x * lb_sin_cos_aux prec n 2 1 (x * x)) \<le> 
-            (\<Sum> i = 0 ..< 2 * n. (if even(i) then 0 else (-1 ^ ((i - Suc 0) div 2))/(real (fact i))) * (Ifloat x) ^ i)"
-	using sin_aux[OF `0 \<le> Ifloat x`] unfolding setsum_morph[symmetric] by auto
+      have "real (x * lb_sin_cos_aux prec n 2 1 (x * x)) \<le> 
+            (\<Sum> i = 0 ..< 2 * n. (if even(i) then 0 else (-1 ^ ((i - Suc 0) div 2))/(real (fact i))) * (real x) ^ i)"
+	using sin_aux[OF `0 \<le> real x`] unfolding setsum_morph[symmetric] by auto
       also have "\<dots> \<le> ?SUM" by auto
-      also have "\<dots> \<le> sin (Ifloat x)"
+      also have "\<dots> \<le> sin (real x)"
       proof -
 	from even[OF `even n`] `0 < ?fact` `0 < ?pow`
 	have "0 \<le> (?rest / ?fact) * ?pow" by (metis mult_nonneg_nonneg divide_nonneg_pos less_imp_le)
 	thus ?thesis unfolding sin_eq by auto
       qed
-      finally have "Ifloat (x * lb_sin_cos_aux prec n 2 1 (x * x)) \<le> sin (Ifloat x)" .
+      finally have "real (x * lb_sin_cos_aux prec n 2 1 (x * x)) \<le> sin (real x)" .
     } note lb = this
 
     {
       assume "odd n"
-      have "sin (Ifloat x) \<le> ?SUM"
+      have "sin (real x) \<le> ?SUM"
       proof -
 	from `0 < ?fact` and `0 < ?pow` and odd[OF `odd n`]
 	have "0 \<le> (- ?rest) / ?fact * ?pow"
 	  by (metis mult_nonneg_nonneg divide_nonneg_pos less_imp_le)
 	thus ?thesis unfolding sin_eq by auto
       qed
-      also have "\<dots> \<le> (\<Sum> i = 0 ..< 2 * n. (if even(i) then 0 else (-1 ^ ((i - Suc 0) div 2))/(real (fact i))) * (Ifloat x) ^ i)"
+      also have "\<dots> \<le> (\<Sum> i = 0 ..< 2 * n. (if even(i) then 0 else (-1 ^ ((i - Suc 0) div 2))/(real (fact i))) * (real x) ^ i)"
 	 by auto
-      also have "\<dots> \<le> Ifloat (x * ub_sin_cos_aux prec n 2 1 (x * x))" 
-	using sin_aux[OF `0 \<le> Ifloat x`] unfolding setsum_morph[symmetric] by auto
-      finally have "sin (Ifloat x) \<le> Ifloat (x * ub_sin_cos_aux prec n 2 1 (x * x))" .
+      also have "\<dots> \<le> real (x * ub_sin_cos_aux prec n 2 1 (x * x))" 
+	using sin_aux[OF `0 \<le> real x`] unfolding setsum_morph[symmetric] by auto
+      finally have "sin (real x) \<le> real (x * ub_sin_cos_aux prec n 2 1 (x * x))" .
     } note ub = this and lb
   } note ub = this(1) and lb = this(2)
 
-  have "sin (Ifloat x) \<le> Ifloat (x * ub_sin_cos_aux prec (get_odd n) 2 1 (x * x))" using ub[OF odd_pos[OF get_odd] get_odd] .
-  moreover have "Ifloat (x * lb_sin_cos_aux prec (get_even n) 2 1 (x * x)) \<le> sin (Ifloat x)" 
+  have "sin (real x) \<le> real (x * ub_sin_cos_aux prec (get_odd n) 2 1 (x * x))" using ub[OF odd_pos[OF get_odd] get_odd] .
+  moreover have "real (x * lb_sin_cos_aux prec (get_even n) 2 1 (x * x)) \<le> sin (real x)" 
   proof (cases "0 < get_even n")
     case True show ?thesis using lb[OF True get_even] .
   next
     case False
     hence "get_even n = 0" by auto
-    with `Ifloat x \<le> pi / 2` `0 \<le> Ifloat x`
-    show ?thesis unfolding `get_even n = 0` ub_sin_cos_aux.simps Ifloat_minus Ifloat_0 using sin_ge_zero by auto
+    with `real x \<le> pi / 2` `0 \<le> real x`
+    show ?thesis unfolding `get_even n = 0` ub_sin_cos_aux.simps real_of_float_minus real_of_float_0 using sin_ge_zero by auto
   qed
   ultimately show ?thesis by auto
 next
@@ -1002,10 +1002,10 @@
   show ?thesis
   proof (cases "n = 0")
     case True 
-    thus ?thesis unfolding `n = 0` get_even_def get_odd_def using `Ifloat x = 0` lapprox_rat[where x="-1" and y=1] by auto
+    thus ?thesis unfolding `n = 0` get_even_def get_odd_def using `real x = 0` lapprox_rat[where x="-1" and y=1] by auto
   next
     case False with not0_implies_Suc obtain m where "n = Suc m" by blast
-    thus ?thesis unfolding `n = Suc m` get_even_def get_odd_def using `Ifloat x = 0` rapprox_rat[where x=1 and y=1] lapprox_rat[where x=1 and y=1] by (cases "even (Suc m)", auto)
+    thus ?thesis unfolding `n = Suc m` get_even_def get_odd_def using `real x = 0` rapprox_rat[where x=1 and y=1] lapprox_rat[where x=1 and y=1] by (cases "even (Suc m)", auto)
   qed
 qed
 
@@ -1034,8 +1034,8 @@
   else if 0 \<le> lx                 then (lb_cos prec ux, ub_cos prec lx)
                                  else (min (lb_cos prec (-lx)) (lb_cos prec ux), Float 1 0))"
 
-lemma lb_cos: assumes "0 \<le> Ifloat x" and "Ifloat x \<le> pi" 
-  shows "cos (Ifloat x) \<in> {Ifloat (lb_cos prec x) .. Ifloat (ub_cos prec x)}" (is "?cos x \<in> { Ifloat (?lb x) .. Ifloat (?ub x) }")
+lemma lb_cos: assumes "0 \<le> real x" and "real x \<le> pi" 
+  shows "cos (real x) \<in> {real (lb_cos prec x) .. real (ub_cos prec x)}" (is "?cos x \<in> { real (?lb x) .. real (?ub x) }")
 proof -
   { fix x :: real
     have "cos x = cos (x / 2 + x / 2)" by auto
@@ -1045,7 +1045,7 @@
     finally have "cos x = 2 * cos (x / 2) * cos (x / 2) - 1" .
   } note x_half = this[symmetric]
 
-  have "\<not> x < 0" using `0 \<le> Ifloat x` unfolding less_float_def by auto
+  have "\<not> x < 0" using `0 \<le> real x` unfolding less_float_def by auto
   let "?ub_horner x" = "ub_sin_cos_aux prec (get_odd (prec div 4 + 1)) 1 1 (x * x)"
   let "?lb_horner x" = "lb_sin_cos_aux prec (get_even (prec div 4 + 1)) 1 1 (x * x)"
   let "?ub_half x" = "Float 1 1 * x * x - 1"
@@ -1053,88 +1053,88 @@
 
   show ?thesis
   proof (cases "x < Float 1 -1")
-    case True hence "Ifloat x \<le> pi / 2" unfolding less_float_def using pi_ge_two by auto
+    case True hence "real x \<le> pi / 2" unfolding less_float_def using pi_ge_two by auto
     show ?thesis unfolding lb_cos_def[where x=x] ub_cos_def[where x=x] if_not_P[OF `\<not> x < 0`] if_P[OF `x < Float 1 -1`] Let_def
-      using cos_boundaries[OF `0 \<le> Ifloat x` `Ifloat x \<le> pi / 2`] .
+      using cos_boundaries[OF `0 \<le> real x` `real x \<le> pi / 2`] .
   next
     case False
     
-    { fix y x :: float let ?x2 = "Ifloat (x * Float 1 -1)"
-      assume "Ifloat y \<le> cos ?x2" and "-pi \<le> Ifloat x" and "Ifloat x \<le> pi"
-      hence "- (pi / 2) \<le> ?x2" and "?x2 \<le> pi / 2" using pi_ge_two unfolding Ifloat_mult Float_num by auto
+    { fix y x :: float let ?x2 = "real (x * Float 1 -1)"
+      assume "real y \<le> cos ?x2" and "-pi \<le> real x" and "real x \<le> pi"
+      hence "- (pi / 2) \<le> ?x2" and "?x2 \<le> pi / 2" using pi_ge_two unfolding real_of_float_mult Float_num by auto
       hence "0 \<le> cos ?x2" by (rule cos_ge_zero)
       
-      have "Ifloat (?lb_half y) \<le> cos (Ifloat x)"
+      have "real (?lb_half y) \<le> cos (real x)"
       proof (cases "y < 0")
 	case True show ?thesis using cos_ge_minus_one unfolding if_P[OF True] by auto
       next
 	case False
-	hence "0 \<le> Ifloat y" unfolding less_float_def by auto
-	from mult_mono[OF `Ifloat y \<le> cos ?x2` `Ifloat y \<le> cos ?x2` `0 \<le> cos ?x2` this]
-	have "Ifloat y * Ifloat y \<le> cos ?x2 * cos ?x2" .
-	hence "2 * Ifloat y * Ifloat y \<le> 2 * cos ?x2 * cos ?x2" by auto
-	hence "2 * Ifloat y * Ifloat y - 1 \<le> 2 * cos (Ifloat x / 2) * cos (Ifloat x / 2) - 1" unfolding Float_num Ifloat_mult by auto
-	thus ?thesis unfolding if_not_P[OF False] x_half Float_num Ifloat_mult Ifloat_sub by auto
+	hence "0 \<le> real y" unfolding less_float_def by auto
+	from mult_mono[OF `real y \<le> cos ?x2` `real y \<le> cos ?x2` `0 \<le> cos ?x2` this]
+	have "real y * real y \<le> cos ?x2 * cos ?x2" .
+	hence "2 * real y * real y \<le> 2 * cos ?x2 * cos ?x2" by auto
+	hence "2 * real y * real y - 1 \<le> 2 * cos (real x / 2) * cos (real x / 2) - 1" unfolding Float_num real_of_float_mult by auto
+	thus ?thesis unfolding if_not_P[OF False] x_half Float_num real_of_float_mult real_of_float_sub by auto
       qed
     } note lb_half = this
     
-    { fix y x :: float let ?x2 = "Ifloat (x * Float 1 -1)"
-      assume ub: "cos ?x2 \<le> Ifloat y" and "- pi \<le> Ifloat x" and "Ifloat x \<le> pi"
-      hence "- (pi / 2) \<le> ?x2" and "?x2 \<le> pi / 2" using pi_ge_two unfolding Ifloat_mult Float_num by auto
+    { fix y x :: float let ?x2 = "real (x * Float 1 -1)"
+      assume ub: "cos ?x2 \<le> real y" and "- pi \<le> real x" and "real x \<le> pi"
+      hence "- (pi / 2) \<le> ?x2" and "?x2 \<le> pi / 2" using pi_ge_two unfolding real_of_float_mult Float_num by auto
       hence "0 \<le> cos ?x2" by (rule cos_ge_zero)
       
-      have "cos (Ifloat x) \<le> Ifloat (?ub_half y)"
+      have "cos (real x) \<le> real (?ub_half y)"
       proof -
-	have "0 \<le> Ifloat y" using `0 \<le> cos ?x2` ub by (rule order_trans)
+	have "0 \<le> real y" using `0 \<le> cos ?x2` ub by (rule order_trans)
 	from mult_mono[OF ub ub this `0 \<le> cos ?x2`]
-	have "cos ?x2 * cos ?x2 \<le> Ifloat y * Ifloat y" .
-	hence "2 * cos ?x2 * cos ?x2 \<le> 2 * Ifloat y * Ifloat y" by auto
-	hence "2 * cos (Ifloat x / 2) * cos (Ifloat x / 2) - 1 \<le> 2 * Ifloat y * Ifloat y - 1" unfolding Float_num Ifloat_mult by auto
-	thus ?thesis unfolding x_half Ifloat_mult Float_num Ifloat_sub by auto
+	have "cos ?x2 * cos ?x2 \<le> real y * real y" .
+	hence "2 * cos ?x2 * cos ?x2 \<le> 2 * real y * real y" by auto
+	hence "2 * cos (real x / 2) * cos (real x / 2) - 1 \<le> 2 * real y * real y - 1" unfolding Float_num real_of_float_mult by auto
+	thus ?thesis unfolding x_half real_of_float_mult Float_num real_of_float_sub by auto
       qed
     } note ub_half = this
     
     let ?x2 = "x * Float 1 -1"
     let ?x4 = "x * Float 1 -1 * Float 1 -1"
     
-    have "-pi \<le> Ifloat x" using pi_ge_zero[THEN le_imp_neg_le, unfolded minus_zero] `0 \<le> Ifloat x` by (rule order_trans)
+    have "-pi \<le> real x" using pi_ge_zero[THEN le_imp_neg_le, unfolded minus_zero] `0 \<le> real x` by (rule order_trans)
     
     show ?thesis
     proof (cases "x < 1")
-      case True hence "Ifloat x \<le> 1" unfolding less_float_def by auto
-      have "0 \<le> Ifloat ?x2" and "Ifloat ?x2 \<le> pi / 2" using pi_ge_two `0 \<le> Ifloat x` unfolding Ifloat_mult Float_num using assms by auto
+      case True hence "real x \<le> 1" unfolding less_float_def by auto
+      have "0 \<le> real ?x2" and "real ?x2 \<le> pi / 2" using pi_ge_two `0 \<le> real x` unfolding real_of_float_mult Float_num using assms by auto
       from cos_boundaries[OF this]
-      have lb: "Ifloat (?lb_horner ?x2) \<le> ?cos ?x2" and ub: "?cos ?x2 \<le> Ifloat (?ub_horner ?x2)" by auto
+      have lb: "real (?lb_horner ?x2) \<le> ?cos ?x2" and ub: "?cos ?x2 \<le> real (?ub_horner ?x2)" by auto
       
-      have "Ifloat (?lb x) \<le> ?cos x"
+      have "real (?lb x) \<le> ?cos x"
       proof -
-	from lb_half[OF lb `-pi \<le> Ifloat x` `Ifloat x \<le> pi`]
+	from lb_half[OF lb `-pi \<le> real x` `real x \<le> pi`]
 	show ?thesis unfolding lb_cos_def[where x=x] Let_def using `\<not> x < 0` `\<not> x < Float 1 -1` `x < 1` by auto
       qed
-      moreover have "?cos x \<le> Ifloat (?ub x)"
+      moreover have "?cos x \<le> real (?ub x)"
       proof -
-	from ub_half[OF ub `-pi \<le> Ifloat x` `Ifloat x \<le> pi`]
+	from ub_half[OF ub `-pi \<le> real x` `real x \<le> pi`]
 	show ?thesis unfolding ub_cos_def[where x=x] Let_def using `\<not> x < 0` `\<not> x < Float 1 -1` `x < 1` by auto 
       qed
       ultimately show ?thesis by auto
     next
       case False
-      have "0 \<le> Ifloat ?x4" and "Ifloat ?x4 \<le> pi / 2" using pi_ge_two `0 \<le> Ifloat x` `Ifloat x \<le> pi` unfolding Ifloat_mult Float_num by auto
+      have "0 \<le> real ?x4" and "real ?x4 \<le> pi / 2" using pi_ge_two `0 \<le> real x` `real x \<le> pi` unfolding real_of_float_mult Float_num by auto
       from cos_boundaries[OF this]
-      have lb: "Ifloat (?lb_horner ?x4) \<le> ?cos ?x4" and ub: "?cos ?x4 \<le> Ifloat (?ub_horner ?x4)" by auto
+      have lb: "real (?lb_horner ?x4) \<le> ?cos ?x4" and ub: "?cos ?x4 \<le> real (?ub_horner ?x4)" by auto
       
       have eq_4: "?x2 * Float 1 -1 = x * Float 1 -2" by (cases x, auto simp add: times_float.simps)
       
-      have "Ifloat (?lb x) \<le> ?cos x"
+      have "real (?lb x) \<le> ?cos x"
       proof -
-	have "-pi \<le> Ifloat ?x2" and "Ifloat ?x2 \<le> pi" unfolding Ifloat_mult Float_num using pi_ge_two `0 \<le> Ifloat x` `Ifloat x \<le> pi` by auto
-	from lb_half[OF lb_half[OF lb this] `-pi \<le> Ifloat x` `Ifloat x \<le> pi`, unfolded eq_4]
+	have "-pi \<le> real ?x2" and "real ?x2 \<le> pi" unfolding real_of_float_mult Float_num using pi_ge_two `0 \<le> real x` `real x \<le> pi` by auto
+	from lb_half[OF lb_half[OF lb this] `-pi \<le> real x` `real x \<le> pi`, unfolded eq_4]
 	show ?thesis unfolding lb_cos_def[where x=x] if_not_P[OF `\<not> x < 0`] if_not_P[OF `\<not> x < Float 1 -1`] if_not_P[OF `\<not> x < 1`] Let_def .
       qed
-      moreover have "?cos x \<le> Ifloat (?ub x)"
+      moreover have "?cos x \<le> real (?ub x)"
       proof -
-	have "-pi \<le> Ifloat ?x2" and "Ifloat ?x2 \<le> pi" unfolding Ifloat_mult Float_num using pi_ge_two `0 \<le> Ifloat x` `Ifloat x \<le> pi` by auto
-	from ub_half[OF ub_half[OF ub this] `-pi \<le> Ifloat x` `Ifloat x \<le> pi`, unfolded eq_4]
+	have "-pi \<le> real ?x2" and "real ?x2 \<le> pi" unfolding real_of_float_mult Float_num using pi_ge_two `0 \<le> real x` `real x \<le> pi` by auto
+	from ub_half[OF ub_half[OF ub this] `-pi \<le> real x` `real x \<le> pi`, unfolded eq_4]
 	show ?thesis unfolding ub_cos_def[where x=x] if_not_P[OF `\<not> x < 0`] if_not_P[OF `\<not> x < Float 1 -1`] if_not_P[OF `\<not> x < 1`] Let_def .
       qed
       ultimately show ?thesis by auto
@@ -1142,38 +1142,38 @@
   qed
 qed
 
-lemma lb_cos_minus: assumes "-pi \<le> Ifloat x" and "Ifloat x \<le> 0" 
-  shows "cos (Ifloat (-x)) \<in> {Ifloat (lb_cos prec (-x)) .. Ifloat (ub_cos prec (-x))}"
+lemma lb_cos_minus: assumes "-pi \<le> real x" and "real x \<le> 0" 
+  shows "cos (real (-x)) \<in> {real (lb_cos prec (-x)) .. real (ub_cos prec (-x))}"
 proof -
-  have "0 \<le> Ifloat (-x)" and "Ifloat (-x) \<le> pi" using `-pi \<le> Ifloat x` `Ifloat x \<le> 0` by auto
+  have "0 \<le> real (-x)" and "real (-x) \<le> pi" using `-pi \<le> real x` `real x \<le> 0` by auto
   from lb_cos[OF this] show ?thesis .
 qed
 
-lemma bnds_cos: "\<forall> x lx ux. (l, u) = bnds_cos prec lx ux \<and> x \<in> {Ifloat lx .. Ifloat ux} \<longrightarrow> Ifloat l \<le> cos x \<and> cos x \<le> Ifloat u"
+lemma bnds_cos: "\<forall> x lx ux. (l, u) = bnds_cos prec lx ux \<and> x \<in> {real lx .. real ux} \<longrightarrow> real l \<le> cos x \<and> cos x \<le> real u"
 proof (rule allI, rule allI, rule allI, rule impI)
   fix x lx ux
-  assume "(l, u) = bnds_cos prec lx ux \<and> x \<in> {Ifloat lx .. Ifloat ux}"
-  hence bnds: "(l, u) = bnds_cos prec lx ux" and x: "x \<in> {Ifloat lx .. Ifloat ux}" by auto
+  assume "(l, u) = bnds_cos prec lx ux \<and> x \<in> {real lx .. real ux}"
+  hence bnds: "(l, u) = bnds_cos prec lx ux" and x: "x \<in> {real lx .. real ux}" by auto
 
   let ?lpi = "lb_pi prec"  
-  have [intro!]: "Ifloat lx \<le> Ifloat ux" using x by auto
+  have [intro!]: "real lx \<le> real ux" using x by auto
   hence "lx \<le> ux" unfolding le_float_def .
 
-  show "Ifloat l \<le> cos x \<and> cos x \<le> Ifloat u"
+  show "real l \<le> cos x \<and> cos x \<le> real u"
   proof (cases "lx < -?lpi \<or> ux > ?lpi")
     case True
     show ?thesis using bnds unfolding bnds_cos_def if_P[OF True] Let_def using cos_le_one cos_ge_minus_one by auto
   next
     case False note not_out = this
-    hence lpi_lx: "- Ifloat ?lpi \<le> Ifloat lx" and lpi_ux: "Ifloat ux \<le> Ifloat ?lpi" unfolding le_float_def less_float_def by auto
+    hence lpi_lx: "- real ?lpi \<le> real lx" and lpi_ux: "real ux \<le> real ?lpi" unfolding le_float_def less_float_def by auto
 
     from pi_boundaries[unfolded atLeastAtMost_iff, THEN conjunct1, THEN le_imp_neg_le] lpi_lx
-    have "- pi \<le> Ifloat lx" by (rule order_trans)
-    hence "- pi \<le> x" and "- pi \<le> Ifloat ux" and "x \<le> Ifloat ux" using x by auto
+    have "- pi \<le> real lx" by (rule order_trans)
+    hence "- pi \<le> x" and "- pi \<le> real ux" and "x \<le> real ux" using x by auto
     
     from lpi_ux pi_boundaries[unfolded atLeastAtMost_iff, THEN conjunct1]
-    have "Ifloat ux \<le> pi" by (rule order_trans)
-    hence "x \<le> pi" and "Ifloat lx \<le> pi" and "Ifloat lx \<le> x" using x by auto
+    have "real ux \<le> pi" by (rule order_trans)
+    hence "x \<le> pi" and "real lx \<le> pi" and "real lx \<le> x" using x by auto
 
     note lb_cos_minus_bottom = lb_cos_minus[unfolded atLeastAtMost_iff, THEN conjunct1]
     note lb_cos_minus_top = lb_cos_minus[unfolded atLeastAtMost_iff, THEN conjunct2]
@@ -1182,50 +1182,50 @@
 
     show ?thesis
     proof (cases "ux \<le> 0")
-      case True hence "Ifloat ux \<le> 0" unfolding le_float_def by auto
-      hence "x \<le> 0" and "Ifloat lx \<le> 0" using x by auto
+      case True hence "real ux \<le> 0" unfolding le_float_def by auto
+      hence "x \<le> 0" and "real lx \<le> 0" using x by auto
       
-      { have "Ifloat (lb_cos prec (-lx)) \<le> cos (Ifloat (-lx))" using lb_cos_minus_bottom[OF `-pi \<le> Ifloat lx` `Ifloat lx \<le> 0`] .
-	also have "\<dots> \<le> cos x" unfolding Ifloat_minus cos_minus using cos_monotone_minus_pi_0'[OF `- pi \<le> Ifloat lx` `Ifloat lx \<le> x` `x \<le> 0`] .
-	finally have "Ifloat (lb_cos prec (-lx)) \<le> cos x" . }
+      { have "real (lb_cos prec (-lx)) \<le> cos (real (-lx))" using lb_cos_minus_bottom[OF `-pi \<le> real lx` `real lx \<le> 0`] .
+	also have "\<dots> \<le> cos x" unfolding real_of_float_minus cos_minus using cos_monotone_minus_pi_0'[OF `- pi \<le> real lx` `real lx \<le> x` `x \<le> 0`] .
+	finally have "real (lb_cos prec (-lx)) \<le> cos x" . }
       moreover
-      { have "cos x \<le> cos (Ifloat (-ux))" unfolding Ifloat_minus cos_minus using cos_monotone_minus_pi_0'[OF `- pi \<le> x` `x \<le> Ifloat ux` `Ifloat ux \<le> 0`] .
-	also have "\<dots> \<le> Ifloat (ub_cos prec (-ux))" using lb_cos_minus_top[OF `-pi \<le> Ifloat ux` `Ifloat ux \<le> 0`] .
-	finally have "cos x \<le> Ifloat (ub_cos prec (-ux))" . }
+      { have "cos x \<le> cos (real (-ux))" unfolding real_of_float_minus cos_minus using cos_monotone_minus_pi_0'[OF `- pi \<le> x` `x \<le> real ux` `real ux \<le> 0`] .
+	also have "\<dots> \<le> real (ub_cos prec (-ux))" using lb_cos_minus_top[OF `-pi \<le> real ux` `real ux \<le> 0`] .
+	finally have "cos x \<le> real (ub_cos prec (-ux))" . }
       ultimately show ?thesis using bnds unfolding bnds_cos_def Let_def if_not_P[OF not_out] if_P[OF True] by auto
     next
       case False note not_ux = this
       
       show ?thesis
       proof (cases "0 \<le> lx")
-	case True hence "0 \<le> Ifloat lx" unfolding le_float_def by auto
-	hence "0 \<le> x" and "0 \<le> Ifloat ux" using x by auto
+	case True hence "0 \<le> real lx" unfolding le_float_def by auto
+	hence "0 \<le> x" and "0 \<le> real ux" using x by auto
       
-	{ have "Ifloat (lb_cos prec ux) \<le> cos (Ifloat ux)" using lb_cos_bottom[OF `0 \<le> Ifloat ux` `Ifloat ux \<le> pi`] .
-	  also have "\<dots> \<le> cos x" using cos_monotone_0_pi'[OF `0 \<le> x` `x \<le> Ifloat ux` `Ifloat ux \<le> pi`] .
-	  finally have "Ifloat (lb_cos prec ux) \<le> cos x" . }
+	{ have "real (lb_cos prec ux) \<le> cos (real ux)" using lb_cos_bottom[OF `0 \<le> real ux` `real ux \<le> pi`] .
+	  also have "\<dots> \<le> cos x" using cos_monotone_0_pi'[OF `0 \<le> x` `x \<le> real ux` `real ux \<le> pi`] .
+	  finally have "real (lb_cos prec ux) \<le> cos x" . }
 	moreover
-	{ have "cos x \<le> cos (Ifloat lx)" using cos_monotone_0_pi'[OF `0 \<le> Ifloat lx` `Ifloat lx \<le> x` `x \<le> pi`] .
-	  also have "\<dots> \<le> Ifloat (ub_cos prec lx)" using lb_cos_top[OF `0 \<le> Ifloat lx` `Ifloat lx \<le> pi`] .
-	  finally have "cos x \<le> Ifloat (ub_cos prec lx)" . }
+	{ have "cos x \<le> cos (real lx)" using cos_monotone_0_pi'[OF `0 \<le> real lx` `real lx \<le> x` `x \<le> pi`] .
+	  also have "\<dots> \<le> real (ub_cos prec lx)" using lb_cos_top[OF `0 \<le> real lx` `real lx \<le> pi`] .
+	  finally have "cos x \<le> real (ub_cos prec lx)" . }
 	ultimately show ?thesis using bnds unfolding bnds_cos_def Let_def if_not_P[OF not_out] if_not_P[OF not_ux] if_P[OF True] by auto
       next
 	case False with not_ux
-	have "Ifloat lx \<le> 0" and "0 \<le> Ifloat ux" unfolding le_float_def by auto
+	have "real lx \<le> 0" and "0 \<le> real ux" unfolding le_float_def by auto
 
-	have "Ifloat (min (lb_cos prec (-lx)) (lb_cos prec ux)) \<le> cos x"
+	have "real (min (lb_cos prec (-lx)) (lb_cos prec ux)) \<le> cos x"
 	proof (cases "x \<le> 0")
 	  case True
-	  have "Ifloat (lb_cos prec (-lx)) \<le> cos (Ifloat (-lx))" using lb_cos_minus_bottom[OF `-pi \<le> Ifloat lx` `Ifloat lx \<le> 0`] .
-	  also have "\<dots> \<le> cos x" unfolding Ifloat_minus cos_minus using cos_monotone_minus_pi_0'[OF `- pi \<le> Ifloat lx` `Ifloat lx \<le> x` `x \<le> 0`] .
-	  finally show ?thesis unfolding Ifloat_min by auto
+	  have "real (lb_cos prec (-lx)) \<le> cos (real (-lx))" using lb_cos_minus_bottom[OF `-pi \<le> real lx` `real lx \<le> 0`] .
+	  also have "\<dots> \<le> cos x" unfolding real_of_float_minus cos_minus using cos_monotone_minus_pi_0'[OF `- pi \<le> real lx` `real lx \<le> x` `x \<le> 0`] .
+	  finally show ?thesis unfolding real_of_float_min by auto
 	next
 	  case False hence "0 \<le> x" by auto
-	  have "Ifloat (lb_cos prec ux) \<le> cos (Ifloat ux)" using lb_cos_bottom[OF `0 \<le> Ifloat ux` `Ifloat ux \<le> pi`] .
-	  also have "\<dots> \<le> cos x" using cos_monotone_0_pi'[OF `0 \<le> x` `x \<le> Ifloat ux` `Ifloat ux \<le> pi`] .
-	  finally show ?thesis unfolding Ifloat_min by auto
+	  have "real (lb_cos prec ux) \<le> cos (real ux)" using lb_cos_bottom[OF `0 \<le> real ux` `real ux \<le> pi`] .
+	  also have "\<dots> \<le> cos x" using cos_monotone_0_pi'[OF `0 \<le> x` `x \<le> real ux` `real ux \<le> pi`] .
+	  finally show ?thesis unfolding real_of_float_min by auto
 	qed
-	moreover have "cos x \<le> Ifloat (Float 1 0)" by auto
+	moreover have "cos x \<le> real (Float 1 0)" by auto
 	ultimately show ?thesis using bnds unfolding bnds_cos_def Let_def if_not_P[OF not_out] if_not_P[OF not_ux] if_not_P[OF False] by auto
       qed
     qed
@@ -1254,45 +1254,45 @@
   in if lx \<le> - half_pi \<or> half_pi \<le> ux then (Float -1 0, Float 1 0)
                                        else (lb_sin prec lx, ub_sin prec ux))"
 
-lemma lb_sin: assumes "- (pi / 2) \<le> Ifloat x" and "Ifloat x \<le> pi / 2"
-  shows "sin (Ifloat x) \<in> { Ifloat (lb_sin prec x) .. Ifloat (ub_sin prec x) }" (is "?sin x \<in> { ?lb x .. ?ub x}")
+lemma lb_sin: assumes "- (pi / 2) \<le> real x" and "real x \<le> pi / 2"
+  shows "sin (real x) \<in> { real (lb_sin prec x) .. real (ub_sin prec x) }" (is "?sin x \<in> { ?lb x .. ?ub x}")
 proof -
-  { fix x :: float assume "0 \<le> Ifloat x" and "Ifloat x \<le> pi / 2"
-    hence "\<not> (x < 0)" and "- (pi / 2) \<le> Ifloat x" unfolding less_float_def using pi_ge_two by auto
+  { fix x :: float assume "0 \<le> real x" and "real x \<le> pi / 2"
+    hence "\<not> (x < 0)" and "- (pi / 2) \<le> real x" unfolding less_float_def using pi_ge_two by auto
 
-    have "Ifloat x \<le> pi" using `Ifloat x \<le> pi / 2` using pi_ge_two by auto
+    have "real x \<le> pi" using `real x \<le> pi / 2` using pi_ge_two by auto
 
     have "?sin x \<in> { ?lb x .. ?ub x}"
     proof (cases "x \<le> Float 1 -1")
-      case True from sin_boundaries[OF `0 \<le> Ifloat x` `Ifloat x \<le> pi / 2`]
+      case True from sin_boundaries[OF `0 \<le> real x` `real x \<le> pi / 2`]
       show ?thesis unfolding lb_sin.simps[of prec x] ub_sin.simps[of prec x] if_not_P[OF `\<not> (x < 0)`] if_P[OF True] Let_def .
     next
       case False
-      have "0 \<le> cos (Ifloat x)" using cos_ge_zero[OF _ `Ifloat x \<le> pi /2`] `0 \<le> Ifloat x` pi_ge_two by auto
-      have "0 \<le> sin (Ifloat x)" using `0 \<le> Ifloat x` and `Ifloat x \<le> pi / 2` using sin_ge_zero by auto
+      have "0 \<le> cos (real x)" using cos_ge_zero[OF _ `real x \<le> pi /2`] `0 \<le> real x` pi_ge_two by auto
+      have "0 \<le> sin (real x)" using `0 \<le> real x` and `real x \<le> pi / 2` using sin_ge_zero by auto
       
       have "?sin x \<le> ?ub x"
       proof (cases "lb_cos prec x < 0")
 	case True
 	have "?sin x \<le> 1" using sin_le_one .
-	also have "\<dots> \<le> Ifloat (the (ub_sqrt prec 1))" using ub_sqrt_lower_bound[where prec=prec and x=1] unfolding Ifloat_1 by auto
+	also have "\<dots> \<le> real (the (ub_sqrt prec 1))" using ub_sqrt_lower_bound[where prec=prec and x=1] unfolding real_of_float_1 by auto
 	finally show ?thesis unfolding ub_sin.simps if_not_P[OF `\<not> (x < 0)`] if_not_P[OF `\<not> x \<le> Float 1 -1`] if_P[OF True] Let_def .
       next
-	case False hence "0 \<le> Ifloat (lb_cos prec x)" unfolding less_float_def by auto
+	case False hence "0 \<le> real (lb_cos prec x)" unfolding less_float_def by auto
 	
-	have "sin (Ifloat x) = sqrt (1 - cos (Ifloat x) ^ 2)" unfolding sin_squared_eq[symmetric] real_sqrt_abs using `0 \<le> sin (Ifloat x)` by auto
-	also have "\<dots> \<le> sqrt (Ifloat (1 - lb_cos prec x * lb_cos prec x))" 
+	have "sin (real x) = sqrt (1 - cos (real x) ^ 2)" unfolding sin_squared_eq[symmetric] real_sqrt_abs using `0 \<le> sin (real x)` by auto
+	also have "\<dots> \<le> sqrt (real (1 - lb_cos prec x * lb_cos prec x))" 
 	proof (rule real_sqrt_le_mono)
-	  have "Ifloat (lb_cos prec x * lb_cos prec x) \<le> cos (Ifloat x) ^ 2" unfolding numeral_2_eq_2 power_Suc2 power_0 Ifloat_mult
-	    using `0 \<le> Ifloat (lb_cos prec x)` lb_cos[OF `0 \<le> Ifloat x` `Ifloat x \<le> pi`] `0 \<le> cos (Ifloat x)` by(auto intro!: mult_mono)
-	  thus "1 - cos (Ifloat x) ^ 2 \<le> Ifloat (1 - lb_cos prec x * lb_cos prec x)" unfolding Ifloat_sub Ifloat_1 by auto
+	  have "real (lb_cos prec x * lb_cos prec x) \<le> cos (real x) ^ 2" unfolding numeral_2_eq_2 power_Suc2 power_0 real_of_float_mult
+	    using `0 \<le> real (lb_cos prec x)` lb_cos[OF `0 \<le> real x` `real x \<le> pi`] `0 \<le> cos (real x)` by(auto intro!: mult_mono)
+	  thus "1 - cos (real x) ^ 2 \<le> real (1 - lb_cos prec x * lb_cos prec x)" unfolding real_of_float_sub real_of_float_1 by auto
 	qed
-	also have "\<dots> \<le> Ifloat (the (ub_sqrt prec (1 - lb_cos prec x * lb_cos prec x)))"
+	also have "\<dots> \<le> real (the (ub_sqrt prec (1 - lb_cos prec x * lb_cos prec x)))"
 	proof (rule ub_sqrt_lower_bound)
-	  have "Ifloat (lb_cos prec x) \<le> cos (Ifloat x)" using lb_cos[OF `0 \<le> Ifloat x` `Ifloat x \<le> pi`] by auto
+	  have "real (lb_cos prec x) \<le> cos (real x)" using lb_cos[OF `0 \<le> real x` `real x \<le> pi`] by auto
 	  from mult_mono[OF order_trans[OF this cos_le_one] order_trans[OF this cos_le_one]]
-	  have "Ifloat (lb_cos prec x) * Ifloat (lb_cos prec x) \<le> 1" using `0 \<le> Ifloat (lb_cos prec x)` by auto
-	  thus "0 \<le> Ifloat (1 - lb_cos prec x * lb_cos prec x)" by auto
+	  have "real (lb_cos prec x) * real (lb_cos prec x) \<le> 1" using `0 \<le> real (lb_cos prec x)` by auto
+	  thus "0 \<le> real (1 - lb_cos prec x * lb_cos prec x)" by auto
 	qed
 	finally show ?thesis unfolding ub_sin.simps if_not_P[OF `\<not> (x < 0)`] if_not_P[OF `\<not> x \<le> Float 1 -1`] if_not_P[OF False] Let_def .
       qed
@@ -1301,25 +1301,25 @@
       proof (cases "1 < ub_cos prec x")
 	case True
 	show ?thesis unfolding lb_sin.simps if_not_P[OF `\<not> (x < 0)`] if_not_P[OF `\<not> x \<le> Float 1 -1`] if_P[OF True] Let_def 
-	  by (rule order_trans[OF _ sin_ge_zero[OF `0 \<le> Ifloat x` `Ifloat x \<le> pi`]]) 
-        (auto simp add: lb_sqrt_upper_bound[where prec=prec and x=0, unfolded Ifloat_0 real_sqrt_zero])
+	  by (rule order_trans[OF _ sin_ge_zero[OF `0 \<le> real x` `real x \<le> pi`]]) 
+        (auto simp add: lb_sqrt_upper_bound[where prec=prec and x=0, unfolded real_of_float_0 real_sqrt_zero])
       next
-	case False hence "Ifloat (ub_cos prec x) \<le> 1" unfolding less_float_def by auto
-	have "0 \<le> Ifloat (ub_cos prec x)" using order_trans[OF `0 \<le> cos (Ifloat x)`] lb_cos `0 \<le> Ifloat x` `Ifloat x \<le> pi` by auto
+	case False hence "real (ub_cos prec x) \<le> 1" unfolding less_float_def by auto
+	have "0 \<le> real (ub_cos prec x)" using order_trans[OF `0 \<le> cos (real x)`] lb_cos `0 \<le> real x` `real x \<le> pi` by auto
 	
-	have "Ifloat (the (lb_sqrt prec (1 - ub_cos prec x * ub_cos prec x))) \<le> sqrt (Ifloat (1 - ub_cos prec x * ub_cos prec x))"
+	have "real (the (lb_sqrt prec (1 - ub_cos prec x * ub_cos prec x))) \<le> sqrt (real (1 - ub_cos prec x * ub_cos prec x))"
 	proof (rule lb_sqrt_upper_bound)
-	  from mult_mono[OF `Ifloat (ub_cos prec x) \<le> 1` `Ifloat (ub_cos prec x) \<le> 1`] `0 \<le> Ifloat (ub_cos prec x)`
-	  have "Ifloat (ub_cos prec x) * Ifloat (ub_cos prec x) \<le> 1" by auto
-	  thus "0 \<le> Ifloat (1 - ub_cos prec x * ub_cos prec x)" by auto
+	  from mult_mono[OF `real (ub_cos prec x) \<le> 1` `real (ub_cos prec x) \<le> 1`] `0 \<le> real (ub_cos prec x)`
+	  have "real (ub_cos prec x) * real (ub_cos prec x) \<le> 1" by auto
+	  thus "0 \<le> real (1 - ub_cos prec x * ub_cos prec x)" by auto
 	qed
-	also have "\<dots> \<le> sqrt (1 - cos (Ifloat x) ^ 2)"
+	also have "\<dots> \<le> sqrt (1 - cos (real x) ^ 2)"
 	proof (rule real_sqrt_le_mono)
-	  have "cos (Ifloat x) ^ 2 \<le> Ifloat (ub_cos prec x * ub_cos prec x)" unfolding numeral_2_eq_2 power_Suc2 power_0 Ifloat_mult
-	    using `0 \<le> Ifloat (ub_cos prec x)` lb_cos[OF `0 \<le> Ifloat x` `Ifloat x \<le> pi`] `0 \<le> cos (Ifloat x)` by(auto intro!: mult_mono)
-	  thus "Ifloat (1 - ub_cos prec x * ub_cos prec x) \<le> 1 - cos (Ifloat x) ^ 2" unfolding Ifloat_sub Ifloat_1 by auto
+	  have "cos (real x) ^ 2 \<le> real (ub_cos prec x * ub_cos prec x)" unfolding numeral_2_eq_2 power_Suc2 power_0 real_of_float_mult
+	    using `0 \<le> real (ub_cos prec x)` lb_cos[OF `0 \<le> real x` `real x \<le> pi`] `0 \<le> cos (real x)` by(auto intro!: mult_mono)
+	  thus "real (1 - ub_cos prec x * ub_cos prec x) \<le> 1 - cos (real x) ^ 2" unfolding real_of_float_sub real_of_float_1 by auto
 	qed
-	also have "\<dots> = sin (Ifloat x)" unfolding sin_squared_eq[symmetric] real_sqrt_abs using `0 \<le> sin (Ifloat x)` by auto
+	also have "\<dots> = sin (real x)" unfolding sin_squared_eq[symmetric] real_sqrt_abs using `0 \<le> sin (real x)` by auto
 	finally show ?thesis unfolding lb_sin.simps if_not_P[OF `\<not> (x < 0)`] if_not_P[OF `\<not> x \<le> Float 1 -1`] if_not_P[OF False] Let_def .
       qed
       ultimately show ?thesis by auto
@@ -1329,40 +1329,40 @@
   show ?thesis
   proof (cases "x < 0")
     case True 
-    hence "0 \<le> Ifloat (-x)" and "Ifloat (- x) \<le> pi / 2" using `-(pi/2) \<le> Ifloat x` unfolding less_float_def by auto
+    hence "0 \<le> real (-x)" and "real (- x) \<le> pi / 2" using `-(pi/2) \<le> real x` unfolding less_float_def by auto
     from for_pos[OF this]
-    show ?thesis unfolding Ifloat_minus sin_minus lb_sin.simps[of prec x] ub_sin.simps[of prec x] if_P[OF True] Let_def atLeastAtMost_iff by auto
+    show ?thesis unfolding real_of_float_minus sin_minus lb_sin.simps[of prec x] ub_sin.simps[of prec x] if_P[OF True] Let_def atLeastAtMost_iff by auto
   next
-    case False hence "0 \<le> Ifloat x" unfolding less_float_def by auto
-    from for_pos[OF this `Ifloat x \<le> pi /2`]
+    case False hence "0 \<le> real x" unfolding less_float_def by auto
+    from for_pos[OF this `real x \<le> pi /2`]
     show ?thesis .
   qed
 qed
 
-lemma bnds_sin: "\<forall> x lx ux. (l, u) = bnds_sin prec lx ux \<and> x \<in> {Ifloat lx .. Ifloat ux} \<longrightarrow> Ifloat l \<le> sin x \<and> sin x \<le> Ifloat u"
+lemma bnds_sin: "\<forall> x lx ux. (l, u) = bnds_sin prec lx ux \<and> x \<in> {real lx .. real ux} \<longrightarrow> real l \<le> sin x \<and> sin x \<le> real u"
 proof (rule allI, rule allI, rule allI, rule impI)
   fix x lx ux
-  assume "(l, u) = bnds_sin prec lx ux \<and> x \<in> {Ifloat lx .. Ifloat ux}"
-  hence bnds: "(l, u) = bnds_sin prec lx ux" and x: "x \<in> {Ifloat lx .. Ifloat ux}" by auto
-  show "Ifloat l \<le> sin x \<and> sin x \<le> Ifloat u"
+  assume "(l, u) = bnds_sin prec lx ux \<and> x \<in> {real lx .. real ux}"
+  hence bnds: "(l, u) = bnds_sin prec lx ux" and x: "x \<in> {real lx .. real ux}" by auto
+  show "real l \<le> sin x \<and> sin x \<le> real u"
   proof (cases "lx \<le> - (lb_pi prec * Float 1 -1) \<or> lb_pi prec * Float 1 -1 \<le> ux")
     case True show ?thesis using bnds unfolding bnds_sin_def if_P[OF True] Let_def by auto
   next
     case False
     hence "- lb_pi prec * Float 1 -1 \<le> lx" and "ux \<le> lb_pi prec * Float 1 -1" unfolding le_float_def by auto
-    moreover have "Ifloat (lb_pi prec * Float 1 -1) \<le> pi / 2" unfolding Ifloat_mult using pi_boundaries by auto
-    ultimately have "- (pi / 2) \<le> Ifloat lx" and "Ifloat ux \<le> pi / 2" and "Ifloat lx \<le> Ifloat ux" unfolding le_float_def using x by auto
-    hence "- (pi / 2) \<le> Ifloat ux" and "Ifloat lx \<le> pi / 2" by auto
+    moreover have "real (lb_pi prec * Float 1 -1) \<le> pi / 2" unfolding real_of_float_mult using pi_boundaries by auto
+    ultimately have "- (pi / 2) \<le> real lx" and "real ux \<le> pi / 2" and "real lx \<le> real ux" unfolding le_float_def using x by auto
+    hence "- (pi / 2) \<le> real ux" and "real lx \<le> pi / 2" by auto
     
-    have "- (pi / 2) \<le> x""x \<le> pi / 2" using `Ifloat ux \<le> pi / 2` `- (pi /2) \<le> Ifloat lx` x by auto
+    have "- (pi / 2) \<le> x""x \<le> pi / 2" using `real ux \<le> pi / 2` `- (pi /2) \<le> real lx` x by auto
     
-    { have "Ifloat (lb_sin prec lx) \<le> sin (Ifloat lx)" using lb_sin[OF `- (pi / 2) \<le> Ifloat lx` `Ifloat lx \<le> pi / 2`] unfolding atLeastAtMost_iff by auto
-      also have "\<dots> \<le> sin x" using sin_monotone_2pi' `- (pi / 2) \<le> Ifloat lx` x `x \<le> pi / 2` by auto
-      finally have "Ifloat (lb_sin prec lx) \<le> sin x" . }
+    { have "real (lb_sin prec lx) \<le> sin (real lx)" using lb_sin[OF `- (pi / 2) \<le> real lx` `real lx \<le> pi / 2`] unfolding atLeastAtMost_iff by auto
+      also have "\<dots> \<le> sin x" using sin_monotone_2pi' `- (pi / 2) \<le> real lx` x `x \<le> pi / 2` by auto
+      finally have "real (lb_sin prec lx) \<le> sin x" . }
     moreover
-    { have "sin x \<le> sin (Ifloat ux)" using sin_monotone_2pi' `- (pi / 2) \<le> x` x `Ifloat ux \<le> pi / 2` by auto
-      also have "\<dots> \<le> Ifloat (ub_sin prec ux)" using lb_sin[OF `- (pi / 2) \<le> Ifloat ux` `Ifloat ux \<le> pi / 2`] unfolding atLeastAtMost_iff by auto
-      finally have "sin x \<le> Ifloat (ub_sin prec ux)" . }
+    { have "sin x \<le> sin (real ux)" using sin_monotone_2pi' `- (pi / 2) \<le> x` x `real ux \<le> pi / 2` by auto
+      also have "\<dots> \<le> real (ub_sin prec ux)" using lb_sin[OF `- (pi / 2) \<le> real ux` `real ux \<le> pi / 2`] unfolding atLeastAtMost_iff by auto
+      finally have "sin x \<le> real (ub_sin prec ux)" . }
     ultimately
     show ?thesis using bnds unfolding bnds_sin_def if_not_P[OF False] Let_def by auto
   qed
@@ -1378,49 +1378,49 @@
 "lb_exp_horner prec 0 i k x       = 0" |
 "lb_exp_horner prec (Suc n) i k x = lapprox_rat prec 1 (int k) + x * ub_exp_horner prec n (i + 1) (k * i) x"
 
-lemma bnds_exp_horner: assumes "Ifloat x \<le> 0"
-  shows "exp (Ifloat x) \<in> { Ifloat (lb_exp_horner prec (get_even n) 1 1 x) .. Ifloat (ub_exp_horner prec (get_odd n) 1 1 x) }"
+lemma bnds_exp_horner: assumes "real x \<le> 0"
+  shows "exp (real x) \<in> { real (lb_exp_horner prec (get_even n) 1 1 x) .. real (ub_exp_horner prec (get_odd n) 1 1 x) }"
 proof -
   { fix n
-    have F: "\<And> m. ((\<lambda>i. i + 1) ^ n) m = n + m" by (induct n, auto)
-    have "fact (Suc n) = fact n * ((\<lambda>i. i + 1) ^ n) 1" unfolding F by auto } note f_eq = this
+    have F: "\<And> m. ((\<lambda>i. i + 1) ^^ n) m = n + m" by (induct n, auto)
+    have "fact (Suc n) = fact n * ((\<lambda>i. i + 1) ^^ n) 1" unfolding F by auto } note f_eq = this
     
   note bounds = horner_bounds_nonpos[where f="fact" and lb="lb_exp_horner prec" and ub="ub_exp_horner prec" and j'=0 and s=1,
     OF assms f_eq lb_exp_horner.simps ub_exp_horner.simps]
 
-  { have "Ifloat (lb_exp_horner prec (get_even n) 1 1 x) \<le> (\<Sum>j = 0..<get_even n. 1 / real (fact j) * Ifloat x ^ j)"
+  { have "real (lb_exp_horner prec (get_even n) 1 1 x) \<le> (\<Sum>j = 0..<get_even n. 1 / real (fact j) * real x ^ j)"
       using bounds(1) by auto
-    also have "\<dots> \<le> exp (Ifloat x)"
+    also have "\<dots> \<le> exp (real x)"
     proof -
-      obtain t where "\<bar>t\<bar> \<le> \<bar>Ifloat x\<bar>" and "exp (Ifloat x) = (\<Sum>m = 0..<get_even n. (Ifloat x) ^ m / real (fact m)) + exp t / real (fact (get_even n)) * (Ifloat x) ^ (get_even n)"
+      obtain t where "\<bar>t\<bar> \<le> \<bar>real x\<bar>" and "exp (real x) = (\<Sum>m = 0..<get_even n. (real x) ^ m / real (fact m)) + exp t / real (fact (get_even n)) * (real x) ^ (get_even n)"
 	using Maclaurin_exp_le by blast
-      moreover have "0 \<le> exp t / real (fact (get_even n)) * (Ifloat x) ^ (get_even n)"
+      moreover have "0 \<le> exp t / real (fact (get_even n)) * (real x) ^ (get_even n)"
 	by (auto intro!: mult_nonneg_nonneg divide_nonneg_pos simp add: get_even zero_le_even_power exp_gt_zero)
       ultimately show ?thesis
 	using get_odd exp_gt_zero by (auto intro!: pordered_cancel_semiring_class.mult_nonneg_nonneg)
     qed
-    finally have "Ifloat (lb_exp_horner prec (get_even n) 1 1 x) \<le> exp (Ifloat x)" .
+    finally have "real (lb_exp_horner prec (get_even n) 1 1 x) \<le> exp (real x)" .
   } moreover
   { 
-    have x_less_zero: "Ifloat x ^ get_odd n \<le> 0"
-    proof (cases "Ifloat x = 0")
+    have x_less_zero: "real x ^ get_odd n \<le> 0"
+    proof (cases "real x = 0")
       case True
       have "(get_odd n) \<noteq> 0" using get_odd[THEN odd_pos] by auto
       thus ?thesis unfolding True power_0_left by auto
     next
-      case False hence "Ifloat x < 0" using `Ifloat x \<le> 0` by auto
-      show ?thesis by (rule less_imp_le, auto simp add: power_less_zero_eq get_odd `Ifloat x < 0`)
+      case False hence "real x < 0" using `real x \<le> 0` by auto
+      show ?thesis by (rule less_imp_le, auto simp add: power_less_zero_eq get_odd `real x < 0`)
     qed
 
-    obtain t where "\<bar>t\<bar> \<le> \<bar>Ifloat x\<bar>" and "exp (Ifloat x) = (\<Sum>m = 0..<get_odd n. (Ifloat x) ^ m / real (fact m)) + exp t / real (fact (get_odd n)) * (Ifloat x) ^ (get_odd n)"
+    obtain t where "\<bar>t\<bar> \<le> \<bar>real x\<bar>" and "exp (real x) = (\<Sum>m = 0..<get_odd n. (real x) ^ m / real (fact m)) + exp t / real (fact (get_odd n)) * (real x) ^ (get_odd n)"
       using Maclaurin_exp_le by blast
-    moreover have "exp t / real (fact (get_odd n)) * (Ifloat x) ^ (get_odd n) \<le> 0"
+    moreover have "exp t / real (fact (get_odd n)) * (real x) ^ (get_odd n) \<le> 0"
       by (auto intro!: mult_nonneg_nonpos divide_nonpos_pos simp add: x_less_zero exp_gt_zero)
-    ultimately have "exp (Ifloat x) \<le> (\<Sum>j = 0..<get_odd n. 1 / real (fact j) * Ifloat x ^ j)"
+    ultimately have "exp (real x) \<le> (\<Sum>j = 0..<get_odd n. 1 / real (fact j) * real x ^ j)"
       using get_odd exp_gt_zero by (auto intro!: pordered_cancel_semiring_class.mult_nonneg_nonneg)
-    also have "\<dots> \<le> Ifloat (ub_exp_horner prec (get_odd n) 1 1 x)"
+    also have "\<dots> \<le> real (ub_exp_horner prec (get_odd n) 1 1 x)"
       using bounds(2) by auto
-    finally have "exp (Ifloat x) \<le> Ifloat (ub_exp_horner prec (get_odd n) 1 1 x)" .
+    finally have "exp (real x) \<le> real (ub_exp_horner prec (get_odd n) 1 1 x)" .
   } ultimately show ?thesis by auto
 qed
 
@@ -1443,12 +1443,12 @@
 proof -
   have eq4: "4 = Suc (Suc (Suc (Suc 0)))" by auto
 
-  have "1 / 4 = Ifloat (Float 1 -2)" unfolding Float_num by auto
-  also have "\<dots> \<le> Ifloat (lb_exp_horner 1 (get_even 4) 1 1 (- 1))"
+  have "1 / 4 = real (Float 1 -2)" unfolding Float_num by auto
+  also have "\<dots> \<le> real (lb_exp_horner 1 (get_even 4) 1 1 (- 1))"
     unfolding get_even_def eq4 
     by (auto simp add: lapprox_posrat_def rapprox_posrat_def normfloat.simps)
-  also have "\<dots> \<le> exp (Ifloat (- 1))" using bnds_exp_horner[where x="- 1"] by auto
-  finally show ?thesis unfolding Ifloat_minus Ifloat_1 . 
+  also have "\<dots> \<le> exp (real (- 1 :: float))" using bnds_exp_horner[where x="- 1"] by auto
+  finally show ?thesis unfolding real_of_float_minus real_of_float_1 . 
 qed
 
 lemma lb_exp_pos: assumes "\<not> 0 < x" shows "0 < lb_exp prec x"
@@ -1457,34 +1457,35 @@
   let "?horner x" = "let  y = ?lb_horner x  in if y \<le> 0 then Float 1 -2 else y"
   have pos_horner: "\<And> x. 0 < ?horner x" unfolding Let_def by (cases "?lb_horner x \<le> 0", auto simp add: le_float_def less_float_def)
   moreover { fix x :: float fix num :: nat
-    have "0 < Ifloat (?horner x) ^ num" using `0 < ?horner x`[unfolded less_float_def Ifloat_0] by (rule zero_less_power)
-    also have "\<dots> = Ifloat ((?horner x) ^ num)" using float_power by auto
-    finally have "0 < Ifloat ((?horner x) ^ num)" .
+    have "0 < real (?horner x) ^ num" using `0 < ?horner x`[unfolded less_float_def real_of_float_0] by (rule zero_less_power)
+    also have "\<dots> = real ((?horner x) ^ num)" using float_power by auto
+    finally have "0 < real ((?horner x) ^ num)" .
   }
   ultimately show ?thesis
-    unfolding lb_exp.simps if_not_P[OF `\<not> 0 < x`] Let_def by (cases "floor_fl x", cases "x < - 1", auto simp add: le_float_def less_float_def normfloat) 
+    unfolding lb_exp.simps if_not_P[OF `\<not> 0 < x`] Let_def
+    by (cases "floor_fl x", cases "x < - 1", auto simp add: float_power le_float_def less_float_def)
 qed
 
 lemma exp_boundaries': assumes "x \<le> 0"
-  shows "exp (Ifloat x) \<in> { Ifloat (lb_exp prec x) .. Ifloat (ub_exp prec x)}"
+  shows "exp (real x) \<in> { real (lb_exp prec x) .. real (ub_exp prec x)}"
 proof -
   let "?lb_exp_horner x" = "lb_exp_horner prec (get_even (prec + 2)) 1 1 x"
   let "?ub_exp_horner x" = "ub_exp_horner prec (get_odd (prec + 2)) 1 1 x"
 
-  have "Ifloat x \<le> 0" and "\<not> x > 0" using `x \<le> 0` unfolding le_float_def less_float_def by auto
+  have "real x \<le> 0" and "\<not> x > 0" using `x \<le> 0` unfolding le_float_def less_float_def by auto
   show ?thesis
   proof (cases "x < - 1")
-    case False hence "- 1 \<le> Ifloat x" unfolding less_float_def by auto
+    case False hence "- 1 \<le> real x" unfolding less_float_def by auto
     show ?thesis
     proof (cases "?lb_exp_horner x \<le> 0")
-      from `\<not> x < - 1` have "- 1 \<le> Ifloat x" unfolding less_float_def by auto
-      hence "exp (- 1) \<le> exp (Ifloat x)" unfolding exp_le_cancel_iff .
+      from `\<not> x < - 1` have "- 1 \<le> real x" unfolding less_float_def by auto
+      hence "exp (- 1) \<le> exp (real x)" unfolding exp_le_cancel_iff .
       from order_trans[OF exp_m1_ge_quarter this]
-      have "Ifloat (Float 1 -2) \<le> exp (Ifloat x)" unfolding Float_num .
+      have "real (Float 1 -2) \<le> exp (real x)" unfolding Float_num .
       moreover case True
-      ultimately show ?thesis using bnds_exp_horner `Ifloat x \<le> 0` `\<not> x > 0` `\<not> x < - 1` by auto
+      ultimately show ?thesis using bnds_exp_horner `real x \<le> 0` `\<not> x > 0` `\<not> x < - 1` by auto
     next
-      case False thus ?thesis using bnds_exp_horner `Ifloat x \<le> 0` `\<not> x > 0` `\<not> x < - 1` by (auto simp add: Let_def)
+      case False thus ?thesis using bnds_exp_horner `real x \<le> 0` `\<not> x > 0` `\<not> x < - 1` by (auto simp add: Let_def)
     qed
   next
     case True
@@ -1492,10 +1493,10 @@
     obtain m e where Float_floor: "floor_fl x = Float m e" by (cases "floor_fl x", auto)
     let ?num = "nat (- m) * 2 ^ nat e"
     
-    have "Ifloat (floor_fl x) < - 1" using floor_fl `x < - 1` unfolding le_float_def less_float_def Ifloat_minus Ifloat_1 by (rule order_le_less_trans)
-    hence "Ifloat (floor_fl x) < 0" unfolding Float_floor Ifloat.simps using zero_less_pow2[of xe] by auto
+    have "real (floor_fl x) < - 1" using floor_fl `x < - 1` unfolding le_float_def less_float_def real_of_float_minus real_of_float_1 by (rule order_le_less_trans)
+    hence "real (floor_fl x) < 0" unfolding Float_floor real_of_float_simp using zero_less_pow2[of xe] by auto
     hence "m < 0"
-      unfolding less_float_def Ifloat_0 Float_floor Ifloat.simps
+      unfolding less_float_def real_of_float_0 Float_floor real_of_float_simp
       unfolding pos_prod_lt[OF zero_less_pow2[of e], unfolded real_mult_commute] by auto
     hence "1 \<le> - m" by auto
     hence "0 < nat (- m)" by auto
@@ -1505,56 +1506,56 @@
     ultimately have "0 < ?num"  by auto
     hence "real ?num \<noteq> 0" by auto
     have e_nat: "int (nat e) = e" using `0 \<le> e` by auto
-    have num_eq: "real ?num = Ifloat (- floor_fl x)" using `0 < nat (- m)`
-      unfolding Float_floor Ifloat_minus Ifloat.simps real_of_nat_mult pow2_int[of "nat e", unfolded e_nat] realpow_real_of_nat[symmetric] by auto
-    have "0 < - floor_fl x" using `0 < ?num`[unfolded real_of_nat_less_iff[symmetric]] unfolding less_float_def num_eq[symmetric] Ifloat_0 real_of_nat_zero .
-    hence "Ifloat (floor_fl x) < 0" unfolding less_float_def by auto
+    have num_eq: "real ?num = real (- floor_fl x)" using `0 < nat (- m)`
+      unfolding Float_floor real_of_float_minus real_of_float_simp real_of_nat_mult pow2_int[of "nat e", unfolded e_nat] realpow_real_of_nat[symmetric] by auto
+    have "0 < - floor_fl x" using `0 < ?num`[unfolded real_of_nat_less_iff[symmetric]] unfolding less_float_def num_eq[symmetric] real_of_float_0 real_of_nat_zero .
+    hence "real (floor_fl x) < 0" unfolding less_float_def by auto
     
-    have "exp (Ifloat x) \<le> Ifloat (ub_exp prec x)"
+    have "exp (real x) \<le> real (ub_exp prec x)"
     proof -
-      have div_less_zero: "Ifloat (float_divr prec x (- floor_fl x)) \<le> 0" 
-	using float_divr_nonpos_pos_upper_bound[OF `x \<le> 0` `0 < - floor_fl x`] unfolding le_float_def Ifloat_0 .
+      have div_less_zero: "real (float_divr prec x (- floor_fl x)) \<le> 0" 
+	using float_divr_nonpos_pos_upper_bound[OF `x \<le> 0` `0 < - floor_fl x`] unfolding le_float_def real_of_float_0 .
       
-      have "exp (Ifloat x) = exp (real ?num * (Ifloat x / real ?num))" using `real ?num \<noteq> 0` by auto
-      also have "\<dots> = exp (Ifloat x / real ?num) ^ ?num" unfolding exp_real_of_nat_mult ..
-      also have "\<dots> \<le> exp (Ifloat (float_divr prec x (- floor_fl x))) ^ ?num" unfolding num_eq
+      have "exp (real x) = exp (real ?num * (real x / real ?num))" using `real ?num \<noteq> 0` by auto
+      also have "\<dots> = exp (real x / real ?num) ^ ?num" unfolding exp_real_of_nat_mult ..
+      also have "\<dots> \<le> exp (real (float_divr prec x (- floor_fl x))) ^ ?num" unfolding num_eq
 	by (rule power_mono, rule exp_le_cancel_iff[THEN iffD2], rule float_divr) auto
-      also have "\<dots> \<le> Ifloat ((?ub_exp_horner (float_divr prec x (- floor_fl x))) ^ ?num)" unfolding float_power
+      also have "\<dots> \<le> real ((?ub_exp_horner (float_divr prec x (- floor_fl x))) ^ ?num)" unfolding float_power
 	by (rule power_mono, rule bnds_exp_horner[OF div_less_zero, unfolded atLeastAtMost_iff, THEN conjunct2], auto)
       finally show ?thesis unfolding ub_exp.simps if_not_P[OF `\<not> 0 < x`] if_P[OF `x < - 1`] float.cases Float_floor Let_def .
     qed
     moreover 
-    have "Ifloat (lb_exp prec x) \<le> exp (Ifloat x)"
+    have "real (lb_exp prec x) \<le> exp (real x)"
     proof -
       let ?divl = "float_divl prec x (- Float m e)"
       let ?horner = "?lb_exp_horner ?divl"
       
       show ?thesis
       proof (cases "?horner \<le> 0")
-	case False hence "0 \<le> Ifloat ?horner" unfolding le_float_def by auto
+	case False hence "0 \<le> real ?horner" unfolding le_float_def by auto
 	
-	have div_less_zero: "Ifloat (float_divl prec x (- floor_fl x)) \<le> 0"
-	  using `Ifloat (floor_fl x) < 0` `Ifloat x \<le> 0` by (auto intro!: order_trans[OF float_divl] divide_nonpos_neg)
+	have div_less_zero: "real (float_divl prec x (- floor_fl x)) \<le> 0"
+	  using `real (floor_fl x) < 0` `real x \<le> 0` by (auto intro!: order_trans[OF float_divl] divide_nonpos_neg)
 	
-	have "Ifloat ((?lb_exp_horner (float_divl prec x (- floor_fl x))) ^ ?num) \<le>  
-          exp (Ifloat (float_divl prec x (- floor_fl x))) ^ ?num" unfolding float_power 
-	  using `0 \<le> Ifloat ?horner`[unfolded Float_floor[symmetric]] bnds_exp_horner[OF div_less_zero, unfolded atLeastAtMost_iff, THEN conjunct1] by (auto intro!: power_mono)
-	also have "\<dots> \<le> exp (Ifloat x / real ?num) ^ ?num" unfolding num_eq
-	  using float_divl by (auto intro!: power_mono simp del: Ifloat_minus)
-	also have "\<dots> = exp (real ?num * (Ifloat x / real ?num))" unfolding exp_real_of_nat_mult ..
-	also have "\<dots> = exp (Ifloat x)" using `real ?num \<noteq> 0` by auto
+	have "real ((?lb_exp_horner (float_divl prec x (- floor_fl x))) ^ ?num) \<le>  
+          exp (real (float_divl prec x (- floor_fl x))) ^ ?num" unfolding float_power 
+	  using `0 \<le> real ?horner`[unfolded Float_floor[symmetric]] bnds_exp_horner[OF div_less_zero, unfolded atLeastAtMost_iff, THEN conjunct1] by (auto intro!: power_mono)
+	also have "\<dots> \<le> exp (real x / real ?num) ^ ?num" unfolding num_eq
+	  using float_divl by (auto intro!: power_mono simp del: real_of_float_minus)
+	also have "\<dots> = exp (real ?num * (real x / real ?num))" unfolding exp_real_of_nat_mult ..
+	also have "\<dots> = exp (real x)" using `real ?num \<noteq> 0` by auto
 	finally show ?thesis
 	  unfolding lb_exp.simps if_not_P[OF `\<not> 0 < x`] if_P[OF `x < - 1`] float.cases Float_floor Let_def if_not_P[OF False] by auto
       next
 	case True
-	have "Ifloat (floor_fl x) \<noteq> 0" and "Ifloat (floor_fl x) \<le> 0" using `Ifloat (floor_fl x) < 0` by auto
-	from divide_right_mono_neg[OF floor_fl[of x] `Ifloat (floor_fl x) \<le> 0`, unfolded divide_self[OF `Ifloat (floor_fl x) \<noteq> 0`]]
-	have "- 1 \<le> Ifloat x / Ifloat (- floor_fl x)" unfolding Ifloat_minus by auto
+	have "real (floor_fl x) \<noteq> 0" and "real (floor_fl x) \<le> 0" using `real (floor_fl x) < 0` by auto
+	from divide_right_mono_neg[OF floor_fl[of x] `real (floor_fl x) \<le> 0`, unfolded divide_self[OF `real (floor_fl x) \<noteq> 0`]]
+	have "- 1 \<le> real x / real (- floor_fl x)" unfolding real_of_float_minus by auto
 	from order_trans[OF exp_m1_ge_quarter this[unfolded exp_le_cancel_iff[where x="- 1", symmetric]]]
-	have "Ifloat (Float 1 -2) \<le> exp (Ifloat x / Ifloat (- floor_fl x))" unfolding Float_num .
-	hence "Ifloat (Float 1 -2) ^ ?num \<le> exp (Ifloat x / Ifloat (- floor_fl x)) ^ ?num"
+	have "real (Float 1 -2) \<le> exp (real x / real (- floor_fl x))" unfolding Float_num .
+	hence "real (Float 1 -2) ^ ?num \<le> exp (real x / real (- floor_fl x)) ^ ?num"
 	  by (auto intro!: power_mono simp add: Float_num)
-	also have "\<dots> = exp (Ifloat x)" unfolding num_eq exp_real_of_nat_mult[symmetric] using `Ifloat (floor_fl x) \<noteq> 0` by auto
+	also have "\<dots> = exp (real x)" unfolding num_eq exp_real_of_nat_mult[symmetric] using `real (floor_fl x) \<noteq> 0` by auto
 	finally show ?thesis
 	  unfolding lb_exp.simps if_not_P[OF `\<not> 0 < x`] if_P[OF `x < - 1`] float.cases Float_floor Let_def if_P[OF True] float_power .
       qed
@@ -1563,7 +1564,7 @@
   qed
 qed
 
-lemma exp_boundaries: "exp (Ifloat x) \<in> { Ifloat (lb_exp prec x) .. Ifloat (ub_exp prec x)}"
+lemma exp_boundaries: "exp (real x) \<in> { real (lb_exp prec x) .. real (ub_exp prec x)}"
 proof -
   show ?thesis
   proof (cases "0 < x")
@@ -1572,50 +1573,51 @@
   next
     case True hence "-x \<le> 0" unfolding less_float_def le_float_def by auto
     
-    have "Ifloat (lb_exp prec x) \<le> exp (Ifloat x)"
+    have "real (lb_exp prec x) \<le> exp (real x)"
     proof -
       from exp_boundaries'[OF `-x \<le> 0`]
-      have ub_exp: "exp (- Ifloat x) \<le> Ifloat (ub_exp prec (-x))" unfolding atLeastAtMost_iff Ifloat_minus by auto
+      have ub_exp: "exp (- real x) \<le> real (ub_exp prec (-x))" unfolding atLeastAtMost_iff real_of_float_minus by auto
       
-      have "Ifloat (float_divl prec 1 (ub_exp prec (-x))) \<le> Ifloat 1 / Ifloat (ub_exp prec (-x))" using float_divl .
-      also have "Ifloat 1 / Ifloat (ub_exp prec (-x)) \<le> exp (Ifloat x)"
+      have "real (float_divl prec 1 (ub_exp prec (-x))) \<le> 1 / real (ub_exp prec (-x))" using float_divl[where x=1] by auto
+      also have "\<dots> \<le> exp (real x)"
 	using ub_exp[unfolded inverse_le_iff_le[OF order_less_le_trans[OF exp_gt_zero ub_exp] exp_gt_zero, symmetric]]
 	unfolding exp_minus nonzero_inverse_inverse_eq[OF exp_not_eq_zero] inverse_eq_divide by auto
       finally show ?thesis unfolding lb_exp.simps if_P[OF True] .
     qed
     moreover
-    have "exp (Ifloat x) \<le> Ifloat (ub_exp prec x)"
+    have "exp (real x) \<le> real (ub_exp prec x)"
     proof -
       have "\<not> 0 < -x" using `0 < x` unfolding less_float_def by auto
       
       from exp_boundaries'[OF `-x \<le> 0`]
-      have lb_exp: "Ifloat (lb_exp prec (-x)) \<le> exp (- Ifloat x)" unfolding atLeastAtMost_iff Ifloat_minus by auto
+      have lb_exp: "real (lb_exp prec (-x)) \<le> exp (- real x)" unfolding atLeastAtMost_iff real_of_float_minus by auto
       
-      have "exp (Ifloat x) \<le> Ifloat 1 / Ifloat (lb_exp prec (-x))"
-	using lb_exp[unfolded inverse_le_iff_le[OF exp_gt_zero lb_exp_pos[OF `\<not> 0 < -x`, unfolded less_float_def Ifloat_0], symmetric]]
-	unfolding exp_minus nonzero_inverse_inverse_eq[OF exp_not_eq_zero] inverse_eq_divide Ifloat_1 by auto
-      also have "\<dots> \<le> Ifloat (float_divr prec 1 (lb_exp prec (-x)))" using float_divr .
+      have "exp (real x) \<le> real (1 :: float) / real (lb_exp prec (-x))"
+	using lb_exp[unfolded inverse_le_iff_le[OF exp_gt_zero lb_exp_pos[OF `\<not> 0 < -x`, unfolded less_float_def real_of_float_0], 
+	                                        symmetric]]
+	unfolding exp_minus nonzero_inverse_inverse_eq[OF exp_not_eq_zero] inverse_eq_divide real_of_float_1 by auto
+      also have "\<dots> \<le> real (float_divr prec 1 (lb_exp prec (-x)))" using float_divr .
       finally show ?thesis unfolding ub_exp.simps if_P[OF True] .
     qed
     ultimately show ?thesis by auto
   qed
 qed
 
-lemma bnds_exp: "\<forall> x lx ux. (l, u) = (lb_exp prec lx, ub_exp prec ux) \<and> x \<in> {Ifloat lx .. Ifloat ux} \<longrightarrow> Ifloat l \<le> exp x \<and> exp x \<le> Ifloat u"
+lemma bnds_exp: "\<forall> x lx ux. (l, u) = (lb_exp prec lx, ub_exp prec ux) \<and> x \<in> {real lx .. real ux} \<longrightarrow> real l \<le> exp x \<and> exp x \<le> real u"
 proof (rule allI, rule allI, rule allI, rule impI)
   fix x lx ux
-  assume "(l, u) = (lb_exp prec lx, ub_exp prec ux) \<and> x \<in> {Ifloat lx .. Ifloat ux}"
-  hence l: "lb_exp prec lx = l " and u: "ub_exp prec ux = u" and x: "x \<in> {Ifloat lx .. Ifloat ux}" by auto
+  assume "(l, u) = (lb_exp prec lx, ub_exp prec ux) \<and> x \<in> {real lx .. real ux}"
+  hence l: "lb_exp prec lx = l " and u: "ub_exp prec ux = u" and x: "x \<in> {real lx .. real ux}" by auto
 
   { from exp_boundaries[of lx prec, unfolded l]
-    have "Ifloat l \<le> exp (Ifloat lx)" by (auto simp del: lb_exp.simps)
+    have "real l \<le> exp (real lx)" by (auto simp del: lb_exp.simps)
     also have "\<dots> \<le> exp x" using x by auto
-    finally have "Ifloat l \<le> exp x" .
+    finally have "real l \<le> exp x" .
   } moreover
-  { have "exp x \<le> exp (Ifloat ux)" using x by auto
-    also have "\<dots> \<le> Ifloat u" using exp_boundaries[of ux prec, unfolded u] by (auto simp del: ub_exp.simps)
-    finally have "exp x \<le> Ifloat u" .
-  } ultimately show "Ifloat l \<le> exp x \<and> exp x \<le> Ifloat u" ..
+  { have "exp x \<le> exp (real ux)" using x by auto
+    also have "\<dots> \<le> real u" using exp_boundaries[of ux prec, unfolded u] by (auto simp del: ub_exp.simps)
+    finally have "exp x \<le> real u" .
+  } ultimately show "real l \<le> exp x \<and> exp x \<le> real u" ..
 qed
 
 section "Logarithm"
@@ -1631,10 +1633,10 @@
 
 lemma ln_bounds:
   assumes "0 \<le> x" and "x < 1"
-  shows "(\<Sum>i=0..<2*n. -1^i * (1 / real (i + 1)) * x^(Suc i)) \<le> ln (x + 1)" (is "?lb")
-  and "ln (x + 1) \<le> (\<Sum>i=0..<2*n + 1. -1^i * (1 / real (i + 1)) * x^(Suc i))" (is "?ub")
+  shows "(\<Sum>i=0..<2*n. -1^i * (1 / real (i + 1)) * x ^ (Suc i)) \<le> ln (x + 1)" (is "?lb")
+  and "ln (x + 1) \<le> (\<Sum>i=0..<2*n + 1. -1^i * (1 / real (i + 1)) * x ^ (Suc i))" (is "?ub")
 proof -
-  let "?a n" = "(1/real (n +1)) * x^(Suc n)"
+  let "?a n" = "(1/real (n +1)) * x ^ (Suc n)"
 
   have ln_eq: "(\<Sum> i. -1^i * ?a i) = ln (x + 1)"
     using ln_series[of "x + 1"] `0 \<le> x` `x < 1` by auto
@@ -1655,26 +1657,26 @@
 qed
 
 lemma ln_float_bounds: 
-  assumes "0 \<le> Ifloat x" and "Ifloat x < 1"
-  shows "Ifloat (x * lb_ln_horner prec (get_even n) 1 x) \<le> ln (Ifloat x + 1)" (is "?lb \<le> ?ln")
-  and "ln (Ifloat x + 1) \<le> Ifloat (x * ub_ln_horner prec (get_odd n) 1 x)" (is "?ln \<le> ?ub")
+  assumes "0 \<le> real x" and "real x < 1"
+  shows "real (x * lb_ln_horner prec (get_even n) 1 x) \<le> ln (real x + 1)" (is "?lb \<le> ?ln")
+  and "ln (real x + 1) \<le> real (x * ub_ln_horner prec (get_odd n) 1 x)" (is "?ln \<le> ?ub")
 proof -
   obtain ev where ev: "get_even n = 2 * ev" using get_even_double ..
   obtain od where od: "get_odd n = 2 * od + 1" using get_odd_double ..
 
-  let "?s n" = "-1^n * (1 / real (1 + n)) * (Ifloat x)^(Suc n)"
+  let "?s n" = "-1^n * (1 / real (1 + n)) * (real x)^(Suc n)"
 
-  have "?lb \<le> setsum ?s {0 ..< 2 * ev}" unfolding power_Suc2 real_mult_assoc[symmetric] Ifloat_mult setsum_left_distrib[symmetric] unfolding real_mult_commute[of "Ifloat x"] ev
+  have "?lb \<le> setsum ?s {0 ..< 2 * ev}" unfolding power_Suc2 real_mult_assoc[symmetric] real_of_float_mult setsum_left_distrib[symmetric] unfolding real_mult_commute[of "real x"] ev
     using horner_bounds(1)[where G="\<lambda> i k. Suc k" and F="\<lambda>x. x" and f="\<lambda>x. x" and lb="\<lambda>n i k x. lb_ln_horner prec n k x" and ub="\<lambda>n i k x. ub_ln_horner prec n k x" and j'=1 and n="2*ev",
-      OF `0 \<le> Ifloat x` refl lb_ln_horner.simps ub_ln_horner.simps] `0 \<le> Ifloat x`
+      OF `0 \<le> real x` refl lb_ln_horner.simps ub_ln_horner.simps] `0 \<le> real x`
     by (rule mult_right_mono)
-  also have "\<dots> \<le> ?ln" using ln_bounds(1)[OF `0 \<le> Ifloat x` `Ifloat x < 1`] by auto
+  also have "\<dots> \<le> ?ln" using ln_bounds(1)[OF `0 \<le> real x` `real x < 1`] by auto
   finally show "?lb \<le> ?ln" . 
 
-  have "?ln \<le> setsum ?s {0 ..< 2 * od + 1}" using ln_bounds(2)[OF `0 \<le> Ifloat x` `Ifloat x < 1`] by auto
-  also have "\<dots> \<le> ?ub" unfolding power_Suc2 real_mult_assoc[symmetric] Ifloat_mult setsum_left_distrib[symmetric] unfolding real_mult_commute[of "Ifloat x"] od
+  have "?ln \<le> setsum ?s {0 ..< 2 * od + 1}" using ln_bounds(2)[OF `0 \<le> real x` `real x < 1`] by auto
+  also have "\<dots> \<le> ?ub" unfolding power_Suc2 real_mult_assoc[symmetric] real_of_float_mult setsum_left_distrib[symmetric] unfolding real_mult_commute[of "real x"] od
     using horner_bounds(2)[where G="\<lambda> i k. Suc k" and F="\<lambda>x. x" and f="\<lambda>x. x" and lb="\<lambda>n i k x. lb_ln_horner prec n k x" and ub="\<lambda>n i k x. ub_ln_horner prec n k x" and j'=1 and n="2*od+1",
-      OF `0 \<le> Ifloat x` refl lb_ln_horner.simps ub_ln_horner.simps] `0 \<le> Ifloat x`
+      OF `0 \<le> real x` refl lb_ln_horner.simps ub_ln_horner.simps] `0 \<le> real x`
     by (rule mult_right_mono)
   finally show "?ln \<le> ?ub" . 
 qed
@@ -1698,43 +1700,43 @@
                                         in (Float 1 -1 * lb_ln_horner prec (get_even prec) 1 (Float 1 -1)) + 
                                            (third * lb_ln_horner prec (get_even prec) 1 third))"
 
-lemma ub_ln2: "ln 2 \<le> Ifloat (ub_ln2 prec)" (is "?ub_ln2")
-  and lb_ln2: "Ifloat (lb_ln2 prec) \<le> ln 2" (is "?lb_ln2")
+lemma ub_ln2: "ln 2 \<le> real (ub_ln2 prec)" (is "?ub_ln2")
+  and lb_ln2: "real (lb_ln2 prec) \<le> ln 2" (is "?lb_ln2")
 proof -
   let ?uthird = "rapprox_rat (max prec 1) 1 3"
   let ?lthird = "lapprox_rat prec 1 3"
 
   have ln2_sum: "ln 2 = ln (1/2 + 1) + ln (1 / 3 + 1)"
     using ln_add[of "3 / 2" "1 / 2"] by auto
-  have lb3: "Ifloat ?lthird \<le> 1 / 3" using lapprox_rat[of prec 1 3] by auto
-  hence lb3_ub: "Ifloat ?lthird < 1" by auto
-  have lb3_lb: "0 \<le> Ifloat ?lthird" using lapprox_rat_bottom[of 1 3] by auto
-  have ub3: "1 / 3 \<le> Ifloat ?uthird" using rapprox_rat[of 1 3] by auto
-  hence ub3_lb: "0 \<le> Ifloat ?uthird" by auto
+  have lb3: "real ?lthird \<le> 1 / 3" using lapprox_rat[of prec 1 3] by auto
+  hence lb3_ub: "real ?lthird < 1" by auto
+  have lb3_lb: "0 \<le> real ?lthird" using lapprox_rat_bottom[of 1 3] by auto
+  have ub3: "1 / 3 \<le> real ?uthird" using rapprox_rat[of 1 3] by auto
+  hence ub3_lb: "0 \<le> real ?uthird" by auto
 
-  have lb2: "0 \<le> Ifloat (Float 1 -1)" and ub2: "Ifloat (Float 1 -1) < 1" unfolding Float_num by auto
+  have lb2: "0 \<le> real (Float 1 -1)" and ub2: "real (Float 1 -1) < 1" unfolding Float_num by auto
 
   have "0 \<le> (1::int)" and "0 < (3::int)" by auto
-  have ub3_ub: "Ifloat ?uthird < 1" unfolding rapprox_rat.simps(2)[OF `0 \<le> 1` `0 < 3`]
+  have ub3_ub: "real ?uthird < 1" unfolding rapprox_rat.simps(2)[OF `0 \<le> 1` `0 < 3`]
     by (rule rapprox_posrat_less1, auto)
 
   have third_gt0: "(0 :: real) < 1 / 3 + 1" by auto
-  have uthird_gt0: "0 < Ifloat ?uthird + 1" using ub3_lb by auto
-  have lthird_gt0: "0 < Ifloat ?lthird + 1" using lb3_lb by auto
+  have uthird_gt0: "0 < real ?uthird + 1" using ub3_lb by auto
+  have lthird_gt0: "0 < real ?lthird + 1" using lb3_lb by auto
 
-  show ?ub_ln2 unfolding ub_ln2_def Let_def Ifloat_add ln2_sum Float_num(4)[symmetric]
+  show ?ub_ln2 unfolding ub_ln2_def Let_def real_of_float_add ln2_sum Float_num(4)[symmetric]
   proof (rule add_mono, fact ln_float_bounds(2)[OF lb2 ub2])
-    have "ln (1 / 3 + 1) \<le> ln (Ifloat ?uthird + 1)" unfolding ln_le_cancel_iff[OF third_gt0 uthird_gt0] using ub3 by auto
-    also have "\<dots> \<le> Ifloat (?uthird * ub_ln_horner prec (get_odd prec) 1 ?uthird)"
+    have "ln (1 / 3 + 1) \<le> ln (real ?uthird + 1)" unfolding ln_le_cancel_iff[OF third_gt0 uthird_gt0] using ub3 by auto
+    also have "\<dots> \<le> real (?uthird * ub_ln_horner prec (get_odd prec) 1 ?uthird)"
       using ln_float_bounds(2)[OF ub3_lb ub3_ub] .
-    finally show "ln (1 / 3 + 1) \<le> Ifloat (?uthird * ub_ln_horner prec (get_odd prec) 1 ?uthird)" .
+    finally show "ln (1 / 3 + 1) \<le> real (?uthird * ub_ln_horner prec (get_odd prec) 1 ?uthird)" .
   qed
-  show ?lb_ln2 unfolding lb_ln2_def Let_def Ifloat_add ln2_sum Float_num(4)[symmetric]
+  show ?lb_ln2 unfolding lb_ln2_def Let_def real_of_float_add ln2_sum Float_num(4)[symmetric]
   proof (rule add_mono, fact ln_float_bounds(1)[OF lb2 ub2])
-    have "Ifloat (?lthird * lb_ln_horner prec (get_even prec) 1 ?lthird) \<le> ln (Ifloat ?lthird + 1)"
+    have "real (?lthird * lb_ln_horner prec (get_even prec) 1 ?lthird) \<le> ln (real ?lthird + 1)"
       using ln_float_bounds(1)[OF lb3_lb lb3_ub] .
     also have "\<dots> \<le> ln (1 / 3 + 1)" unfolding ln_le_cancel_iff[OF lthird_gt0 third_gt0] using lb3 by auto
-    finally show "Ifloat (?lthird * lb_ln_horner prec (get_even prec) 1 ?lthird) \<le> ln (1 / 3 + 1)" .
+    finally show "real (?lthird * lb_ln_horner prec (get_even prec) 1 ?lthird) \<le> ln (1 / 3 + 1)" .
   qed
 qed
 
@@ -1767,7 +1769,7 @@
   show False using `float_divr prec 1 x < 1` unfolding less_float_def le_float_def by auto
 qed
 
-lemma ln_shifted_float: assumes "0 < m" shows "ln (Ifloat (Float m e)) = ln 2 * real (e + (bitlen m - 1)) + ln (Ifloat (Float m (- (bitlen m - 1))))"
+lemma ln_shifted_float: assumes "0 < m" shows "ln (real (Float m e)) = ln 2 * real (e + (bitlen m - 1)) + ln (real (Float m (- (bitlen m - 1))))"
 proof -
   let ?B = "2^nat (bitlen m - 1)"
   have "0 < real m" and "\<And>X. (0 :: real) < 2^X" and "0 < (2 :: real)" and "m \<noteq> 0" using assms by auto
@@ -1777,7 +1779,7 @@
     case True
     show ?thesis unfolding normalized_float[OF `m \<noteq> 0`]
       unfolding ln_div[OF `0 < real m` `0 < ?B`] real_of_int_add ln_realpow[OF `0 < 2`] 
-      unfolding Ifloat_ge0_exp[OF True] ln_mult[OF `0 < real m` `0 < 2^nat e`] 
+      unfolding real_of_float_ge0_exp[OF True] ln_mult[OF `0 < real m` `0 < 2^nat e`] 
       ln_realpow[OF `0 < 2`] algebra_simps using `0 \<le> bitlen m - 1` True by auto
   next
     case False hence "0 < -e" by auto
@@ -1785,20 +1787,20 @@
     hence inv_gt0: "(0::real) < inverse (2^nat (-e))" by auto
     show ?thesis unfolding normalized_float[OF `m \<noteq> 0`]
       unfolding ln_div[OF `0 < real m` `0 < ?B`] real_of_int_add ln_realpow[OF `0 < 2`] 
-      unfolding Ifloat_nge0_exp[OF False] ln_mult[OF `0 < real m` inv_gt0] ln_inverse[OF pow_gt0]
+      unfolding real_of_float_nge0_exp[OF False] ln_mult[OF `0 < real m` inv_gt0] ln_inverse[OF pow_gt0]
       ln_realpow[OF `0 < 2`] algebra_simps using `0 \<le> bitlen m - 1` False by auto
   qed
 qed
 
 lemma ub_ln_lb_ln_bounds': assumes "1 \<le> x"
-  shows "Ifloat (the (lb_ln prec x)) \<le> ln (Ifloat x) \<and> ln (Ifloat x) \<le> Ifloat (the (ub_ln prec x))"
+  shows "real (the (lb_ln prec x)) \<le> ln (real x) \<and> ln (real x) \<le> real (the (ub_ln prec x))"
   (is "?lb \<le> ?ln \<and> ?ln \<le> ?ub")
 proof (cases "x < Float 1 1")
-  case True hence "Ifloat (x - 1) < 1" unfolding less_float_def Float_num by auto
+  case True hence "real (x - 1) < 1" unfolding less_float_def Float_num by auto
   have "\<not> x \<le> 0" and "\<not> x < 1" using `1 \<le> x` unfolding less_float_def le_float_def by auto
-  hence "0 \<le> Ifloat (x - 1)" using `1 \<le> x` unfolding less_float_def Float_num by auto
+  hence "0 \<le> real (x - 1)" using `1 \<le> x` unfolding less_float_def Float_num by auto
   show ?thesis unfolding lb_ln.simps unfolding ub_ln.simps Let_def
-    using ln_float_bounds[OF `0 \<le> Ifloat (x - 1)` `Ifloat (x - 1) < 1`] `\<not> x \<le> 0` `\<not> x < 1` True by auto
+    using ln_float_bounds[OF `0 \<le> real (x - 1)` `real (x - 1) < 1`] `\<not> x \<le> 0` `\<not> x < 1` True by auto
 next
   case False
   have "\<not> x \<le> 0" and "\<not> x < 1" "0 < x" using `1 \<le> x` unfolding less_float_def le_float_def by auto
@@ -1811,8 +1813,8 @@
     have "0 < m" and "m \<noteq> 0" using float_pos_m_pos `0 < x` Float by auto
 
     {
-      have "Ifloat (lb_ln2 prec * ?s) \<le> ln 2 * real (e + (bitlen m - 1))" (is "?lb2 \<le> _")
-	unfolding Ifloat_mult Ifloat_ge0_exp[OF order_refl] nat_0 power_0 mult_1_right
+      have "real (lb_ln2 prec * ?s) \<le> ln 2 * real (e + (bitlen m - 1))" (is "?lb2 \<le> _")
+	unfolding real_of_float_mult real_of_float_ge0_exp[OF order_refl] nat_0 power_0 mult_1_right
 	using lb_ln2[of prec]
       proof (rule mult_right_mono)
 	have "1 \<le> Float m e" using `1 \<le> x` Float unfolding le_float_def by auto
@@ -1821,38 +1823,38 @@
       qed
       moreover
       from bitlen_div[OF `0 < m`, unfolded normalized_float[OF `m \<noteq> 0`, symmetric]]
-      have "0 \<le> Ifloat (?x - 1)" and "Ifloat (?x - 1) < 1" by auto
+      have "0 \<le> real (?x - 1)" and "real (?x - 1) < 1" by auto
       from ln_float_bounds(1)[OF this]
-      have "Ifloat ((?x - 1) * lb_ln_horner prec (get_even prec) 1 (?x - 1)) \<le> ln (Ifloat ?x)" (is "?lb_horner \<le> _") by auto
-      ultimately have "?lb2 + ?lb_horner \<le> ln (Ifloat x)"
+      have "real ((?x - 1) * lb_ln_horner prec (get_even prec) 1 (?x - 1)) \<le> ln (real ?x)" (is "?lb_horner \<le> _") by auto
+      ultimately have "?lb2 + ?lb_horner \<le> ln (real x)"
 	unfolding Float ln_shifted_float[OF `0 < m`, of e] by auto
     } 
     moreover
     {
       from bitlen_div[OF `0 < m`, unfolded normalized_float[OF `m \<noteq> 0`, symmetric]]
-      have "0 \<le> Ifloat (?x - 1)" and "Ifloat (?x - 1) < 1" by auto
+      have "0 \<le> real (?x - 1)" and "real (?x - 1) < 1" by auto
       from ln_float_bounds(2)[OF this]
-      have "ln (Ifloat ?x) \<le> Ifloat ((?x - 1) * ub_ln_horner prec (get_odd prec) 1 (?x - 1))" (is "_ \<le> ?ub_horner") by auto
+      have "ln (real ?x) \<le> real ((?x - 1) * ub_ln_horner prec (get_odd prec) 1 (?x - 1))" (is "_ \<le> ?ub_horner") by auto
       moreover
-      have "ln 2 * real (e + (bitlen m - 1)) \<le> Ifloat (ub_ln2 prec * ?s)" (is "_ \<le> ?ub2")
-	unfolding Ifloat_mult Ifloat_ge0_exp[OF order_refl] nat_0 power_0 mult_1_right
+      have "ln 2 * real (e + (bitlen m - 1)) \<le> real (ub_ln2 prec * ?s)" (is "_ \<le> ?ub2")
+	unfolding real_of_float_mult real_of_float_ge0_exp[OF order_refl] nat_0 power_0 mult_1_right
 	using ub_ln2[of prec] 
       proof (rule mult_right_mono)
 	have "1 \<le> Float m e" using `1 \<le> x` Float unfolding le_float_def by auto
 	from float_gt1_scale[OF this]
 	show "0 \<le> real (e + (bitlen m - 1))" by auto
       qed
-      ultimately have "ln (Ifloat x) \<le> ?ub2 + ?ub_horner"
+      ultimately have "ln (real x) \<le> ?ub2 + ?ub_horner"
 	unfolding Float ln_shifted_float[OF `0 < m`, of e] by auto
     }
     ultimately show ?thesis unfolding lb_ln.simps unfolding ub_ln.simps
       unfolding if_not_P[OF `\<not> x \<le> 0`] if_not_P[OF `\<not> x < 1`] if_not_P[OF False] Let_def
-      unfolding scale.simps[of m e, unfolded Float[symmetric]] mantissa.simps[of m e, unfolded Float[symmetric]] Ifloat_add by auto
+      unfolding scale.simps[of m e, unfolded Float[symmetric]] mantissa.simps[of m e, unfolded Float[symmetric]] real_of_float_add by auto
   qed
 qed
 
 lemma ub_ln_lb_ln_bounds: assumes "0 < x"
-  shows "Ifloat (the (lb_ln prec x)) \<le> ln (Ifloat x) \<and> ln (Ifloat x) \<le> Ifloat (the (ub_ln prec x))"
+  shows "real (the (lb_ln prec x)) \<le> ln (real x) \<and> ln (real x) \<le> real (the (ub_ln prec x))"
   (is "?lb \<le> ?ln \<and> ?ln \<le> ?ub")
 proof (cases "x < 1")
   case False hence "1 \<le> x" unfolding less_float_def le_float_def by auto
@@ -1860,74 +1862,74 @@
 next
   case True have "\<not> x \<le> 0" using `0 < x` unfolding less_float_def le_float_def by auto
 
-  have "0 < Ifloat x" and "Ifloat x \<noteq> 0" using `0 < x` unfolding less_float_def by auto
-  hence A: "0 < 1 / Ifloat x" by auto
+  have "0 < real x" and "real x \<noteq> 0" using `0 < x` unfolding less_float_def by auto
+  hence A: "0 < 1 / real x" by auto
 
   {
     let ?divl = "float_divl (max prec 1) 1 x"
     have A': "1 \<le> ?divl" using float_divl_pos_less1_bound[OF `0 < x` `x < 1`] unfolding le_float_def less_float_def by auto
-    hence B: "0 < Ifloat ?divl" unfolding le_float_def by auto
+    hence B: "0 < real ?divl" unfolding le_float_def by auto
     
-    have "ln (Ifloat ?divl) \<le> ln (1 / Ifloat x)" unfolding ln_le_cancel_iff[OF B A] using float_divl[of _ 1 x] by auto
-    hence "ln (Ifloat x) \<le> - ln (Ifloat ?divl)" unfolding nonzero_inverse_eq_divide[OF `Ifloat x \<noteq> 0`, symmetric] ln_inverse[OF `0 < Ifloat x`] by auto
+    have "ln (real ?divl) \<le> ln (1 / real x)" unfolding ln_le_cancel_iff[OF B A] using float_divl[of _ 1 x] by auto
+    hence "ln (real x) \<le> - ln (real ?divl)" unfolding nonzero_inverse_eq_divide[OF `real x \<noteq> 0`, symmetric] ln_inverse[OF `0 < real x`] by auto
     from this ub_ln_lb_ln_bounds'[OF A', THEN conjunct1, THEN le_imp_neg_le] 
-    have "?ln \<le> Ifloat (- the (lb_ln prec ?divl))" unfolding Ifloat_minus by (rule order_trans)
+    have "?ln \<le> real (- the (lb_ln prec ?divl))" unfolding real_of_float_minus by (rule order_trans)
   } moreover
   {
     let ?divr = "float_divr prec 1 x"
     have A': "1 \<le> ?divr" using float_divr_pos_less1_lower_bound[OF `0 < x` `x < 1`] unfolding le_float_def less_float_def by auto
-    hence B: "0 < Ifloat ?divr" unfolding le_float_def by auto
+    hence B: "0 < real ?divr" unfolding le_float_def by auto
     
-    have "ln (1 / Ifloat x) \<le> ln (Ifloat ?divr)" unfolding ln_le_cancel_iff[OF A B] using float_divr[of 1 x] by auto
-    hence "- ln (Ifloat ?divr) \<le> ln (Ifloat x)" unfolding nonzero_inverse_eq_divide[OF `Ifloat x \<noteq> 0`, symmetric] ln_inverse[OF `0 < Ifloat x`] by auto
+    have "ln (1 / real x) \<le> ln (real ?divr)" unfolding ln_le_cancel_iff[OF A B] using float_divr[of 1 x] by auto
+    hence "- ln (real ?divr) \<le> ln (real x)" unfolding nonzero_inverse_eq_divide[OF `real x \<noteq> 0`, symmetric] ln_inverse[OF `0 < real x`] by auto
     from ub_ln_lb_ln_bounds'[OF A', THEN conjunct2, THEN le_imp_neg_le] this
-    have "Ifloat (- the (ub_ln prec ?divr)) \<le> ?ln" unfolding Ifloat_minus by (rule order_trans)
+    have "real (- the (ub_ln prec ?divr)) \<le> ?ln" unfolding real_of_float_minus by (rule order_trans)
   }
   ultimately show ?thesis unfolding lb_ln.simps[where x=x]  ub_ln.simps[where x=x]
     unfolding if_not_P[OF `\<not> x \<le> 0`] if_P[OF True] by auto
 qed
 
 lemma lb_ln: assumes "Some y = lb_ln prec x"
-  shows "Ifloat y \<le> ln (Ifloat x)" and "0 < Ifloat x"
+  shows "real y \<le> ln (real x)" and "0 < real x"
 proof -
   have "0 < x"
   proof (rule ccontr)
     assume "\<not> 0 < x" hence "x \<le> 0" unfolding le_float_def less_float_def by auto
     thus False using assms by auto
   qed
-  thus "0 < Ifloat x" unfolding less_float_def by auto
-  have "Ifloat (the (lb_ln prec x)) \<le> ln (Ifloat x)" using ub_ln_lb_ln_bounds[OF `0 < x`] ..
-  thus "Ifloat y \<le> ln (Ifloat x)" unfolding assms[symmetric] by auto
+  thus "0 < real x" unfolding less_float_def by auto
+  have "real (the (lb_ln prec x)) \<le> ln (real x)" using ub_ln_lb_ln_bounds[OF `0 < x`] ..
+  thus "real y \<le> ln (real x)" unfolding assms[symmetric] by auto
 qed
 
 lemma ub_ln: assumes "Some y = ub_ln prec x"
-  shows "ln (Ifloat x) \<le> Ifloat y" and "0 < Ifloat x"
+  shows "ln (real x) \<le> real y" and "0 < real x"
 proof -
   have "0 < x"
   proof (rule ccontr)
     assume "\<not> 0 < x" hence "x \<le> 0" unfolding le_float_def less_float_def by auto
     thus False using assms by auto
   qed
-  thus "0 < Ifloat x" unfolding less_float_def by auto
-  have "ln (Ifloat x) \<le> Ifloat (the (ub_ln prec x))" using ub_ln_lb_ln_bounds[OF `0 < x`] ..
-  thus "ln (Ifloat x) \<le> Ifloat y" unfolding assms[symmetric] by auto
+  thus "0 < real x" unfolding less_float_def by auto
+  have "ln (real x) \<le> real (the (ub_ln prec x))" using ub_ln_lb_ln_bounds[OF `0 < x`] ..
+  thus "ln (real x) \<le> real y" unfolding assms[symmetric] by auto
 qed
 
-lemma bnds_ln: "\<forall> x lx ux. (Some l, Some u) = (lb_ln prec lx, ub_ln prec ux) \<and> x \<in> {Ifloat lx .. Ifloat ux} \<longrightarrow> Ifloat l \<le> ln x \<and> ln x \<le> Ifloat u"
+lemma bnds_ln: "\<forall> x lx ux. (Some l, Some u) = (lb_ln prec lx, ub_ln prec ux) \<and> x \<in> {real lx .. real ux} \<longrightarrow> real l \<le> ln x \<and> ln x \<le> real u"
 proof (rule allI, rule allI, rule allI, rule impI)
   fix x lx ux
-  assume "(Some l, Some u) = (lb_ln prec lx, ub_ln prec ux) \<and> x \<in> {Ifloat lx .. Ifloat ux}"
-  hence l: "Some l = lb_ln prec lx " and u: "Some u = ub_ln prec ux" and x: "x \<in> {Ifloat lx .. Ifloat ux}" by auto
+  assume "(Some l, Some u) = (lb_ln prec lx, ub_ln prec ux) \<and> x \<in> {real lx .. real ux}"
+  hence l: "Some l = lb_ln prec lx " and u: "Some u = ub_ln prec ux" and x: "x \<in> {real lx .. real ux}" by auto
 
-  have "ln (Ifloat ux) \<le> Ifloat u" and "0 < Ifloat ux" using ub_ln u by auto
-  have "Ifloat l \<le> ln (Ifloat lx)" and "0 < Ifloat lx" and "0 < x" using lb_ln[OF l] x by auto
+  have "ln (real ux) \<le> real u" and "0 < real ux" using ub_ln u by auto
+  have "real l \<le> ln (real lx)" and "0 < real lx" and "0 < x" using lb_ln[OF l] x by auto
 
-  from ln_le_cancel_iff[OF `0 < Ifloat lx` `0 < x`] `Ifloat l \<le> ln (Ifloat lx)` 
-  have "Ifloat l \<le> ln x" using x unfolding atLeastAtMost_iff by auto
+  from ln_le_cancel_iff[OF `0 < real lx` `0 < x`] `real l \<le> ln (real lx)` 
+  have "real l \<le> ln x" using x unfolding atLeastAtMost_iff by auto
   moreover
-  from ln_le_cancel_iff[OF `0 < x` `0 < Ifloat ux`] `ln (Ifloat ux) \<le> Ifloat u` 
-  have "ln x \<le> Ifloat u" using x unfolding atLeastAtMost_iff by auto
-  ultimately show "Ifloat l \<le> ln x \<and> ln x \<le> Ifloat u" ..
+  from ln_le_cancel_iff[OF `0 < x` `0 < real ux`] `ln (real ux) \<le> real u` 
+  have "ln x \<le> real u" using x unfolding atLeastAtMost_iff by auto
+  ultimately show "real l \<le> ln x \<and> ln x \<le> real u" ..
 qed
 
 
@@ -1954,25 +1956,25 @@
   | Atom nat
   | Num float
 
-fun Ifloatarith :: "floatarith \<Rightarrow> real list \<Rightarrow> real"
+fun interpret_floatarith :: "floatarith \<Rightarrow> real list \<Rightarrow> real"
 where
-"Ifloatarith (Add a b) vs   = (Ifloatarith a vs) + (Ifloatarith b vs)" |
-"Ifloatarith (Minus a) vs    = - (Ifloatarith a vs)" |
-"Ifloatarith (Mult a b) vs   = (Ifloatarith a vs) * (Ifloatarith b vs)" |
-"Ifloatarith (Inverse a) vs  = inverse (Ifloatarith a vs)" |
-"Ifloatarith (Sin a) vs      = sin (Ifloatarith a vs)" |
-"Ifloatarith (Cos a) vs      = cos (Ifloatarith a vs)" |
-"Ifloatarith (Arctan a) vs   = arctan (Ifloatarith a vs)" |
-"Ifloatarith (Min a b) vs    = min (Ifloatarith a vs) (Ifloatarith b vs)" |
-"Ifloatarith (Max a b) vs    = max (Ifloatarith a vs) (Ifloatarith b vs)" |
-"Ifloatarith (Abs a) vs      = abs (Ifloatarith a vs)" |
-"Ifloatarith Pi vs           = pi" |
-"Ifloatarith (Sqrt a) vs     = sqrt (Ifloatarith a vs)" |
-"Ifloatarith (Exp a) vs      = exp (Ifloatarith a vs)" |
-"Ifloatarith (Ln a) vs       = ln (Ifloatarith a vs)" |
-"Ifloatarith (Power a n) vs  = (Ifloatarith a vs)^n" |
-"Ifloatarith (Num f) vs      = Ifloat f" |
-"Ifloatarith (Atom n) vs     = vs ! n"
+"interpret_floatarith (Add a b) vs   = (interpret_floatarith a vs) + (interpret_floatarith b vs)" |
+"interpret_floatarith (Minus a) vs    = - (interpret_floatarith a vs)" |
+"interpret_floatarith (Mult a b) vs   = (interpret_floatarith a vs) * (interpret_floatarith b vs)" |
+"interpret_floatarith (Inverse a) vs  = inverse (interpret_floatarith a vs)" |
+"interpret_floatarith (Sin a) vs      = sin (interpret_floatarith a vs)" |
+"interpret_floatarith (Cos a) vs      = cos (interpret_floatarith a vs)" |
+"interpret_floatarith (Arctan a) vs   = arctan (interpret_floatarith a vs)" |
+"interpret_floatarith (Min a b) vs    = min (interpret_floatarith a vs) (interpret_floatarith b vs)" |
+"interpret_floatarith (Max a b) vs    = max (interpret_floatarith a vs) (interpret_floatarith b vs)" |
+"interpret_floatarith (Abs a) vs      = abs (interpret_floatarith a vs)" |
+"interpret_floatarith Pi vs           = pi" |
+"interpret_floatarith (Sqrt a) vs     = sqrt (interpret_floatarith a vs)" |
+"interpret_floatarith (Exp a) vs      = exp (interpret_floatarith a vs)" |
+"interpret_floatarith (Ln a) vs       = ln (interpret_floatarith a vs)" |
+"interpret_floatarith (Power a n) vs  = (interpret_floatarith a vs)^n" |
+"interpret_floatarith (Num f) vs      = real f" |
+"interpret_floatarith (Atom n) vs     = vs ! n"
 
 subsection "Implement approximation function"
 
@@ -1995,18 +1997,18 @@
 "lift_un' b f = None"
 
 fun bounded_by :: "real list \<Rightarrow> (float * float) list \<Rightarrow> bool " where
-bounded_by_Cons: "bounded_by (v#vs) ((l, u)#bs) = ((Ifloat l \<le> v \<and> v \<le> Ifloat u) \<and> bounded_by vs bs)" |
+bounded_by_Cons: "bounded_by (v#vs) ((l, u)#bs) = ((real l \<le> v \<and> v \<le> real u) \<and> bounded_by vs bs)" |
 bounded_by_Nil: "bounded_by [] [] = True" |
 "bounded_by _ _ = False"
 
 lemma bounded_by: assumes "bounded_by vs bs" and "i < length bs"
-  shows "Ifloat (fst (bs ! i)) \<le> vs ! i \<and> vs ! i \<le> Ifloat (snd (bs ! i))"
+  shows "real (fst (bs ! i)) \<le> vs ! i \<and> vs ! i \<le> real (snd (bs ! i))"
   using `bounded_by vs bs` and `i < length bs`
 proof (induct arbitrary: i rule: bounded_by.induct)
   fix v :: real and vs :: "real list" and l u :: float and bs :: "(float * float) list" and i :: nat
-  assume hyp: "\<And>i. \<lbrakk>bounded_by vs bs; i < length bs\<rbrakk> \<Longrightarrow> Ifloat (fst (bs ! i)) \<le> vs ! i \<and> vs ! i \<le> Ifloat (snd (bs ! i))"
+  assume hyp: "\<And>i. \<lbrakk>bounded_by vs bs; i < length bs\<rbrakk> \<Longrightarrow> real (fst (bs ! i)) \<le> vs ! i \<and> vs ! i \<le> real (snd (bs ! i))"
   assume bounded: "bounded_by (v # vs) ((l, u) # bs)" and length: "i < length ((l, u) # bs)"
-  show "Ifloat (fst (((l, u) # bs) ! i)) \<le> (v # vs) ! i \<and> (v # vs) ! i \<le> Ifloat (snd (((l, u) # bs) ! i))"
+  show "real (fst (((l, u) # bs) ! i)) \<le> (v # vs) ! i \<and> (v # vs) ! i \<le> real (snd (((l, u) # bs) ! i))"
   proof (cases i)
     case 0
     show ?thesis using bounded unfolding 0 nth_Cons_0 fst_conv snd_conv bounded_by.simps ..
@@ -2072,9 +2074,9 @@
 qed
 
 lemma approx_approx':
-  assumes Pa: "\<And>l u. Some (l, u) = approx prec a vs \<Longrightarrow> Ifloat l \<le> Ifloatarith a xs \<and> Ifloatarith a xs \<le> Ifloat u"
+  assumes Pa: "\<And>l u. Some (l, u) = approx prec a vs \<Longrightarrow> real l \<le> interpret_floatarith a xs \<and> interpret_floatarith a xs \<le> real u"
   and approx': "Some (l, u) = approx' prec a vs"
-  shows "Ifloat l \<le> Ifloatarith a xs \<and> Ifloatarith a xs \<le> Ifloat u"
+  shows "real l \<le> interpret_floatarith a xs \<and> interpret_floatarith a xs \<le> real u"
 proof -
   obtain l' u' where S: "Some (l', u') = approx prec a vs"
     using approx' unfolding approx'.simps by (cases "approx prec a vs", auto)
@@ -2087,18 +2089,18 @@
 
 lemma lift_bin':
   assumes lift_bin'_Some: "Some (l, u) = lift_bin' (approx' prec a bs) (approx' prec b bs) f"
-  and Pa: "\<And>l u. Some (l, u) = approx prec a bs \<Longrightarrow> Ifloat l \<le> Ifloatarith a xs \<and> Ifloatarith a xs \<le> Ifloat u" (is "\<And>l u. _ = ?g a \<Longrightarrow> ?P l u a")
-  and Pb: "\<And>l u. Some (l, u) = approx prec b bs \<Longrightarrow> Ifloat l \<le> Ifloatarith b xs \<and> Ifloatarith b xs \<le> Ifloat u"
-  shows "\<exists> l1 u1 l2 u2. (Ifloat l1 \<le> Ifloatarith a xs \<and> Ifloatarith a xs \<le> Ifloat u1) \<and> 
-                        (Ifloat l2 \<le> Ifloatarith b xs \<and> Ifloatarith b xs \<le> Ifloat u2) \<and> 
+  and Pa: "\<And>l u. Some (l, u) = approx prec a bs \<Longrightarrow> real l \<le> interpret_floatarith a xs \<and> interpret_floatarith a xs \<le> real u" (is "\<And>l u. _ = ?g a \<Longrightarrow> ?P l u a")
+  and Pb: "\<And>l u. Some (l, u) = approx prec b bs \<Longrightarrow> real l \<le> interpret_floatarith b xs \<and> interpret_floatarith b xs \<le> real u"
+  shows "\<exists> l1 u1 l2 u2. (real l1 \<le> interpret_floatarith a xs \<and> interpret_floatarith a xs \<le> real u1) \<and> 
+                        (real l2 \<le> interpret_floatarith b xs \<and> interpret_floatarith b xs \<le> real u2) \<and> 
                         l = fst (f l1 u1 l2 u2) \<and> u = snd (f l1 u1 l2 u2)"
 proof -
   { fix l u assume "Some (l, u) = approx' prec a bs"
     with approx_approx'[of prec a bs, OF _ this] Pa
-    have "Ifloat l \<le> Ifloatarith a xs \<and> Ifloatarith a xs \<le> Ifloat u" by auto } note Pa = this
+    have "real l \<le> interpret_floatarith a xs \<and> interpret_floatarith a xs \<le> real u" by auto } note Pa = this
   { fix l u assume "Some (l, u) = approx' prec b bs"
     with approx_approx'[of prec b bs, OF _ this] Pb
-    have "Ifloat l \<le> Ifloatarith b xs \<and> Ifloatarith b xs \<le> Ifloat u" by auto } note Pb = this
+    have "real l \<le> interpret_floatarith b xs \<and> interpret_floatarith b xs \<le> real u" by auto } note Pb = this
 
   from lift_bin'_f[where g="\<lambda>a. approx' prec a bs" and P = ?P, OF lift_bin'_Some, OF Pa Pb]
   show ?thesis by auto
@@ -2129,26 +2131,26 @@
 
 lemma lift_un':
   assumes lift_un'_Some: "Some (l, u) = lift_un' (approx' prec a bs) f"
-  and Pa: "\<And>l u. Some (l, u) = approx prec a bs \<Longrightarrow> Ifloat l \<le> Ifloatarith a xs \<and> Ifloatarith a xs \<le> Ifloat u" (is "\<And>l u. _ = ?g a \<Longrightarrow> ?P l u a")
-  shows "\<exists> l1 u1. (Ifloat l1 \<le> Ifloatarith a xs \<and> Ifloatarith a xs \<le> Ifloat u1) \<and> 
+  and Pa: "\<And>l u. Some (l, u) = approx prec a bs \<Longrightarrow> real l \<le> interpret_floatarith a xs \<and> interpret_floatarith a xs \<le> real u" (is "\<And>l u. _ = ?g a \<Longrightarrow> ?P l u a")
+  shows "\<exists> l1 u1. (real l1 \<le> interpret_floatarith a xs \<and> interpret_floatarith a xs \<le> real u1) \<and> 
                         l = fst (f l1 u1) \<and> u = snd (f l1 u1)"
 proof -
   { fix l u assume "Some (l, u) = approx' prec a bs"
     with approx_approx'[of prec a bs, OF _ this] Pa
-    have "Ifloat l \<le> Ifloatarith a xs \<and> Ifloatarith a xs \<le> Ifloat u" by auto } note Pa = this
+    have "real l \<le> interpret_floatarith a xs \<and> interpret_floatarith a xs \<le> real u" by auto } note Pa = this
   from lift_un'_f[where g="\<lambda>a. approx' prec a bs" and P = ?P, OF lift_un'_Some, OF Pa]
   show ?thesis by auto
 qed
 
 lemma lift_un'_bnds:
-  assumes bnds: "\<forall> x lx ux. (l, u) = f lx ux \<and> x \<in> { Ifloat lx .. Ifloat ux } \<longrightarrow> Ifloat l \<le> f' x \<and> f' x \<le> Ifloat u"
+  assumes bnds: "\<forall> x lx ux. (l, u) = f lx ux \<and> x \<in> { real lx .. real ux } \<longrightarrow> real l \<le> f' x \<and> f' x \<le> real u"
   and lift_un'_Some: "Some (l, u) = lift_un' (approx' prec a bs) f"
-  and Pa: "\<And>l u. Some (l, u) = approx prec a bs \<Longrightarrow> Ifloat l \<le> Ifloatarith a xs \<and> Ifloatarith a xs \<le> Ifloat u"
-  shows "Ifloat l \<le> f' (Ifloatarith a xs) \<and> f' (Ifloatarith a xs) \<le> Ifloat u"
+  and Pa: "\<And>l u. Some (l, u) = approx prec a bs \<Longrightarrow> real l \<le> interpret_floatarith a xs \<and> interpret_floatarith a xs \<le> real u"
+  shows "real l \<le> f' (interpret_floatarith a xs) \<and> f' (interpret_floatarith a xs) \<le> real u"
 proof -
   from lift_un'[OF lift_un'_Some Pa]
-  obtain l1 u1 where "Ifloat l1 \<le> Ifloatarith a xs" and "Ifloatarith a xs \<le> Ifloat u1" and "l = fst (f l1 u1)" and "u = snd (f l1 u1)" by blast
-  hence "(l, u) = f l1 u1" and "Ifloatarith a xs \<in> {Ifloat l1 .. Ifloat u1}" by auto
+  obtain l1 u1 where "real l1 \<le> interpret_floatarith a xs" and "interpret_floatarith a xs \<le> real u1" and "l = fst (f l1 u1)" and "u = snd (f l1 u1)" by blast
+  hence "(l, u) = f l1 u1" and "interpret_floatarith a xs \<in> {real l1 .. real u1}" by auto
   thus ?thesis using bnds by auto
 qed
 
@@ -2194,115 +2196,115 @@
 
 lemma lift_un:
   assumes lift_un_Some: "Some (l, u) = lift_un (approx' prec a bs) f"
-  and Pa: "\<And>l u. Some (l, u) = approx prec a bs \<Longrightarrow> Ifloat l \<le> Ifloatarith a xs \<and> Ifloatarith a xs \<le> Ifloat u" (is "\<And>l u. _ = ?g a \<Longrightarrow> ?P l u a")
-  shows "\<exists> l1 u1. (Ifloat l1 \<le> Ifloatarith a xs \<and> Ifloatarith a xs \<le> Ifloat u1) \<and> 
+  and Pa: "\<And>l u. Some (l, u) = approx prec a bs \<Longrightarrow> real l \<le> interpret_floatarith a xs \<and> interpret_floatarith a xs \<le> real u" (is "\<And>l u. _ = ?g a \<Longrightarrow> ?P l u a")
+  shows "\<exists> l1 u1. (real l1 \<le> interpret_floatarith a xs \<and> interpret_floatarith a xs \<le> real u1) \<and> 
                   Some l = fst (f l1 u1) \<and> Some u = snd (f l1 u1)"
 proof -
   { fix l u assume "Some (l, u) = approx' prec a bs"
     with approx_approx'[of prec a bs, OF _ this] Pa
-    have "Ifloat l \<le> Ifloatarith a xs \<and> Ifloatarith a xs \<le> Ifloat u" by auto } note Pa = this
+    have "real l \<le> interpret_floatarith a xs \<and> interpret_floatarith a xs \<le> real u" by auto } note Pa = this
   from lift_un_f[where g="\<lambda>a. approx' prec a bs" and P = ?P, OF lift_un_Some, OF Pa]
   show ?thesis by auto
 qed
 
 lemma lift_un_bnds:
-  assumes bnds: "\<forall> x lx ux. (Some l, Some u) = f lx ux \<and> x \<in> { Ifloat lx .. Ifloat ux } \<longrightarrow> Ifloat l \<le> f' x \<and> f' x \<le> Ifloat u"
+  assumes bnds: "\<forall> x lx ux. (Some l, Some u) = f lx ux \<and> x \<in> { real lx .. real ux } \<longrightarrow> real l \<le> f' x \<and> f' x \<le> real u"
   and lift_un_Some: "Some (l, u) = lift_un (approx' prec a bs) f"
-  and Pa: "\<And>l u. Some (l, u) = approx prec a bs \<Longrightarrow> Ifloat l \<le> Ifloatarith a xs \<and> Ifloatarith a xs \<le> Ifloat u"
-  shows "Ifloat l \<le> f' (Ifloatarith a xs) \<and> f' (Ifloatarith a xs) \<le> Ifloat u"
+  and Pa: "\<And>l u. Some (l, u) = approx prec a bs \<Longrightarrow> real l \<le> interpret_floatarith a xs \<and> interpret_floatarith a xs \<le> real u"
+  shows "real l \<le> f' (interpret_floatarith a xs) \<and> f' (interpret_floatarith a xs) \<le> real u"
 proof -
   from lift_un[OF lift_un_Some Pa]
-  obtain l1 u1 where "Ifloat l1 \<le> Ifloatarith a xs" and "Ifloatarith a xs \<le> Ifloat u1" and "Some l = fst (f l1 u1)" and "Some u = snd (f l1 u1)" by blast
-  hence "(Some l, Some u) = f l1 u1" and "Ifloatarith a xs \<in> {Ifloat l1 .. Ifloat u1}" by auto
+  obtain l1 u1 where "real l1 \<le> interpret_floatarith a xs" and "interpret_floatarith a xs \<le> real u1" and "Some l = fst (f l1 u1)" and "Some u = snd (f l1 u1)" by blast
+  hence "(Some l, Some u) = f l1 u1" and "interpret_floatarith a xs \<in> {real l1 .. real u1}" by auto
   thus ?thesis using bnds by auto
 qed
 
 lemma approx:
   assumes "bounded_by xs vs"
   and "Some (l, u) = approx prec arith vs" (is "_ = ?g arith")
-  shows "Ifloat l \<le> Ifloatarith arith xs \<and> Ifloatarith arith xs \<le> Ifloat u" (is "?P l u arith")
+  shows "real l \<le> interpret_floatarith arith xs \<and> interpret_floatarith arith xs \<le> real u" (is "?P l u arith")
   using `Some (l, u) = approx prec arith vs` 
 proof (induct arith arbitrary: l u x)
   case (Add a b)
   from lift_bin'[OF Add.prems[unfolded approx.simps]] Add.hyps
   obtain l1 u1 l2 u2 where "l = l1 + l2" and "u = u1 + u2"
-    "Ifloat l1 \<le> Ifloatarith a xs" and "Ifloatarith a xs \<le> Ifloat u1"
-    "Ifloat l2 \<le> Ifloatarith b xs" and "Ifloatarith b xs \<le> Ifloat u2" unfolding fst_conv snd_conv by blast
-  thus ?case unfolding Ifloatarith.simps by auto
+    "real l1 \<le> interpret_floatarith a xs" and "interpret_floatarith a xs \<le> real u1"
+    "real l2 \<le> interpret_floatarith b xs" and "interpret_floatarith b xs \<le> real u2" unfolding fst_conv snd_conv by blast
+  thus ?case unfolding interpret_floatarith.simps by auto
 next
   case (Minus a)
   from lift_un'[OF Minus.prems[unfolded approx.simps]] Minus.hyps
   obtain l1 u1 where "l = -u1" and "u = -l1"
-    "Ifloat l1 \<le> Ifloatarith a xs" and "Ifloatarith a xs \<le> Ifloat u1" unfolding fst_conv snd_conv by blast
-  thus ?case unfolding Ifloatarith.simps using Ifloat_minus by auto
+    "real l1 \<le> interpret_floatarith a xs" and "interpret_floatarith a xs \<le> real u1" unfolding fst_conv snd_conv by blast
+  thus ?case unfolding interpret_floatarith.simps using real_of_float_minus by auto
 next
   case (Mult a b)
   from lift_bin'[OF Mult.prems[unfolded approx.simps]] Mult.hyps
   obtain l1 u1 l2 u2 
     where l: "l = float_nprt l1 * float_pprt u2 + float_nprt u1 * float_nprt u2 + float_pprt l1 * float_pprt l2 + float_pprt u1 * float_nprt l2"
     and u: "u = float_pprt u1 * float_pprt u2 + float_pprt l1 * float_nprt u2 + float_nprt u1 * float_pprt l2 + float_nprt l1 * float_nprt l2"
-    and "Ifloat l1 \<le> Ifloatarith a xs" and "Ifloatarith a xs \<le> Ifloat u1"
-    and "Ifloat l2 \<le> Ifloatarith b xs" and "Ifloatarith b xs \<le> Ifloat u2" unfolding fst_conv snd_conv by blast
-  thus ?case unfolding Ifloatarith.simps l u Ifloat_add Ifloat_mult Ifloat_nprt Ifloat_pprt 
+    and "real l1 \<le> interpret_floatarith a xs" and "interpret_floatarith a xs \<le> real u1"
+    and "real l2 \<le> interpret_floatarith b xs" and "interpret_floatarith b xs \<le> real u2" unfolding fst_conv snd_conv by blast
+  thus ?case unfolding interpret_floatarith.simps l u real_of_float_add real_of_float_mult real_of_float_nprt real_of_float_pprt 
     using mult_le_prts mult_ge_prts by auto
 next
   case (Inverse a)
   from lift_un[OF Inverse.prems[unfolded approx.simps], unfolded if_distrib[of fst] if_distrib[of snd] fst_conv snd_conv] Inverse.hyps
   obtain l1 u1 where l': "Some l = (if 0 < l1 \<or> u1 < 0 then Some (float_divl prec 1 u1) else None)" 
     and u': "Some u = (if 0 < l1 \<or> u1 < 0 then Some (float_divr prec 1 l1) else None)"
-    and l1: "Ifloat l1 \<le> Ifloatarith a xs" and u1: "Ifloatarith a xs \<le> Ifloat u1" by blast
+    and l1: "real l1 \<le> interpret_floatarith a xs" and u1: "interpret_floatarith a xs \<le> real u1" by blast
   have either: "0 < l1 \<or> u1 < 0" proof (rule ccontr) assume P: "\<not> (0 < l1 \<or> u1 < 0)" show False using l' unfolding if_not_P[OF P] by auto qed
-  moreover have l1_le_u1: "Ifloat l1 \<le> Ifloat u1" using l1 u1 by auto
-  ultimately have "Ifloat l1 \<noteq> 0" and "Ifloat u1 \<noteq> 0" unfolding less_float_def by auto
+  moreover have l1_le_u1: "real l1 \<le> real u1" using l1 u1 by auto
+  ultimately have "real l1 \<noteq> 0" and "real u1 \<noteq> 0" unfolding less_float_def by auto
 
-  have inv: "inverse (Ifloat u1) \<le> inverse (Ifloatarith a xs)
-           \<and> inverse (Ifloatarith a xs) \<le> inverse (Ifloat l1)"
+  have inv: "inverse (real u1) \<le> inverse (interpret_floatarith a xs)
+           \<and> inverse (interpret_floatarith a xs) \<le> inverse (real l1)"
   proof (cases "0 < l1")
-    case True hence "0 < Ifloat u1" and "0 < Ifloat l1" "0 < Ifloatarith a xs" 
+    case True hence "0 < real u1" and "0 < real l1" "0 < interpret_floatarith a xs" 
       unfolding less_float_def using l1_le_u1 l1 by auto
     show ?thesis
-      unfolding inverse_le_iff_le[OF `0 < Ifloat u1` `0 < Ifloatarith a xs`]
-	inverse_le_iff_le[OF `0 < Ifloatarith a xs` `0 < Ifloat l1`]
+      unfolding inverse_le_iff_le[OF `0 < real u1` `0 < interpret_floatarith a xs`]
+	inverse_le_iff_le[OF `0 < interpret_floatarith a xs` `0 < real l1`]
       using l1 u1 by auto
   next
     case False hence "u1 < 0" using either by blast
-    hence "Ifloat u1 < 0" and "Ifloat l1 < 0" "Ifloatarith a xs < 0" 
+    hence "real u1 < 0" and "real l1 < 0" "interpret_floatarith a xs < 0" 
       unfolding less_float_def using l1_le_u1 u1 by auto
     show ?thesis
-      unfolding inverse_le_iff_le_neg[OF `Ifloat u1 < 0` `Ifloatarith a xs < 0`]
-	inverse_le_iff_le_neg[OF `Ifloatarith a xs < 0` `Ifloat l1 < 0`]
+      unfolding inverse_le_iff_le_neg[OF `real u1 < 0` `interpret_floatarith a xs < 0`]
+	inverse_le_iff_le_neg[OF `interpret_floatarith a xs < 0` `real l1 < 0`]
       using l1 u1 by auto
   qed
     
   from l' have "l = float_divl prec 1 u1" by (cases "0 < l1 \<or> u1 < 0", auto)
-  hence "Ifloat l \<le> inverse (Ifloat u1)" unfolding nonzero_inverse_eq_divide[OF `Ifloat u1 \<noteq> 0`] using float_divl[of prec 1 u1] by auto
-  also have "\<dots> \<le> inverse (Ifloatarith a xs)" using inv by auto
-  finally have "Ifloat l \<le> inverse (Ifloatarith a xs)" .
+  hence "real l \<le> inverse (real u1)" unfolding nonzero_inverse_eq_divide[OF `real u1 \<noteq> 0`] using float_divl[of prec 1 u1] by auto
+  also have "\<dots> \<le> inverse (interpret_floatarith a xs)" using inv by auto
+  finally have "real l \<le> inverse (interpret_floatarith a xs)" .
   moreover
   from u' have "u = float_divr prec 1 l1" by (cases "0 < l1 \<or> u1 < 0", auto)
-  hence "inverse (Ifloat l1) \<le> Ifloat u" unfolding nonzero_inverse_eq_divide[OF `Ifloat l1 \<noteq> 0`] using float_divr[of 1 l1 prec] by auto
-  hence "inverse (Ifloatarith a xs) \<le> Ifloat u" by (rule order_trans[OF inv[THEN conjunct2]])
-  ultimately show ?case unfolding Ifloatarith.simps using l1 u1 by auto
+  hence "inverse (real l1) \<le> real u" unfolding nonzero_inverse_eq_divide[OF `real l1 \<noteq> 0`] using float_divr[of 1 l1 prec] by auto
+  hence "inverse (interpret_floatarith a xs) \<le> real u" by (rule order_trans[OF inv[THEN conjunct2]])
+  ultimately show ?case unfolding interpret_floatarith.simps using l1 u1 by auto
 next
   case (Abs x)
   from lift_un'[OF Abs.prems[unfolded approx.simps], unfolded fst_conv snd_conv] Abs.hyps
   obtain l1 u1 where l': "l = (if l1 < 0 \<and> 0 < u1 then 0 else min \<bar>l1\<bar> \<bar>u1\<bar>)" and u': "u = max \<bar>l1\<bar> \<bar>u1\<bar>"
-    and l1: "Ifloat l1 \<le> Ifloatarith x xs" and u1: "Ifloatarith x xs \<le> Ifloat u1" by blast
-  thus ?case unfolding l' u' by (cases "l1 < 0 \<and> 0 < u1", auto simp add: Ifloat_min Ifloat_max Ifloat_abs less_float_def)
+    and l1: "real l1 \<le> interpret_floatarith x xs" and u1: "interpret_floatarith x xs \<le> real u1" by blast
+  thus ?case unfolding l' u' by (cases "l1 < 0 \<and> 0 < u1", auto simp add: real_of_float_min real_of_float_max real_of_float_abs less_float_def)
 next
   case (Min a b)
   from lift_bin'[OF Min.prems[unfolded approx.simps], unfolded fst_conv snd_conv] Min.hyps
   obtain l1 u1 l2 u2 where l': "l = min l1 l2" and u': "u = min u1 u2"
-    and l1: "Ifloat l1 \<le> Ifloatarith a xs" and u1: "Ifloatarith a xs \<le> Ifloat u1"
-    and l1: "Ifloat l2 \<le> Ifloatarith b xs" and u1: "Ifloatarith b xs \<le> Ifloat u2" by blast
-  thus ?case unfolding l' u' by (auto simp add: Ifloat_min)
+    and l1: "real l1 \<le> interpret_floatarith a xs" and u1: "interpret_floatarith a xs \<le> real u1"
+    and l1: "real l2 \<le> interpret_floatarith b xs" and u1: "interpret_floatarith b xs \<le> real u2" by blast
+  thus ?case unfolding l' u' by (auto simp add: real_of_float_min)
 next
   case (Max a b)
   from lift_bin'[OF Max.prems[unfolded approx.simps], unfolded fst_conv snd_conv] Max.hyps
   obtain l1 u1 l2 u2 where l': "l = max l1 l2" and u': "u = max u1 u2"
-    and l1: "Ifloat l1 \<le> Ifloatarith a xs" and u1: "Ifloatarith a xs \<le> Ifloat u1"
-    and l1: "Ifloat l2 \<le> Ifloatarith b xs" and u1: "Ifloatarith b xs \<le> Ifloat u2" by blast
-  thus ?case unfolding l' u' by (auto simp add: Ifloat_max)
+    and l1: "real l1 \<le> interpret_floatarith a xs" and u1: "interpret_floatarith a xs \<le> real u1"
+    and l1: "real l2 \<le> interpret_floatarith b xs" and u1: "interpret_floatarith b xs \<le> real u2" by blast
+  thus ?case unfolding l' u' by (auto simp add: real_of_float_max)
 next case (Sin a) with lift_un'_bnds[OF bnds_sin] show ?case by auto
 next case (Cos a) with lift_un'_bnds[OF bnds_cos] show ?case by auto
 next case (Arctan a) with lift_un'_bnds[OF bnds_arctan] show ?case by auto
@@ -2324,19 +2326,19 @@
   qed
 qed
 
-datatype ApproxEq = Less floatarith floatarith 
-                  | LessEqual floatarith floatarith 
+datatype inequality = Less floatarith floatarith 
+                    | LessEqual floatarith floatarith 
 
-fun uneq :: "ApproxEq \<Rightarrow> real list \<Rightarrow> bool" where 
-"uneq (Less a b) vs                   = (Ifloatarith a vs < Ifloatarith b vs)" |
-"uneq (LessEqual a b) vs              = (Ifloatarith a vs \<le> Ifloatarith b vs)"
+fun interpret_inequality :: "inequality \<Rightarrow> real list \<Rightarrow> bool" where 
+"interpret_inequality (Less a b) vs                   = (interpret_floatarith a vs < interpret_floatarith b vs)" |
+"interpret_inequality (LessEqual a b) vs              = (interpret_floatarith a vs \<le> interpret_floatarith b vs)"
 
-fun uneq' :: "nat \<Rightarrow> ApproxEq \<Rightarrow> (float * float) list \<Rightarrow> bool" where 
-"uneq' prec (Less a b) bs = (case (approx prec a bs, approx prec b bs) of (Some (l, u), Some (l', u')) \<Rightarrow> u < l' | _ \<Rightarrow> False)" |
-"uneq' prec (LessEqual a b) bs = (case (approx prec a bs, approx prec b bs) of (Some (l, u), Some (l', u')) \<Rightarrow> u \<le> l' | _ \<Rightarrow> False)"
+fun approx_inequality :: "nat \<Rightarrow> inequality \<Rightarrow> (float * float) list \<Rightarrow> bool" where 
+"approx_inequality prec (Less a b) bs = (case (approx prec a bs, approx prec b bs) of (Some (l, u), Some (l', u')) \<Rightarrow> u < l' | _ \<Rightarrow> False)" |
+"approx_inequality prec (LessEqual a b) bs = (case (approx prec a bs, approx prec b bs) of (Some (l, u), Some (l', u')) \<Rightarrow> u \<le> l' | _ \<Rightarrow> False)"
 
-lemma uneq_approx: fixes m :: nat assumes "bounded_by vs bs" and "uneq' prec eq bs"
-  shows "uneq eq vs"
+lemma approx_inequality: fixes m :: nat assumes "bounded_by vs bs" and "approx_inequality prec eq bs"
+  shows "interpret_inequality eq vs"
 proof (cases eq)
   case (Less a b)
   show ?thesis
@@ -2345,17 +2347,17 @@
     case True
     then obtain l u l' u' where a_approx: "approx prec a bs = Some (l, u)"
       and b_approx: "approx prec b bs = Some (l', u') " by auto
-    with `uneq' prec eq bs` have "Ifloat u < Ifloat l'"
-      unfolding Less uneq'.simps less_float_def by auto
+    with `approx_inequality prec eq bs` have "real u < real l'"
+      unfolding Less approx_inequality.simps less_float_def by auto
     moreover from a_approx[symmetric] and b_approx[symmetric] and `bounded_by vs bs`
-    have "Ifloatarith a vs \<le> Ifloat u" and "Ifloat l' \<le> Ifloatarith b vs"
+    have "interpret_floatarith a vs \<le> real u" and "real l' \<le> interpret_floatarith b vs"
       using approx by auto
-    ultimately show ?thesis unfolding uneq.simps Less by auto
+    ultimately show ?thesis unfolding interpret_inequality.simps Less by auto
   next
     case False
     hence "approx prec a bs = None \<or> approx prec b bs = None"
       unfolding not_Some_eq[symmetric] by auto
-    hence "\<not> uneq' prec eq bs" unfolding Less uneq'.simps 
+    hence "\<not> approx_inequality prec eq bs" unfolding Less approx_inequality.simps 
       by (cases "approx prec a bs = None", auto)
     thus ?thesis using assms by auto
   qed
@@ -2367,66 +2369,104 @@
     case True
     then obtain l u l' u' where a_approx: "approx prec a bs = Some (l, u)"
       and b_approx: "approx prec b bs = Some (l', u') " by auto
-    with `uneq' prec eq bs` have "Ifloat u \<le> Ifloat l'"
-      unfolding LessEqual uneq'.simps le_float_def by auto
+    with `approx_inequality prec eq bs` have "real u \<le> real l'"
+      unfolding LessEqual approx_inequality.simps le_float_def by auto
     moreover from a_approx[symmetric] and b_approx[symmetric] and `bounded_by vs bs`
-    have "Ifloatarith a vs \<le> Ifloat u" and "Ifloat l' \<le> Ifloatarith b vs"
+    have "interpret_floatarith a vs \<le> real u" and "real l' \<le> interpret_floatarith b vs"
       using approx by auto
-    ultimately show ?thesis unfolding uneq.simps LessEqual by auto
+    ultimately show ?thesis unfolding interpret_inequality.simps LessEqual by auto
   next
     case False
     hence "approx prec a bs = None \<or> approx prec b bs = None"
       unfolding not_Some_eq[symmetric] by auto
-    hence "\<not> uneq' prec eq bs" unfolding LessEqual uneq'.simps 
+    hence "\<not> approx_inequality prec eq bs" unfolding LessEqual approx_inequality.simps 
       by (cases "approx prec a bs = None", auto)
     thus ?thesis using assms by auto
   qed
 qed
 
-lemma Ifloatarith_divide: "Ifloatarith (Mult a (Inverse b)) vs = (Ifloatarith a vs) / (Ifloatarith b vs)"
-  unfolding real_divide_def Ifloatarith.simps ..
+lemma interpret_floatarith_divide: "interpret_floatarith (Mult a (Inverse b)) vs = (interpret_floatarith a vs) / (interpret_floatarith b vs)"
+  unfolding real_divide_def interpret_floatarith.simps ..
 
-lemma Ifloatarith_diff: "Ifloatarith (Add a (Minus b)) vs = (Ifloatarith a vs) - (Ifloatarith b vs)"
-  unfolding real_diff_def Ifloatarith.simps ..
+lemma interpret_floatarith_diff: "interpret_floatarith (Add a (Minus b)) vs = (interpret_floatarith a vs) - (interpret_floatarith b vs)"
+  unfolding real_diff_def interpret_floatarith.simps ..
+
+lemma interpret_floatarith_tan: "interpret_floatarith (Mult (Sin a) (Inverse (Cos a))) vs = tan (interpret_floatarith a vs)"
+  unfolding tan_def interpret_floatarith.simps real_divide_def ..
 
-lemma Ifloatarith_tan: "Ifloatarith (Mult (Sin a) (Inverse (Cos a))) vs = tan (Ifloatarith a vs)"
-  unfolding tan_def Ifloatarith.simps real_divide_def ..
+lemma interpret_floatarith_powr: "interpret_floatarith (Exp (Mult b (Ln a))) vs = (interpret_floatarith a vs) powr (interpret_floatarith b vs)"
+  unfolding powr_def interpret_floatarith.simps ..
 
-lemma Ifloatarith_powr: "Ifloatarith (Exp (Mult b (Ln a))) vs = (Ifloatarith a vs) powr (Ifloatarith b vs)"
-  unfolding powr_def Ifloatarith.simps ..
+lemma interpret_floatarith_log: "interpret_floatarith ((Mult (Ln x) (Inverse (Ln b)))) vs = log (interpret_floatarith b vs) (interpret_floatarith x vs)"
+  unfolding log_def interpret_floatarith.simps real_divide_def ..
 
-lemma Ifloatarith_log: "Ifloatarith ((Mult (Ln x) (Inverse (Ln b)))) vs = log (Ifloatarith b vs) (Ifloatarith x vs)"
-  unfolding log_def Ifloatarith.simps real_divide_def ..
-
-lemma Ifloatarith_num: shows "Ifloatarith (Num (Float 0 0)) vs = 0" and "Ifloatarith (Num (Float 1 0)) vs = 1" and "Ifloatarith (Num (Float (number_of a) 0)) vs = number_of a" by auto
+lemma interpret_floatarith_num:
+  shows "interpret_floatarith (Num (Float 0 0)) vs = 0"
+  and "interpret_floatarith (Num (Float 1 0)) vs = 1"
+  and "interpret_floatarith (Num (Float (number_of a) 0)) vs = number_of a" by auto
 
 subsection {* Implement proof method \texttt{approximation} *}
 
-lemma bounded_divl: assumes "Ifloat a / Ifloat b \<le> x" shows "Ifloat (float_divl p a b) \<le> x" by (rule order_trans[OF _ assms], rule float_divl)
-lemma bounded_divr: assumes "x \<le> Ifloat a / Ifloat b" shows "x \<le> Ifloat (float_divr p a b)" by (rule order_trans[OF assms _], rule float_divr)
-lemma bounded_num: shows "Ifloat (Float 5 1) = 10" and "Ifloat (Float 0 0) = 0" and "Ifloat (Float 1 0) = 1" and "Ifloat (Float (number_of n) 0) = (number_of n)"
-                     and "0 * pow2 e = Ifloat (Float 0 e)" and "1 * pow2 e = Ifloat (Float 1 e)" and "number_of m * pow2 e = Ifloat (Float (number_of m) e)"
-                     and "Ifloat (Float (number_of A) (int B)) = (number_of A) * 2^B"
-                     and "Ifloat (Float 1 (int B)) = 2^B"
-                     and "Ifloat (Float (number_of A) (- int B)) = (number_of A) / 2^B"
-                     and "Ifloat (Float 1 (- int B)) = 1 / 2^B"
-  by (auto simp add: Ifloat.simps pow2_def real_divide_def)
+lemma bounded_divl: assumes "real a / real b \<le> x" shows "real (float_divl p a b) \<le> x" by (rule order_trans[OF _ assms], rule float_divl)
+lemma bounded_divr: assumes "x \<le> real a / real b" shows "x \<le> real (float_divr p a b)" by (rule order_trans[OF assms _], rule float_divr)
+lemma bounded_num: shows "real (Float 5 1) = 10" and "real (Float 0 0) = 0" and "real (Float 1 0) = 1" and "real (Float (number_of n) 0) = (number_of n)"
+                     and "0 * pow2 e = real (Float 0 e)" and "1 * pow2 e = real (Float 1 e)" and "number_of m * pow2 e = real (Float (number_of m) e)"
+                     and "real (Float (number_of A) (int B)) = (number_of A) * 2^B"
+                     and "real (Float 1 (int B)) = 2^B"
+                     and "real (Float (number_of A) (- int B)) = (number_of A) / 2^B"
+                     and "real (Float 1 (- int B)) = 1 / 2^B"
+  by (auto simp add: real_of_float_simp pow2_def real_divide_def)
 
 lemmas bounded_by_equations = bounded_by_Cons bounded_by_Nil float_power bounded_divl bounded_divr bounded_num HOL.simp_thms
-lemmas uneq_equations = uneq.simps Ifloatarith.simps Ifloatarith_num Ifloatarith_divide Ifloatarith_diff Ifloatarith_tan Ifloatarith_powr Ifloatarith_log
+lemmas interpret_inequality_equations = interpret_inequality.simps interpret_floatarith.simps interpret_floatarith_num
+  interpret_floatarith_divide interpret_floatarith_diff interpret_floatarith_tan interpret_floatarith_powr interpret_floatarith_log
 
 ML {*
-  val uneq_equations = PureThy.get_thms @{theory} "uneq_equations";
+structure Float_Arith =
+struct
+
+@{code_datatype float = Float}
+@{code_datatype floatarith = Add | Minus | Mult | Inverse | Sin | Cos | Arctan 
+                           | Abs | Max | Min | Pi | Sqrt | Exp | Ln | Power | Atom | Num }
+@{code_datatype inequality = Less | LessEqual }
+
+val approx_inequality = @{code approx_inequality}
+
+end
+*}
+
+code_reserved Eval Float_Arith
+
+code_type float (Eval "Float'_Arith.float")
+code_const Float (Eval "Float'_Arith.Float/ (_,/ _)")
+
+code_type floatarith (Eval "Float'_Arith.floatarith")
+code_const Add and Minus and Mult and Inverse and Sin and Cos and Arctan and Abs and Max and Min and
+           Pi and Sqrt  and Exp and Ln and Power and Atom and Num
+  (Eval "Float'_Arith.Add/ (_,/ _)" and "Float'_Arith.Minus" and "Float'_Arith.Mult/ (_,/ _)" and
+        "Float'_Arith.Inverse" and "Float'_Arith.Sin" and "Float'_Arith.Cos" and
+        "Float'_Arith.Arctan" and "Float'_Arith.Abs" and "Float'_Arith.Max/ (_,/ _)" and
+        "Float'_Arith.Min/ (_,/ _)" and "Float'_Arith.Pi" and "Float'_Arith.Sqrt" and
+        "Float'_Arith.Exp" and "Float'_Arith.Ln" and "Float'_Arith.Power/ (_,/ _)" and
+        "Float'_Arith.Atom" and "Float'_Arith.Num")
+
+code_type inequality (Eval "Float'_Arith.inequality")
+code_const Less and LessEqual (Eval "Float'_Arith.Less/ (_,/ _)" and "Float'_Arith.LessEqual/ (_,/ _)")
+
+code_const approx_inequality (Eval "Float'_Arith.approx'_inequality")
+
+ML {*
+  val ineq_equations = PureThy.get_thms @{theory} "interpret_inequality_equations";
   val bounded_by_equations = PureThy.get_thms @{theory} "bounded_by_equations";
   val bounded_by_simpset = (HOL_basic_ss addsimps bounded_by_equations)
 
-  fun reify_uneq ctxt i = (fn st =>
+  fun reify_ineq ctxt i = (fn st =>
     let
       val to = HOLogic.dest_Trueprop (Logic.strip_imp_concl (List.nth (prems_of st, i - 1)))
-    in (Reflection.genreify_tac ctxt uneq_equations (SOME to) i) st
+    in (Reflection.genreify_tac ctxt ineq_equations (SOME to) i) st
     end)
 
-  fun rule_uneq ctxt prec i thm = let
+  fun rule_ineq ctxt prec i thm = let
     fun conv_num typ = HOLogic.dest_number #> snd #> HOLogic.mk_number typ
     val to_natc = conv_num @{typ "nat"} #> Thm.cterm_of (ProofContext.theory_of ctxt)
     val to_nat = conv_num @{typ "nat"}
@@ -2479,7 +2519,7 @@
     fun lift_var (Free (varname, _)) = (case AList.lookup (op =) bound_eqs varname of
                                           SOME bound => bound
                                         | NONE => raise TERM ("No bound equations found for " ^ varname, []))
-      | lift_var t = raise TERM ("Can not convert expression " ^ 
+      | lift_var t = raise TERM ("Can not convert expression " ^
                                  (Syntax.string_of_term ctxt t), [t])
 
     val _ $ vs = HOLogic.dest_Trueprop (Logic.strip_imp_concl goal')
@@ -2487,7 +2527,7 @@
     val bs = (HOLogic.dest_list #> map lift_var #> HOLogic.mk_list @{typ "float * float"}) vs
     val map = [(@{cpat "?prec::nat"}, to_natc prec),
                (@{cpat "?bs::(float * float) list"}, Thm.cterm_of (ProofContext.theory_of ctxt) bs)]
-  in rtac (Thm.instantiate ([], map) @{thm "uneq_approx"}) i thm end
+  in rtac (Thm.instantiate ([], map) @{thm "approx_inequality"}) i thm end
 
   val eval_tac = CSUBGOAL (fn (ct, i) => rtac (eval_oracle ct) i)
 
@@ -2500,11 +2540,13 @@
   Args.term >>
   (fn prec => fn ctxt =>
     SIMPLE_METHOD' (fn i =>
-     (DETERM (reify_uneq ctxt i)
-      THEN rule_uneq ctxt prec i
+     (DETERM (reify_ineq ctxt i)
+      THEN rule_ineq ctxt prec i
       THEN Simplifier.asm_full_simp_tac bounded_by_simpset i 
       THEN (TRY (filter_prems_tac (fn t => false) i))
       THEN (gen_eval_tac eval_oracle ctxt) i)))
 *} "real number approximation"
+
+lemma "sin 1 > 0" by (approximation 10)
  
 end

--- a/src/HOL/Decision_Procs/Dense_Linear_Order.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Decision_Procs/Dense_Linear_Order.thy	Fri May 15 15:56:28 2009 +0200
@@ -639,7 +639,7 @@
 
 interpretation class_ordered_field_dense_linear_order: constr_dense_linear_order
  "op <=" "op <"
-   "\<lambda> x y. 1/2 * ((x::'a::{ordered_field,recpower,number_ring}) + y)"
+   "\<lambda> x y. 1/2 * ((x::'a::{ordered_field,number_ring}) + y)"
 proof (unfold_locales, dlo, dlo, auto)
   fix x y::'a assume lt: "x < y"
   from  less_half_sum[OF lt] show "x < (x + y) /2" by simp

--- a/src/HOL/Decision_Procs/cooper_tac.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Decision_Procs/cooper_tac.ML	Fri May 15 15:56:28 2009 +0200
@@ -76,14 +76,14 @@
 				  @{thm "div_by_1"}, @{thm "mod_by_1"}, @{thm "div_1"}, @{thm "mod_1"},
 				  Suc_plus1]
 			addsimps @{thms add_ac}
-			addsimprocs [cancel_div_mod_proc]
+			addsimprocs [cancel_div_mod_nat_proc, cancel_div_mod_int_proc]
     val simpset0 = HOL_basic_ss
       addsimps [mod_div_equality', Suc_plus1]
       addsimps comp_arith
       addsplits [split_zdiv, split_zmod, split_div', @{thm "split_min"}, @{thm "split_max"}]
     (* Simp rules for changing (n::int) to int n *)
     val simpset1 = HOL_basic_ss
-      addsimps [nat_number_of_def, zdvd_int] @ map (fn r => r RS sym)
+      addsimps [@{thm nat_number_of_def}, zdvd_int] @ map (fn r => r RS sym)
         [@{thm int_int_eq}, @{thm zle_int}, @{thm zless_int}, @{thm zadd_int}, @{thm zmult_int}]
       addsplits [zdiff_int_split]
     (*simp rules for elimination of int n*)

--- a/src/HOL/Decision_Procs/ex/Dense_Linear_Order_Ex.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Decision_Procs/ex/Dense_Linear_Order_Ex.thy	Fri May 15 15:56:28 2009 +0200
@@ -7,147 +7,147 @@
 begin
 
 lemma
-  "\<exists>(y::'a::{ordered_field,recpower,number_ring, division_by_zero}) <2. x + 3* y < 0 \<and> x - y >0"
+  "\<exists>(y::'a::{ordered_field,number_ring, division_by_zero}) <2. x + 3* y < 0 \<and> x - y >0"
   by ferrack
 
-lemma "~ (ALL x (y::'a::{ordered_field,recpower,number_ring, division_by_zero}). x < y --> 10*x < 11*y)"
+lemma "~ (ALL x (y::'a::{ordered_field,number_ring, division_by_zero}). x < y --> 10*x < 11*y)"
   by ferrack
 
-lemma "ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y. x < y --> (10*(x + 5*y + -1) < 60*y)"
+lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y. x < y --> (10*(x + 5*y + -1) < 60*y)"
   by ferrack
 
-lemma "EX (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y. x ~= y --> x < y"
+lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y. x ~= y --> x < y"
   by ferrack
 
-lemma "EX (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y. (x ~= y & 10*x ~= 9*y & 10*x < y) --> x < y"
+lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y. (x ~= y & 10*x ~= 9*y & 10*x < y) --> x < y"
   by ferrack
 
-lemma "ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y. (x ~= y & 5*x <= y) --> 500*x <= 100*y"
+lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y. (x ~= y & 5*x <= y) --> 500*x <= 100*y"
   by ferrack
 
-lemma "ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}). (EX (y::'a::{ordered_field,recpower,number_ring, division_by_zero}). 4*x + 3*y <= 0 & 4*x + 3*y >= -1)"
+lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}). (EX (y::'a::{ordered_field,number_ring, division_by_zero}). 4*x + 3*y <= 0 & 4*x + 3*y >= -1)"
   by ferrack
 
-lemma "ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) < 0. (EX (y::'a::{ordered_field,recpower,number_ring, division_by_zero}) > 0. 7*x + y > 0 & x - y <= 9)"
+lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) < 0. (EX (y::'a::{ordered_field,number_ring, division_by_zero}) > 0. 7*x + y > 0 & x - y <= 9)"
   by ferrack
 
-lemma "EX (x::'a::{ordered_field,recpower,number_ring, division_by_zero}). (0 < x & x < 1) --> (ALL y > 1. x + y ~= 1)"
+lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}). (0 < x & x < 1) --> (ALL y > 1. x + y ~= 1)"
   by ferrack
 
-lemma "EX x. (ALL (y::'a::{ordered_field,recpower,number_ring, division_by_zero}). y < 2 -->  2*(y - x) \<le> 0 )"
+lemma "EX x. (ALL (y::'a::{ordered_field,number_ring, division_by_zero}). y < 2 -->  2*(y - x) \<le> 0 )"
   by ferrack
 
-lemma "ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}). x < 10 | x > 20 | (EX y. y>= 0 & y <= 10 & x+y = 20)"
+lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}). x < 10 | x > 20 | (EX y. y>= 0 & y <= 10 & x+y = 20)"
   by ferrack
 
-lemma "ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y z. x + y < z --> y >= z --> x < 0"
+lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y z. x + y < z --> y >= z --> x < 0"
   by ferrack
 
-lemma "EX (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y z. x + 7*y < 5* z & 5*y >= 7*z & x < 0"
+lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y z. x + 7*y < 5* z & 5*y >= 7*z & x < 0"
   by ferrack
 
-lemma "ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y z. abs (x + y) <= z --> (abs z = z)"
+lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y z. abs (x + y) <= z --> (abs z = z)"
   by ferrack
 
-lemma "EX (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y z. x + 7*y - 5* z < 0 & 5*y + 7*z + 3*x < 0"
+lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y z. x + 7*y - 5* z < 0 & 5*y + 7*z + 3*x < 0"
   by ferrack
 
-lemma "ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y z. (abs (5*x+3*y+z) <= 5*x+3*y+z & abs (5*x+3*y+z) >= - (5*x+3*y+z)) | (abs (5*x+3*y+z) >= 5*x+3*y+z & abs (5*x+3*y+z) <= - (5*x+3*y+z))"
+lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y z. (abs (5*x+3*y+z) <= 5*x+3*y+z & abs (5*x+3*y+z) >= - (5*x+3*y+z)) | (abs (5*x+3*y+z) >= 5*x+3*y+z & abs (5*x+3*y+z) <= - (5*x+3*y+z))"
   by ferrack
 
-lemma "ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y. x < y --> (EX z>0. x+z = y)"
+lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y. x < y --> (EX z>0. x+z = y)"
   by ferrack
 
-lemma "ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y. x < y --> (EX z>0. x+z = y)"
+lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y. x < y --> (EX z>0. x+z = y)"
   by ferrack
 
-lemma "ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y. (EX z>0. abs (x - y) <= z )"
+lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y. (EX z>0. abs (x - y) <= z )"
   by ferrack
 
-lemma "EX (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y. (ALL z<0. (z < x --> z <= y) & (z > y --> z >= x))"
+lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y. (ALL z<0. (z < x --> z <= y) & (z > y --> z >= x))"
   by ferrack
 
-lemma "EX (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y. (ALL z>=0. abs (3*x+7*y) <= 2*z + 1)"
+lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y. (ALL z>=0. abs (3*x+7*y) <= 2*z + 1)"
   by ferrack
 
-lemma "EX (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y. (ALL z<0. (z < x --> z <= y) & (z > y --> z >= x))"
+lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y. (ALL z<0. (z < x --> z <= y) & (z > y --> z >= x))"
   by ferrack
 
-lemma "EX (x::'a::{ordered_field,recpower,number_ring, division_by_zero})>0. (ALL y. (EX z. 13* abs z \<noteq> abs (12*y - x) & 5*x - 3*(abs y) <= 7*z))"
+lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero})>0. (ALL y. (EX z. 13* abs z \<noteq> abs (12*y - x) & 5*x - 3*(abs y) <= 7*z))"
   by ferrack
 
-lemma "EX (x::'a::{ordered_field,recpower,number_ring, division_by_zero}). abs (4*x + 17) < 4 & (ALL y . abs (x*34 - 34*y - 9) \<noteq> 0 \<longrightarrow> (EX z. 5*x - 3*abs y <= 7*z))"
+lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}). abs (4*x + 17) < 4 & (ALL y . abs (x*34 - 34*y - 9) \<noteq> 0 \<longrightarrow> (EX z. 5*x - 3*abs y <= 7*z))"
   by ferrack
 
-lemma "ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}). (EX y > abs (23*x - 9). (ALL z > abs (3*y - 19* abs x). x+z > 2*y))"
+lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}). (EX y > abs (23*x - 9). (ALL z > abs (3*y - 19* abs x). x+z > 2*y))"
   by ferrack
 
-lemma "ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}). (EX y< abs (3*x - 1). (ALL z >= (3*abs x - 1). abs (12*x - 13*y + 19*z) > abs (23*x) ))"
+lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}). (EX y< abs (3*x - 1). (ALL z >= (3*abs x - 1). abs (12*x - 13*y + 19*z) > abs (23*x) ))"
   by ferrack
 
-lemma "EX (x::'a::{ordered_field,recpower,number_ring, division_by_zero}). abs x < 100 & (ALL y > x. (EX z<2*y - x. 5*x - 3*y <= 7*z))"
+lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}). abs x < 100 & (ALL y > x. (EX z<2*y - x. 5*x - 3*y <= 7*z))"
   by ferrack
 
-lemma "ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y z w. 7*x<3*y --> 5*y < 7*z --> z < 2*w --> 7*(2*w-x) > 2*y"
+lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y z w. 7*x<3*y --> 5*y < 7*z --> z < 2*w --> 7*(2*w-x) > 2*y"
   by ferrack
 
-lemma "EX (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y z w. 5*x + 3*z - 17*w + abs (y - 8*x + z) <= 89"
+lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y z w. 5*x + 3*z - 17*w + abs (y - 8*x + z) <= 89"
   by ferrack
 
-lemma "EX (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y z w. 5*x + 3*z - 17*w + 7* (y - 8*x + z) <= max y (7*z - x + w)"
+lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y z w. 5*x + 3*z - 17*w + 7* (y - 8*x + z) <= max y (7*z - x + w)"
   by ferrack
 
-lemma "EX (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y z w. min (5*x + 3*z) (17*w) + 5* abs (y - 8*x + z) <= max y (7*z - x + w)"
+lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y z w. min (5*x + 3*z) (17*w) + 5* abs (y - 8*x + z) <= max y (7*z - x + w)"
   by ferrack
 
-lemma "ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y z. (EX w >= (x+y+z). w <= abs x + abs y + abs z)"
+lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y z. (EX w >= (x+y+z). w <= abs x + abs y + abs z)"
   by ferrack
 
-lemma "~(ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}). (EX y z w. 3* x + z*4 = 3*y & x + y < z & x> w & 3*x < w + y))"
+lemma "~(ALL (x::'a::{ordered_field,number_ring, division_by_zero}). (EX y z w. 3* x + z*4 = 3*y & x + y < z & x> w & 3*x < w + y))"
   by ferrack
 
-lemma "ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y. (EX z w. abs (x-y) = (z-w) & z*1234 < 233*x & w ~= y)"
+lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y. (EX z w. abs (x-y) = (z-w) & z*1234 < 233*x & w ~= y)"
   by ferrack
 
-lemma "ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}). (EX y z w. min (5*x + 3*z) (17*w) + 5* abs (y - 8*x + z) <= max y (7*z - x + w))"
+lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}). (EX y z w. min (5*x + 3*z) (17*w) + 5* abs (y - 8*x + z) <= max y (7*z - x + w))"
   by ferrack
 
-lemma "EX (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y z. (ALL w >= abs (x+y+z). w >= abs x + abs y + abs z)"
+lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y z. (ALL w >= abs (x+y+z). w >= abs x + abs y + abs z)"
   by ferrack
 
-lemma "EX z. (ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y. (EX w >= (x+y+z). w <= abs x + abs y + abs z))"
+lemma "EX z. (ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y. (EX w >= (x+y+z). w <= abs x + abs y + abs z))"
   by ferrack
 
-lemma "EX z. (ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) < abs z. (EX y w. x< y & x < z & x> w & 3*x < w + y))"
+lemma "EX z. (ALL (x::'a::{ordered_field,number_ring, division_by_zero}) < abs z. (EX y w. x< y & x < z & x> w & 3*x < w + y))"
   by ferrack
 
-lemma "ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y. (EX z. (ALL w. abs (x-y) = abs (z-w) --> z < x & w ~= y))"
+lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y. (EX z. (ALL w. abs (x-y) = abs (z-w) --> z < x & w ~= y))"
   by ferrack
 
-lemma "EX y. (ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}). (EX z w. min (5*x + 3*z) (17*w) + 5* abs (y - 8*x + z) <= max y (7*z - x + w)))"
+lemma "EX y. (ALL (x::'a::{ordered_field,number_ring, division_by_zero}). (EX z w. min (5*x + 3*z) (17*w) + 5* abs (y - 8*x + z) <= max y (7*z - x + w)))"
   by ferrack
 
-lemma "EX (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) z. (ALL w >= 13*x - 4*z. (EX y. w >= abs x + abs y + z))"
+lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) z. (ALL w >= 13*x - 4*z. (EX y. w >= abs x + abs y + z))"
   by ferrack
 
-lemma "EX (x::'a::{ordered_field,recpower,number_ring, division_by_zero}). (ALL y < x. (EX z > (x+y).
+lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}). (ALL y < x. (EX z > (x+y).
   (ALL w. 5*w + 10*x - z >= y --> w + 7*x + 3*z >= 2*y)))"
   by ferrack
 
-lemma "EX (x::'a::{ordered_field,recpower,number_ring, division_by_zero}). (ALL y. (EX z > y.
+lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}). (ALL y. (EX z > y.
   (ALL w . w < 13 --> w + 10*x - z >= y --> 5*w + 7*x + 13*z >= 2*y)))"
   by ferrack
 
-lemma "EX (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y z w. min (5*x + 3*z) (17*w) + 5* abs (y - 8*x + z) <= max y (7*z - x + w)"
+lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y z w. min (5*x + 3*z) (17*w) + 5* abs (y - 8*x + z) <= max y (7*z - x + w)"
   by ferrack
 
-lemma "ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}). (EX y. (ALL z>19. y <= x + z & (EX w. abs (y - x) < w)))"
+lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}). (EX y. (ALL z>19. y <= x + z & (EX w. abs (y - x) < w)))"
   by ferrack
 
-lemma "ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}). (EX y. (ALL z>19. y <= x + z & (EX w. abs (x + z) < w - y)))"
+lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}). (EX y. (ALL z>19. y <= x + z & (EX w. abs (x + z) < w - y)))"
   by ferrack
 
-lemma "ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}). (EX y. abs y ~= abs x & (ALL z> max x y. (EX w. w ~= y & w ~= z & 3*w - z >= x + y)))"
+lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}). (EX y. abs y ~= abs x & (ALL z> max x y. (EX w. w ~= y & w ~= z & 3*w - z >= x + y)))"
   by ferrack
 
 end

--- a/src/HOL/Decision_Procs/mir_tac.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Decision_Procs/mir_tac.ML	Fri May 15 15:56:28 2009 +0200
@@ -99,7 +99,7 @@
                                   @{thm "div_by_1"}, @{thm "mod_by_1"}, @{thm "div_1"}, @{thm "mod_1"},
                                   @{thm "Suc_plus1"}]
                         addsimps @{thms add_ac}
-                        addsimprocs [cancel_div_mod_proc]
+                        addsimprocs [cancel_div_mod_nat_proc, cancel_div_mod_int_proc]
     val simpset0 = HOL_basic_ss
       addsimps [mod_div_equality', Suc_plus1]
       addsimps comp_ths

--- a/src/HOL/Deriv.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Deriv.thy	Fri May 15 15:56:28 2009 +0200
@@ -1,5 +1,4 @@
 (*  Title       : Deriv.thy
-    ID          : $Id$
     Author      : Jacques D. Fleuriot
     Copyright   : 1998  University of Cambridge
     Conversion to Isar and new proofs by Lawrence C Paulson, 2004
@@ -197,7 +196,7 @@
 done
 
 lemma DERIV_power_Suc:
-  fixes f :: "'a \<Rightarrow> 'a::{real_normed_field,recpower}"
+  fixes f :: "'a \<Rightarrow> 'a::{real_normed_field}"
   assumes f: "DERIV f x :> D"
   shows "DERIV (\<lambda>x. f x ^ Suc n) x :> (1 + of_nat n) * (D * f x ^ n)"
 proof (induct n)
@@ -211,7 +210,7 @@
 qed
 
 lemma DERIV_power:
-  fixes f :: "'a \<Rightarrow> 'a::{real_normed_field,recpower}"
+  fixes f :: "'a \<Rightarrow> 'a::{real_normed_field}"
   assumes f: "DERIV f x :> D"
   shows "DERIV (\<lambda>x. f x ^ n) x :> of_nat n * (D * f x ^ (n - Suc 0))"
 by (cases "n", simp, simp add: DERIV_power_Suc f del: power_Suc)
@@ -287,20 +286,20 @@
 text{*Power of -1*}
 
 lemma DERIV_inverse:
-  fixes x :: "'a::{real_normed_field,recpower}"
+  fixes x :: "'a::{real_normed_field}"
   shows "x \<noteq> 0 ==> DERIV (%x. inverse(x)) x :> (-(inverse x ^ Suc (Suc 0)))"
 by (drule DERIV_inverse' [OF DERIV_ident]) simp
 
 text{*Derivative of inverse*}
 lemma DERIV_inverse_fun:
-  fixes x :: "'a::{real_normed_field,recpower}"
+  fixes x :: "'a::{real_normed_field}"
   shows "[| DERIV f x :> d; f(x) \<noteq> 0 |]
       ==> DERIV (%x. inverse(f x)) x :> (- (d * inverse(f(x) ^ Suc (Suc 0))))"
 by (drule (1) DERIV_inverse') (simp add: mult_ac nonzero_inverse_mult_distrib)
 
 text{*Derivative of quotient*}
 lemma DERIV_quotient:
-  fixes x :: "'a::{real_normed_field,recpower}"
+  fixes x :: "'a::{real_normed_field}"
   shows "[| DERIV f x :> d; DERIV g x :> e; g(x) \<noteq> 0 |]
        ==> DERIV (%y. f(y) / (g y)) x :> (d*g(x) - (e*f(x))) / (g(x) ^ Suc (Suc 0))"
 by (drule (2) DERIV_divide) (simp add: mult_commute)
@@ -404,7 +403,7 @@
   unfolding divide_inverse using prems by simp
 
 lemma differentiable_power [simp]:
-  fixes f :: "'a::{recpower,real_normed_field} \<Rightarrow> 'a"
+  fixes f :: "'a::{real_normed_field} \<Rightarrow> 'a"
   assumes "f differentiable x"
   shows "(\<lambda>x. f x ^ n) differentiable x"
   by (induct n, simp, simp add: prems)

--- a/src/HOL/Divides.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Divides.thy	Fri May 15 15:56:28 2009 +0200
@@ -1,5 +1,4 @@
 (*  Title:      HOL/Divides.thy
-    ID:         $Id$
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1999  University of Cambridge
 *)
@@ -20,11 +19,12 @@
 
 subsection {* Abstract division in commutative semirings. *}
 
-class semiring_div = comm_semiring_1_cancel + div +
+class semiring_div = comm_semiring_1_cancel + no_zero_divisors + div +
   assumes mod_div_equality: "a div b * b + a mod b = a"
     and div_by_0 [simp]: "a div 0 = 0"
     and div_0 [simp]: "0 div a = 0"
     and div_mult_self1 [simp]: "b \<noteq> 0 \<Longrightarrow> (a + c * b) div b = c + a div b"
+    and div_mult_mult1 [simp]: "c \<noteq> 0 \<Longrightarrow> (c * a) div (c * b) = a div b"
 begin
 
 text {* @{const div} and @{const mod} *}
@@ -38,16 +38,16 @@
   by (simp only: add_ac)
 
 lemma div_mod_equality: "((a div b) * b + a mod b) + c = a + c"
-by (simp add: mod_div_equality)
+  by (simp add: mod_div_equality)
 
 lemma div_mod_equality2: "(b * (a div b) + a mod b) + c = a + c"
-by (simp add: mod_div_equality2)
+  by (simp add: mod_div_equality2)
 
 lemma mod_by_0 [simp]: "a mod 0 = a"
-using mod_div_equality [of a zero] by simp
+  using mod_div_equality [of a zero] by simp
 
 lemma mod_0 [simp]: "0 mod a = 0"
-using mod_div_equality [of zero a] div_0 by simp
+  using mod_div_equality [of zero a] div_0 by simp
 
 lemma div_mult_self2 [simp]:
   assumes "b \<noteq> 0"
@@ -72,7 +72,7 @@
 qed
 
 lemma mod_mult_self2 [simp]: "(a + b * c) mod b = a mod b"
-by (simp add: mult_commute [of b])
+  by (simp add: mult_commute [of b])
 
 lemma div_mult_self1_is_id [simp]: "b \<noteq> 0 \<Longrightarrow> b * a div b = a"
   using div_mult_self2 [of b 0 a] by simp
@@ -238,9 +238,9 @@
     by (simp only: mod_add_eq [symmetric])
 qed
 
-lemma div_add[simp]: "z dvd x \<Longrightarrow> z dvd y
+lemma div_add [simp]: "z dvd x \<Longrightarrow> z dvd y
   \<Longrightarrow> (x + y) div z = x div z + y div z"
-by(cases "z=0", simp, unfold dvd_def, auto simp add: algebra_simps)
+by (cases "z = 0", simp, unfold dvd_def, auto simp add: algebra_simps)
 
 text {* Multiplication respects modular equivalence. *}
 
@@ -297,24 +297,45 @@
   finally show ?thesis .
 qed
 
+lemma div_mult_div_if_dvd:
+  "y dvd x \<Longrightarrow> z dvd w \<Longrightarrow> (x div y) * (w div z) = (x * w) div (y * z)"
+  apply (cases "y = 0", simp)
+  apply (cases "z = 0", simp)
+  apply (auto elim!: dvdE simp add: algebra_simps)
+  apply (subst mult_assoc [symmetric])
+  apply (simp add: no_zero_divisors)
+  done
+
+lemma div_mult_mult2 [simp]:
+  "c \<noteq> 0 \<Longrightarrow> (a * c) div (b * c) = a div b"
+  by (drule div_mult_mult1) (simp add: mult_commute)
+
+lemma div_mult_mult1_if [simp]:
+  "(c * a) div (c * b) = (if c = 0 then 0 else a div b)"
+  by simp_all
+
+lemma mod_mult_mult1:
+  "(c * a) mod (c * b) = c * (a mod b)"
+proof (cases "c = 0")
+  case True then show ?thesis by simp
+next
+  case False
+  from mod_div_equality
+  have "((c * a) div (c * b)) * (c * b) + (c * a) mod (c * b) = c * a" .
+  with False have "c * ((a div b) * b + a mod b) + (c * a) mod (c * b)
+    = c * a + c * (a mod b)" by (simp add: algebra_simps)
+  with mod_div_equality show ?thesis by simp 
+qed
+  
+lemma mod_mult_mult2:
+  "(a * c) mod (b * c) = (a mod b) * c"
+  using mod_mult_mult1 [of c a b] by (simp add: mult_commute)
+
 end
 
-lemma div_mult_div_if_dvd: "(y::'a::{semiring_div,no_zero_divisors}) dvd x \<Longrightarrow> 
-  z dvd w \<Longrightarrow> (x div y) * (w div z) = (x * w) div (y * z)"
-unfolding dvd_def
-  apply clarify
-  apply (case_tac "y = 0")
-  apply simp
-  apply (case_tac "z = 0")
-  apply simp
-  apply (simp add: algebra_simps)
-  apply (subst mult_assoc [symmetric])
-  apply (simp add: no_zero_divisors)
-done
-
-
-lemma div_power: "(y::'a::{semiring_div,no_zero_divisors,recpower}) dvd x \<Longrightarrow>
-    (x div y)^n = x^n div y^n"
+lemma div_power:
+  "(y::'a::{semiring_div,no_zero_divisors,power}) dvd x \<Longrightarrow>
+    (x div y) ^ n = x ^ n div y ^ n"
 apply (induct n)
  apply simp
 apply(simp add: div_mult_div_if_dvd dvd_power_same)
@@ -398,15 +419,17 @@
   @{term "q\<Colon>nat"}(uotient) and @{term "r\<Colon>nat"}(emainder).
 *}
 
-definition divmod_rel :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
-  "divmod_rel m n q r \<longleftrightarrow> m = q * n + r \<and> (if n > 0 then 0 \<le> r \<and> r < n else q = 0)"
+definition divmod_rel :: "nat \<Rightarrow> nat \<Rightarrow> nat \<times> nat \<Rightarrow> bool" where
+  "divmod_rel m n qr \<longleftrightarrow>
+    m = fst qr * n + snd qr \<and>
+      (if n = 0 then fst qr = 0 else if n > 0 then 0 \<le> snd qr \<and> snd qr < n else n < snd qr \<and> snd qr \<le> 0)"
 
 text {* @{const divmod_rel} is total: *}
 
 lemma divmod_rel_ex:
-  obtains q r where "divmod_rel m n q r"
+  obtains q r where "divmod_rel m n (q, r)"
 proof (cases "n = 0")
-  case True with that show thesis
+  case True  with that show thesis
     by (auto simp add: divmod_rel_def)
 next
   case False
@@ -436,13 +459,14 @@
 
 text {* @{const divmod_rel} is injective: *}
 
-lemma divmod_rel_unique_div:
-  assumes "divmod_rel m n q r"
-    and "divmod_rel m n q' r'"
-  shows "q = q'"
+lemma divmod_rel_unique:
+  assumes "divmod_rel m n qr"
+    and "divmod_rel m n qr'"
+  shows "qr = qr'"
 proof (cases "n = 0")
   case True with assms show ?thesis
-    by (simp add: divmod_rel_def)
+    by (cases qr, cases qr')
+      (simp add: divmod_rel_def)
 next
   case False
   have aux: "\<And>q r q' r'. q' * n + r' = q * n + r \<Longrightarrow> r < n \<Longrightarrow> q' \<le> (q\<Colon>nat)"
@@ -450,18 +474,11 @@
   apply (subst less_iff_Suc_add)
   apply (auto simp add: add_mult_distrib)
   done
-  from `n \<noteq> 0` assms show ?thesis
-    by (auto simp add: divmod_rel_def
-      intro: order_antisym dest: aux sym)
-qed
-
-lemma divmod_rel_unique_mod:
-  assumes "divmod_rel m n q r"
-    and "divmod_rel m n q' r'"
-  shows "r = r'"
-proof -
-  from assms have "q = q'" by (rule divmod_rel_unique_div)
-  with assms show ?thesis by (simp add: divmod_rel_def)
+  from `n \<noteq> 0` assms have "fst qr = fst qr'"
+    by (auto simp add: divmod_rel_def intro: order_antisym dest: aux sym)
+  moreover from this assms have "snd qr = snd qr'"
+    by (simp add: divmod_rel_def)
+  ultimately show ?thesis by (cases qr, cases qr') simp
 qed
 
 text {*
@@ -473,7 +490,21 @@
 begin
 
 definition divmod :: "nat \<Rightarrow> nat \<Rightarrow> nat \<times> nat" where
-  [code del]: "divmod m n = (THE (q, r). divmod_rel m n q r)"
+  [code del]: "divmod m n = (THE qr. divmod_rel m n qr)"
+
+lemma divmod_rel_divmod:
+  "divmod_rel m n (divmod m n)"
+proof -
+  from divmod_rel_ex
+    obtain qr where rel: "divmod_rel m n qr" .
+  then show ?thesis
+  by (auto simp add: divmod_def intro: theI elim: divmod_rel_unique)
+qed
+
+lemma divmod_eq:
+  assumes "divmod_rel m n qr" 
+  shows "divmod m n = qr"
+  using assms by (auto intro: divmod_rel_unique divmod_rel_divmod)
 
 definition div_nat where
   "m div n = fst (divmod m n)"
@@ -485,30 +516,18 @@
   "divmod m n = (m div n, m mod n)"
   unfolding div_nat_def mod_nat_def by simp
 
-lemma divmod_eq:
-  assumes "divmod_rel m n q r" 
-  shows "divmod m n = (q, r)"
-  using assms by (auto simp add: divmod_def
-    dest: divmod_rel_unique_div divmod_rel_unique_mod)
-
 lemma div_eq:
-  assumes "divmod_rel m n q r" 
+  assumes "divmod_rel m n (q, r)" 
   shows "m div n = q"
-  using assms by (auto dest: divmod_eq simp add: div_nat_def)
+  using assms by (auto dest: divmod_eq simp add: divmod_div_mod)
 
 lemma mod_eq:
-  assumes "divmod_rel m n q r" 
+  assumes "divmod_rel m n (q, r)" 
   shows "m mod n = r"
-  using assms by (auto dest: divmod_eq simp add: mod_nat_def)
+  using assms by (auto dest: divmod_eq simp add: divmod_div_mod)
 
-lemma divmod_rel: "divmod_rel m n (m div n) (m mod n)"
-proof -
-  from divmod_rel_ex
-    obtain q r where rel: "divmod_rel m n q r" .
-  moreover with div_eq mod_eq have "m div n = q" and "m mod n = r"
-    by simp_all
-  ultimately show ?thesis by simp
-qed
+lemma divmod_rel: "divmod_rel m n (m div n, m mod n)"
+  by (simp add: div_nat_def mod_nat_def divmod_rel_divmod)
 
 lemma divmod_zero:
   "divmod m 0 = (0, m)"
@@ -531,10 +550,10 @@
   assumes "0 < n" and "n \<le> m"
   shows "divmod m n = (Suc ((m - n) div n), (m - n) mod n)"
 proof -
-  from divmod_rel have divmod_m_n: "divmod_rel m n (m div n) (m mod n)" .
+  from divmod_rel have divmod_m_n: "divmod_rel m n (m div n, m mod n)" .
   with assms have m_div_n: "m div n \<ge> 1"
     by (cases "m div n") (auto simp add: divmod_rel_def)
-  from assms divmod_m_n have "divmod_rel (m - n) n (m div n - Suc 0) (m mod n)"
+  from assms divmod_m_n have "divmod_rel (m - n) n (m div n - Suc 0, m mod n)"
     by (cases "m div n") (auto simp add: divmod_rel_def)
   with divmod_eq have "divmod (m - n) n = (m div n - Suc 0, m mod n)" by simp
   moreover from divmod_div_mod have "divmod (m - n) n = ((m - n) div n, (m - n) mod n)" .
@@ -569,55 +588,74 @@
   shows "m mod n = (m - n) mod n"
   using assms divmod_step divmod_div_mod by (cases "n = 0") simp_all
 
-instance proof
-  fix m n :: nat show "m div n * n + m mod n = m"
-    using divmod_rel [of m n] by (simp add: divmod_rel_def)
-next
-  fix n :: nat show "n div 0 = 0"
-    using divmod_zero divmod_div_mod [of n 0] by simp
-next
-  fix n :: nat show "0 div n = 0"
-    using divmod_rel [of 0 n] by (cases n) (simp_all add: divmod_rel_def)
-next
-  fix m n q :: nat assume "n \<noteq> 0" then show "(q + m * n) div n = m + q div n"
-    by (induct m) (simp_all add: le_div_geq)
+instance proof -
+  have [simp]: "\<And>n::nat. n div 0 = 0"
+    by (simp add: div_nat_def divmod_zero)
+  have [simp]: "\<And>n::nat. 0 div n = 0"
+  proof -
+    fix n :: nat
+    show "0 div n = 0"
+      by (cases "n = 0") simp_all
+  qed
+  show "OFCLASS(nat, semiring_div_class)" proof
+    fix m n :: nat
+    show "m div n * n + m mod n = m"
+      using divmod_rel [of m n] by (simp add: divmod_rel_def)
+  next
+    fix m n q :: nat
+    assume "n \<noteq> 0"
+    then show "(q + m * n) div n = m + q div n"
+      by (induct m) (simp_all add: le_div_geq)
+  next
+    fix m n q :: nat
+    assume "m \<noteq> 0"
+    then show "(m * n) div (m * q) = n div q"
+    proof (cases "n \<noteq> 0 \<and> q \<noteq> 0")
+      case False then show ?thesis by auto
+    next
+      case True with `m \<noteq> 0`
+        have "m > 0" and "n > 0" and "q > 0" by auto
+      then have "\<And>a b. divmod_rel n q (a, b) \<Longrightarrow> divmod_rel (m * n) (m * q) (a, m * b)"
+        by (auto simp add: divmod_rel_def) (simp_all add: algebra_simps)
+      moreover from divmod_rel have "divmod_rel n q (n div q, n mod q)" .
+      ultimately have "divmod_rel (m * n) (m * q) (n div q, m * (n mod q))" .
+      then show ?thesis by (simp add: div_eq)
+    qed
+  qed simp_all
 qed
 
 end
 
 text {* Simproc for cancelling @{const div} and @{const mod} *}
 
-(*lemmas mod_div_equality_nat = semiring_div_class.times_div_mod_plus_zero_one.mod_div_equality [of "m\<Colon>nat" n, standard]
-lemmas mod_div_equality2_nat = mod_div_equality2 [of "n\<Colon>nat" m, standard*)
+ML {*
+local
+
+structure CancelDivMod = CancelDivModFun(struct
 
-ML {*
-structure CancelDivModData =
-struct
-
-val div_name = @{const_name div};
-val mod_name = @{const_name mod};
-val mk_binop = HOLogic.mk_binop;
-val mk_sum = Nat_Arith.mk_sum;
-val dest_sum = Nat_Arith.dest_sum;
+  val div_name = @{const_name div};
+  val mod_name = @{const_name mod};
+  val mk_binop = HOLogic.mk_binop;
+  val mk_sum = Nat_Arith.mk_sum;
+  val dest_sum = Nat_Arith.dest_sum;
 
-(*logic*)
+  val div_mod_eqs = map mk_meta_eq [@{thm div_mod_equality}, @{thm div_mod_equality2}];
 
-val div_mod_eqs = map mk_meta_eq [@{thm div_mod_equality}, @{thm div_mod_equality2}]
-
-val trans = trans
+  val trans = trans;
 
-val prove_eq_sums =
-  let val simps = @{thm add_0} :: @{thm add_0_right} :: @{thms add_ac}
-  in Arith_Data.prove_conv2 all_tac (Arith_Data.simp_all_tac simps) end;
+  val prove_eq_sums = Arith_Data.prove_conv2 all_tac (Arith_Data.simp_all_tac
+    (@{thm monoid_add_class.add_0_left} :: @{thm monoid_add_class.add_0_right} :: @{thms add_ac}))
 
-end;
+end)
 
-structure CancelDivMod = CancelDivModFun(CancelDivModData);
+in
 
-val cancel_div_mod_proc = Simplifier.simproc (the_context ())
+val cancel_div_mod_nat_proc = Simplifier.simproc (the_context ())
   "cancel_div_mod" ["(m::nat) + n"] (K CancelDivMod.proc);
 
-Addsimprocs[cancel_div_mod_proc];
+val _ = Addsimprocs [cancel_div_mod_nat_proc];
+
+end
 *}
 
 text {* code generator setup *}
@@ -658,7 +696,7 @@
   fixes m n :: nat
   assumes "n > 0"
   shows "m mod n < (n::nat)"
-  using assms divmod_rel unfolding divmod_rel_def by auto
+  using assms divmod_rel [of m n] unfolding divmod_rel_def by auto
 
 lemma mod_less_eq_dividend [simp]:
   fixes m n :: nat
@@ -700,18 +738,19 @@
 subsubsection {* Quotient and Remainder *}
 
 lemma divmod_rel_mult1_eq:
-  "[| divmod_rel b c q r; c > 0 |]
-   ==> divmod_rel (a*b) c (a*q + a*r div c) (a*r mod c)"
+  "divmod_rel b c (q, r) \<Longrightarrow> c > 0
+   \<Longrightarrow> divmod_rel (a * b) c (a * q + a * r div c, a * r mod c)"
 by (auto simp add: split_ifs divmod_rel_def algebra_simps)
 
-lemma div_mult1_eq: "(a*b) div c = a*(b div c) + a*(b mod c) div (c::nat)"
+lemma div_mult1_eq:
+  "(a * b) div c = a * (b div c) + a * (b mod c) div (c::nat)"
 apply (cases "c = 0", simp)
 apply (blast intro: divmod_rel [THEN divmod_rel_mult1_eq, THEN div_eq])
 done
 
 lemma divmod_rel_add1_eq:
-  "[| divmod_rel a c aq ar; divmod_rel b c bq br;  c > 0 |]
-   ==> divmod_rel (a + b) c (aq + bq + (ar+br) div c) ((ar + br) mod c)"
+  "divmod_rel a c (aq, ar) \<Longrightarrow> divmod_rel b c (bq, br) \<Longrightarrow>  c > 0
+   \<Longrightarrow> divmod_rel (a + b) c (aq + bq + (ar + br) div c, (ar + br) mod c)"
 by (auto simp add: split_ifs divmod_rel_def algebra_simps)
 
 (*NOT suitable for rewriting: the RHS has an instance of the LHS*)
@@ -728,8 +767,9 @@
   apply (simp add: add_mult_distrib2)
   done
 
-lemma divmod_rel_mult2_eq: "[| divmod_rel a b q r;  0 < b;  0 < c |]
-      ==> divmod_rel a (b*c) (q div c) (b*(q mod c) + r)"
+lemma divmod_rel_mult2_eq:
+  "divmod_rel a b (q, r) \<Longrightarrow> 0 < b \<Longrightarrow> 0 < c
+   \<Longrightarrow> divmod_rel a (b * c) (q div c, b *(q mod c) + r)"
 by (auto simp add: mult_ac divmod_rel_def add_mult_distrib2 [symmetric] mod_lemma)
 
 lemma div_mult2_eq: "a div (b*c) = (a div b) div (c::nat)"
@@ -745,23 +785,6 @@
   done
 
 
-subsubsection{*Cancellation of Common Factors in Division*}
-
-lemma div_mult_mult_lemma:
-    "[| (0::nat) < b;  0 < c |] ==> (c*a) div (c*b) = a div b"
-by (auto simp add: div_mult2_eq)
-
-lemma div_mult_mult1 [simp]: "(0::nat) < c ==> (c*a) div (c*b) = a div b"
-  apply (cases "b = 0")
-  apply (auto simp add: linorder_neq_iff [of b] div_mult_mult_lemma)
-  done
-
-lemma div_mult_mult2 [simp]: "(0::nat) < c ==> (a*c) div (b*c) = a div b"
-  apply (drule div_mult_mult1)
-  apply (auto simp add: mult_commute)
-  done
-
-
 subsubsection{*Further Facts about Quotient and Remainder*}
 
 lemma div_1 [simp]: "m div Suc 0 = m"
@@ -769,7 +792,7 @@
 
 
 (* Monotonicity of div in first argument *)
-lemma div_le_mono [rule_format]:
+lemma div_le_mono [rule_format (no_asm)]:
     "\<forall>m::nat. m \<le> n --> (m div k) \<le> (n div k)"
 apply (case_tac "k=0", simp)
 apply (induct "n" rule: nat_less_induct, clarify)
@@ -824,12 +847,6 @@
   apply (simp_all)
 done
 
-lemma nat_div_eq_0 [simp]: "(n::nat) > 0 ==> ((m div n) = 0) = (m < n)"
-by(auto, subst mod_div_equality [of m n, symmetric], auto)
-
-lemma nat_div_gt_0 [simp]: "(n::nat) > 0 ==> ((m div n) > 0) = (m >= n)"
-by (subst neq0_conv [symmetric], auto)
-
 declare div_less_dividend [simp]
 
 text{*A fact for the mutilated chess board*}
@@ -915,21 +932,13 @@
   done
 
 lemma dvd_imp_le: "[| k dvd n; 0 < n |] ==> k \<le> (n::nat)"
-by (auto elim!: dvdE) (auto simp add: gr0_conv_Suc)
-
-lemma nat_dvd_not_less: "(0::nat) < m \<Longrightarrow> m < n \<Longrightarrow> \<not> n dvd m"
-by (auto elim!: dvdE) (auto simp add: gr0_conv_Suc)
+  by (auto elim!: dvdE) (auto simp add: gr0_conv_Suc)
 
 lemma dvd_mult_div_cancel: "n dvd m ==> n * (m div n) = (m::nat)"
-  apply (subgoal_tac "m mod n = 0")
-   apply (simp add: mult_div_cancel)
-  apply (simp only: dvd_eq_mod_eq_0)
-  done
+  by (simp add: dvd_eq_mod_eq_0 mult_div_cancel)
 
-lemma nat_zero_less_power_iff [simp]: "(x^n > 0) = (x > (0::nat) | n=0)"
-  by (induct n) auto
-
-lemma power_dvd_imp_le: "[|i^m dvd i^n;  (1::nat) < i|] ==> m \<le> n"
+lemma power_dvd_imp_le:
+  "i ^ m dvd i ^ n \<Longrightarrow> (1::nat) < i \<Longrightarrow> m \<le> n"
   apply (rule power_le_imp_le_exp, assumption)
   apply (erule dvd_imp_le, simp)
   done
@@ -1001,9 +1010,11 @@
   from A B show ?lhs ..
 next
   assume P: ?lhs
-  then have "divmod_rel m n q (m - n * q)"
+  then have "divmod_rel m n (q, m - n * q)"
     unfolding divmod_rel_def by (auto simp add: mult_ac)
-  then show ?rhs using divmod_rel by (rule divmod_rel_unique_div)
+  with divmod_rel_unique divmod_rel [of m n]
+  have "(q, m - n * q) = (m div n, m mod n)" by auto
+  then show ?rhs by simp
 qed
 
 theorem split_div':
@@ -1155,4 +1166,9 @@
   with j show ?thesis by blast
 qed
 
+lemma nat_dvd_not_less:
+  fixes m n :: nat
+  shows "0 < m \<Longrightarrow> m < n \<Longrightarrow> \<not> n dvd m"
+by (auto elim!: dvdE) (auto simp add: gr0_conv_Suc)
+
 end

--- a/src/HOL/Finite_Set.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Finite_Set.thy	Fri May 15 15:56:28 2009 +0200
@@ -365,6 +365,29 @@
 lemma finite_Plus: "[| finite A; finite B |] ==> finite (A <+> B)"
 by (simp add: Plus_def)
 
+lemma finite_PlusD: 
+  fixes A :: "'a set" and B :: "'b set"
+  assumes fin: "finite (A <+> B)"
+  shows "finite A" "finite B"
+proof -
+  have "Inl ` A \<subseteq> A <+> B" by auto
+  hence "finite (Inl ` A :: ('a + 'b) set)" using fin by(rule finite_subset)
+  thus "finite A" by(rule finite_imageD)(auto intro: inj_onI)
+next
+  have "Inr ` B \<subseteq> A <+> B" by auto
+  hence "finite (Inr ` B :: ('a + 'b) set)" using fin by(rule finite_subset)
+  thus "finite B" by(rule finite_imageD)(auto intro: inj_onI)
+qed
+
+lemma finite_Plus_iff[simp]: "finite (A <+> B) \<longleftrightarrow> finite A \<and> finite B"
+by(auto intro: finite_PlusD finite_Plus)
+
+lemma finite_Plus_UNIV_iff[simp]:
+  "finite (UNIV :: ('a + 'b) set) =
+  (finite (UNIV :: 'a set) & finite (UNIV :: 'b set))"
+by(subst UNIV_Plus_UNIV[symmetric])(rule finite_Plus_iff)
+
+
 text {* Sigma of finite sets *}
 
 lemma finite_SigmaI [simp]:
@@ -1563,6 +1586,20 @@
 qed
 
 
+lemma setsum_Plus:
+  fixes A :: "'a set" and B :: "'b set"
+  assumes fin: "finite A" "finite B"
+  shows "setsum f (A <+> B) = setsum (f \<circ> Inl) A + setsum (f \<circ> Inr) B"
+proof -
+  have "A <+> B = Inl ` A \<union> Inr ` B" by auto
+  moreover from fin have "finite (Inl ` A :: ('a + 'b) set)" "finite (Inr ` B :: ('a + 'b) set)"
+    by(auto intro: finite_imageI)
+  moreover have "Inl ` A \<inter> Inr ` B = ({} :: ('a + 'b) set)" by auto
+  moreover have "inj_on (Inl :: 'a \<Rightarrow> 'a + 'b) A" "inj_on (Inr :: 'b \<Rightarrow> 'a + 'b) B" by(auto intro: inj_onI)
+  ultimately show ?thesis using fin by(simp add: setsum_Un_disjoint setsum_reindex)
+qed
+
+
 text {* Commuting outer and inner summation *}
 
 lemma swap_inj_on:
@@ -2047,14 +2084,14 @@
 apply (auto simp add: algebra_simps)
 done
 
-lemma setprod_constant: "finite A ==> (\<Prod>x\<in> A. (y::'a::{recpower, comm_monoid_mult})) = y^(card A)"
+lemma setprod_constant: "finite A ==> (\<Prod>x\<in> A. (y::'a::{comm_monoid_mult})) = y^(card A)"
 apply (erule finite_induct)
 apply (auto simp add: power_Suc)
 done
 
 lemma setprod_gen_delta:
   assumes fS: "finite S"
-  shows "setprod (\<lambda>k. if k=a then b k else c) S = (if a \<in> S then (b a ::'a::{comm_monoid_mult, recpower}) * c^ (card S - 1) else c^ card S)"
+  shows "setprod (\<lambda>k. if k=a then b k else c) S = (if a \<in> S then (b a ::'a::{comm_monoid_mult}) * c^ (card S - 1) else c^ card S)"
 proof-
   let ?f = "(\<lambda>k. if k=a then b k else c)"
   {assume a: "a \<notin> S"
@@ -2091,6 +2128,10 @@
 qed
 
 
+lemma card_UNIV_unit: "card (UNIV :: unit set) = 1"
+  unfolding UNIV_unit by simp
+
+
 subsubsection {* Cardinality of unions *}
 
 lemma card_UN_disjoint:
@@ -2201,6 +2242,10 @@
     by (simp add: card_Un_disjoint card_image)
 qed
 
+lemma card_Plus_conv_if:
+  "card (A <+> B) = (if finite A \<and> finite B then card(A) + card(B) else 0)"
+by(auto simp: card_def setsum_Plus simp del: setsum_constant)
+
 
 subsubsection {* Cardinality of the Powerset *}
 

--- a/src/HOL/Fun.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Fun.thy	Fri May 15 15:56:28 2009 +0200
@@ -412,6 +412,9 @@
      "f(x:=y) ` A = (if x \<in> A then insert y (f ` (A-{x})) else f ` A)"
 by auto
 
+lemma fun_upd_comp: "f \<circ> (g(x := y)) = (f \<circ> g)(x := f y)"
+by(auto intro: ext)
+
 
 subsection {* @{text override_on} *}
 

--- a/src/HOL/Groebner_Basis.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Groebner_Basis.thy	Fri May 15 15:56:28 2009 +0200
@@ -5,7 +5,7 @@
 header {* Semiring normalization and Groebner Bases *}
 
 theory Groebner_Basis
-imports NatBin
+imports Nat_Numeral
 uses
   "Tools/Groebner_Basis/misc.ML"
   "Tools/Groebner_Basis/normalizer_data.ML"
@@ -164,7 +164,7 @@
 end
 
 interpretation class_semiring: gb_semiring
-    "op +" "op *" "op ^" "0::'a::{comm_semiring_1, recpower}" "1"
+    "op +" "op *" "op ^" "0::'a::{comm_semiring_1}" "1"
   proof qed (auto simp add: algebra_simps power_Suc)
 
 lemmas nat_arith =
@@ -242,7 +242,7 @@
 
 
 interpretation class_ring: gb_ring "op +" "op *" "op ^"
-    "0::'a::{comm_semiring_1,recpower,number_ring}" 1 "op -" "uminus"
+    "0::'a::{comm_semiring_1,number_ring}" 1 "op -" "uminus"
   proof qed simp_all
 
 
@@ -349,9 +349,9 @@
 qed
 
 interpretation class_ringb: ringb
-  "op +" "op *" "op ^" "0::'a::{idom,recpower,number_ring}" "1" "op -" "uminus"
+  "op +" "op *" "op ^" "0::'a::{idom,number_ring}" "1" "op -" "uminus"
 proof(unfold_locales, simp add: algebra_simps power_Suc, auto)
-  fix w x y z ::"'a::{idom,recpower,number_ring}"
+  fix w x y z ::"'a::{idom,number_ring}"
   assume p: "w * y + x * z = w * z + x * y" and ynz: "y \<noteq> z"
   hence ynz': "y - z \<noteq> 0" by simp
   from p have "w * y + x* z - w*z - x*y = 0" by simp
@@ -471,7 +471,7 @@
 subsection{* Groebner Bases for fields *}
 
 interpretation class_fieldgb:
-  fieldgb "op +" "op *" "op ^" "0::'a::{field,recpower,number_ring}" "1" "op -" "uminus" "op /" "inverse" apply (unfold_locales) by (simp_all add: divide_inverse)
+  fieldgb "op +" "op *" "op ^" "0::'a::{field,number_ring}" "1" "op -" "uminus" "op /" "inverse" apply (unfold_locales) by (simp_all add: divide_inverse)
 
 lemma divide_Numeral1: "(x::'a::{field,number_ring}) / Numeral1 = x" by simp
 lemma divide_Numeral0: "(x::'a::{field,number_ring, division_by_zero}) / Numeral0 = 0"
@@ -635,7 +635,7 @@
 val comp_conv = (Simplifier.rewrite
 (HOL_basic_ss addsimps @{thms "Groebner_Basis.comp_arith"}
               addsimps ths addsimps simp_thms
-              addsimprocs field_cancel_numeral_factors
+              addsimprocs Numeral_Simprocs.field_cancel_numeral_factors
                addsimprocs [add_frac_frac_simproc, add_frac_num_simproc,
                             ord_frac_simproc]
                 addcongs [@{thm "if_weak_cong"}]))

--- a/src/HOL/HOL.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/HOL.thy	Fri May 15 15:56:28 2009 +0200
@@ -5,9 +5,10 @@
 header {* The basis of Higher-Order Logic *}
 
 theory HOL
-imports Pure
+imports Pure "~~/src/Tools/Code_Generator"
 uses
   ("Tools/hologic.ML")
+  "~~/src/Tools/auto_solve.ML"
   "~~/src/Tools/IsaPlanner/zipper.ML"
   "~~/src/Tools/IsaPlanner/isand.ML"
   "~~/src/Tools/IsaPlanner/rw_tools.ML"
@@ -27,16 +28,6 @@
   "~~/src/Tools/atomize_elim.ML"
   "~~/src/Tools/induct.ML"
   ("~~/src/Tools/induct_tacs.ML")
-  "~~/src/Tools/value.ML"
-  "~~/src/Tools/code/code_name.ML"
-  "~~/src/Tools/code/code_funcgr.ML" (*formal dependency*)
-  "~~/src/Tools/code/code_wellsorted.ML" 
-  "~~/src/Tools/code/code_thingol.ML"
-  "~~/src/Tools/code/code_printer.ML"
-  "~~/src/Tools/code/code_target.ML"
-  "~~/src/Tools/code/code_ml.ML"
-  "~~/src/Tools/code/code_haskell.ML"
-  "~~/src/Tools/nbe.ML"
   ("Tools/recfun_codegen.ML")
 begin
 
@@ -1340,7 +1331,7 @@
     of Abs (_, _, t') => count_loose t' 0 <= 1
      | _ => true;
 in fn _ => fn ss => fn ct => if is_trivial_let (Thm.term_of ct)
-  then SOME @{thm Let_def} (*no or one ocurrenc of bound variable*)
+  then SOME @{thm Let_def} (*no or one ocurrence of bound variable*)
   else let (*Norbert Schirmer's case*)
     val ctxt = Simplifier.the_context ss;
     val thy = ProofContext.theory_of ctxt;
@@ -1577,6 +1568,56 @@
 setup Coherent.setup
 
 
+subsubsection {* Reorienting equalities *}
+
+ML {*
+signature REORIENT_PROC =
+sig
+  val init : theory -> theory
+  val add : (term -> bool) -> theory -> theory
+  val proc : morphism -> simpset -> cterm -> thm option
+end;
+
+structure ReorientProc : REORIENT_PROC =
+struct
+  structure Data = TheoryDataFun
+  (
+    type T = term -> bool;
+    val empty = (fn _ => false);
+    val copy = I;
+    val extend = I;
+    fun merge _ (m1, m2) = (fn t => m1 t orelse m2 t);
+  )
+
+  val init = Data.init;
+  fun add m = Data.map (fn matches => fn t => matches t orelse m t);
+  val meta_reorient = @{thm eq_commute [THEN eq_reflection]};
+  fun proc phi ss ct =
+    let
+      val ctxt = Simplifier.the_context ss;
+      val thy = ProofContext.theory_of ctxt;
+      val matches = Data.get thy;
+    in
+      case Thm.term_of ct of
+        (_ $ t $ u) => if matches u then NONE else SOME meta_reorient
+      | _ => NONE
+    end;
+end;
+*}
+
+setup ReorientProc.init
+
+setup {*
+  ReorientProc.add
+    (fn Const(@{const_name HOL.zero}, _) => true
+      | Const(@{const_name HOL.one}, _) => true
+      | _ => false)
+*}
+
+simproc_setup reorient_zero ("0 = x") = ReorientProc.proc
+simproc_setup reorient_one ("1 = x") = ReorientProc.proc
+
+
 subsection {* Other simple lemmas and lemma duplicates *}
 
 lemma Let_0 [simp]: "Let 0 f = f 0"
@@ -1674,37 +1715,287 @@
 *}
 
 
-subsection {* Code generator basics -- see further theory @{text "Code_Setup"} *}
+subsection {* Code generator setup *}
+
+subsubsection {* SML code generator setup *}
+
+use "Tools/recfun_codegen.ML"
+
+setup {*
+  Codegen.setup
+  #> RecfunCodegen.setup
+*}
+
+types_code
+  "bool"  ("bool")
+attach (term_of) {*
+fun term_of_bool b = if b then HOLogic.true_const else HOLogic.false_const;
+*}
+attach (test) {*
+fun gen_bool i =
+  let val b = one_of [false, true]
+  in (b, fn () => term_of_bool b) end;
+*}
+  "prop"  ("bool")
+attach (term_of) {*
+fun term_of_prop b =
+  HOLogic.mk_Trueprop (if b then HOLogic.true_const else HOLogic.false_const);
+*}
 
-text {* Equality *}
+consts_code
+  "Trueprop" ("(_)")
+  "True"    ("true")
+  "False"   ("false")
+  "Not"     ("Bool.not")
+  "op |"    ("(_ orelse/ _)")
+  "op &"    ("(_ andalso/ _)")
+  "If"      ("(if _/ then _/ else _)")
+
+setup {*
+let
+
+fun eq_codegen thy defs dep thyname b t gr =
+    (case strip_comb t of
+       (Const ("op =", Type (_, [Type ("fun", _), _])), _) => NONE
+     | (Const ("op =", _), [t, u]) =>
+          let
+            val (pt, gr') = Codegen.invoke_codegen thy defs dep thyname false t gr;
+            val (pu, gr'') = Codegen.invoke_codegen thy defs dep thyname false u gr';
+            val (_, gr''') = Codegen.invoke_tycodegen thy defs dep thyname false HOLogic.boolT gr'';
+          in
+            SOME (Codegen.parens
+              (Pretty.block [pt, Codegen.str " =", Pretty.brk 1, pu]), gr''')
+          end
+     | (t as Const ("op =", _), ts) => SOME (Codegen.invoke_codegen
+         thy defs dep thyname b (Codegen.eta_expand t ts 2) gr)
+     | _ => NONE);
+
+in
+  Codegen.add_codegen "eq_codegen" eq_codegen
+end
+*}
+
+subsubsection {* Generic code generator preprocessor setup *}
+
+setup {*
+  Code_Preproc.map_pre (K HOL_basic_ss)
+  #> Code_Preproc.map_post (K HOL_basic_ss)
+*}
+
+subsubsection {* Equality *}
 
 class eq =
   fixes eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
   assumes eq_equals: "eq x y \<longleftrightarrow> x = y"
 begin
 
-lemma eq: "eq = (op =)"
+lemma eq [code unfold, code inline del]: "eq = (op =)"
   by (rule ext eq_equals)+
 
 lemma eq_refl: "eq x x \<longleftrightarrow> True"
   unfolding eq by rule+
 
+lemma equals_eq: "(op =) \<equiv> eq"
+  by (rule eq_reflection) (rule ext, rule ext, rule sym, rule eq_equals)
+
+declare equals_eq [symmetric, code post]
+
 end
 
-text {* Module setup *}
-
-use "Tools/recfun_codegen.ML"
+declare equals_eq [code]
 
 setup {*
-  Code_ML.setup
-  #> Code_Haskell.setup
-  #> Nbe.setup
-  #> Codegen.setup
-  #> RecfunCodegen.setup
+  Code_Preproc.map_pre (fn simpset =>
+    simpset addsimprocs [Simplifier.simproc_i @{theory} "eq" [@{term "op ="}]
+      (fn thy => fn _ => fn t as Const (_, T) => case strip_type T
+        of ((T as Type _) :: _, _) => SOME @{thm equals_eq}
+         | _ => NONE)])
 *}
 
 
-subsection {* Nitpick hooks *}
+subsubsection {* Generic code generator foundation *}
+
+text {* Datatypes *}
+
+code_datatype True False
+
+code_datatype "TYPE('a\<Colon>{})"
+
+code_datatype Trueprop "prop"
+
+text {* Code equations *}
+
+lemma [code]:
+  shows "(True \<Longrightarrow> PROP P) \<equiv> PROP P" 
+    and "(False \<Longrightarrow> Q) \<equiv> Trueprop True" 
+    and "(PROP P \<Longrightarrow> True) \<equiv> Trueprop True" 
+    and "(Q \<Longrightarrow> False) \<equiv> Trueprop (\<not> Q)" by (auto intro!: equal_intr_rule)
+
+lemma [code]:
+  shows "False \<and> x \<longleftrightarrow> False"
+    and "True \<and> x \<longleftrightarrow> x"
+    and "x \<and> False \<longleftrightarrow> False"
+    and "x \<and> True \<longleftrightarrow> x" by simp_all
+
+lemma [code]:
+  shows "False \<or> x \<longleftrightarrow> x"
+    and "True \<or> x \<longleftrightarrow> True"
+    and "x \<or> False \<longleftrightarrow> x"
+    and "x \<or> True \<longleftrightarrow> True" by simp_all
+
+lemma [code]:
+  shows "\<not> True \<longleftrightarrow> False"
+    and "\<not> False \<longleftrightarrow> True" by (rule HOL.simp_thms)+
+
+lemmas [code] = Let_def if_True if_False
+
+lemmas [code, code unfold, symmetric, code post] = imp_conv_disj
+
+instantiation itself :: (type) eq
+begin
+
+definition eq_itself :: "'a itself \<Rightarrow> 'a itself \<Rightarrow> bool" where
+  "eq_itself x y \<longleftrightarrow> x = y"
+
+instance proof
+qed (fact eq_itself_def)
+
+end
+
+lemma eq_itself_code [code]:
+  "eq_class.eq TYPE('a) TYPE('a) \<longleftrightarrow> True"
+  by (simp add: eq)
+
+text {* Equality *}
+
+declare simp_thms(6) [code nbe]
+
+setup {*
+  Code.add_const_alias @{thm equals_eq}
+*}
+
+hide (open) const eq
+hide const eq
+
+text {* Cases *}
+
+lemma Let_case_cert:
+  assumes "CASE \<equiv> (\<lambda>x. Let x f)"
+  shows "CASE x \<equiv> f x"
+  using assms by simp_all
+
+lemma If_case_cert:
+  assumes "CASE \<equiv> (\<lambda>b. If b f g)"
+  shows "(CASE True \<equiv> f) &&& (CASE False \<equiv> g)"
+  using assms by simp_all
+
+setup {*
+  Code.add_case @{thm Let_case_cert}
+  #> Code.add_case @{thm If_case_cert}
+  #> Code.add_undefined @{const_name undefined}
+*}
+
+code_abort undefined
+
+subsubsection {* Generic code generator target languages *}
+
+text {* type bool *}
+
+code_type bool
+  (SML "bool")
+  (OCaml "bool")
+  (Haskell "Bool")
+
+code_const True and False and Not and "op &" and "op |" and If
+  (SML "true" and "false" and "not"
+    and infixl 1 "andalso" and infixl 0 "orelse"
+    and "!(if (_)/ then (_)/ else (_))")
+  (OCaml "true" and "false" and "not"
+    and infixl 4 "&&" and infixl 2 "||"
+    and "!(if (_)/ then (_)/ else (_))")
+  (Haskell "True" and "False" and "not"
+    and infixl 3 "&&" and infixl 2 "||"
+    and "!(if (_)/ then (_)/ else (_))")
+
+code_reserved SML
+  bool true false not
+
+code_reserved OCaml
+  bool not
+
+text {* using built-in Haskell equality *}
+
+code_class eq
+  (Haskell "Eq")
+
+code_const "eq_class.eq"
+  (Haskell infixl 4 "==")
+
+code_const "op ="
+  (Haskell infixl 4 "==")
+
+text {* undefined *}
+
+code_const undefined
+  (SML "!(raise/ Fail/ \"undefined\")")
+  (OCaml "failwith/ \"undefined\"")
+  (Haskell "error/ \"undefined\"")
+
+subsubsection {* Evaluation and normalization by evaluation *}
+
+setup {*
+  Value.add_evaluator ("SML", Codegen.eval_term o ProofContext.theory_of)
+*}
+
+ML {*
+structure Eval_Method =
+struct
+
+val eval_ref : (unit -> bool) option ref = ref NONE;
+
+end;
+*}
+
+oracle eval_oracle = {* fn ct =>
+  let
+    val thy = Thm.theory_of_cterm ct;
+    val t = Thm.term_of ct;
+    val dummy = @{cprop True};
+  in case try HOLogic.dest_Trueprop t
+   of SOME t' => if Code_ML.eval NONE
+         ("Eval_Method.eval_ref", Eval_Method.eval_ref) (K I) thy t' [] 
+       then Thm.capply (Thm.capply @{cterm "op \<equiv> \<Colon> prop \<Rightarrow> prop \<Rightarrow> prop"} ct) dummy
+       else dummy
+    | NONE => dummy
+  end
+*}
+
+ML {*
+fun gen_eval_method conv ctxt = SIMPLE_METHOD'
+  (CONVERSION (Conv.params_conv (~1) (K (Conv.concl_conv (~1) conv)) ctxt)
+    THEN' rtac TrueI)
+*}
+
+method_setup eval = {* Scan.succeed (gen_eval_method eval_oracle) *}
+  "solve goal by evaluation"
+
+method_setup evaluation = {* Scan.succeed (gen_eval_method Codegen.evaluation_conv) *}
+  "solve goal by evaluation"
+
+method_setup normalization = {*
+  Scan.succeed (K (SIMPLE_METHOD' (CONVERSION Nbe.norm_conv THEN' (fn k => TRY (rtac TrueI k)))))
+*} "solve goal by normalization"
+
+subsubsection {* Quickcheck *}
+
+setup {*
+  Quickcheck.add_generator ("SML", Codegen.test_term)
+*}
+
+quickcheck_params [size = 5, iterations = 50]
+
+
+subsection {* Nitpick setup *}
 
 text {* This will be relocated once Nitpick is moved to HOL. *}
 
@@ -1730,10 +2021,14 @@
   val description = "introduction rules for (co)inductive predicates as needed by Nitpick"
 )
 *}
-setup {* Nitpick_Const_Def_Thms.setup
-         #> Nitpick_Const_Simp_Thms.setup
-         #> Nitpick_Const_Psimp_Thms.setup
-         #> Nitpick_Ind_Intro_Thms.setup *}
+
+setup {*
+  Nitpick_Const_Def_Thms.setup
+  #> Nitpick_Const_Simp_Thms.setup
+  #> Nitpick_Const_Psimp_Thms.setup
+  #> Nitpick_Ind_Intro_Thms.setup
+*}
+
 
 subsection {* Legacy tactics and ML bindings *}
 

--- a/src/HOL/HoareParallel/Graph.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/HoareParallel/Graph.thy	Fri May 15 15:56:28 2009 +0200
@@ -172,9 +172,9 @@
  prefer 2 apply arith
  apply(drule_tac n = "Suc nata" in Compl_lemma)
  apply clarify
- using [[fast_arith_split_limit = 0]]
+ using [[linarith_split_limit = 0]]
  apply force
- using [[fast_arith_split_limit = 9]]
+ using [[linarith_split_limit = 9]]
 apply(drule leI)
 apply(subgoal_tac "Suc (length path - Suc m + nata)=(length path - Suc 0) - (m - Suc nata)")
  apply(erule_tac x = "m - (Suc nata)" in allE)

--- a/src/HOL/HoareParallel/OG_Examples.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/HoareParallel/OG_Examples.thy	Fri May 15 15:56:28 2009 +0200
@@ -443,7 +443,7 @@
 --{* 32 subgoals left *}
 apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
 
-apply(tactic {* TRYALL (linear_arith_tac @{context}) *})
+apply(tactic {* TRYALL (Lin_Arith.tac @{context}) *})
 --{* 9 subgoals left *}
 apply (force simp add:less_Suc_eq)
 apply(drule sym)

--- a/src/HOL/HoareParallel/OG_Tran.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/HoareParallel/OG_Tran.thy	Fri May 15 15:56:28 2009 +0200
@@ -74,7 +74,7 @@
 abbreviation
   ann_transition_n :: "('a ann_com_op \<times> 'a) \<Rightarrow> nat \<Rightarrow> ('a ann_com_op \<times> 'a) 
                            \<Rightarrow> bool"  ("_ -_\<rightarrow> _"[81,81] 100)  where
-  "con_0 -n\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> ann_transition^n"
+  "con_0 -n\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> ann_transition ^^ n"
 
 abbreviation
   ann_transitions :: "('a ann_com_op \<times> 'a) \<Rightarrow> ('a ann_com_op \<times> 'a) \<Rightarrow> bool"
@@ -84,7 +84,7 @@
 abbreviation
   transition_n :: "('a com \<times> 'a) \<Rightarrow> nat \<Rightarrow> ('a com \<times> 'a) \<Rightarrow> bool"  
                           ("_ -P_\<rightarrow> _"[81,81,81] 100)  where
-  "con_0 -Pn\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> transition^n"
+  "con_0 -Pn\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> transition ^^ n"
 
 subsection {* Definition of Semantics *}
 

--- a/src/HOL/IMP/Compiler0.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/IMP/Compiler0.thy	Fri May 15 15:56:28 2009 +0200
@@ -45,7 +45,7 @@
 abbreviation
   stepan :: "[instr list,state,nat,nat,state,nat] \<Rightarrow> bool"
     ("_ \<turnstile>/ (3\<langle>_,_\<rangle>/ -(_)\<rightarrow> \<langle>_,_\<rangle>)" [50,0,0,0,0,0] 50)  where
-  "P \<turnstile> \<langle>s,m\<rangle> -(i)\<rightarrow> \<langle>t,n\<rangle> == ((s,m),t,n) : ((stepa1 P)^i)"
+  "P \<turnstile> \<langle>s,m\<rangle> -(i)\<rightarrow> \<langle>t,n\<rangle> == ((s,m),t,n) : (stepa1 P ^^ i)"
 
 subsection "The compiler"
 

--- a/src/HOL/IMP/Machines.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/IMP/Machines.thy	Fri May 15 15:56:28 2009 +0200
@@ -1,7 +1,6 @@
-
-(* $Id$ *)
-
-theory Machines imports Natural begin
+theory Machines
+imports Natural
+begin
 
 lemma rtrancl_eq: "R^* = Id \<union> (R O R^*)"
   by (fast intro: rtrancl_into_rtrancl elim: rtranclE)
@@ -11,20 +10,22 @@
 
 lemmas converse_rel_powE = rel_pow_E2
 
-lemma R_O_Rn_commute: "R O R^n = R^n O R"
+lemma R_O_Rn_commute: "R O R ^^ n = R ^^ n O R"
   by (induct n) (simp, simp add: O_assoc [symmetric])
 
 lemma converse_in_rel_pow_eq:
-  "((x,z) \<in> R^n) = (n=0 \<and> z=x \<or> (\<exists>m y. n = Suc m \<and> (x,y) \<in> R \<and> (y,z) \<in> R^m))"
+  "((x,z) \<in> R ^^ n) = (n=0 \<and> z=x \<or> (\<exists>m y. n = Suc m \<and> (x,y) \<in> R \<and> (y,z) \<in> R ^^ m))"
 apply(rule iffI)
  apply(blast elim:converse_rel_powE)
 apply (fastsimp simp add:gr0_conv_Suc R_O_Rn_commute)
 done
 
-lemma rel_pow_plus: "R^(m+n) = R^n O R^m"
+lemma rel_pow_plus:
+  "R ^^ (m+n) = R ^^ n O R ^^ m"
   by (induct n) (simp, simp add: O_assoc)
 
-lemma rel_pow_plusI: "\<lbrakk> (x,y) \<in> R^m; (y,z) \<in> R^n \<rbrakk> \<Longrightarrow> (x,z) \<in> R^(m+n)"
+lemma rel_pow_plusI:
+  "\<lbrakk> (x,y) \<in> R ^^ m; (y,z) \<in> R ^^ n \<rbrakk> \<Longrightarrow> (x,z) \<in> R ^^ (m+n)"
   by (simp add: rel_pow_plus rel_compI)
 
 subsection "Instructions"
@@ -57,7 +58,7 @@
 abbreviation
   exec0n :: "[instrs, nat,state, nat, nat,state] \<Rightarrow> bool"
     ("(_/ \<turnstile> (1\<langle>_,/_\<rangle>)/ -_\<rightarrow> (1\<langle>_,/_\<rangle>))" [50,0,0,0,0] 50)  where
-  "p \<turnstile> \<langle>i,s\<rangle> -n\<rightarrow> \<langle>j,t\<rangle> == ((i,s),j,t) : (exec01 p)^n"
+  "p \<turnstile> \<langle>i,s\<rangle> -n\<rightarrow> \<langle>j,t\<rangle> == ((i,s),j,t) : (exec01 p)^^n"
 
 subsection "M0 with lists"
 
@@ -89,7 +90,7 @@
 abbreviation
   stepan :: "[instrs,instrs,state, nat, instrs,instrs,state] \<Rightarrow> bool"
     ("((1\<langle>_,/_,/_\<rangle>)/ -_\<rightarrow> (1\<langle>_,/_,/_\<rangle>))" 50) where
-  "\<langle>p,q,s\<rangle> -i\<rightarrow> \<langle>p',q',t\<rangle> == ((p,q,s),p',q',t) : (stepa1^i)"
+  "\<langle>p,q,s\<rangle> -i\<rightarrow> \<langle>p',q',t\<rangle> == ((p,q,s),p',q',t) : (stepa1^^i)"
 
 inductive_cases execE: "((i#is,p,s), (is',p',s')) : stepa1"
 

--- a/src/HOL/IMP/Transition.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/IMP/Transition.thy	Fri May 15 15:56:28 2009 +0200
@@ -1,5 +1,4 @@
 (*  Title:        HOL/IMP/Transition.thy
-    ID:           $Id$
     Author:       Tobias Nipkow & Robert Sandner, TUM
     Isar Version: Gerwin Klein, 2001
     Copyright     1996 TUM
@@ -69,7 +68,7 @@
 abbreviation
   evalcn :: "[(com option\<times>state),nat,(com option\<times>state)] \<Rightarrow> bool"
     ("_ -_\<rightarrow>\<^sub>1 _" [60,60,60] 60)  where
-  "cs -n\<rightarrow>\<^sub>1 cs' == (cs,cs') \<in> evalc1^n"
+  "cs -n\<rightarrow>\<^sub>1 cs' == (cs,cs') \<in> evalc1^^n"
 
 abbreviation
   evalc' :: "[(com option\<times>state),(com option\<times>state)] \<Rightarrow> bool"
@@ -77,28 +76,9 @@
   "cs \<longrightarrow>\<^sub>1\<^sup>* cs' == (cs,cs') \<in> evalc1^*"
 
 (*<*)
-(* fixme: move to Relation_Power.thy *)
-lemma rel_pow_Suc_E2 [elim!]:
-  "[| (x, z) \<in> R ^ Suc n; !!y. [| (x, y) \<in> R; (y, z) \<in> R ^ n |] ==> P |] ==> P"
-  by (blast dest: rel_pow_Suc_D2)
+declare rel_pow_Suc_E2 [elim!]
+(*>*)
 
-lemma rtrancl_imp_rel_pow: "p \<in> R^* \<Longrightarrow> \<exists>n. p \<in> R^n"
-proof (induct p)
-  fix x y
-  assume "(x, y) \<in> R\<^sup>*"
-  thus "\<exists>n. (x, y) \<in> R^n"
-  proof induct
-    fix a have "(a, a) \<in> R^0" by simp
-    thus "\<exists>n. (a, a) \<in> R ^ n" ..
-  next
-    fix a b c assume "\<exists>n. (a, b) \<in> R ^ n"
-    then obtain n where "(a, b) \<in> R^n" ..
-    moreover assume "(b, c) \<in> R"
-    ultimately have "(a, c) \<in> R^(Suc n)" by auto
-    thus "\<exists>n. (a, c) \<in> R^n" ..
-  qed
-qed
-(*>*)
 text {*
   As for the big step semantics you can read these rules in a
   syntax directed way:
@@ -189,8 +169,8 @@
 (*<*)
 (* FIXME: relpow.simps don't work *)
 lemmas [simp del] = relpow.simps
-lemma rel_pow_0 [simp]: "!!R::('a*'a) set. R^0 = Id" by (simp add: relpow.simps)
-lemma rel_pow_Suc_0 [simp]: "!!R::('a*'a) set. R^(Suc 0) = R" by (simp add: relpow.simps)
+lemma rel_pow_0 [simp]: "!!R::('a*'a) set. R ^^ 0 = Id" by (simp add: relpow.simps)
+lemma rel_pow_Suc_0 [simp]: "!!R::('a*'a) set. R ^^ Suc 0 = R" by (simp add: relpow.simps)
 
 (*>*)
 lemma evalc1_None_0 [simp]: "\<langle>s\<rangle> -n\<rightarrow>\<^sub>1 y = (n = 0 \<and> y = \<langle>s\<rangle>)"

--- a/src/HOL/Imperative_HOL/Heap_Monad.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Imperative_HOL/Heap_Monad.thy	Fri May 15 15:56:28 2009 +0200
@@ -317,7 +317,7 @@
       val dummy_type = ITyVar dummy_name;
       val dummy_case_term = IVar dummy_name;
       (*assumption: dummy values are not relevant for serialization*)
-      val unitt = IConst (unit', ([], []));
+      val unitt = IConst (unit', (([], []), []));
       fun dest_abs ((v, ty) `|-> t, _) = ((v, ty), t)
         | dest_abs (t, ty) =
             let
@@ -353,10 +353,10 @@
     | imp_monad_bind bind' return' unit' (ICase (((t, ty), pats), t0)) = ICase
         (((imp_monad_bind bind' return' unit' t, ty), (map o pairself) (imp_monad_bind bind' return' unit') pats), imp_monad_bind bind' return' unit' t0);
 
-   fun imp_program naming = (Graph.map_nodes o map_terms_stmt)
-     (imp_monad_bind (lookup naming @{const_name bindM})
-       (lookup naming @{const_name return})
-       (lookup naming @{const_name Unity}));
+  fun imp_program naming = (Graph.map_nodes o map_terms_stmt)
+    (imp_monad_bind (lookup naming @{const_name bindM})
+      (lookup naming @{const_name return})
+      (lookup naming @{const_name Unity}));
 
 in
 

--- a/src/HOL/Import/HOL/HOL4Base.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Import/HOL/HOL4Base.thy	Fri May 15 15:56:28 2009 +0200
@@ -2794,8 +2794,8 @@
   by (import numeral numeral_fact)
 
 lemma numeral_funpow: "ALL n::nat.
-   ((f::'a::type => 'a::type) ^ n) (x::'a::type) =
-   (if n = 0 then x else (f ^ (n - 1)) (f x))"
+   ((f::'a::type => 'a::type) ^^ n) (x::'a::type) =
+   (if n = 0 then x else (f ^^ (n - 1)) (f x))"
   by (import numeral numeral_funpow)
 
 ;end_setup

--- a/src/HOL/Import/HOL/HOL4Word32.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Import/HOL/HOL4Word32.thy	Fri May 15 15:56:28 2009 +0200
@@ -434,15 +434,15 @@
   by (import word32 EQUIV_QT)
 
 lemma FUNPOW_THM: "ALL (f::'a::type => 'a::type) (n::nat) x::'a::type.
-   (f ^ n) (f x) = f ((f ^ n) x)"
+   (f ^^ n) (f x) = f ((f ^^ n) x)"
   by (import word32 FUNPOW_THM)
 
 lemma FUNPOW_THM2: "ALL (f::'a::type => 'a::type) (n::nat) x::'a::type.
-   (f ^ Suc n) x = f ((f ^ n) x)"
+   (f ^^ Suc n) x = f ((f ^^ n) x)"
   by (import word32 FUNPOW_THM2)
 
 lemma FUNPOW_COMP: "ALL (f::'a::type => 'a::type) (m::nat) (n::nat) a::'a::type.
-   (f ^ m) ((f ^ n) a) = (f ^ (m + n)) a"
+   (f ^^ m) ((f ^^ n) a) = (f ^^ (m + n)) a"
   by (import word32 FUNPOW_COMP)
 
 lemma INw_MODw: "ALL n::nat. INw (MODw n)"
@@ -1170,23 +1170,23 @@
 
 constdefs
   word_lsr :: "word32 => nat => word32" 
-  "word_lsr == %(a::word32) n::nat. (word_lsr1 ^ n) a"
+  "word_lsr == %(a::word32) n::nat. (word_lsr1 ^^ n) a"
 
-lemma word_lsr: "ALL (a::word32) n::nat. word_lsr a n = (word_lsr1 ^ n) a"
+lemma word_lsr: "ALL (a::word32) n::nat. word_lsr a n = (word_lsr1 ^^ n) a"
   by (import word32 word_lsr)
 
 constdefs
   word_asr :: "word32 => nat => word32" 
-  "word_asr == %(a::word32) n::nat. (word_asr1 ^ n) a"
+  "word_asr == %(a::word32) n::nat. (word_asr1 ^^ n) a"
 
-lemma word_asr: "ALL (a::word32) n::nat. word_asr a n = (word_asr1 ^ n) a"
+lemma word_asr: "ALL (a::word32) n::nat. word_asr a n = (word_asr1 ^^ n) a"
   by (import word32 word_asr)
 
 constdefs
   word_ror :: "word32 => nat => word32" 
-  "word_ror == %(a::word32) n::nat. (word_ror1 ^ n) a"
+  "word_ror == %(a::word32) n::nat. (word_ror1 ^^ n) a"
 
-lemma word_ror: "ALL (a::word32) n::nat. word_ror a n = (word_ror1 ^ n) a"
+lemma word_ror: "ALL (a::word32) n::nat. word_ror a n = (word_ror1 ^^ n) a"
   by (import word32 word_ror)
 
 consts
@@ -1583,4 +1583,3 @@
 ;end_setup
 
 end
-

--- a/src/HOL/Import/HOL/arithmetic.imp	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Import/HOL/arithmetic.imp	Fri May 15 15:56:28 2009 +0200
@@ -43,7 +43,7 @@
   "TWO" > "HOL4Base.arithmetic.TWO"
   "TIMES2" > "NatSimprocs.nat_mult_2"
   "SUC_SUB1" > "HOL4Base.arithmetic.SUC_SUB1"
-  "SUC_ONE_ADD" > "NatBin.Suc_eq_add_numeral_1_left"
+  "SUC_ONE_ADD" > "Nat_Numeral.Suc_eq_add_numeral_1_left"
   "SUC_NOT" > "Nat.nat.simps_2"
   "SUC_ELIM_THM" > "HOL4Base.arithmetic.SUC_ELIM_THM"
   "SUC_ADD_SYM" > "HOL4Base.arithmetic.SUC_ADD_SYM"
@@ -233,7 +233,7 @@
   "EVEN_AND_ODD" > "HOL4Base.arithmetic.EVEN_AND_ODD"
   "EVEN_ADD" > "HOL4Base.arithmetic.EVEN_ADD"
   "EVEN" > "HOL4Base.arithmetic.EVEN"
-  "EQ_MULT_LCANCEL" > "NatBin.nat_mult_eq_cancel_disj"
+  "EQ_MULT_LCANCEL" > "Nat_Numeral.nat_mult_eq_cancel_disj"
   "EQ_MONO_ADD_EQ" > "Nat.nat_add_right_cancel"
   "EQ_LESS_EQ" > "Orderings.order_eq_iff"
   "EQ_ADD_RCANCEL" > "Nat.nat_add_right_cancel"

--- a/src/HOL/Import/HOL/real.imp	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Import/HOL/real.imp	Fri May 15 15:56:28 2009 +0200
@@ -99,7 +99,7 @@
   "REAL_POW_INV" > "Power.power_inverse"
   "REAL_POW_DIV" > "Power.power_divide"
   "REAL_POW_ADD" > "Power.power_add"
-  "REAL_POW2_ABS" > "NatBin.power2_abs"
+  "REAL_POW2_ABS" > "Nat_Numeral.power2_abs"
   "REAL_POS_NZ" > "HOL4Real.real.REAL_POS_NZ"
   "REAL_POS" > "RealDef.real_of_nat_ge_zero"
   "REAL_POASQ" > "HOL4Real.real.REAL_POASQ"
@@ -210,7 +210,7 @@
   "REAL_LE_RDIV_EQ" > "Ring_and_Field.pos_le_divide_eq"
   "REAL_LE_RDIV" > "Ring_and_Field.mult_imp_le_div_pos"
   "REAL_LE_RADD" > "OrderedGroup.add_le_cancel_right"
-  "REAL_LE_POW2" > "NatBin.zero_compare_simps_12"
+  "REAL_LE_POW2" > "Nat_Numeral.zero_compare_simps_12"
   "REAL_LE_NEGTOTAL" > "HOL4Real.real.REAL_LE_NEGTOTAL"
   "REAL_LE_NEGR" > "OrderedGroup.le_minus_self_iff"
   "REAL_LE_NEGL" > "OrderedGroup.minus_le_self_iff"
@@ -313,7 +313,7 @@
   "POW_ONE" > "Power.power_one"
   "POW_NZ" > "Power.field_power_not_zero"
   "POW_MUL" > "Power.power_mult_distrib"
-  "POW_MINUS1" > "NatBin.power_minus1_even"
+  "POW_MINUS1" > "Nat_Numeral.power_minus1_even"
   "POW_M1" > "HOL4Real.real.POW_M1"
   "POW_LT" > "HOL4Real.real.POW_LT"
   "POW_LE" > "Power.power_mono"
@@ -323,7 +323,7 @@
   "POW_ABS" > "Power.power_abs"
   "POW_2_LT" > "RealPow.two_realpow_gt"
   "POW_2_LE1" > "RealPow.two_realpow_ge_one"
-  "POW_2" > "NatBin.power2_eq_square"
+  "POW_2" > "Nat_Numeral.power2_eq_square"
   "POW_1" > "Power.power_one_right"
   "POW_0" > "Power.power_0_Suc"
   "ABS_ZERO" > "OrderedGroup.abs_eq_0"
@@ -335,7 +335,7 @@
   "ABS_SIGN2" > "HOL4Real.real.ABS_SIGN2"
   "ABS_SIGN" > "HOL4Real.real.ABS_SIGN"
   "ABS_REFL" > "HOL4Real.real.ABS_REFL"
-  "ABS_POW2" > "NatBin.abs_power2"
+  "ABS_POW2" > "Nat_Numeral.abs_power2"
   "ABS_POS" > "OrderedGroup.abs_ge_zero"
   "ABS_NZ" > "OrderedGroup.zero_less_abs_iff"
   "ABS_NEG" > "OrderedGroup.abs_minus_cancel"

--- a/src/HOL/Import/HOL4Compat.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Import/HOL4Compat.thy	Fri May 15 15:56:28 2009 +0200
@@ -202,19 +202,13 @@
 
 constdefs
   FUNPOW :: "('a => 'a) => nat => 'a => 'a"
-  "FUNPOW f n == f ^ n"
+  "FUNPOW f n == f ^^ n"
 
-lemma FUNPOW: "(ALL f x. (f ^ 0) x = x) &
-  (ALL f n x. (f ^ Suc n) x = (f ^ n) (f x))"
-proof auto
-  fix f n x
-  have "ALL x. f ((f ^ n) x) = (f ^ n) (f x)"
-    by (induct n,auto)
-  thus "f ((f ^ n) x) = (f ^ n) (f x)"
-    ..
-qed
+lemma FUNPOW: "(ALL f x. (f ^^ 0) x = x) &
+  (ALL f n x. (f ^^ Suc n) x = (f ^^ n) (f x))"
+  by (simp add: funpow_swap1)
 
-lemma [hol4rew]: "FUNPOW f n = f ^ n"
+lemma [hol4rew]: "FUNPOW f n = f ^^ n"
   by (simp add: FUNPOW_def)
 
 lemma ADD: "(!n. (0::nat) + n = n) & (!m n. Suc m + n = Suc (m + n))"
@@ -224,7 +218,7 @@
   by simp
 
 lemma SUB: "(!m. (0::nat) - m = 0) & (!m n. (Suc m) - n = (if m < n then 0 else Suc (m - n)))"
-  by (simp, arith)
+  by (simp) arith
 
 lemma MAX_DEF: "max (m::nat) n = (if m < n then n else m)"
   by (simp add: max_def)

--- a/src/HOL/Import/HOLLight/hollight.imp	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Import/HOLLight/hollight.imp	Fri May 15 15:56:28 2009 +0200
@@ -1515,7 +1515,7 @@
   "EQ_REFL_T" > "HOL.simp_thms_6"
   "EQ_REFL" > "Presburger.fm_modd_pinf"
   "EQ_MULT_RCANCEL" > "Nat.mult_cancel2"
-  "EQ_MULT_LCANCEL" > "NatBin.nat_mult_eq_cancel_disj"
+  "EQ_MULT_LCANCEL" > "Nat_Numeral.nat_mult_eq_cancel_disj"
   "EQ_IMP_LE" > "HOLLight.hollight.EQ_IMP_LE"
   "EQ_EXT" > "HOL.meta_eq_to_obj_eq"
   "EQ_CLAUSES" > "HOLLight.hollight.EQ_CLAUSES"

--- a/src/HOL/Int.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Int.thy	Fri May 15 15:56:28 2009 +0200
@@ -12,10 +12,13 @@
 uses
   ("Tools/numeral.ML")
   ("Tools/numeral_syntax.ML")
+  ("Tools/int_arith.ML")
   "~~/src/Provers/Arith/assoc_fold.ML"
   "~~/src/Provers/Arith/cancel_numerals.ML"
   "~~/src/Provers/Arith/combine_numerals.ML"
-  ("Tools/int_arith.ML")
+  "~~/src/Provers/Arith/cancel_numeral_factor.ML"
+  "~~/src/Provers/Arith/extract_common_term.ML"
+  ("Tools/numeral_simprocs.ML")
 begin
 
 subsection {* The equivalence relation underlying the integers *}
@@ -292,9 +295,7 @@
 context ring_1
 begin
 
-definition
-  of_int :: "int \<Rightarrow> 'a"
-where
+definition of_int :: "int \<Rightarrow> 'a" where
   [code del]: "of_int z = contents (\<Union>(i, j) \<in> Rep_Integ z. { of_nat i - of_nat j })"
 
 lemma of_int: "of_int (Abs_Integ (intrel `` {(i,j)})) = of_nat i - of_nat j"
@@ -330,6 +331,10 @@
 lemma of_int_of_nat_eq [simp]: "of_int (of_nat n) = of_nat n"
 by (induct n) auto
 
+lemma of_int_power:
+  "of_int (z ^ n) = of_int z ^ n"
+  by (induct n) simp_all
+
 end
 
 context ordered_idom
@@ -1266,14 +1271,9 @@
 definition Ints  :: "'a set" where
   [code del]: "Ints = range of_int"
 
-end
-
 notation (xsymbols)
   Ints  ("\<int>")
 
-context ring_1
-begin
-
 lemma Ints_0 [simp]: "0 \<in> \<int>"
 apply (simp add: Ints_def)
 apply (rule range_eqI)
@@ -1518,9 +1518,19 @@
   of_nat_0 of_nat_1 of_nat_Suc of_nat_add of_nat_mult
   of_int_0 of_int_1 of_int_add of_int_mult
 
+use "Tools/numeral_simprocs.ML"
+
 use "Tools/int_arith.ML"
+setup {* Int_Arith.global_setup *}
 declaration {* K Int_Arith.setup *}
 
+setup {*
+  ReorientProc.add
+    (fn Const (@{const_name number_of}, _) $ _ => true | _ => false)
+*}
+
+simproc_setup reorient_numeral ("number_of w = x") = ReorientProc.proc
+
 
 subsection{*Lemmas About Small Numerals*}
 
@@ -1536,7 +1546,7 @@
 by (simp add: abs_if)
 
 lemma abs_power_minus_one [simp]:
-     "abs(-1 ^ n) = (1::'a::{ordered_idom,number_ring,recpower})"
+  "abs(-1 ^ n) = (1::'a::{ordered_idom,number_ring})"
 by (simp add: power_abs)
 
 lemma of_int_number_of_eq [simp]:
@@ -1846,49 +1856,6 @@
 qed
 
 
-subsection {* Integer Powers *} 
-
-instantiation int :: recpower
-begin
-
-primrec power_int where
-  "p ^ 0 = (1\<Colon>int)"
-  | "p ^ (Suc n) = (p\<Colon>int) * (p ^ n)"
-
-instance proof
-  fix z :: int
-  fix n :: nat
-  show "z ^ 0 = 1" by simp
-  show "z ^ Suc n = z * (z ^ n)" by simp
-qed
-
-declare power_int.simps [simp del]
-
-end
-
-lemma zpower_zadd_distrib: "x ^ (y + z) = ((x ^ y) * (x ^ z)::int)"
-  by (rule Power.power_add)
-
-lemma zpower_zpower: "(x ^ y) ^ z = (x ^ (y * z)::int)"
-  by (rule Power.power_mult [symmetric])
-
-lemma zero_less_zpower_abs_iff [simp]:
-  "(0 < abs x ^ n) \<longleftrightarrow> (x \<noteq> (0::int) | n = 0)"
-  by (induct n) (auto simp add: zero_less_mult_iff)
-
-lemma zero_le_zpower_abs [simp]: "(0::int) \<le> abs x ^ n"
-  by (induct n) (auto simp add: zero_le_mult_iff)
-
-lemma of_int_power:
-  "of_int (z ^ n) = (of_int z ^ n :: 'a::{recpower, ring_1})"
-  by (induct n) simp_all
-
-lemma int_power: "int (m^n) = (int m) ^ n"
-  by (rule of_nat_power)
-
-lemmas zpower_int = int_power [symmetric]
-
-
 subsection {* Further theorems on numerals *}
 
 subsubsection{*Special Simplification for Constants*}
@@ -2278,4 +2245,25 @@
 lemmas zless_le = less_int_def
 lemmas int_eq_of_nat = TrueI
 
+lemma zpower_zadd_distrib:
+  "x ^ (y + z) = ((x ^ y) * (x ^ z)::int)"
+  by (rule power_add)
+
+lemma zero_less_zpower_abs_iff:
+  "(0 < abs x ^ n) \<longleftrightarrow> (x \<noteq> (0::int) | n = 0)"
+  by (rule zero_less_power_abs_iff)
+
+lemma zero_le_zpower_abs: "(0::int) \<le> abs x ^ n"
+  by (rule zero_le_power_abs)
+
+lemma zpower_zpower:
+  "(x ^ y) ^ z = (x ^ (y * z)::int)"
+  by (rule power_mult [symmetric])
+
+lemma int_power:
+  "int (m ^ n) = int m ^ n"
+  by (rule of_nat_power)
+
+lemmas zpower_int = int_power [symmetric]
+
 end

--- a/src/HOL/IntDiv.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/IntDiv.thy	Fri May 15 15:56:28 2009 +0200
@@ -8,10 +8,6 @@
 
 theory IntDiv
 imports Int Divides FunDef
-uses
-  "~~/src/Provers/Arith/cancel_numeral_factor.ML"
-  "~~/src/Provers/Arith/extract_common_term.ML"
-  ("Tools/int_factor_simprocs.ML")
 begin
 
 definition divmod_rel :: "int \<Rightarrow> int \<Rightarrow> int \<times> int \<Rightarrow> bool" where
@@ -249,33 +245,33 @@
 text {* Tool setup *}
 
 ML {*
-local 
+local
 
-structure CancelDivMod = CancelDivModFun(
-struct
-  val div_name = @{const_name Divides.div};
-  val mod_name = @{const_name Divides.mod};
+structure CancelDivMod = CancelDivModFun(struct
+
+  val div_name = @{const_name div};
+  val mod_name = @{const_name mod};
   val mk_binop = HOLogic.mk_binop;
-  val mk_sum = Int_Numeral_Simprocs.mk_sum HOLogic.intT;
-  val dest_sum = Int_Numeral_Simprocs.dest_sum;
-  val div_mod_eqs =
-    map mk_meta_eq [@{thm zdiv_zmod_equality},
-      @{thm zdiv_zmod_equality2}];
+  val mk_sum = Numeral_Simprocs.mk_sum HOLogic.intT;
+  val dest_sum = Numeral_Simprocs.dest_sum;
+
+  val div_mod_eqs = map mk_meta_eq [@{thm zdiv_zmod_equality}, @{thm zdiv_zmod_equality2}];
+
   val trans = trans;
-  val prove_eq_sums =
-    let
-      val simps = @{thm diff_int_def} :: Int_Numeral_Simprocs.add_0s @ @{thms zadd_ac}
-    in Arith_Data.prove_conv2 all_tac (Arith_Data.simp_all_tac simps) end;
+
+  val prove_eq_sums = Arith_Data.prove_conv2 all_tac (Arith_Data.simp_all_tac 
+    (@{thm diff_minus} :: @{thms add_0s} @ @{thms add_ac}))
+
 end)
 
 in
 
-val cancel_zdiv_zmod_proc = Simplifier.simproc (the_context ())
-  "cancel_zdiv_zmod" ["(m::int) + n"] (K CancelDivMod.proc)
+val cancel_div_mod_int_proc = Simplifier.simproc (the_context ())
+  "cancel_zdiv_zmod" ["(k::int) + l"] (K CancelDivMod.proc);
 
-end;
+val _ = Addsimprocs [cancel_div_mod_int_proc];
 
-Addsimprocs [cancel_zdiv_zmod_proc]
+end
 *}
 
 lemma pos_mod_conj : "(0::int) < b ==> 0 \<le> a mod b & a mod b < b"
@@ -711,6 +707,25 @@
   show "(a + c * b) div b = c + a div b"
     unfolding zdiv_zadd1_eq [of a "c * b"] using not0 
       by (simp add: zmod_zmult1_eq zmod_zdiv_trivial zdiv_zmult1_eq)
+next
+  fix a b c :: int
+  assume "a \<noteq> 0"
+  then show "(a * b) div (a * c) = b div c"
+  proof (cases "b \<noteq> 0 \<and> c \<noteq> 0")
+    case False then show ?thesis by auto
+  next
+    case True then have "b \<noteq> 0" and "c \<noteq> 0" by auto
+    with `a \<noteq> 0`
+    have "\<And>q r. divmod_rel b c (q, r) \<Longrightarrow> divmod_rel (a * b) (a * c) (q, a * r)"
+      apply (auto simp add: divmod_rel_def) 
+      apply (auto simp add: algebra_simps)
+      apply (auto simp add: zero_less_mult_iff zero_le_mult_iff mult_le_0_iff)
+      done
+    moreover with `c \<noteq> 0` divmod_rel_div_mod have "divmod_rel b c (b div c, b mod c)" by auto
+    ultimately have "divmod_rel (a * b) (a * c) (b div c, a * (b mod c))" .
+    moreover from  `a \<noteq> 0` `c \<noteq> 0` have "a * c \<noteq> 0" by simp
+    ultimately show ?thesis by (rule divmod_rel_div)
+  qed
 qed auto
 
 lemma posDivAlg_div_mod:
@@ -808,52 +823,6 @@
 done
 
 
-subsection{*Cancellation of Common Factors in div*}
-
-lemma zdiv_zmult_zmult1_aux1:
-     "[| (0::int) < b;  c \<noteq> 0 |] ==> (c*a) div (c*b) = a div b"
-by (subst zdiv_zmult2_eq, auto)
-
-lemma zdiv_zmult_zmult1_aux2:
-     "[| b < (0::int);  c \<noteq> 0 |] ==> (c*a) div (c*b) = a div b"
-apply (subgoal_tac " (c * (-a)) div (c * (-b)) = (-a) div (-b) ")
-apply (rule_tac [2] zdiv_zmult_zmult1_aux1, auto)
-done
-
-lemma zdiv_zmult_zmult1: "c \<noteq> (0::int) ==> (c*a) div (c*b) = a div b"
-apply (case_tac "b = 0", simp)
-apply (auto simp add: linorder_neq_iff zdiv_zmult_zmult1_aux1 zdiv_zmult_zmult1_aux2)
-done
-
-lemma zdiv_zmult_zmult1_if[simp]:
-  "(k*m) div (k*n) = (if k = (0::int) then 0 else m div n)"
-by (simp add:zdiv_zmult_zmult1)
-
-
-subsection{*Distribution of Factors over mod*}
-
-lemma zmod_zmult_zmult1_aux1:
-     "[| (0::int) < b;  c \<noteq> 0 |] ==> (c*a) mod (c*b) = c * (a mod b)"
-by (subst zmod_zmult2_eq, auto)
-
-lemma zmod_zmult_zmult1_aux2:
-     "[| b < (0::int);  c \<noteq> 0 |] ==> (c*a) mod (c*b) = c * (a mod b)"
-apply (subgoal_tac " (c * (-a)) mod (c * (-b)) = c * ((-a) mod (-b))")
-apply (rule_tac [2] zmod_zmult_zmult1_aux1, auto)
-done
-
-lemma zmod_zmult_zmult1: "(c*a) mod (c*b) = (c::int) * (a mod b)"
-apply (case_tac "b = 0", simp)
-apply (case_tac "c = 0", simp)
-apply (auto simp add: linorder_neq_iff zmod_zmult_zmult1_aux1 zmod_zmult_zmult1_aux2)
-done
-
-lemma zmod_zmult_zmult2: "(a*c) mod (b*c) = (a mod b) * (c::int)"
-apply (cut_tac c = c in zmod_zmult_zmult1)
-apply (auto simp add: mult_commute)
-done
-
-
 subsection {*Splitting Rules for div and mod*}
 
 text{*The proofs of the two lemmas below are essentially identical*}
@@ -937,7 +906,7 @@
                   right_distrib) 
   thus ?thesis
     by (subst zdiv_zadd1_eq,
-        simp add: zdiv_zmult_zmult1 zmod_zmult_zmult1 one_less_a2
+        simp add: mod_mult_mult1 one_less_a2
                   div_pos_pos_trivial)
 qed
 
@@ -961,7 +930,7 @@
            then number_of v div (number_of w)     
            else (number_of v + (1::int)) div (number_of w))"
 apply (simp only: number_of_eq numeral_simps UNIV_I split: split_if) 
-apply (simp add: zdiv_zmult_zmult1 pos_zdiv_mult_2 neg_zdiv_mult_2 add_ac)
+apply (simp add: pos_zdiv_mult_2 neg_zdiv_mult_2 add_ac)
 done
 
 
@@ -977,7 +946,7 @@
 apply (auto simp add: add_commute [of 1] mult_commute add1_zle_eq 
                       pos_mod_bound)
 apply (subst mod_add_eq)
-apply (simp add: zmod_zmult_zmult2 mod_pos_pos_trivial)
+apply (simp add: mod_mult_mult2 mod_pos_pos_trivial)
 apply (rule mod_pos_pos_trivial)
 apply (auto simp add: mod_pos_pos_trivial ring_distribs)
 apply (subgoal_tac "0 \<le> b mod a", arith, simp)
@@ -998,7 +967,7 @@
      "number_of (Int.Bit0 v) mod number_of (Int.Bit0 w) =  
       (2::int) * (number_of v mod number_of w)"
 apply (simp only: number_of_eq numeral_simps) 
-apply (simp add: zmod_zmult_zmult1 pos_zmod_mult_2 
+apply (simp add: mod_mult_mult1 pos_zmod_mult_2 
                  neg_zmod_mult_2 add_ac)
 done
 
@@ -1008,7 +977,7 @@
                 then 2 * (number_of v mod number_of w) + 1     
                 else 2 * ((number_of v + (1::int)) mod number_of w) - 1)"
 apply (simp only: number_of_eq numeral_simps) 
-apply (simp add: zmod_zmult_zmult1 pos_zmod_mult_2 
+apply (simp add: mod_mult_mult1 pos_zmod_mult_2 
                  neg_zmod_mult_2 add_ac)
 done
 
@@ -1090,9 +1059,7 @@
 done
 
 lemma zdvd_zmod: "f dvd m ==> f dvd (n::int) ==> f dvd m mod n"
-  apply (simp add: dvd_def)
-  apply (auto simp add: zmod_zmult_zmult1)
-  done
+  by (auto elim!: dvdE simp add: mod_mult_mult1)
 
 lemma zdvd_zmod_imp_zdvd: "k dvd m mod n ==> k dvd n ==> k dvd (m::int)"
   apply (subgoal_tac "k dvd n * (m div n) + m mod n")
@@ -1106,8 +1073,6 @@
    prefer 2
    apply (blast intro: order_less_trans)
   apply (simp add: zero_less_mult_iff)
-  apply (subgoal_tac "n * k < n * 1")
-   apply (drule mult_less_cancel_left [THEN iffD1], auto)
   done
 
 lemma zmult_div_cancel: "(n::int) * (m div n) = m - (m mod n)"
@@ -1247,9 +1212,9 @@
 lemmas zmod_simps =
   mod_add_left_eq  [symmetric]
   mod_add_right_eq [symmetric]
-  IntDiv.zmod_zmult1_eq     [symmetric]
-  mod_mult_left_eq          [symmetric]
-  IntDiv.zpower_zmod
+  zmod_zmult1_eq   [symmetric]
+  mod_mult_left_eq [symmetric]
+  zpower_zmod
   zminus_zmod zdiff_zmod_left zdiff_zmod_right
 
 text {* Distributive laws for function @{text nat}. *}
@@ -1362,11 +1327,6 @@
 qed
 
 
-subsection {* Simproc setup *}
-
-use "Tools/int_factor_simprocs.ML"
-
-
 subsection {* Code generation *}
 
 definition pdivmod :: "int \<Rightarrow> int \<Rightarrow> int \<times> int" where

--- a/src/HOL/IsaMakefile	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/IsaMakefile	Fri May 15 15:56:28 2009 +0200
@@ -89,24 +89,24 @@
   $(SRC)/Tools/IsaPlanner/rw_tools.ML \
   $(SRC)/Tools/IsaPlanner/zipper.ML \
   $(SRC)/Tools/atomize_elim.ML \
-  $(SRC)/Tools/code/code_funcgr.ML \
+  $(SRC)/Tools/auto_solve.ML \
   $(SRC)/Tools/code/code_haskell.ML \
   $(SRC)/Tools/code/code_ml.ML \
-  $(SRC)/Tools/code/code_name.ML \
+  $(SRC)/Tools/code/code_preproc.ML \
   $(SRC)/Tools/code/code_printer.ML \
   $(SRC)/Tools/code/code_target.ML \
   $(SRC)/Tools/code/code_thingol.ML \
-  $(SRC)/Tools/code/code_wellsorted.ML \
   $(SRC)/Tools/coherent.ML \
   $(SRC)/Tools/eqsubst.ML \
   $(SRC)/Tools/induct.ML \
   $(SRC)/Tools/intuitionistic.ML \
   $(SRC)/Tools/induct_tacs.ML \
   $(SRC)/Tools/nbe.ML \
+  $(SRC)/Tools/quickcheck.ML \
   $(SRC)/Tools/project_rule.ML \
   $(SRC)/Tools/random_word.ML \
   $(SRC)/Tools/value.ML \
-  Code_Setup.thy \
+  $(SRC)/Tools/Code_Generator.thy \
   HOL.thy \
   Tools/hologic.ML \
   Tools/recfun_codegen.ML \
@@ -206,7 +206,6 @@
 MAIN_DEPENDENCIES = $(PLAIN_DEPENDENCIES) \
   ATP_Linkup.thy \
   Code_Eval.thy \
-  Code_Message.thy \
   Equiv_Relations.thy \
   Groebner_Basis.thy \
   Hilbert_Choice.thy \
@@ -216,29 +215,30 @@
   List.thy \
   Main.thy \
   Map.thy \
-  NatBin.thy \
+  Nat_Numeral.thy \
   Presburger.thy \
   Recdef.thy \
-  Relation_Power.thy \
   SetInterval.thy \
+  String.thy \
   $(SRC)/Provers/Arith/assoc_fold.ML \
   $(SRC)/Provers/Arith/cancel_numeral_factor.ML \
   $(SRC)/Provers/Arith/cancel_numerals.ML \
   $(SRC)/Provers/Arith/combine_numerals.ML \
   $(SRC)/Provers/Arith/extract_common_term.ML \
   $(SRC)/Tools/Metis/metis.ML \
-  Tools/int_arith.ML \
-  Tools/int_factor_simprocs.ML \
-  Tools/nat_simprocs.ML \
   Tools/Groebner_Basis/groebner.ML \
   Tools/Groebner_Basis/misc.ML \
   Tools/Groebner_Basis/normalizer_data.ML \
   Tools/Groebner_Basis/normalizer.ML \
   Tools/atp_manager.ML \
   Tools/atp_wrapper.ML \
+  Tools/int_arith.ML \
+  Tools/list_code.ML \
   Tools/meson.ML \
   Tools/metis_tools.ML \
+  Tools/nat_numeral_simprocs.ML \
   Tools/numeral.ML \
+  Tools/numeral_simprocs.ML \
   Tools/numeral_syntax.ML \
   Tools/polyhash.ML \
   Tools/Qelim/cooper_data.ML \
@@ -253,6 +253,7 @@
   Tools/res_hol_clause.ML \
   Tools/res_reconstruct.ML \
   Tools/specification_package.ML \
+  Tools/string_code.ML \
   Tools/string_syntax.ML \
   Tools/TFL/casesplit.ML \
   Tools/TFL/dcterm.ML \
@@ -294,8 +295,6 @@
   Real.thy \
   RealVector.thy \
   Tools/float_syntax.ML \
-  Tools/rat_arith.ML \
-  Tools/real_arith.ML \
   Tools/Qelim/ferrante_rackoff_data.ML \
   Tools/Qelim/ferrante_rackoff.ML \
   Tools/Qelim/langford_data.ML \
@@ -311,7 +310,8 @@
 $(LOG)/HOL-Library.gz: $(OUT)/HOL Library/SetsAndFunctions.thy		\
   Library/Abstract_Rat.thy \
   Library/BigO.thy Library/ContNotDenum.thy Library/Efficient_Nat.thy	\
-  Library/Euclidean_Space.thy Library/Glbs.thy Library/normarith.ML \
+  Library/Euclidean_Space.thy Library/Sum_Of_Squares.thy Library/positivstellensatz.ML	\
+  Library/sum_of_squares.ML Library/Glbs.thy Library/normarith.ML \
   Library/Executable_Set.thy Library/Infinite_Set.thy			\
   Library/FuncSet.thy Library/Permutations.thy Library/Determinants.thy\
   Library/Bit.thy Library/Topology_Euclidean_Space.thy \
@@ -341,6 +341,7 @@
   Library/Random.thy Library/Quickcheck.thy	\
   Library/Poly_Deriv.thy \
   Library/Polynomial.thy \
+  Library/Preorder.thy \
   Library/Product_plus.thy \
   Library/Product_Vector.thy \
   Library/Enum.thy Library/Float.thy $(SRC)/Tools/float.ML $(SRC)/HOL/Tools/float_arith.ML \
@@ -853,7 +854,7 @@
   ex/Sudoku.thy ex/Tarski.thy ex/Term_Of_Syntax.thy	\
   ex/Termination.thy ex/Unification.thy ex/document/root.bib		\
   ex/document/root.tex ex/set.thy ex/svc_funcs.ML ex/svc_test.thy \
-  ex/Predicate_Compile.thy ex/predicate_compile.ML
+  ex/Predicate_Compile.thy ex/predicate_compile.ML ex/Predicate_Compile_ex.thy
 	@$(ISABELLE_TOOL) usedir $(OUT)/HOL ex
 
 
@@ -1049,7 +1050,6 @@
   NSA/HyperDef.thy \
   NSA/HyperNat.thy \
   NSA/Hyperreal.thy \
-  NSA/hypreal_arith.ML \
   NSA/Filter.thy \
   NSA/NatStar.thy \
   NSA/NSA.thy \

--- a/src/HOL/Library/Binomial.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Library/Binomial.thy	Fri May 15 15:56:28 2009 +0200
@@ -292,7 +292,7 @@
 
 subsection{* Generalized binomial coefficients *}
 
-definition gbinomial :: "'a::{field, recpower,ring_char_0} \<Rightarrow> nat \<Rightarrow> 'a" (infixl "gchoose" 65)
+definition gbinomial :: "'a::{field, ring_char_0} \<Rightarrow> nat \<Rightarrow> 'a" (infixl "gchoose" 65)
   where "a gchoose n = (if n = 0 then 1 else (setprod (\<lambda>i. a - of_nat i) {0 .. n - 1}) / of_nat (fact n))"
 
 lemma gbinomial_0[simp]: "a gchoose 0 = 1" "0 gchoose (Suc n) = 0"
@@ -420,16 +420,16 @@
   by (simp add: gbinomial_def)
  
 lemma gbinomial_mult_fact:
-  "(of_nat (fact (Suc k)) :: 'a) * ((a::'a::{field, ring_char_0,recpower}) gchoose (Suc k)) = (setprod (\<lambda>i. a - of_nat i) {0 .. k})"
+  "(of_nat (fact (Suc k)) :: 'a) * ((a::'a::{field, ring_char_0}) gchoose (Suc k)) = (setprod (\<lambda>i. a - of_nat i) {0 .. k})"
   unfolding gbinomial_Suc
   by (simp_all add: field_simps del: fact_Suc)
 
 lemma gbinomial_mult_fact':
-  "((a::'a::{field, ring_char_0,recpower}) gchoose (Suc k)) * (of_nat (fact (Suc k)) :: 'a) = (setprod (\<lambda>i. a - of_nat i) {0 .. k})"
+  "((a::'a::{field, ring_char_0}) gchoose (Suc k)) * (of_nat (fact (Suc k)) :: 'a) = (setprod (\<lambda>i. a - of_nat i) {0 .. k})"
   using gbinomial_mult_fact[of k a]
   apply (subst mult_commute) .
 
-lemma gbinomial_Suc_Suc: "((a::'a::{field,recpower, ring_char_0}) + 1) gchoose (Suc k) = a gchoose k + (a gchoose (Suc k))"
+lemma gbinomial_Suc_Suc: "((a::'a::{field, ring_char_0}) + 1) gchoose (Suc k) = a gchoose k + (a gchoose (Suc k))"
 proof-
   {assume "k = 0" then have ?thesis by simp}
   moreover

--- a/src/HOL/Library/Code_Char.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Library/Code_Char.thy	Fri May 15 15:56:28 2009 +0200
@@ -14,8 +14,8 @@
   (Haskell "Char")
 
 setup {*
-  fold (fn target => add_literal_char target) ["SML", "OCaml", "Haskell"] 
-  #> add_literal_list_string "Haskell"
+  fold String_Code.add_literal_char ["SML", "OCaml", "Haskell"] 
+  #> String_Code.add_literal_list_string "Haskell"
 *}
 
 code_instance char :: eq
@@ -33,6 +33,6 @@
   (Haskell infixl 4 "==")
 
 code_const "Code_Eval.term_of \<Colon> char \<Rightarrow> term"
-  (SML "HOLogic.mk'_char/ (IntInf.fromInt/ (Char.ord/ _))")
+  (Eval "HOLogic.mk'_char/ (IntInf.fromInt/ (Char.ord/ _))")
 
 end

--- a/src/HOL/Library/Code_Index.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Library/Code_Index.thy	Fri May 15 15:56:28 2009 +0200
@@ -144,7 +144,7 @@
 
 subsection {* Basic arithmetic *}
 
-instantiation index :: "{minus, ordered_semidom, Divides.div, linorder}"
+instantiation index :: "{minus, ordered_semidom, semiring_div, linorder}"
 begin
 
 definition [simp, code del]:
@@ -172,7 +172,7 @@
   "n < m \<longleftrightarrow> nat_of n < nat_of m"
 
 instance proof
-qed (auto simp add: left_distrib)
+qed (auto simp add: index left_distrib div_mult_self1)
 
 end
 

--- a/src/HOL/Library/Coinductive_List.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Library/Coinductive_List.thy	Fri May 15 15:56:28 2009 +0200
@@ -786,7 +786,7 @@
 
 lemma funpow_lmap:
   fixes f :: "'a \<Rightarrow> 'a"
-  shows "(lmap f ^ n) (LCons b l) = LCons ((f ^ n) b) ((lmap f ^ n) l)"
+  shows "(lmap f ^^ n) (LCons b l) = LCons ((f ^^ n) b) ((lmap f ^^ n) l)"
   by (induct n) simp_all
 
 
@@ -796,35 +796,35 @@
 proof
   fix x
   have "(h x, iterates f x) \<in>
-      {((lmap f ^ n) (h u), (lmap f ^ n) (iterates f u)) | u n. True}"
+      {((lmap f ^^ n) (h u), (lmap f ^^ n) (iterates f u)) | u n. True}"
   proof -
-    have "(h x, iterates f x) = ((lmap f ^ 0) (h x), (lmap f ^ 0) (iterates f x))"
+    have "(h x, iterates f x) = ((lmap f ^^ 0) (h x), (lmap f ^^ 0) (iterates f x))"
       by simp
     then show ?thesis by blast
   qed
   then show "h x = iterates f x"
   proof (coinduct rule: llist_equalityI)
     case (Eqllist q)
-    then obtain u n where "q = ((lmap f ^ n) (h u), (lmap f ^ n) (iterates f u))"
+    then obtain u n where "q = ((lmap f ^^ n) (h u), (lmap f ^^ n) (iterates f u))"
         (is "_ = (?q1, ?q2)")
       by auto
-    also have "?q1 = LCons ((f ^ n) u) ((lmap f ^ Suc n) (h u))"
+    also have "?q1 = LCons ((f ^^ n) u) ((lmap f ^^ Suc n) (h u))"
     proof -
-      have "?q1 = (lmap f ^ n) (LCons u (lmap f (h u)))"
+      have "?q1 = (lmap f ^^ n) (LCons u (lmap f (h u)))"
         by (subst h) rule
-      also have "\<dots> = LCons ((f ^ n) u) ((lmap f ^ n) (lmap f (h u)))"
+      also have "\<dots> = LCons ((f ^^ n) u) ((lmap f ^^ n) (lmap f (h u)))"
         by (rule funpow_lmap)
-      also have "(lmap f ^ n) (lmap f (h u)) = (lmap f ^ Suc n) (h u)"
+      also have "(lmap f ^^ n) (lmap f (h u)) = (lmap f ^^ Suc n) (h u)"
         by (simp add: funpow_swap1)
       finally show ?thesis .
     qed
-    also have "?q2 = LCons ((f ^ n) u) ((lmap f ^ Suc n) (iterates f u))"
+    also have "?q2 = LCons ((f ^^ n) u) ((lmap f ^^ Suc n) (iterates f u))"
     proof -
-      have "?q2 = (lmap f ^ n) (LCons u (iterates f (f u)))"
+      have "?q2 = (lmap f ^^ n) (LCons u (iterates f (f u)))"
         by (subst iterates) rule
-      also have "\<dots> = LCons ((f ^ n) u) ((lmap f ^ n) (iterates f (f u)))"
+      also have "\<dots> = LCons ((f ^^ n) u) ((lmap f ^^ n) (iterates f (f u)))"
         by (rule funpow_lmap)
-      also have "(lmap f ^ n) (iterates f (f u)) = (lmap f ^ Suc n) (iterates f u)"
+      also have "(lmap f ^^ n) (iterates f (f u)) = (lmap f ^^ Suc n) (iterates f u)"
         by (simp add: lmap_iterates funpow_swap1)
       finally show ?thesis .
     qed

--- a/src/HOL/Library/Commutative_Ring.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Library/Commutative_Ring.thy	Fri May 15 15:56:28 2009 +0200
@@ -27,15 +27,15 @@
 
 text {* Interpretation functions for the shadow syntax. *}
 
-fun
-  Ipol :: "'a::{comm_ring,recpower} list \<Rightarrow> 'a pol \<Rightarrow> 'a"
+primrec
+  Ipol :: "'a::{comm_ring_1} list \<Rightarrow> 'a pol \<Rightarrow> 'a"
 where
     "Ipol l (Pc c) = c"
   | "Ipol l (Pinj i P) = Ipol (drop i l) P"
   | "Ipol l (PX P x Q) = Ipol l P * (hd l)^x + Ipol (drop 1 l) Q"
 
-fun
-  Ipolex :: "'a::{comm_ring,recpower} list \<Rightarrow> 'a polex \<Rightarrow> 'a"
+primrec
+  Ipolex :: "'a::{comm_ring_1} list \<Rightarrow> 'a polex \<Rightarrow> 'a"
 where
     "Ipolex l (Pol P) = Ipol l P"
   | "Ipolex l (Add P Q) = Ipolex l P + Ipolex l Q"
@@ -54,7 +54,7 @@
     PX p1 y p2 \<Rightarrow> Pinj x P)"
 
 definition
-  mkPX :: "'a::{comm_ring,recpower} pol \<Rightarrow> nat \<Rightarrow> 'a pol \<Rightarrow> 'a pol" where
+  mkPX :: "'a::{comm_ring} pol \<Rightarrow> nat \<Rightarrow> 'a pol \<Rightarrow> 'a pol" where
   "mkPX P i Q = (case P of
     Pc c \<Rightarrow> (if (c = 0) then (mkPinj 1 Q) else (PX P i Q)) |
     Pinj j R \<Rightarrow> PX P i Q |
@@ -63,7 +63,7 @@
 text {* Defining the basic ring operations on normalized polynomials *}
 
 function
-  add :: "'a::{comm_ring,recpower} pol \<Rightarrow> 'a pol \<Rightarrow> 'a pol" (infixl "\<oplus>" 65)
+  add :: "'a::{comm_ring} pol \<Rightarrow> 'a pol \<Rightarrow> 'a pol" (infixl "\<oplus>" 65)
 where
     "Pc a \<oplus> Pc b = Pc (a + b)"
   | "Pc c \<oplus> Pinj i P = Pinj i (P \<oplus> Pc c)"
@@ -90,7 +90,7 @@
 termination by (relation "measure (\<lambda>(x, y). size x + size y)") auto
 
 function
-  mul :: "'a::{comm_ring,recpower} pol \<Rightarrow> 'a pol \<Rightarrow> 'a pol" (infixl "\<otimes>" 70)
+  mul :: "'a::{comm_ring} pol \<Rightarrow> 'a pol \<Rightarrow> 'a pol" (infixl "\<otimes>" 70)
 where
     "Pc a \<otimes> Pc b = Pc (a * b)"
   | "Pc c \<otimes> Pinj i P =
@@ -122,8 +122,8 @@
   (auto simp add: mkPinj_def split: pol.split)
 
 text {* Negation*}
-fun
-  neg :: "'a::{comm_ring,recpower} pol \<Rightarrow> 'a pol"
+primrec
+  neg :: "'a::{comm_ring} pol \<Rightarrow> 'a pol"
 where
     "neg (Pc c) = Pc (-c)"
   | "neg (Pinj i P) = Pinj i (neg P)"
@@ -131,13 +131,13 @@
 
 text {* Substraction *}
 definition
-  sub :: "'a::{comm_ring,recpower} pol \<Rightarrow> 'a pol \<Rightarrow> 'a pol" (infixl "\<ominus>" 65)
+  sub :: "'a::{comm_ring} pol \<Rightarrow> 'a pol \<Rightarrow> 'a pol" (infixl "\<ominus>" 65)
 where
   "sub P Q = P \<oplus> neg Q"
 
 text {* Square for Fast Exponentation *}
-fun
-  sqr :: "'a::{comm_ring,recpower} pol \<Rightarrow> 'a pol"
+primrec
+  sqr :: "'a::{comm_ring_1} pol \<Rightarrow> 'a pol"
 where
     "sqr (Pc c) = Pc (c * c)"
   | "sqr (Pinj i P) = mkPinj i (sqr P)"
@@ -146,7 +146,7 @@
 
 text {* Fast Exponentation *}
 fun
-  pow :: "nat \<Rightarrow> 'a::{comm_ring,recpower} pol \<Rightarrow> 'a pol"
+  pow :: "nat \<Rightarrow> 'a::{comm_ring_1} pol \<Rightarrow> 'a pol"
 where
     "pow 0 P = Pc 1"
   | "pow n P = (if even n then pow (n div 2) (sqr P)
@@ -161,8 +161,8 @@
 
 text {* Normalization of polynomial expressions *}
 
-fun
-  norm :: "'a::{comm_ring,recpower} polex \<Rightarrow> 'a pol"
+primrec
+  norm :: "'a::{comm_ring_1} polex \<Rightarrow> 'a pol"
 where
     "norm (Pol P) = P"
   | "norm (Add P Q) = norm P \<oplus> norm Q"

--- a/src/HOL/Library/Continuity.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Library/Continuity.thy	Fri May 15 15:56:28 2009 +0200
@@ -5,7 +5,7 @@
 header {* Continuity and iterations (of set transformers) *}
 
 theory Continuity
-imports Relation_Power Main
+imports Transitive_Closure Main
 begin
 
 subsection {* Continuity for complete lattices *}
@@ -48,25 +48,25 @@
 qed
 
 lemma continuous_lfp:
- assumes "continuous F" shows "lfp F = (SUP i. (F^i) bot)"
+ assumes "continuous F" shows "lfp F = (SUP i. (F ^^ i) bot)"
 proof -
   note mono = continuous_mono[OF `continuous F`]
-  { fix i have "(F^i) bot \<le> lfp F"
+  { fix i have "(F ^^ i) bot \<le> lfp F"
     proof (induct i)
-      show "(F^0) bot \<le> lfp F" by simp
+      show "(F ^^ 0) bot \<le> lfp F" by simp
     next
       case (Suc i)
-      have "(F^(Suc i)) bot = F((F^i) bot)" by simp
+      have "(F ^^ Suc i) bot = F((F ^^ i) bot)" by simp
       also have "\<dots> \<le> F(lfp F)" by(rule monoD[OF mono Suc])
       also have "\<dots> = lfp F" by(simp add:lfp_unfold[OF mono, symmetric])
       finally show ?case .
     qed }
-  hence "(SUP i. (F^i) bot) \<le> lfp F" by (blast intro!:SUP_leI)
-  moreover have "lfp F \<le> (SUP i. (F^i) bot)" (is "_ \<le> ?U")
+  hence "(SUP i. (F ^^ i) bot) \<le> lfp F" by (blast intro!:SUP_leI)
+  moreover have "lfp F \<le> (SUP i. (F ^^ i) bot)" (is "_ \<le> ?U")
   proof (rule lfp_lowerbound)
-    have "chain(%i. (F^i) bot)"
+    have "chain(%i. (F ^^ i) bot)"
     proof -
-      { fix i have "(F^i) bot \<le> (F^(Suc i)) bot"
+      { fix i have "(F ^^ i) bot \<le> (F ^^ (Suc i)) bot"
 	proof (induct i)
 	  case 0 show ?case by simp
 	next
@@ -74,7 +74,7 @@
 	qed }
       thus ?thesis by(auto simp add:chain_def)
     qed
-    hence "F ?U = (SUP i. (F^(i+1)) bot)" using `continuous F` by (simp add:continuous_def)
+    hence "F ?U = (SUP i. (F ^^ (i+1)) bot)" using `continuous F` by (simp add:continuous_def)
     also have "\<dots> \<le> ?U" by(fast intro:SUP_leI le_SUPI)
     finally show "F ?U \<le> ?U" .
   qed
@@ -193,7 +193,7 @@
 
 definition
   up_iterate :: "('a set => 'a set) => nat => 'a set" where
-  "up_iterate f n = (f^n) {}"
+  "up_iterate f n = (f ^^ n) {}"
 
 lemma up_iterate_0 [simp]: "up_iterate f 0 = {}"
   by (simp add: up_iterate_def)
@@ -245,7 +245,7 @@
 
 definition
   down_iterate :: "('a set => 'a set) => nat => 'a set" where
-  "down_iterate f n = (f^n) UNIV"
+  "down_iterate f n = (f ^^ n) UNIV"
 
 lemma down_iterate_0 [simp]: "down_iterate f 0 = UNIV"
   by (simp add: down_iterate_def)

--- a/src/HOL/Library/Efficient_Nat.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Library/Efficient_Nat.thy	Fri May 15 15:56:28 2009 +0200
@@ -179,10 +179,8 @@
        else NONE
   end;
 
-fun eqn_suc_preproc thy = map fst
-  #> gen_eqn_suc_preproc
-      @{thm Suc_if_eq} I (fst o Logic.dest_equals) thy
-  #> (Option.map o map) (Code_Unit.mk_eqn thy);
+val eqn_suc_preproc = Code_Preproc.simple_functrans (gen_eqn_suc_preproc
+  @{thm Suc_if_eq} I (fst o Logic.dest_equals));
 
 fun eqn_suc_preproc' thy thms = gen_eqn_suc_preproc
   @{thm Suc_if_eq'} (snd o Thm.dest_comb) (fst o HOLogic.dest_eq o HOLogic.dest_Trueprop) thy thms
@@ -231,7 +229,7 @@
 
   Codegen.add_preprocessor eqn_suc_preproc'
   #> Codegen.add_preprocessor clause_suc_preproc
-  #> Code.add_functrans ("eqn_Suc", eqn_suc_preproc)
+  #> Code_Preproc.add_functrans ("eqn_Suc", eqn_suc_preproc)
 
 end;
 *}

--- a/src/HOL/Library/Euclidean_Space.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Library/Euclidean_Space.thy	Fri May 15 15:56:28 2009 +0200
@@ -9,7 +9,7 @@
   Complex_Main "~~/src/HOL/Decision_Procs/Dense_Linear_Order"
   Finite_Cartesian_Product Glbs Infinite_Set Numeral_Type
   Inner_Product
-uses ("normarith.ML")
+uses "positivstellensatz.ML" ("normarith.ML")
 begin
 
 text{* Some common special cases.*}
@@ -253,13 +253,6 @@
   "vector_power x 0 = 1"
   | "vector_power x (Suc n) = x * vector_power x n"
 
-instantiation "^" :: (recpower,type) recpower
-begin
-  definition vec_power_def: "op ^ \<equiv> vector_power"
-  instance
-  apply (intro_classes) by (simp_all add: vec_power_def)
-end
-
 instance "^" :: (semiring,type) semiring
   apply (intro_classes) by (vector ring_simps)+
 
@@ -600,7 +593,7 @@
   from insert.prems have Fx: "f x \<ge> 0" and Fp: "\<forall> a \<in> F. f a \<ge> 0" by simp_all
   from insert.hyps Fp setsum_nonneg[OF Fp]
   have h: "setsum f F = 0 \<longleftrightarrow> (\<forall>a \<in>F. f a = 0)" by metis
-  from sum_nonneg_eq_zero_iff[OF Fx  setsum_nonneg[OF Fp]] insert.hyps(1,2)
+  from add_nonneg_eq_0_iff[OF Fx  setsum_nonneg[OF Fp]] insert.hyps(1,2)
   show ?case by (simp add: h)
 qed
 
@@ -2762,7 +2755,7 @@
 (* Geometric progression.                                                    *)
 (* ------------------------------------------------------------------------- *)
 
-lemma sum_gp_basic: "((1::'a::{field, recpower}) - x) * setsum (\<lambda>i. x^i) {0 .. n} = (1 - x^(Suc n))"
+lemma sum_gp_basic: "((1::'a::{field}) - x) * setsum (\<lambda>i. x^i) {0 .. n} = (1 - x^(Suc n))"
   (is "?lhs = ?rhs")
 proof-
   {assume x1: "x = 1" hence ?thesis by simp}
@@ -2780,7 +2773,7 @@
 qed
 
 lemma sum_gp_multiplied: assumes mn: "m <= n"
-  shows "((1::'a::{field, recpower}) - x) * setsum (op ^ x) {m..n} = x^m - x^ Suc n"
+  shows "((1::'a::{field}) - x) * setsum (op ^ x) {m..n} = x^m - x^ Suc n"
   (is "?lhs = ?rhs")
 proof-
   let ?S = "{0..(n - m)}"
@@ -2797,7 +2790,7 @@
     by (simp add: ring_simps power_add[symmetric])
 qed
 
-lemma sum_gp: "setsum (op ^ (x::'a::{field, recpower})) {m .. n} =
+lemma sum_gp: "setsum (op ^ (x::'a::{field})) {m .. n} =
    (if n < m then 0 else if x = 1 then of_nat ((n + 1) - m)
                     else (x^ m - x^ (Suc n)) / (1 - x))"
 proof-
@@ -2813,7 +2806,7 @@
   ultimately show ?thesis by metis
 qed
 
-lemma sum_gp_offset: "setsum (op ^ (x::'a::{field,recpower})) {m .. m+n} =
+lemma sum_gp_offset: "setsum (op ^ (x::'a::{field})) {m .. m+n} =
   (if x = 1 then of_nat n + 1 else x^m * (1 - x^Suc n) / (1 - x))"
   unfolding sum_gp[of x m "m + n"] power_Suc
   by (simp add: ring_simps power_add)

--- a/src/HOL/Library/Eval_Witness.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Library/Eval_Witness.thy	Fri May 15 15:56:28 2009 +0200
@@ -68,7 +68,7 @@
     | dest_exs _ _ = sys_error "dest_exs";
   val t = dest_exs (length ws) (HOLogic.dest_Trueprop goal);
 in
-  if Code_ML.eval_term ("Eval_Witness_Method.eval_ref", Eval_Witness_Method.eval_ref) thy t ws
+  if Code_ML.eval NONE ("Eval_Witness_Method.eval_ref", Eval_Witness_Method.eval_ref) (K I) thy t ws
   then Thm.cterm_of thy goal
   else @{cprop True} (*dummy*)
 end

--- a/src/HOL/Library/Float.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Library/Float.thy	Fri May 15 15:56:28 2009 +0200
@@ -15,8 +15,17 @@
 
 datatype float = Float int int
 
-fun Ifloat :: "float \<Rightarrow> real" where
-"Ifloat (Float a b) = real a * pow2 b"
+primrec of_float :: "float \<Rightarrow> real" where
+  "of_float (Float a b) = real a * pow2 b"
+
+defs (overloaded)
+  real_of_float_def [code unfold]: "real == of_float"
+
+primrec mantissa :: "float \<Rightarrow> int" where
+  "mantissa (Float a b) = a"
+
+primrec scale :: "float \<Rightarrow> int" where
+  "scale (Float a b) = b"
 
 instantiation float :: zero begin
 definition zero_float where "0 = Float 0 0" 
@@ -33,20 +42,17 @@
 instance ..
 end
 
-fun mantissa :: "float \<Rightarrow> int" where
-"mantissa (Float a b) = a"
+lemma real_of_float_simp[simp]: "real (Float a b) = real a * pow2 b"
+  unfolding real_of_float_def using of_float.simps .
 
-fun scale :: "float \<Rightarrow> int" where
-"scale (Float a b) = b"
-
-lemma Ifloat_neg_exp: "e < 0 \<Longrightarrow> Ifloat (Float m e) = real m * inverse (2^nat (-e))" by auto
-lemma Ifloat_nge0_exp: "\<not> 0 \<le> e \<Longrightarrow> Ifloat (Float m e) = real m * inverse (2^nat (-e))" by auto
-lemma Ifloat_ge0_exp: "0 \<le> e \<Longrightarrow> Ifloat (Float m e) = real m * (2^nat e)" by auto
+lemma real_of_float_neg_exp: "e < 0 \<Longrightarrow> real (Float m e) = real m * inverse (2^nat (-e))" by auto
+lemma real_of_float_nge0_exp: "\<not> 0 \<le> e \<Longrightarrow> real (Float m e) = real m * inverse (2^nat (-e))" by auto
+lemma real_of_float_ge0_exp: "0 \<le> e \<Longrightarrow> real (Float m e) = real m * (2^nat e)" by auto
 
 lemma Float_num[simp]: shows
-   "Ifloat (Float 1 0) = 1" and "Ifloat (Float 1 1) = 2" and "Ifloat (Float 1 2) = 4" and 
-   "Ifloat (Float 1 -1) = 1/2" and "Ifloat (Float 1 -2) = 1/4" and "Ifloat (Float 1 -3) = 1/8" and
-   "Ifloat (Float -1 0) = -1" and "Ifloat (Float (number_of n) 0) = number_of n"
+   "real (Float 1 0) = 1" and "real (Float 1 1) = 2" and "real (Float 1 2) = 4" and 
+   "real (Float 1 -1) = 1/2" and "real (Float 1 -2) = 1/4" and "real (Float 1 -3) = 1/8" and
+   "real (Float -1 0) = -1" and "real (Float (number_of n) 0) = number_of n"
   by auto
 
 lemma pow2_0[simp]: "pow2 0 = 1" by simp
@@ -131,7 +137,7 @@
 
 lemma float_split2: "(\<forall> a b. x \<noteq> Float a b) = False" by (auto simp add: float_split)
 
-lemma float_zero[simp]: "Ifloat (Float 0 e) = 0" by simp
+lemma float_zero[simp]: "real (Float 0 e) = 0" by simp
 
 lemma abs_div_2_less: "a \<noteq> 0 \<Longrightarrow> a \<noteq> -1 \<Longrightarrow> abs((a::int) div 2) < abs a"
 by arith
@@ -142,7 +148,7 @@
 termination by (relation "measure (nat o abs o mantissa)") (auto intro: abs_div_2_less)
 declare normfloat.simps[simp del]
 
-theorem normfloat[symmetric, simp]: "Ifloat f = Ifloat (normfloat f)"
+theorem normfloat[symmetric, simp]: "real f = real (normfloat f)"
 proof (induct f rule: normfloat.induct)
   case (1 a b)
   have real2: "2 = real (2::int)"
@@ -217,7 +223,7 @@
 
 lemma float_eq_odd_helper: 
   assumes odd: "odd a'"
-  and floateq: "Ifloat (Float a b) = Ifloat (Float a' b')"
+  and floateq: "real (Float a b) = real (Float a' b')"
   shows "b \<le> b'"
 proof - 
   {
@@ -267,7 +273,7 @@
 lemma float_eq_odd: 
   assumes odd1: "odd a"
   and odd2: "odd a'"
-  and floateq: "Ifloat (Float a b) = Ifloat (Float a' b')"
+  and floateq: "real (Float a b) = real (Float a' b')"
   shows "a = a' \<and> b = b'"
 proof -
   from 
@@ -278,14 +284,14 @@
 qed
 
 theorem normfloat_unique:
-  assumes Ifloat_eq: "Ifloat f = Ifloat g"
+  assumes real_of_float_eq: "real f = real g"
   shows "normfloat f = normfloat g"
 proof - 
   from float_split[of "normfloat f"] obtain a b where normf:"normfloat f = Float a b" by auto
   from float_split[of "normfloat g"] obtain a' b' where normg:"normfloat g = Float a' b'" by auto
-  have "Ifloat (normfloat f) = Ifloat (normfloat g)"
-    by (simp add: Ifloat_eq)
-  then have float_eq: "Ifloat (Float a b) = Ifloat (Float a' b')"
+  have "real (normfloat f) = real (normfloat g)"
+    by (simp add: real_of_float_eq)
+  then have float_eq: "real (Float a b) = real (Float a' b')"
     by (simp add: normf normg)
   have ab: "odd a \<or> (a = 0 \<and> b = 0)" by (rule normfloat_imp_odd_or_zero[OF normf])
   have ab': "odd a' \<or> (a' = 0 \<and> b' = 0)" by (rule normfloat_imp_odd_or_zero[OF normg])
@@ -320,12 +326,12 @@
 end
 
 instantiation float :: uminus begin
-fun uminus_float where [simp del]: "uminus_float (Float m e) = Float (-m) e"
+primrec uminus_float where [simp del]: "uminus_float (Float m e) = Float (-m) e"
 instance ..
 end
 
 instantiation float :: minus begin
-fun minus_float where [simp del]: "(z::float) - w = z + (- w)"
+definition minus_float where [simp del]: "(z::float) - w = z + (- w)"
 instance ..
 end
 
@@ -334,39 +340,39 @@
 instance ..
 end
 
-fun float_pprt :: "float \<Rightarrow> float" where
-"float_pprt (Float a e) = (if 0 <= a then (Float a e) else 0)"
+primrec float_pprt :: "float \<Rightarrow> float" where
+  "float_pprt (Float a e) = (if 0 <= a then (Float a e) else 0)"
 
-fun float_nprt :: "float \<Rightarrow> float" where
-"float_nprt (Float a e) = (if 0 <= a then 0 else (Float a e))" 
+primrec float_nprt :: "float \<Rightarrow> float" where
+  "float_nprt (Float a e) = (if 0 <= a then 0 else (Float a e))" 
 
 instantiation float :: ord begin
-definition le_float_def: "z \<le> w \<equiv> Ifloat z \<le> Ifloat w"
-definition less_float_def: "z < w \<equiv> Ifloat z < Ifloat w"
+definition le_float_def: "z \<le> (w :: float) \<equiv> real z \<le> real w"
+definition less_float_def: "z < (w :: float) \<equiv> real z < real w"
 instance ..
 end
 
-lemma Ifloat_add[simp]: "Ifloat (a + b) = Ifloat a + Ifloat b"
+lemma real_of_float_add[simp]: "real (a + b) = real a + real (b :: float)"
   by (cases a, cases b, simp add: algebra_simps plus_float.simps, 
       auto simp add: pow2_int[symmetric] pow2_add[symmetric])
 
-lemma Ifloat_minus[simp]: "Ifloat (- a) = - Ifloat a"
+lemma real_of_float_minus[simp]: "real (- a) = - real (a :: float)"
   by (cases a, simp add: uminus_float.simps)
 
-lemma Ifloat_sub[simp]: "Ifloat (a - b) = Ifloat a - Ifloat b" 
-  by (cases a, cases b, simp add: minus_float.simps)
+lemma real_of_float_sub[simp]: "real (a - b) = real a - real (b :: float)"
+  by (cases a, cases b, simp add: minus_float_def)
 
-lemma Ifloat_mult[simp]: "Ifloat (a*b) = Ifloat a * Ifloat b"
+lemma real_of_float_mult[simp]: "real (a*b) = real a * real (b :: float)"
   by (cases a, cases b, simp add: times_float.simps pow2_add)
 
-lemma Ifloat_0[simp]: "Ifloat 0 = 0"
+lemma real_of_float_0[simp]: "real (0 :: float) = 0"
   by (auto simp add: zero_float_def float_zero)
 
-lemma Ifloat_1[simp]: "Ifloat 1 = 1"
+lemma real_of_float_1[simp]: "real (1 :: float) = 1"
   by (auto simp add: one_float_def)
 
 lemma zero_le_float:
-  "(0 <= Ifloat (Float a b)) = (0 <= a)"
+  "(0 <= real (Float a b)) = (0 <= a)"
   apply auto
   apply (auto simp add: zero_le_mult_iff)
   apply (insert zero_less_pow2[of b])
@@ -374,19 +380,19 @@
   done
 
 lemma float_le_zero:
-  "(Ifloat (Float a b) <= 0) = (a <= 0)"
+  "(real (Float a b) <= 0) = (a <= 0)"
   apply auto
   apply (auto simp add: mult_le_0_iff)
   apply (insert zero_less_pow2[of b])
   apply auto
   done
 
-declare Ifloat.simps[simp del]
+declare real_of_float_simp[simp del]
 
-lemma Ifloat_pprt[simp]: "Ifloat (float_pprt a) = pprt (Ifloat a)"
+lemma real_of_float_pprt[simp]: "real (float_pprt a) = pprt (real a)"
   by (cases a, auto simp add: float_pprt.simps zero_le_float float_le_zero float_zero)
 
-lemma Ifloat_nprt[simp]: "Ifloat (float_nprt a) = nprt (Ifloat a)"
+lemma real_of_float_nprt[simp]: "real (float_nprt a) = nprt (real a)"
   by (cases a,  auto simp add: float_nprt.simps zero_le_float float_le_zero float_zero)
 
 instance float :: ab_semigroup_add
@@ -440,40 +446,11 @@
 lemma float_less_simp: "((x::float) < y) = (0 < y - x)"
   by (auto simp add: less_float_def)
 
-lemma Ifloat_min: "Ifloat (min x y) = min (Ifloat x) (Ifloat y)" unfolding min_def le_float_def by auto
-lemma Ifloat_max: "Ifloat (max a b) = max (Ifloat a) (Ifloat b)" unfolding max_def le_float_def by auto
-
-instantiation float :: power begin 
-fun power_float where [simp del]: "(Float m e) ^ n = Float (m ^ n) (e * int n)"
-instance ..
-end
-
-instance float :: recpower
-proof (intro_classes)
-  fix a :: float show "a ^ 0 = 1" by (cases a, auto simp add: power_float.simps one_float_def)
-next
-  fix a :: float and n :: nat show "a ^ (Suc n) = a * a ^ n" 
-  by (cases a, auto simp add: power_float.simps times_float.simps algebra_simps)
-qed
+lemma real_of_float_min: "real (min x y :: float) = min (real x) (real y)" unfolding min_def le_float_def by auto
+lemma real_of_float_max: "real (max a b :: float) = max (real a) (real b)" unfolding max_def le_float_def by auto
 
-lemma float_power: "Ifloat (x ^ n) = (Ifloat x) ^ n"
-proof (cases x)
-  case (Float m e)
-  
-  have "pow2 e ^ n = pow2 (e * int n)"
-  proof (cases "e >= 0")
-    case True hence e_nat: "e = int (nat e)" by auto
-    hence "pow2 e ^ n = (2 ^ nat e) ^ n" using pow2_int[of "nat e"] by auto
-    thus ?thesis unfolding power_mult[symmetric] unfolding pow2_int[symmetric] int_mult e_nat[symmetric] .
-  next
-    case False hence e_minus: "-e = int (nat (-e))" by auto
-    hence "pow2 (-e) ^ n = (2 ^ nat (-e)) ^ n" using pow2_int[of "nat (-e)"] by auto
-    hence "pow2 (-e) ^ n = pow2 ((-e) * int n)" unfolding power_mult[symmetric] unfolding pow2_int[symmetric] int_mult e_minus[symmetric] zmult_zminus .
-    thus ?thesis unfolding pow2_neg[of "-e"] pow2_neg[of "-e * int n"] unfolding zmult_zminus zminus_zminus nonzero_power_inverse[OF pow2_neq_zero, symmetric]
-      using nonzero_inverse_eq_imp_eq[OF _ pow2_neq_zero pow2_neq_zero] by auto
-  qed
-  thus ?thesis by (auto simp add: Float power_mult_distrib Ifloat.simps power_float.simps)
-qed
+lemma float_power: "real (x ^ n :: float) = real x ^ n"
+  by (induct n) simp_all
 
 lemma zero_le_pow2[simp]: "0 \<le> pow2 s"
   apply (subgoal_tac "0 < pow2 s")
@@ -496,7 +473,7 @@
   done
 
 lemma float_pos_m_pos: "0 < Float m e \<Longrightarrow> 0 < m"
-  unfolding less_float_def Ifloat.simps Ifloat_0 zero_less_mult_iff
+  unfolding less_float_def real_of_float_simp real_of_float_0 zero_less_mult_iff
   by auto
 
 lemma float_pos_less1_e_neg: assumes "0 < Float m e" and "Float m e < 1" shows "e < 0"
@@ -509,7 +486,7 @@
     assume "\<not> e < 0" hence "0 \<le> e" by auto
     hence "1 \<le> pow2 e" unfolding pow2_def by auto
     from mult_mono[OF `1 \<le> real m` this `0 \<le> real m`]
-    have "1 \<le> Float m e" by (simp add: le_float_def Ifloat.simps)
+    have "1 \<le> Float m e" by (simp add: le_float_def real_of_float_simp)
     thus False using `Float m e < 1` unfolding less_float_def le_float_def by auto
   qed
 qed
@@ -519,7 +496,7 @@
   have "e < 0" using float_pos_less1_e_neg assms by auto
   have "\<And>x. (0::real) < 2^x" by auto
   have "real m < 2^(nat (-e))" using `Float m e < 1`
-    unfolding less_float_def Ifloat_neg_exp[OF `e < 0`] Ifloat_1
+    unfolding less_float_def real_of_float_neg_exp[OF `e < 0`] real_of_float_1
           real_mult_less_iff1[of _ _ 1, OF `0 < 2^(nat (-e))`, symmetric] 
           real_mult_assoc by auto
   thus ?thesis unfolding real_of_int_less_iff[symmetric] by auto
@@ -617,7 +594,7 @@
   hence "0 < m" using float_pos_m_pos by auto
   hence "m \<noteq> 0" and "1 < (2::int)" by auto
   case False let ?S = "2^(nat (-e))"
-  have "1 \<le> real m * inverse ?S" using assms unfolding le_float_def Ifloat_nge0_exp[OF False] by auto
+  have "1 \<le> real m * inverse ?S" using assms unfolding le_float_def real_of_float_nge0_exp[OF False] by auto
   hence "1 * ?S \<le> real m * inverse ?S * ?S" by (rule mult_right_mono, auto)
   hence "?S \<le> real m" unfolding mult_assoc by auto
   hence "?S \<le> m" unfolding real_of_int_le_iff[symmetric] by auto
@@ -627,12 +604,12 @@
   thus ?thesis by auto
 qed
 
-lemma normalized_float: assumes "m \<noteq> 0" shows "Ifloat (Float m (- (bitlen m - 1))) = real m / 2^nat (bitlen m - 1)"
+lemma normalized_float: assumes "m \<noteq> 0" shows "real (Float m (- (bitlen m - 1))) = real m / 2^nat (bitlen m - 1)"
 proof (cases "- (bitlen m - 1) = 0")
-  case True show ?thesis unfolding Ifloat.simps pow2_def using True by auto
+  case True show ?thesis unfolding real_of_float_simp pow2_def using True by auto
 next
   case False hence P: "\<not> 0 \<le> - (bitlen m - 1)" using bitlen_ge1[OF `m \<noteq> 0`] by auto
-  show ?thesis unfolding Ifloat_nge0_exp[OF P] real_divide_def by auto
+  show ?thesis unfolding real_of_float_nge0_exp[OF P] real_divide_def by auto
 qed
 
 lemma bitlen_Pls: "bitlen (Int.Pls) = Int.Pls" by (subst Pls_def, subst Pls_def, simp)
@@ -689,7 +666,7 @@
 lemma lapprox_posrat: 
   assumes x: "0 \<le> x"
   and y: "0 < y"
-  shows "Ifloat (lapprox_posrat prec x y) \<le> real x / real y"
+  shows "real (lapprox_posrat prec x y) \<le> real x / real y"
 proof -
   let ?l = "nat (int prec + bitlen y - bitlen x)"
   
@@ -697,7 +674,7 @@
     by (rule mult_right_mono, fact real_of_int_div4, simp)
   also have "\<dots> \<le> (real x / real y) * 2^?l * inverse (2^?l)" by auto
   finally have "real (x * 2^?l div y) * inverse (2^?l) \<le> real x / real y" unfolding real_mult_assoc by auto
-  thus ?thesis unfolding lapprox_posrat_def Let_def normfloat Ifloat.simps
+  thus ?thesis unfolding lapprox_posrat_def Let_def normfloat real_of_float_simp
     unfolding pow2_minus pow2_int minus_minus .
 qed
 
@@ -717,19 +694,19 @@
 qed
 
 lemma lapprox_posrat_bottom: assumes "0 < y"
-  shows "real (x div y) \<le> Ifloat (lapprox_posrat n x y)" 
+  shows "real (x div y) \<le> real (lapprox_posrat n x y)" 
 proof -
   have pow: "\<And>x. (0::int) < 2^x" by auto
   show ?thesis
-    unfolding lapprox_posrat_def Let_def Ifloat_add normfloat Ifloat.simps pow2_minus pow2_int
+    unfolding lapprox_posrat_def Let_def real_of_float_add normfloat real_of_float_simp pow2_minus pow2_int
     using real_of_int_div_mult[OF `0 < y` pow] by auto
 qed
 
 lemma lapprox_posrat_nonneg: assumes "0 \<le> x" and "0 < y"
-  shows "0 \<le> Ifloat (lapprox_posrat n x y)" 
+  shows "0 \<le> real (lapprox_posrat n x y)" 
 proof -
   show ?thesis
-    unfolding lapprox_posrat_def Let_def Ifloat_add normfloat Ifloat.simps pow2_minus pow2_int
+    unfolding lapprox_posrat_def Let_def real_of_float_add normfloat real_of_float_simp pow2_minus pow2_int
     using pos_imp_zdiv_nonneg_iff[OF `0 < y`] assms by (auto intro!: mult_nonneg_nonneg)
 qed
 
@@ -745,7 +722,7 @@
 lemma rapprox_posrat:
   assumes x: "0 \<le> x"
   and y: "0 < y"
-  shows "real x / real y \<le> Ifloat (rapprox_posrat prec x y)"
+  shows "real x / real y \<le> real (rapprox_posrat prec x y)"
 proof -
   let ?l = "nat (int prec + bitlen y - bitlen x)" let ?X = "x * 2^?l"
   show ?thesis 
@@ -756,7 +733,7 @@
     also have "\<dots> = real x / real y * (2^?l * inverse (2^?l))" by auto
     finally have "real (?X div y) * inverse (2^?l) = real x / real y" by auto
     thus ?thesis unfolding rapprox_posrat_def Let_def normfloat if_P[OF True] 
-      unfolding Ifloat.simps pow2_minus pow2_int minus_minus by auto
+      unfolding real_of_float_simp pow2_minus pow2_int minus_minus by auto
   next
     case False
     have "0 \<le> real y" and "real y \<noteq> 0" using `0 < y` by auto
@@ -771,13 +748,13 @@
     also have "\<dots> = real y * real (?X div y + 1) / real y / 2^?l" by auto
     also have "\<dots> = real (?X div y + 1) * inverse (2^?l)" unfolding nonzero_mult_divide_cancel_left[OF `real y \<noteq> 0`] 
       unfolding real_divide_def ..
-    finally show ?thesis unfolding rapprox_posrat_def Let_def normfloat Ifloat.simps if_not_P[OF False]
+    finally show ?thesis unfolding rapprox_posrat_def Let_def normfloat real_of_float_simp if_not_P[OF False]
       unfolding pow2_minus pow2_int minus_minus by auto
   qed
 qed
 
 lemma rapprox_posrat_le1: assumes "0 \<le> x" and "0 < y" and "x \<le> y"
-  shows "Ifloat (rapprox_posrat n x y) \<le> 1"
+  shows "real (rapprox_posrat n x y) \<le> 1"
 proof -
   let ?l = "nat (int n + bitlen y - bitlen x)" let ?X = "x * 2^?l"
   show ?thesis
@@ -789,7 +766,7 @@
     finally have "real (?X div y) * inverse (2^?l) = real x / real y" by auto
     also have "real x / real y \<le> 1" using `0 \<le> x` and `0 < y` and `x \<le> y` by auto
     finally show ?thesis unfolding rapprox_posrat_def Let_def normfloat if_P[OF True]
-      unfolding Ifloat.simps pow2_minus pow2_int minus_minus by auto
+      unfolding real_of_float_simp pow2_minus pow2_int minus_minus by auto
   next
     case False
     have "x \<noteq> y"
@@ -810,7 +787,7 @@
       unfolding real_of_int_le_iff[of _ "2^?l", symmetric] real_of_int_power[symmetric] real_number_of
       by (rule mult_right_mono, auto)
     hence "real (?X div y + 1) * inverse (2^?l) \<le> 1" by auto
-    thus ?thesis unfolding rapprox_posrat_def Let_def normfloat Ifloat.simps if_not_P[OF False]
+    thus ?thesis unfolding rapprox_posrat_def Let_def normfloat real_of_float_simp if_not_P[OF False]
       unfolding pow2_minus pow2_int minus_minus by auto
   qed
 qed
@@ -827,9 +804,9 @@
 qed
 
 lemma rapprox_posrat_less1: assumes "0 \<le> x" and "0 < y" and "2 * x < y" and "0 < n"
-  shows "Ifloat (rapprox_posrat n x y) < 1"
+  shows "real (rapprox_posrat n x y) < 1"
 proof (cases "x = 0")
-  case True thus ?thesis unfolding rapprox_posrat_def True Let_def normfloat Ifloat.simps by auto
+  case True thus ?thesis unfolding rapprox_posrat_def True Let_def normfloat real_of_float_simp by auto
 next
   case False hence "0 < x" using `0 \<le> x` by auto
   hence "x < y" using assms by auto
@@ -843,7 +820,7 @@
     also have "\<dots> = real x / real y * (2^?l * inverse (2^?l))" by auto
     finally have "real (?X div y) * inverse (2^?l) = real x / real y" by auto
     also have "real x / real y < 1" using `0 \<le> x` and `0 < y` and `x < y` by auto
-    finally show ?thesis unfolding rapprox_posrat_def Let_def normfloat Ifloat.simps if_P[OF True]
+    finally show ?thesis unfolding rapprox_posrat_def Let_def normfloat real_of_float_simp if_P[OF True]
       unfolding pow2_minus pow2_int minus_minus by auto
   next
     case False
@@ -884,7 +861,7 @@
       unfolding real_of_int_less_iff[of _ "2^?l", symmetric] real_of_int_power[symmetric] real_number_of
       by (rule mult_strict_right_mono, auto)
     hence "real (?X div y + 1) * inverse (2^?l) < 1" by auto
-    thus ?thesis unfolding rapprox_posrat_def Let_def normfloat Ifloat.simps if_not_P[OF False]
+    thus ?thesis unfolding rapprox_posrat_def Let_def normfloat real_of_float_simp if_not_P[OF False]
       unfolding pow2_minus pow2_int minus_minus by auto
   qed
 qed
@@ -919,7 +896,7 @@
                                                              else (if 0 < y then - (rapprox_posrat prec (-x) y) else lapprox_posrat prec (-x) (-y)))"
   by auto
             
-lemma lapprox_rat: "Ifloat (lapprox_rat prec x y) \<le> real x / real y"
+lemma lapprox_rat: "real (lapprox_rat prec x y) \<le> real x / real y"
 proof -      
   have h[rule_format]: "! a b b'. b' \<le> b \<longrightarrow> a \<le> b' \<longrightarrow> a \<le> (b::real)" by auto
   show ?thesis
@@ -946,7 +923,7 @@
 qed
 
 lemma lapprox_rat_bottom: assumes "0 \<le> x" and "0 < y"
-  shows "real (x div y) \<le> Ifloat (lapprox_rat n x y)" 
+  shows "real (x div y) \<le> real (lapprox_rat n x y)" 
   unfolding lapprox_rat.simps(2)[OF assms]  using lapprox_posrat_bottom[OF `0<y`] .
 
 function rapprox_rat :: "nat \<Rightarrow> int \<Rightarrow> int \<Rightarrow> float"
@@ -964,7 +941,7 @@
                                                                   (if 0 < y then - (lapprox_posrat prec (-x) y) else rapprox_posrat prec (-x) (-y)))"
   by auto
 
-lemma rapprox_rat: "real x / real y \<le> Ifloat (rapprox_rat prec x y)"
+lemma rapprox_rat: "real x / real y \<le> real (rapprox_rat prec x y)"
 proof -      
   have h[rule_format]: "! a b b'. b' \<le> b \<longrightarrow> a \<le> b' \<longrightarrow> a \<le> (b::real)" by auto
   show ?thesis
@@ -991,19 +968,19 @@
 qed
 
 lemma rapprox_rat_le1: assumes "0 \<le> x" and "0 < y" and "x \<le> y"
-  shows "Ifloat (rapprox_rat n x y) \<le> 1"
+  shows "real (rapprox_rat n x y) \<le> 1"
   unfolding rapprox_rat.simps(2)[OF `0 \<le> x` `0 < y`] using rapprox_posrat_le1[OF assms] .
 
 lemma rapprox_rat_neg: assumes "x < 0" and "0 < y"
-  shows "Ifloat (rapprox_rat n x y) \<le> 0"
+  shows "real (rapprox_rat n x y) \<le> 0"
   unfolding rapprox_rat.simps(3)[OF assms] using lapprox_posrat_nonneg[of "-x" y n] assms by auto
 
 lemma rapprox_rat_nonneg_neg: assumes "0 \<le> x" and "y < 0"
-  shows "Ifloat (rapprox_rat n x y) \<le> 0"
+  shows "real (rapprox_rat n x y) \<le> 0"
   unfolding rapprox_rat.simps(5)[OF assms] using lapprox_posrat_nonneg[of x "-y" n] assms by auto
 
 lemma rapprox_rat_nonpos_pos: assumes "x \<le> 0" and "0 < y"
-  shows "Ifloat (rapprox_rat n x y) \<le> 0"
+  shows "real (rapprox_rat n x y) \<le> 0"
 proof (cases "x = 0") 
   case True hence "0 \<le> x" by auto show ?thesis unfolding rapprox_rat.simps(2)[OF `0 \<le> x` `0 < y`]
     unfolding True rapprox_posrat_def Let_def by auto
@@ -1021,7 +998,7 @@
      in
        f * l)"     
 
-lemma float_divl: "Ifloat (float_divl prec x y) \<le> Ifloat x / Ifloat y"
+lemma float_divl: "real (float_divl prec x y) \<le> real x / real y"
 proof - 
   from float_split[of x] obtain mx sx where x: "x = Float mx sx" by auto
   from float_split[of y] obtain my sy where y: "y = Float my sy" by auto
@@ -1042,29 +1019,29 @@
     apply (subst pow2_add[symmetric])
     apply (simp add: field_simps)
     done
-  then have "Ifloat (lapprox_rat prec mx my) \<le> (real mx * pow2 sx / (real my * pow2 sy)) / (pow2 (sx - sy))"
+  then have "real (lapprox_rat prec mx my) \<le> (real mx * pow2 sx / (real my * pow2 sy)) / (pow2 (sx - sy))"
     by (rule order_trans[OF lapprox_rat])
-  then have "Ifloat (lapprox_rat prec mx my) * pow2 (sx - sy) \<le> real mx * pow2 sx / (real my * pow2 sy)"
+  then have "real (lapprox_rat prec mx my) * pow2 (sx - sy) \<le> real mx * pow2 sx / (real my * pow2 sy)"
     apply (subst pos_le_divide_eq[symmetric])
     apply simp_all
     done
-  then have "pow2 (sx - sy) * Ifloat (lapprox_rat prec mx my) \<le> real mx * pow2 sx / (real my * pow2 sy)"
+  then have "pow2 (sx - sy) * real (lapprox_rat prec mx my) \<le> real mx * pow2 sx / (real my * pow2 sy)"
     by (simp add: algebra_simps)
   then show ?thesis
-    by (simp add: x y Let_def Ifloat.simps)
+    by (simp add: x y Let_def real_of_float_simp)
 qed
 
 lemma float_divl_lower_bound: assumes "0 \<le> x" and "0 < y" shows "0 \<le> float_divl prec x y"
 proof (cases x, cases y)
   fix xm xe ym ye :: int
   assume x_eq: "x = Float xm xe" and y_eq: "y = Float ym ye"
-  have "0 \<le> xm" using `0 \<le> x`[unfolded x_eq le_float_def Ifloat.simps Ifloat_0 zero_le_mult_iff] by auto
-  have "0 < ym" using `0 < y`[unfolded y_eq less_float_def Ifloat.simps Ifloat_0 zero_less_mult_iff] by auto
+  have "0 \<le> xm" using `0 \<le> x`[unfolded x_eq le_float_def real_of_float_simp real_of_float_0 zero_le_mult_iff] by auto
+  have "0 < ym" using `0 < y`[unfolded y_eq less_float_def real_of_float_simp real_of_float_0 zero_less_mult_iff] by auto
 
-  have "\<And>n. 0 \<le> Ifloat (Float 1 n)" unfolding Ifloat.simps using zero_le_pow2 by auto
-  moreover have "0 \<le> Ifloat (lapprox_rat prec xm ym)" by (rule order_trans[OF _ lapprox_rat_bottom[OF `0 \<le> xm` `0 < ym`]], auto simp add: `0 \<le> xm` pos_imp_zdiv_nonneg_iff[OF `0 < ym`])
+  have "\<And>n. 0 \<le> real (Float 1 n)" unfolding real_of_float_simp using zero_le_pow2 by auto
+  moreover have "0 \<le> real (lapprox_rat prec xm ym)" by (rule order_trans[OF _ lapprox_rat_bottom[OF `0 \<le> xm` `0 < ym`]], auto simp add: `0 \<le> xm` pos_imp_zdiv_nonneg_iff[OF `0 < ym`])
   ultimately show "0 \<le> float_divl prec x y"
-    unfolding x_eq y_eq float_divl.simps Let_def le_float_def Ifloat_0 by (auto intro!: mult_nonneg_nonneg)
+    unfolding x_eq y_eq float_divl.simps Let_def le_float_def real_of_float_0 by (auto intro!: mult_nonneg_nonneg)
 qed
 
 lemma float_divl_pos_less1_bound: assumes "0 < x" and "x < 1" and "0 < prec" shows "1 \<le> float_divl prec 1 x"
@@ -1105,7 +1082,7 @@
   
   show ?thesis 
     unfolding one_float_def Float float_divl.simps Let_def lapprox_rat.simps(2)[OF zero_le_one `0 < m`] lapprox_posrat_def `bitlen 1 = 1`
-    unfolding le_float_def Ifloat_mult normfloat Ifloat.simps pow2_minus pow2_int e_nat
+    unfolding le_float_def real_of_float_mult normfloat real_of_float_simp pow2_minus pow2_int e_nat
     using `1 \<le> 2^?e * ?d` by (auto simp add: pow2_def)
 qed
 
@@ -1118,7 +1095,7 @@
      in
        f * r)"  
 
-lemma float_divr: "Ifloat x / Ifloat y \<le> Ifloat (float_divr prec x y)"
+lemma float_divr: "real x / real y \<le> real (float_divr prec x y)"
 proof - 
   from float_split[of x] obtain mx sx where x: "x = Float mx sx" by auto
   from float_split[of y] obtain my sy where y: "y = Float my sy" by auto
@@ -1138,20 +1115,20 @@
     apply (subst pow2_add[symmetric])
     apply (simp add: field_simps)
     done
-  then have "Ifloat (rapprox_rat prec mx my) \<ge> (real mx * pow2 sx / (real my * pow2 sy)) / (pow2 (sx - sy))"
+  then have "real (rapprox_rat prec mx my) \<ge> (real mx * pow2 sx / (real my * pow2 sy)) / (pow2 (sx - sy))"
     by (rule order_trans[OF _ rapprox_rat])
-  then have "Ifloat (rapprox_rat prec mx my) * pow2 (sx - sy) \<ge> real mx * pow2 sx / (real my * pow2 sy)"
+  then have "real (rapprox_rat prec mx my) * pow2 (sx - sy) \<ge> real mx * pow2 sx / (real my * pow2 sy)"
     apply (subst pos_divide_le_eq[symmetric])
     apply simp_all
     done
   then show ?thesis
-    by (simp add: x y Let_def algebra_simps Ifloat.simps)
+    by (simp add: x y Let_def algebra_simps real_of_float_simp)
 qed
 
 lemma float_divr_pos_less1_lower_bound: assumes "0 < x" and "x < 1" shows "1 \<le> float_divr prec 1 x"
 proof -
-  have "1 \<le> 1 / Ifloat x" using `0 < x` and `x < 1` unfolding less_float_def by auto
-  also have "\<dots> \<le> Ifloat (float_divr prec 1 x)" using float_divr[where x=1 and y=x] by auto
+  have "1 \<le> 1 / real x" using `0 < x` and `x < 1` unfolding less_float_def by auto
+  also have "\<dots> \<le> real (float_divr prec 1 x)" using float_divr[where x=1 and y=x] by auto
   finally show ?thesis unfolding le_float_def by auto
 qed
 
@@ -1159,40 +1136,40 @@
 proof (cases x, cases y)
   fix xm xe ym ye :: int
   assume x_eq: "x = Float xm xe" and y_eq: "y = Float ym ye"
-  have "xm \<le> 0" using `x \<le> 0`[unfolded x_eq le_float_def Ifloat.simps Ifloat_0 mult_le_0_iff] by auto
-  have "0 < ym" using `0 < y`[unfolded y_eq less_float_def Ifloat.simps Ifloat_0 zero_less_mult_iff] by auto
+  have "xm \<le> 0" using `x \<le> 0`[unfolded x_eq le_float_def real_of_float_simp real_of_float_0 mult_le_0_iff] by auto
+  have "0 < ym" using `0 < y`[unfolded y_eq less_float_def real_of_float_simp real_of_float_0 zero_less_mult_iff] by auto
 
-  have "\<And>n. 0 \<le> Ifloat (Float 1 n)" unfolding Ifloat.simps using zero_le_pow2 by auto
-  moreover have "Ifloat (rapprox_rat prec xm ym) \<le> 0" using rapprox_rat_nonpos_pos[OF `xm \<le> 0` `0 < ym`] .
+  have "\<And>n. 0 \<le> real (Float 1 n)" unfolding real_of_float_simp using zero_le_pow2 by auto
+  moreover have "real (rapprox_rat prec xm ym) \<le> 0" using rapprox_rat_nonpos_pos[OF `xm \<le> 0` `0 < ym`] .
   ultimately show "float_divr prec x y \<le> 0"
-    unfolding x_eq y_eq float_divr.simps Let_def le_float_def Ifloat_0 Ifloat_mult by (auto intro!: mult_nonneg_nonpos)
+    unfolding x_eq y_eq float_divr.simps Let_def le_float_def real_of_float_0 real_of_float_mult by (auto intro!: mult_nonneg_nonpos)
 qed
 
 lemma float_divr_nonneg_neg_upper_bound: assumes "0 \<le> x" and "y < 0" shows "float_divr prec x y \<le> 0"
 proof (cases x, cases y)
   fix xm xe ym ye :: int
   assume x_eq: "x = Float xm xe" and y_eq: "y = Float ym ye"
-  have "0 \<le> xm" using `0 \<le> x`[unfolded x_eq le_float_def Ifloat.simps Ifloat_0 zero_le_mult_iff] by auto
-  have "ym < 0" using `y < 0`[unfolded y_eq less_float_def Ifloat.simps Ifloat_0 mult_less_0_iff] by auto
+  have "0 \<le> xm" using `0 \<le> x`[unfolded x_eq le_float_def real_of_float_simp real_of_float_0 zero_le_mult_iff] by auto
+  have "ym < 0" using `y < 0`[unfolded y_eq less_float_def real_of_float_simp real_of_float_0 mult_less_0_iff] by auto
   hence "0 < - ym" by auto
 
-  have "\<And>n. 0 \<le> Ifloat (Float 1 n)" unfolding Ifloat.simps using zero_le_pow2 by auto
-  moreover have "Ifloat (rapprox_rat prec xm ym) \<le> 0" using rapprox_rat_nonneg_neg[OF `0 \<le> xm` `ym < 0`] .
+  have "\<And>n. 0 \<le> real (Float 1 n)" unfolding real_of_float_simp using zero_le_pow2 by auto
+  moreover have "real (rapprox_rat prec xm ym) \<le> 0" using rapprox_rat_nonneg_neg[OF `0 \<le> xm` `ym < 0`] .
   ultimately show "float_divr prec x y \<le> 0"
-    unfolding x_eq y_eq float_divr.simps Let_def le_float_def Ifloat_0 Ifloat_mult by (auto intro!: mult_nonneg_nonpos)
+    unfolding x_eq y_eq float_divr.simps Let_def le_float_def real_of_float_0 real_of_float_mult by (auto intro!: mult_nonneg_nonpos)
 qed
 
-fun round_down :: "nat \<Rightarrow> float \<Rightarrow> float" where
+primrec round_down :: "nat \<Rightarrow> float \<Rightarrow> float" where
 "round_down prec (Float m e) = (let d = bitlen m - int prec in
      if 0 < d then let P = 2^nat d ; n = m div P in Float n (e + d)
               else Float m e)"
 
-fun round_up :: "nat \<Rightarrow> float \<Rightarrow> float" where
+primrec round_up :: "nat \<Rightarrow> float \<Rightarrow> float" where
 "round_up prec (Float m e) = (let d = bitlen m - int prec in
   if 0 < d then let P = 2^nat d ; n = m div P ; r = m mod P in Float (n + (if r = 0 then 0 else 1)) (e + d) 
            else Float m e)"
 
-lemma round_up: "Ifloat x \<le> Ifloat (round_up prec x)"
+lemma round_up: "real x \<le> real (round_up prec x)"
 proof (cases x)
   case (Float m e)
   let ?d = "bitlen m - int prec"
@@ -1206,7 +1183,7 @@
     proof (cases "m mod ?p = 0")
       case True
       have m: "m = m div ?p * ?p + 0" unfolding True[symmetric] using zdiv_zmod_equality2[where k=0, unfolded monoid_add_class.add_0_right, symmetric] .
-      have "Ifloat (Float m e) = Ifloat (Float (m div ?p) (e + ?d))" unfolding Ifloat.simps arg_cong[OF m, of real]
+      have "real (Float m e) = real (Float (m div ?p) (e + ?d))" unfolding real_of_float_simp arg_cong[OF m, of real]
 	by (auto simp add: pow2_add `0 < ?d` pow_d)
       thus ?thesis
 	unfolding Float round_up.simps Let_def if_P[OF `m mod ?p = 0`] if_P[OF `0 < ?d`]
@@ -1215,7 +1192,7 @@
       case False
       have "m = m div ?p * ?p + m mod ?p" unfolding zdiv_zmod_equality2[where k=0, unfolded monoid_add_class.add_0_right] ..
       also have "\<dots> \<le> (m div ?p + 1) * ?p" unfolding left_distrib zmult_1 by (rule add_left_mono, rule pos_mod_bound[OF `0 < ?p`, THEN less_imp_le])
-      finally have "Ifloat (Float m e) \<le> Ifloat (Float (m div ?p + 1) (e + ?d))" unfolding Ifloat.simps add_commute[of e]
+      finally have "real (Float m e) \<le> real (Float (m div ?p + 1) (e + ?d))" unfolding real_of_float_simp add_commute[of e]
 	unfolding pow2_add mult_assoc[symmetric] real_of_int_le_iff[of m, symmetric]
 	by (auto intro!: mult_mono simp add: pow2_add `0 < ?d` pow_d)
       thus ?thesis
@@ -1228,7 +1205,7 @@
   qed
 qed
 
-lemma round_down: "Ifloat (round_down prec x) \<le> Ifloat x"
+lemma round_down: "real (round_down prec x) \<le> real x"
 proof (cases x)
   case (Float m e)
   let ?d = "bitlen m - int prec"
@@ -1240,7 +1217,7 @@
     hence pow_d: "pow2 ?d = real ?p" unfolding pow2_int[symmetric] power_real_number_of[symmetric] by auto
     have "m div ?p * ?p \<le> m div ?p * ?p + m mod ?p" by (auto simp add: pos_mod_bound[OF `0 < ?p`, THEN less_imp_le])
     also have "\<dots> \<le> m" unfolding zdiv_zmod_equality2[where k=0, unfolded monoid_add_class.add_0_right] ..
-    finally have "Ifloat (Float (m div ?p) (e + ?d)) \<le> Ifloat (Float m e)" unfolding Ifloat.simps add_commute[of e]
+    finally have "real (Float (m div ?p) (e + ?d)) \<le> real (Float m e)" unfolding real_of_float_simp add_commute[of e]
       unfolding pow2_add mult_assoc[symmetric] real_of_int_le_iff[of _ m, symmetric]
       by (auto intro!: mult_mono simp add: pow2_add `0 < ?d` pow_d)
     thus ?thesis
@@ -1264,12 +1241,12 @@
   in if l > 0 then Float (m div (2^nat l) + 1) (e + l)
               else Float m e)"
 
-lemma lb_mult: "Ifloat (lb_mult prec x y) \<le> Ifloat (x * y)"
+lemma lb_mult: "real (lb_mult prec x y) \<le> real (x * y)"
 proof (cases "normfloat (x * y)")
   case (Float m e)
   hence "odd m \<or> (m = 0 \<and> e = 0)" by (rule normfloat_imp_odd_or_zero)
   let ?l = "bitlen m - int prec"
-  have "Ifloat (lb_mult prec x y) \<le> Ifloat (normfloat (x * y))"
+  have "real (lb_mult prec x y) \<le> real (normfloat (x * y))"
   proof (cases "?l > 0")
     case False thus ?thesis unfolding lb_mult_def Float Let_def float.cases by auto
   next
@@ -1282,19 +1259,19 @@
       also have "\<dots> = real m" unfolding zmod_zdiv_equality[symmetric] ..
       finally show ?thesis by auto
     qed
-    thus ?thesis unfolding lb_mult_def Float Let_def float.cases if_P[OF True] Ifloat.simps pow2_add real_mult_commute real_mult_assoc by auto
+    thus ?thesis unfolding lb_mult_def Float Let_def float.cases if_P[OF True] real_of_float_simp pow2_add real_mult_commute real_mult_assoc by auto
   qed
-  also have "\<dots> = Ifloat (x * y)" unfolding normfloat ..
+  also have "\<dots> = real (x * y)" unfolding normfloat ..
   finally show ?thesis .
 qed
 
-lemma ub_mult: "Ifloat (x * y) \<le> Ifloat (ub_mult prec x y)"
+lemma ub_mult: "real (x * y) \<le> real (ub_mult prec x y)"
 proof (cases "normfloat (x * y)")
   case (Float m e)
   hence "odd m \<or> (m = 0 \<and> e = 0)" by (rule normfloat_imp_odd_or_zero)
   let ?l = "bitlen m - int prec"
-  have "Ifloat (x * y) = Ifloat (normfloat (x * y))" unfolding normfloat ..
-  also have "\<dots> \<le> Ifloat (ub_mult prec x y)"
+  have "real (x * y) = real (normfloat (x * y))" unfolding normfloat ..
+  also have "\<dots> \<le> real (ub_mult prec x y)"
   proof (cases "?l > 0")
     case False thus ?thesis unfolding ub_mult_def Float Let_def float.cases by auto
   next
@@ -1309,41 +1286,41 @@
       also have "\<dots> \<le> (real (m div 2^(nat ?l)) + 1) * 2^(nat ?l)" unfolding real_add_mult_distrib using mod_uneq by auto
       finally show ?thesis unfolding pow2_int[symmetric] using True by auto
     qed
-    thus ?thesis unfolding ub_mult_def Float Let_def float.cases if_P[OF True] Ifloat.simps pow2_add real_mult_commute real_mult_assoc by auto
+    thus ?thesis unfolding ub_mult_def Float Let_def float.cases if_P[OF True] real_of_float_simp pow2_add real_mult_commute real_mult_assoc by auto
   qed
   finally show ?thesis .
 qed
 
-fun float_abs :: "float \<Rightarrow> float" where
-"float_abs (Float m e) = Float \<bar>m\<bar> e"
+primrec float_abs :: "float \<Rightarrow> float" where
+  "float_abs (Float m e) = Float \<bar>m\<bar> e"
 
 instantiation float :: abs begin
 definition abs_float_def: "\<bar>x\<bar> = float_abs x"
 instance ..
 end
 
-lemma Ifloat_abs: "Ifloat \<bar>x\<bar> = \<bar>Ifloat x\<bar>" 
+lemma real_of_float_abs: "real \<bar>x :: float\<bar> = \<bar>real x\<bar>" 
 proof (cases x)
   case (Float m e)
   have "\<bar>real m\<bar> * pow2 e = \<bar>real m * pow2 e\<bar>" unfolding abs_mult by auto
-  thus ?thesis unfolding Float abs_float_def float_abs.simps Ifloat.simps by auto
+  thus ?thesis unfolding Float abs_float_def float_abs.simps real_of_float_simp by auto
 qed
 
-fun floor_fl :: "float \<Rightarrow> float" where
-"floor_fl (Float m e) = (if 0 \<le> e then Float m e
+primrec floor_fl :: "float \<Rightarrow> float" where
+  "floor_fl (Float m e) = (if 0 \<le> e then Float m e
                                   else Float (m div (2 ^ (nat (-e)))) 0)"
 
-lemma floor_fl: "Ifloat (floor_fl x) \<le> Ifloat x"
+lemma floor_fl: "real (floor_fl x) \<le> real x"
 proof (cases x)
   case (Float m e)
   show ?thesis
   proof (cases "0 \<le> e")
     case False
     hence me_eq: "pow2 (-e) = pow2 (int (nat (-e)))" by auto
-    have "Ifloat (Float (m div (2 ^ (nat (-e)))) 0) = real (m div 2 ^ (nat (-e)))" unfolding Ifloat.simps by auto
+    have "real (Float (m div (2 ^ (nat (-e)))) 0) = real (m div 2 ^ (nat (-e)))" unfolding real_of_float_simp by auto
     also have "\<dots> \<le> real m / real ((2::int) ^ (nat (-e)))" using real_of_int_div4 .
     also have "\<dots> = real m * inverse (2 ^ (nat (-e)))" unfolding power_real_number_of[symmetric] real_divide_def ..
-    also have "\<dots> = Ifloat (Float m e)" unfolding Ifloat.simps me_eq pow2_int pow2_neg[of e] ..
+    also have "\<dots> = real (Float m e)" unfolding real_of_float_simp me_eq pow2_int pow2_neg[of e] ..
     finally show ?thesis unfolding Float floor_fl.simps if_not_P[OF `\<not> 0 \<le> e`] .
   next
     case True thus ?thesis unfolding Float by auto
@@ -1358,21 +1335,21 @@
 
 declare floor_fl.simps[simp del]
 
-fun ceiling_fl :: "float \<Rightarrow> float" where
-"ceiling_fl (Float m e) = (if 0 \<le> e then Float m e
+primrec ceiling_fl :: "float \<Rightarrow> float" where
+  "ceiling_fl (Float m e) = (if 0 \<le> e then Float m e
                                     else Float (m div (2 ^ (nat (-e))) + 1) 0)"
 
-lemma ceiling_fl: "Ifloat x \<le> Ifloat (ceiling_fl x)"
+lemma ceiling_fl: "real x \<le> real (ceiling_fl x)"
 proof (cases x)
   case (Float m e)
   show ?thesis
   proof (cases "0 \<le> e")
     case False
     hence me_eq: "pow2 (-e) = pow2 (int (nat (-e)))" by auto
-    have "Ifloat (Float m e) = real m * inverse (2 ^ (nat (-e)))" unfolding Ifloat.simps me_eq pow2_int pow2_neg[of e] ..
+    have "real (Float m e) = real m * inverse (2 ^ (nat (-e)))" unfolding real_of_float_simp me_eq pow2_int pow2_neg[of e] ..
     also have "\<dots> = real m / real ((2::int) ^ (nat (-e)))" unfolding power_real_number_of[symmetric] real_divide_def ..
     also have "\<dots> \<le> 1 + real (m div 2 ^ (nat (-e)))" using real_of_int_div3[unfolded diff_le_eq] .
-    also have "\<dots> = Ifloat (Float (m div (2 ^ (nat (-e))) + 1) 0)" unfolding Ifloat.simps by auto
+    also have "\<dots> = real (Float (m div (2 ^ (nat (-e))) + 1) 0)" unfolding real_of_float_simp by auto
     finally show ?thesis unfolding Float ceiling_fl.simps if_not_P[OF `\<not> 0 \<le> e`] .
   next
     case True thus ?thesis unfolding Float by auto
@@ -1387,48 +1364,48 @@
 definition ub_mod :: "nat \<Rightarrow> float \<Rightarrow> float \<Rightarrow> float \<Rightarrow> float" where
 "ub_mod prec x ub lb = x - floor_fl (float_divl prec x ub) * lb"
 
-lemma lb_mod: fixes k :: int assumes "0 \<le> Ifloat x" and "real k * y \<le> Ifloat x" (is "?k * y \<le> ?x")
-  assumes "0 < Ifloat lb" "Ifloat lb \<le> y" (is "?lb \<le> y") "y \<le> Ifloat ub" (is "y \<le> ?ub")
-  shows "Ifloat (lb_mod prec x ub lb) \<le> ?x - ?k * y"
+lemma lb_mod: fixes k :: int assumes "0 \<le> real x" and "real k * y \<le> real x" (is "?k * y \<le> ?x")
+  assumes "0 < real lb" "real lb \<le> y" (is "?lb \<le> y") "y \<le> real ub" (is "y \<le> ?ub")
+  shows "real (lb_mod prec x ub lb) \<le> ?x - ?k * y"
 proof -
   have "?lb \<le> ?ub" by (auto!)
   have "0 \<le> ?lb" and "?lb \<noteq> 0" by (auto!)
   have "?k * y \<le> ?x" using assms by auto
   also have "\<dots> \<le> ?x / ?lb * ?ub" by (metis mult_left_mono[OF `?lb \<le> ?ub` `0 \<le> ?x`] divide_right_mono[OF _ `0 \<le> ?lb` ] times_divide_eq_left nonzero_mult_divide_cancel_right[OF `?lb \<noteq> 0`])
-  also have "\<dots> \<le> Ifloat (ceiling_fl (float_divr prec x lb)) * ?ub" by (metis mult_right_mono order_trans `0 \<le> ?lb` `?lb \<le> ?ub` float_divr ceiling_fl)
-  finally show ?thesis unfolding lb_mod_def Ifloat_sub Ifloat_mult by auto
+  also have "\<dots> \<le> real (ceiling_fl (float_divr prec x lb)) * ?ub" by (metis mult_right_mono order_trans `0 \<le> ?lb` `?lb \<le> ?ub` float_divr ceiling_fl)
+  finally show ?thesis unfolding lb_mod_def real_of_float_sub real_of_float_mult by auto
 qed
 
-lemma ub_mod: fixes k :: int assumes "0 \<le> Ifloat x" and "Ifloat x \<le> real k * y" (is "?x \<le> ?k * y")
-  assumes "0 < Ifloat lb" "Ifloat lb \<le> y" (is "?lb \<le> y") "y \<le> Ifloat ub" (is "y \<le> ?ub")
-  shows "?x - ?k * y \<le> Ifloat (ub_mod prec x ub lb)"
+lemma ub_mod: fixes k :: int and x :: float assumes "0 \<le> real x" and "real x \<le> real k * y" (is "?x \<le> ?k * y")
+  assumes "0 < real lb" "real lb \<le> y" (is "?lb \<le> y") "y \<le> real ub" (is "y \<le> ?ub")
+  shows "?x - ?k * y \<le> real (ub_mod prec x ub lb)"
 proof -
   have "?lb \<le> ?ub" by (auto!)
   hence "0 \<le> ?lb" and "0 \<le> ?ub" and "?ub \<noteq> 0" by (auto!)
-  have "Ifloat (floor_fl (float_divl prec x ub)) * ?lb \<le> ?x / ?ub * ?lb" by (metis mult_right_mono order_trans `0 \<le> ?lb` `?lb \<le> ?ub` float_divl floor_fl)
+  have "real (floor_fl (float_divl prec x ub)) * ?lb \<le> ?x / ?ub * ?lb" by (metis mult_right_mono order_trans `0 \<le> ?lb` `?lb \<le> ?ub` float_divl floor_fl)
   also have "\<dots> \<le> ?x" by (metis mult_left_mono[OF `?lb \<le> ?ub` `0 \<le> ?x`] divide_right_mono[OF _ `0 \<le> ?ub` ] times_divide_eq_left nonzero_mult_divide_cancel_right[OF `?ub \<noteq> 0`])
   also have "\<dots> \<le> ?k * y" using assms by auto
-  finally show ?thesis unfolding ub_mod_def Ifloat_sub Ifloat_mult by auto
+  finally show ?thesis unfolding ub_mod_def real_of_float_sub real_of_float_mult by auto
 qed
 
 lemma le_float_def': "f \<le> g = (case f - g of Float a b \<Rightarrow> a \<le> 0)"
 proof -
-  have le_transfer: "(f \<le> g) = (Ifloat (f - g) \<le> 0)" by (auto simp add: le_float_def)
+  have le_transfer: "(f \<le> g) = (real (f - g) \<le> 0)" by (auto simp add: le_float_def)
   from float_split[of "f - g"] obtain a b where f_diff_g: "f - g = Float a b" by auto
-  with le_transfer have le_transfer': "f \<le> g = (Ifloat (Float a b) \<le> 0)" by simp
+  with le_transfer have le_transfer': "f \<le> g = (real (Float a b) \<le> 0)" by simp
   show ?thesis by (simp add: le_transfer' f_diff_g float_le_zero)
 qed
 
 lemma float_less_zero:
-  "(Ifloat (Float a b) < 0) = (a < 0)"
-  apply (auto simp add: mult_less_0_iff Ifloat.simps)
+  "(real (Float a b) < 0) = (a < 0)"
+  apply (auto simp add: mult_less_0_iff real_of_float_simp)
   done
 
 lemma less_float_def': "f < g = (case f - g of Float a b \<Rightarrow> a < 0)"
 proof -
-  have less_transfer: "(f < g) = (Ifloat (f - g) < 0)" by (auto simp add: less_float_def)
+  have less_transfer: "(f < g) = (real (f - g) < 0)" by (auto simp add: less_float_def)
   from float_split[of "f - g"] obtain a b where f_diff_g: "f - g = Float a b" by auto
-  with less_transfer have less_transfer': "f < g = (Ifloat (Float a b) < 0)" by simp
+  with less_transfer have less_transfer': "f < g = (real (Float a b) < 0)" by simp
   show ?thesis by (simp add: less_transfer' f_diff_g float_less_zero)
 qed
 

--- a/src/HOL/Library/Formal_Power_Series.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Library/Formal_Power_Series.thy	Fri May 15 15:56:28 2009 +0200
@@ -680,30 +680,12 @@
 
 subsection {* Powers*}
 
-instantiation fps :: (semiring_1) power
-begin
-
-fun fps_pow :: "nat \<Rightarrow> 'a fps \<Rightarrow> 'a fps" where
-  "fps_pow 0 f = 1"
-| "fps_pow (Suc n) f = f * fps_pow n f"
-
-definition fps_power_def: "power (f::'a fps) n = fps_pow n f"
-instance ..
-end
-
-instantiation fps :: (comm_ring_1) recpower
-begin
-instance
-  apply (intro_classes)
-  by (simp_all add: fps_power_def)
-end
-
 lemma fps_power_zeroth_eq_one: "a$0 =1 \<Longrightarrow> a^n $ 0 = (1::'a::semiring_1)"
-  by (induct n, auto simp add: fps_power_def expand_fps_eq fps_mult_nth)
+  by (induct n, auto simp add: expand_fps_eq fps_mult_nth)
 
 lemma fps_power_first_eq: "(a:: 'a::comm_ring_1 fps)$0 =1 \<Longrightarrow> a^n $ 1 = of_nat n * a$1"
 proof(induct n)
-  case 0 thus ?case by (simp add: fps_power_def)
+  case 0 thus ?case by simp
 next
   case (Suc n)
   note h = Suc.hyps[OF `a$0 = 1`]
@@ -712,16 +694,16 @@
 qed
 
 lemma startsby_one_power:"a $ 0 = (1::'a::comm_ring_1) \<Longrightarrow> a^n $ 0 = 1"
-  by (induct n, auto simp add: fps_power_def fps_mult_nth)
+  by (induct n, auto simp add: fps_mult_nth)
 
 lemma startsby_zero_power:"a $0 = (0::'a::comm_ring_1) \<Longrightarrow> n > 0 \<Longrightarrow> a^n $0 = 0"
-  by (induct n, auto simp add: fps_power_def fps_mult_nth)
+  by (induct n, auto simp add: fps_mult_nth)
 
-lemma startsby_power:"a $0 = (v::'a::{comm_ring_1, recpower}) \<Longrightarrow> a^n $0 = v^n"
-  by (induct n, auto simp add: fps_power_def fps_mult_nth power_Suc)
+lemma startsby_power:"a $0 = (v::'a::{comm_ring_1}) \<Longrightarrow> a^n $0 = v^n"
+  by (induct n, auto simp add: fps_mult_nth power_Suc)
 
 lemma startsby_zero_power_iff[simp]:
-  "a^n $0 = (0::'a::{idom, recpower}) \<longleftrightarrow> (n \<noteq> 0 \<and> a$0 = 0)"
+  "a^n $0 = (0::'a::{idom}) \<longleftrightarrow> (n \<noteq> 0 \<and> a$0 = 0)"
 apply (rule iffI)
 apply (induct n, auto simp add: power_Suc fps_mult_nth)
 by (rule startsby_zero_power, simp_all)
@@ -764,7 +746,7 @@
   apply (rule startsby_zero_power_prefix[rule_format, OF a0])
   by arith
 
-lemma startsby_zero_power_nth_same: assumes a0: "a$0 = (0::'a::{recpower, idom})"
+lemma startsby_zero_power_nth_same: assumes a0: "a$0 = (0::'a::{idom})"
   shows "a^n $ n = (a$1) ^ n"
 proof(induct n)
   case 0 thus ?case by (simp add: power_0)
@@ -785,7 +767,7 @@
 qed
 
 lemma fps_inverse_power:
-  fixes a :: "('a::{field, recpower}) fps"
+  fixes a :: "('a::{field}) fps"
   shows "inverse (a^n) = inverse a ^ n"
 proof-
   {assume a0: "a$0 = 0"
@@ -874,7 +856,7 @@
 
 subsection{* The eXtractor series X*}
 
-lemma minus_one_power_iff: "(- (1::'a :: {recpower, comm_ring_1})) ^ n = (if even n then 1 else - 1)"
+lemma minus_one_power_iff: "(- (1::'a :: {comm_ring_1})) ^ n = (if even n then 1 else - 1)"
   by (induct n, auto)
 
 definition "X = Abs_fps (\<lambda>n. if n = 1 then 1 else 0)"
@@ -901,7 +883,7 @@
 
 lemma X_power_iff: "X^k = Abs_fps (\<lambda>n. if n = k then (1::'a::comm_ring_1) else 0)"
 proof(induct k)
-  case 0 thus ?case by (simp add: X_def fps_power_def fps_eq_iff)
+  case 0 thus ?case by (simp add: X_def fps_eq_iff)
 next
   case (Suc k)
   {fix m
@@ -931,12 +913,11 @@
   by (simp add: X_power_iff)
 
 lemma fps_inverse_X_plus1:
-  "inverse (1 + X) = Abs_fps (\<lambda>n. (- (1::'a::{recpower, field})) ^ n)" (is "_ = ?r")
+  "inverse (1 + X) = Abs_fps (\<lambda>n. (- (1::'a::{field})) ^ n)" (is "_ = ?r")
 proof-
   have eq: "(1 + X) * ?r = 1"
     unfolding minus_one_power_iff
-    apply (auto simp add: ring_simps fps_eq_iff)
-    by presburger+
+    by (auto simp add: ring_simps fps_eq_iff)
   show ?thesis by (auto simp add: eq intro: fps_inverse_unique)
 qed
 
@@ -979,7 +960,7 @@
   (* {a_{n+k}}_0^infty Corresponds to (f - setsum (\<lambda>i. a_i * x^i))/x^h, for h>0*)
 
 lemma fps_power_mult_eq_shift:
-  "X^Suc k * Abs_fps (\<lambda>n. a (n + Suc k)) = Abs_fps a - setsum (\<lambda>i. fps_const (a i :: 'a:: field) * X^i) {0 .. k}" (is "?lhs = ?rhs")
+  "X^Suc k * Abs_fps (\<lambda>n. a (n + Suc k)) = Abs_fps a - setsum (\<lambda>i. fps_const (a i :: 'a:: comm_ring_1) * X^i) {0 .. k}" (is "?lhs = ?rhs")
 proof-
   {fix n:: nat
     have "?lhs $ n = (if n < Suc k then 0 else a n)"
@@ -990,7 +971,7 @@
     next
       case (Suc k)
       note th = Suc.hyps[symmetric]
-      have "(Abs_fps a - setsum (\<lambda>i. fps_const (a i :: 'a:: field) * X^i) {0 .. Suc k})$n = (Abs_fps a - setsum (\<lambda>i. fps_const (a i :: 'a:: field) * X^i) {0 .. k} - fps_const (a (Suc k)) * X^ Suc k) $ n" by (simp add: ring_simps)
+      have "(Abs_fps a - setsum (\<lambda>i. fps_const (a i :: 'a) * X^i) {0 .. Suc k})$n = (Abs_fps a - setsum (\<lambda>i. fps_const (a i :: 'a) * X^i) {0 .. k} - fps_const (a (Suc k)) * X^ Suc k) $ n" by (simp add: ring_simps)
       also  have "\<dots> = (if n < Suc k then 0 else a n) - (fps_const (a (Suc k)) * X^ Suc k)$n"
 	using th
 	unfolding fps_sub_nth by simp
@@ -1022,13 +1003,16 @@
 lemma XD_linear[simp]: "XD (fps_const c * a + fps_const d * b) = fps_const c * XD a + fps_const d * XD (b :: ('a::comm_ring_1) fps)"
   by simp
 
-lemma XDN_linear: "(XD^n) (fps_const c * a + fps_const d * b) = fps_const c * (XD^n) a + fps_const d * (XD^n) (b :: ('a::comm_ring_1) fps)"
+lemma XDN_linear:
+  "(XD ^^ n) (fps_const c * a + fps_const d * b) = fps_const c * (XD ^^ n) a + fps_const d * (XD ^^ n) (b :: ('a::comm_ring_1) fps)"
   by (induct n, simp_all)
 
 lemma fps_mult_X_deriv_shift: "X* fps_deriv a = Abs_fps (\<lambda>n. of_nat n* a$n)" by (simp add: fps_eq_iff)
 
-lemma fps_mult_XD_shift: "(XD ^k) (a:: ('a::{comm_ring_1, recpower, ring_char_0}) fps) = Abs_fps (\<lambda>n. (of_nat n ^ k) * a$n)"
-by (induct k arbitrary: a) (simp_all add: power_Suc XD_def fps_eq_iff ring_simps del: One_nat_def)
+
+lemma fps_mult_XD_shift:
+  "(XD ^^ k) (a:: ('a::{comm_ring_1}) fps) = Abs_fps (\<lambda>n. (of_nat n ^ k) * a$n)"
+  by (induct k arbitrary: a) (simp_all add: power_Suc XD_def fps_eq_iff ring_simps del: One_nat_def)
 
 subsubsection{* Rule 3 is trivial and is given by @{text fps_times_def}*}
 subsubsection{* Rule 5 --- summation and "division" by (1 - X)*}
@@ -1309,7 +1293,7 @@
   by (cases m, simp_all add: fps_power_nth_Suc del: power_Suc)
 
 lemma fps_nth_power_0:
-  fixes m :: nat and a :: "('a::{comm_ring_1, recpower}) fps"
+  fixes m :: nat and a :: "('a::{comm_ring_1}) fps"
   shows "(a ^m)$0 = (a$0) ^ m"
 proof-
   {assume "m=0" hence ?thesis by simp}
@@ -1325,7 +1309,7 @@
 qed
 
 lemma fps_compose_inj_right:
-  assumes a0: "a$0 = (0::'a::{recpower,idom})"
+  assumes a0: "a$0 = (0::'a::{idom})"
   and a1: "a$1 \<noteq> 0"
   shows "(b oo a = c oo a) \<longleftrightarrow> b = c" (is "?lhs \<longleftrightarrow>?rhs")
 proof-
@@ -1366,7 +1350,7 @@
 subsection {* Radicals *}
 
 declare setprod_cong[fundef_cong]
-function radical :: "(nat \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> ('a::{field, recpower}) fps \<Rightarrow> nat \<Rightarrow> 'a" where
+function radical :: "(nat \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> ('a::{field}) fps \<Rightarrow> nat \<Rightarrow> 'a" where
   "radical r 0 a 0 = 1"
 | "radical r 0 a (Suc n) = 0"
 | "radical r (Suc k) a 0 = r (Suc k) (a$0)"
@@ -1454,7 +1438,68 @@
 qed
 
 lemma power_radical:
-  fixes a:: "'a ::{field, ring_char_0, recpower} fps"
+  fixes a:: "'a ::{field, ring_char_0} fps"
+  assumes a0: "a$0 \<noteq> 0"
+  shows "(r (Suc k) (a$0)) ^ Suc k = a$0 \<longleftrightarrow> (fps_radical r (Suc k) a) ^ (Suc k) = a"
+proof-
+  let ?r = "fps_radical r (Suc k) a"
+  {assume r0: "(r (Suc k) (a$0)) ^ Suc k = a$0"
+    from a0 r0 have r00: "r (Suc k) (a$0) \<noteq> 0" by auto
+    {fix z have "?r ^ Suc k $ z = a$z"
+      proof(induct z rule: nat_less_induct)
+	fix n assume H: "\<forall>m<n. ?r ^ Suc k $ m = a$m"
+	{assume "n = 0" hence "?r ^ Suc k $ n = a $n"
+	    using fps_radical_power_nth[of r "Suc k" a, OF r0] by simp}
+	moreover
+	{fix n1 assume n1: "n = Suc n1"
+	  have fK: "finite {0..k}" by simp
+	  have nz: "n \<noteq> 0" using n1 by arith
+	  let ?Pnk = "natpermute n (k + 1)"
+	  let ?Pnkn = "{xs \<in> ?Pnk. n \<in> set xs}"
+	  let ?Pnknn = "{xs \<in> ?Pnk. n \<notin> set xs}"
+	  have eq: "?Pnkn \<union> ?Pnknn = ?Pnk" by blast
+	  have d: "?Pnkn \<inter> ?Pnknn = {}" by blast
+	  have f: "finite ?Pnkn" "finite ?Pnknn"
+	    using finite_Un[of ?Pnkn ?Pnknn, unfolded eq]
+	    by (metis natpermute_finite)+
+	  let ?f = "\<lambda>v. \<Prod>j\<in>{0..k}. ?r $ v ! j"
+	  have "setsum ?f ?Pnkn = setsum (\<lambda>v. ?r $ n * r (Suc k) (a $ 0) ^ k) ?Pnkn"
+	  proof(rule setsum_cong2)
+	    fix v assume v: "v \<in> {xs \<in> natpermute n (k + 1). n \<in> set xs}"
+	    let ?ths = "(\<Prod>j\<in>{0..k}. fps_radical r (Suc k) a $ v ! j) = fps_radical r (Suc k) a $ n * r (Suc k) (a $ 0) ^ k"
+	  from v obtain i where i: "i \<in> {0..k}" "v = replicate (k+1) 0 [i:= n]"
+	    unfolding natpermute_contain_maximal by auto
+	  have "(\<Prod>j\<in>{0..k}. fps_radical r (Suc k) a $ v ! j) = (\<Prod>j\<in>{0..k}. if j = i then fps_radical r (Suc k) a $ n else r (Suc k) (a$0))"
+	    apply (rule setprod_cong, simp)
+	    using i r0 by (simp del: replicate.simps)
+	  also have "\<dots> = (fps_radical r (Suc k) a $ n) * r (Suc k) (a$0) ^ k"
+	    unfolding setprod_gen_delta[OF fK] using i r0 by simp
+	  finally show ?ths .
+	qed
+	then have "setsum ?f ?Pnkn = of_nat (k+1) * ?r $ n * r (Suc k) (a $ 0) ^ k"
+	  by (simp add: natpermute_max_card[OF nz, simplified])
+	also have "\<dots> = a$n - setsum ?f ?Pnknn"
+	  unfolding n1 using r00 a0 by (simp add: field_simps fps_radical_def del: of_nat_Suc )
+	finally have fn: "setsum ?f ?Pnkn = a$n - setsum ?f ?Pnknn" .
+	have "(?r ^ Suc k)$n = setsum ?f ?Pnkn + setsum ?f ?Pnknn"
+	  unfolding fps_power_nth_Suc setsum_Un_disjoint[OF f d, unfolded eq] ..
+	also have "\<dots> = a$n" unfolding fn by simp
+	finally have "?r ^ Suc k $ n = a $n" .}
+      ultimately  show "?r ^ Suc k $ n = a $n" by (cases n, auto)
+    qed }
+  then have ?thesis using r0 by (simp add: fps_eq_iff)}
+moreover 
+{ assume h: "(fps_radical r (Suc k) a) ^ (Suc k) = a"
+  hence "((fps_radical r (Suc k) a) ^ (Suc k))$0 = a$0" by simp
+  then have "(r (Suc k) (a$0)) ^ Suc k = a$0"
+    unfolding fps_power_nth_Suc
+    by (simp add: setprod_constant del: replicate.simps)}
+ultimately show ?thesis by blast
+qed
+
+(*
+lemma power_radical:
+  fixes a:: "'a ::{field, ring_char_0} fps"
   assumes r0: "(r (Suc k) (a$0)) ^ Suc k = a$0" and a0: "a$0 \<noteq> 0"
   shows "(fps_radical r (Suc k) a) ^ (Suc k) = a"
 proof-
@@ -1505,6 +1550,7 @@
   then show ?thesis by (simp add: fps_eq_iff)
 qed
 
+*)
 lemma eq_divide_imp': assumes c0: "(c::'a::field) ~= 0" and eq: "a * c = b"
   shows "a = b / c"
 proof-
@@ -1515,16 +1561,15 @@
 
 lemma radical_unique:
   assumes r0: "(r (Suc k) (b$0)) ^ Suc k = b$0"
-  and a0: "r (Suc k) (b$0 ::'a::{field, ring_char_0, recpower}) = a$0" and b0: "b$0 \<noteq> 0"
+  and a0: "r (Suc k) (b$0 ::'a::{field, ring_char_0}) = a$0" and b0: "b$0 \<noteq> 0"
   shows "a^(Suc k) = b \<longleftrightarrow> a = fps_radical r (Suc k) b"
 proof-
   let ?r = "fps_radical r (Suc k) b"
   have r00: "r (Suc k) (b$0) \<noteq> 0" using b0 r0 by auto
   {assume H: "a = ?r"
-    from H have "a^Suc k = b" using power_radical[of r k, OF r0 b0] by simp}
+    from H have "a^Suc k = b" using power_radical[OF b0, of r k, unfolded r0] by simp}
   moreover
   {assume H: "a^Suc k = b"
-    (* Generally a$0 would need to be the k+1 st root of b$0 *)
     have ceq: "card {0..k} = Suc k" by simp
     have fk: "finite {0..k}" by simp
     from a0 have a0r0: "a$0 = ?r$0" by simp
@@ -1610,7 +1655,7 @@
 
 lemma radical_power:
   assumes r0: "r (Suc k) ((a$0) ^ Suc k) = a$0"
-  and a0: "(a$0 ::'a::{field, ring_char_0, recpower}) \<noteq> 0"
+  and a0: "(a$0 ::'a::{field, ring_char_0}) \<noteq> 0"
   shows "(fps_radical r (Suc k) (a ^ Suc k)) = a"
 proof-
   let ?ak = "a^ Suc k"
@@ -1622,7 +1667,7 @@
 qed
 
 lemma fps_deriv_radical:
-  fixes a:: "'a ::{field, ring_char_0, recpower} fps"
+  fixes a:: "'a ::{field, ring_char_0} fps"
   assumes r0: "(r (Suc k) (a$0)) ^ Suc k = a$0" and a0: "a$0 \<noteq> 0"
   shows "fps_deriv (fps_radical r (Suc k) a) = fps_deriv a / (fps_const (of_nat (Suc k)) * (fps_radical r (Suc k) a) ^ k)"
 proof-
@@ -1632,7 +1677,7 @@
   from r0' have w0: "?w $ 0 \<noteq> 0" by (simp del: of_nat_Suc)
   note th0 = inverse_mult_eq_1[OF w0]
   let ?iw = "inverse ?w"
-  from power_radical[of r, OF r0 a0]
+  from iffD1[OF power_radical[of a r], OF a0 r0]
   have "fps_deriv (?r ^ Suc k) = fps_deriv a" by simp
   hence "fps_deriv ?r * ?w = fps_deriv a"
     by (simp add: fps_deriv_power mult_ac del: power_Suc)
@@ -1643,11 +1688,45 @@
 qed
 
 lemma radical_mult_distrib:
-  fixes a:: "'a ::{field, ring_char_0, recpower} fps"
+  fixes a:: "'a ::{field, ring_char_0} fps"
   assumes
-  ra0: "r (k) (a $ 0) ^ k = a $ 0"
-  and rb0: "r (k) (b $ 0) ^ k = b $ 0"
-  and r0': "r (k) ((a * b) $ 0) = r (k) (a $ 0) * r (k) (b $ 0)"
+  k: "k > 0"
+  and ra0: "r k (a $ 0) ^ k = a $ 0"
+  and rb0: "r k (b $ 0) ^ k = b $ 0"
+  and a0: "a$0 \<noteq> 0"
+  and b0: "b$0 \<noteq> 0"
+  shows "r k ((a * b) $ 0) = r k (a $ 0) * r k (b $ 0) \<longleftrightarrow> fps_radical r (k) (a*b) = fps_radical r (k) a * fps_radical r (k) (b)"
+proof-
+  {assume  r0': "r k ((a * b) $ 0) = r k (a $ 0) * r k (b $ 0)"
+  from r0' have r0: "(r (k) ((a*b)$0)) ^ k = (a*b)$0"
+    by (simp add: fps_mult_nth ra0 rb0 power_mult_distrib)
+  {assume "k=0" hence ?thesis using r0' by simp}
+  moreover
+  {fix h assume k: "k = Suc h"
+  let ?ra = "fps_radical r (Suc h) a"
+  let ?rb = "fps_radical r (Suc h) b"
+  have th0: "r (Suc h) ((a * b) $ 0) = (fps_radical r (Suc h) a * fps_radical r (Suc h) b) $ 0"
+    using r0' k by (simp add: fps_mult_nth)
+  have ab0: "(a*b) $ 0 \<noteq> 0" using a0 b0 by (simp add: fps_mult_nth)
+  from radical_unique[of r h "a*b" "fps_radical r (Suc h) a * fps_radical r (Suc h) b", OF r0[unfolded k] th0 ab0, symmetric]
+    iffD1[OF power_radical[of _ r], OF a0 ra0[unfolded k]] iffD1[OF power_radical[of _ r], OF b0 rb0[unfolded k]] k r0'
+  have ?thesis by (auto simp add: power_mult_distrib simp del: power_Suc)}
+ultimately have ?thesis by (cases k, auto)}
+moreover
+{assume h: "fps_radical r k (a*b) = fps_radical r k a * fps_radical r k b"
+  hence "(fps_radical r k (a*b))$0 = (fps_radical r k a * fps_radical r k b)$0" by simp
+  then have "r k ((a * b) $ 0) = r k (a $ 0) * r k (b $ 0)"
+    using k by (simp add: fps_mult_nth)}
+ultimately show ?thesis by blast
+qed
+
+(*
+lemma radical_mult_distrib:
+  fixes a:: "'a ::{field, ring_char_0} fps"
+  assumes
+  ra0: "r k (a $ 0) ^ k = a $ 0"
+  and rb0: "r k (b $ 0) ^ k = b $ 0"
+  and r0': "r k ((a * b) $ 0) = r k (a $ 0) * r k (b $ 0)"
   and a0: "a$0 \<noteq> 0"
   and b0: "b$0 \<noteq> 0"
   shows "fps_radical r (k) (a*b) = fps_radical r (k) a * fps_radical r (k) (b)"
@@ -1667,88 +1746,60 @@
   have ?thesis by (auto simp add: power_mult_distrib simp del: power_Suc)}
 ultimately show ?thesis by (cases k, auto)
 qed
+*)
 
-lemma radical_inverse:
-  fixes a:: "'a ::{field, ring_char_0, recpower} fps"
-  assumes
-  ra0: "r (k) (a $ 0) ^ k = a $ 0"
-  and ria0: "r (k) (inverse (a $ 0)) = inverse (r (k) (a $ 0))"
-  and r1: "(r (k) 1) = 1"
-  and a0: "a$0 \<noteq> 0"
-  shows "fps_radical r (k) (inverse a) = inverse (fps_radical r (k) a)"
-proof-
-  {assume "k=0" then have ?thesis by simp}
-  moreover
-  {fix h assume k[simp]: "k = Suc h"
-    let ?ra = "fps_radical r (Suc h) a"
-    let ?ria = "fps_radical r (Suc h) (inverse a)"
-    from ra0 a0 have th00: "r (Suc h) (a$0) \<noteq> 0" by auto
-    have ria0': "r (Suc h) (inverse a $ 0) ^ Suc h = inverse a$0"
-    using ria0 ra0 a0
-    by (simp add: fps_inverse_def  nonzero_power_inverse[OF th00, symmetric]
-             del: power_Suc)
-  from inverse_mult_eq_1[OF a0] have th0: "a * inverse a = 1"
-    by (simp add: mult_commute)
-  from radical_unique[where a=1 and b=1 and r=r and k=h, simplified, OF r1[unfolded k]]
-  have th01: "fps_radical r (Suc h) 1 = 1" .
-  have th1: "r (Suc h) ((a * inverse a) $ 0) ^ Suc h = (a * inverse a) $ 0"
-    "r (Suc h) ((a * inverse a) $ 0) =
-r (Suc h) (a $ 0) * r (Suc h) (inverse a $ 0)"
-    using r1 unfolding th0  apply (simp_all add: ria0[symmetric])
-    apply (simp add: fps_inverse_def a0)
-    unfolding ria0[unfolded k]
-    using th00 by simp
-  from nonzero_imp_inverse_nonzero[OF a0] a0
-  have th2: "inverse a $ 0 \<noteq> 0" by (simp add: fps_inverse_def)
-  from radical_mult_distrib[of r "Suc h" a "inverse a", OF ra0[unfolded k] ria0' th1(2) a0 th2]
-  have th3: "?ra * ?ria = 1" unfolding th0 th01 by simp
-  from th00 have ra0: "?ra $ 0 \<noteq> 0" by simp
-  from fps_inverse_unique[OF ra0 th3] have ?thesis by simp}
-ultimately show ?thesis by (cases k, auto)
-qed
-
-lemma fps_divide_inverse: "(a::('a::field) fps) / b = a * inverse b"
+lemma fps_divide_1[simp]: "(a:: ('a::field) fps) / 1 = a"
   by (simp add: fps_divide_def)
 
 lemma radical_divide:
-  fixes a:: "'a ::{field, ring_char_0, recpower} fps"
+  fixes a:: "'a ::{field, ring_char_0} fps"
   assumes
-      ra0: "r k (a $ 0) ^ k = a $ 0"
-  and rb0: "r k (b $ 0) ^ k = b $ 0"
-  and r1: "r k 1 = 1"
-  and rb0': "r k (inverse (b $ 0)) = inverse (r k (b $ 0))"
-  and raib': "r k (a$0 / (b$0)) = r k (a$0) / r k (b$0)"
+  kp: "k>0"
+  and ra0: "(r k (a $ 0)) ^ k = a $ 0"
+  and rb0: "(r k (b $ 0)) ^ k = b $ 0"
   and a0: "a$0 \<noteq> 0"
   and b0: "b$0 \<noteq> 0"
-  shows "fps_radical r k (a/b) = fps_radical r k a / fps_radical r k b"
+  shows "r k ((a $ 0) / (b$0)) = r k (a$0) / r k (b $ 0) \<longleftrightarrow> fps_radical r k (a/b) = fps_radical r k a / fps_radical r k b" (is "?lhs = ?rhs")
 proof-
-  from raib'
-  have raib: "r k (a$0 / (b$0)) = r k (a$0) * r k (inverse (b$0))"
-    by (simp add: divide_inverse rb0'[symmetric])
-
-  {assume "k=0" hence ?thesis by (simp add: fps_divide_def)}
-  moreover
-  {assume k0: "k\<noteq> 0"
-    from b0 k0 rb0 have rbn0: "r k (b $0) \<noteq> 0"
-      by (auto simp add: power_0_left)
+  let ?r = "fps_radical r k"
+  from kp obtain h where k: "k = Suc h" by (cases k, auto)
+  have ra0': "r k (a$0) \<noteq> 0" using a0 ra0 k by auto
+  have rb0': "r k (b$0) \<noteq> 0" using b0 rb0 k by auto
 
-    from rb0 rb0' have rib0: "(r k (inverse (b $ 0)))^k = inverse (b$0)"
-    by (simp add: nonzero_power_inverse[OF rbn0, symmetric])
-  from rib0 have th0: "r k (inverse b $ 0) ^ k = inverse b $ 0"
-    by (simp add:fps_inverse_def b0)
-  from raib
-  have th1: "r k ((a * inverse b) $ 0) = r k (a $ 0) * r k (inverse b $ 0)"
-    by (simp add: divide_inverse fps_inverse_def  b0 fps_mult_nth)
-  from nonzero_imp_inverse_nonzero[OF b0] b0 have th2: "inverse b $ 0 \<noteq> 0"
-    by (simp add: fps_inverse_def)
-  from radical_mult_distrib[of r k a "inverse b", OF ra0 th0 th1 a0 th2]
-  have th: "fps_radical r k (a/b) = fps_radical r k a * fps_radical r k (inverse b)"
-    by (simp add: fps_divide_def)
-  with radical_inverse[of r k b, OF rb0 rb0' r1 b0]
-  have ?thesis by (simp add: fps_divide_def)}
-ultimately show ?thesis by blast
+  {assume ?rhs
+    then have "?r (a/b) $ 0 = (?r a / ?r b)$0" by simp
+    then have ?lhs using k a0 b0 rb0' 
+      by (simp add: fps_divide_def fps_mult_nth fps_inverse_def divide_inverse) }
+  moreover
+  {assume h: ?lhs
+    from a0 b0 have ab0[simp]: "(a/b)$0 = a$0 / b$0" 
+      by (simp add: fps_divide_def fps_mult_nth divide_inverse fps_inverse_def)
+    have th0: "r k ((a/b)$0) ^ k = (a/b)$0"
+      by (simp add: h nonzero_power_divide[OF rb0'] ra0 rb0 del: k)
+    from a0 b0 ra0' rb0' kp h 
+    have th1: "r k ((a / b) $ 0) = (fps_radical r k a / fps_radical r k b) $ 0"
+      by (simp add: fps_divide_def fps_mult_nth fps_inverse_def divide_inverse del: k)
+    from a0 b0 ra0' rb0' kp have ab0': "(a / b) $ 0 \<noteq> 0"
+      by (simp add: fps_divide_def fps_mult_nth fps_inverse_def nonzero_imp_inverse_nonzero)
+    note tha[simp] = iffD1[OF power_radical[where r=r and k=h], OF a0 ra0[unfolded k], unfolded k[symmetric]]
+    note thb[simp] = iffD1[OF power_radical[where r=r and k=h], OF b0 rb0[unfolded k], unfolded k[symmetric]]
+    have th2: "(?r a / ?r b)^k = a/b"
+      by (simp add: fps_divide_def power_mult_distrib fps_inverse_power[symmetric])
+    from iffD1[OF radical_unique[where r=r and a="?r a / ?r b" and b="a/b" and k=h], symmetric, unfolded k[symmetric], OF th0 th1 ab0' th2] have ?rhs .}
+  ultimately show ?thesis by blast
 qed
 
+lemma radical_inverse:
+  fixes a:: "'a ::{field, ring_char_0} fps"
+  assumes
+  k: "k>0"
+  and ra0: "r k (a $ 0) ^ k = a $ 0"
+  and r1: "(r k 1)^k = 1"
+  and a0: "a$0 \<noteq> 0"
+  shows "r k (inverse (a $ 0)) = r k 1 / (r k (a $ 0)) \<longleftrightarrow> fps_radical r k (inverse a) = fps_radical r k 1 / fps_radical r k a"
+  using radical_divide[where k=k and r=r and a=1 and b=a, OF k ] ra0 r1 a0
+  by (simp add: divide_inverse fps_divide_def)
+
 subsection{* Derivative of composition *}
 
 lemma fps_compose_deriv:
@@ -1831,7 +1882,7 @@
 subsection{* Compositional inverses *}
 
 
-fun compinv :: "'a fps \<Rightarrow> nat \<Rightarrow> 'a::{recpower,field}" where
+fun compinv :: "'a fps \<Rightarrow> nat \<Rightarrow> 'a::{field}" where
   "compinv a 0 = X$0"
 | "compinv a (Suc n) = (X$ Suc n - setsum (\<lambda>i. (compinv a i) * (a^i)$Suc n) {0 .. n}) / (a$1) ^ Suc n"
 
@@ -1862,7 +1913,7 @@
 qed
 
 
-fun gcompinv :: "'a fps \<Rightarrow> 'a fps \<Rightarrow> nat \<Rightarrow> 'a::{recpower,field}" where
+fun gcompinv :: "'a fps \<Rightarrow> 'a fps \<Rightarrow> nat \<Rightarrow> 'a::{field}" where
   "gcompinv b a 0 = b$0"
 | "gcompinv b a (Suc n) = (b$ Suc n - setsum (\<lambda>i. (gcompinv b a i) * (a^i)$Suc n) {0 .. n}) / (a$1) ^ Suc n"
 
@@ -1901,19 +1952,16 @@
   done
 
 lemma fps_compose_1[simp]: "1 oo a = 1"
-  by (simp add: fps_eq_iff fps_compose_nth fps_power_def mult_delta_left setsum_delta)
+  by (simp add: fps_eq_iff fps_compose_nth mult_delta_left setsum_delta)
 
 lemma fps_compose_0[simp]: "0 oo a = 0"
   by (simp add: fps_eq_iff fps_compose_nth)
 
-lemma fps_pow_0: "fps_pow n 0 = (if n = 0 then 1 else 0)"
-  by (induct n, simp_all)
-
 lemma fps_compose_0_right[simp]: "a oo 0 = fps_const (a$0)"
-  by (auto simp add: fps_eq_iff fps_compose_nth fps_power_def fps_pow_0 setsum_0')
+  by (auto simp add: fps_eq_iff fps_compose_nth power_0_left setsum_0')
 
 lemma fps_compose_add_distrib: "(a + b) oo c = (a oo c) + (b oo c)"
-  by (simp add: fps_eq_iff fps_compose_nth  ring_simps setsum_addf)
+  by (simp add: fps_eq_iff fps_compose_nth ring_simps setsum_addf)
 
 lemma fps_compose_setsum_distrib: "(setsum f S) oo a = setsum (\<lambda>i. f i oo a) S"
 proof-
@@ -2118,7 +2166,7 @@
 qed
 
 lemma fps_inv_deriv:
-  assumes a0:"a$0 = (0::'a::{recpower,field})" and a1: "a$1 \<noteq> 0"
+  assumes a0:"a$0 = (0::'a::{field})" and a1: "a$1 \<noteq> 0"
   shows "fps_deriv (fps_inv a) = inverse (fps_deriv a oo fps_inv a)"
 proof-
   let ?ia = "fps_inv a"
@@ -2138,7 +2186,7 @@
 subsubsection{* Exponential series *}
 definition "E x = Abs_fps (\<lambda>n. x^n / of_nat (fact n))"
 
-lemma E_deriv[simp]: "fps_deriv (E a) = fps_const (a::'a::{field, recpower, ring_char_0}) * E a" (is "?l = ?r")
+lemma E_deriv[simp]: "fps_deriv (E a) = fps_const (a::'a::{field, ring_char_0}) * E a" (is "?l = ?r")
 proof-
   {fix n
     have "?l$n = ?r $ n"
@@ -2148,7 +2196,7 @@
 qed
 
 lemma E_unique_ODE:
-  "fps_deriv a = fps_const c * a \<longleftrightarrow> a = fps_const (a$0) * E (c :: 'a::{field, ring_char_0, recpower})"
+  "fps_deriv a = fps_const c * a \<longleftrightarrow> a = fps_const (a$0) * E (c :: 'a::{field, ring_char_0})"
   (is "?lhs \<longleftrightarrow> ?rhs")
 proof-
   {assume d: ?lhs
@@ -2175,7 +2223,7 @@
 ultimately show ?thesis by blast
 qed
 
-lemma E_add_mult: "E (a + b) = E (a::'a::{ring_char_0, field, recpower}) * E b" (is "?l = ?r")
+lemma E_add_mult: "E (a + b) = E (a::'a::{ring_char_0, field}) * E b" (is "?l = ?r")
 proof-
   have "fps_deriv (?r) = fps_const (a+b) * ?r"
     by (simp add: fps_const_add[symmetric] ring_simps del: fps_const_add)
@@ -2187,10 +2235,10 @@
 lemma E_nth[simp]: "E a $ n = a^n / of_nat (fact n)"
   by (simp add: E_def)
 
-lemma E0[simp]: "E (0::'a::{field, recpower}) = 1"
+lemma E0[simp]: "E (0::'a::{field}) = 1"
   by (simp add: fps_eq_iff power_0_left)
 
-lemma E_neg: "E (- a) = inverse (E (a::'a::{ring_char_0, field, recpower}))"
+lemma E_neg: "E (- a) = inverse (E (a::'a::{ring_char_0, field}))"
 proof-
   from E_add_mult[of a "- a"] have th0: "E a * E (- a) = 1"
     by (simp )
@@ -2198,7 +2246,7 @@
   from fps_inverse_unique[OF th1 th0] show ?thesis by simp
 qed
 
-lemma E_nth_deriv[simp]: "fps_nth_deriv n (E (a::'a::{field, recpower, ring_char_0})) = (fps_const a)^n * (E a)"
+lemma E_nth_deriv[simp]: "fps_nth_deriv n (E (a::'a::{field, ring_char_0})) = (fps_const a)^n * (E a)"
   by (induct n, auto simp add: power_Suc)
 
 lemma fps_compose_uminus: "- (a::'a::ring_1 fps) oo c = - (a oo c)"
@@ -2211,7 +2259,7 @@
 lemma X_fps_compose:"X oo a = Abs_fps (\<lambda>n. if n = 0 then (0::'a::comm_ring_1) else a$n)"
   by (simp add: fps_eq_iff fps_compose_nth mult_delta_left setsum_delta power_Suc)
 
-lemma X_compose_E[simp]: "X oo E (a::'a::{field, recpower}) = E a - 1"
+lemma X_compose_E[simp]: "X oo E (a::'a::{field}) = E a - 1"
   by (simp add: fps_eq_iff X_fps_compose)
 
 lemma LE_compose:
@@ -2233,22 +2281,20 @@
 
 
 lemma inverse_one_plus_X:
-  "inverse (1 + X) = Abs_fps (\<lambda>n. (- 1 ::'a::{field, recpower})^n)"
+  "inverse (1 + X) = Abs_fps (\<lambda>n. (- 1 ::'a::{field})^n)"
   (is "inverse ?l = ?r")
 proof-
   have th: "?l * ?r = 1"
-    apply (auto simp add: ring_simps fps_eq_iff X_mult_nth  minus_one_power_iff)
-    apply presburger+
-    done
+    by (auto simp add: ring_simps fps_eq_iff minus_one_power_iff)
   have th': "?l $ 0 \<noteq> 0" by (simp add: )
   from fps_inverse_unique[OF th' th] show ?thesis .
 qed
 
-lemma E_power_mult: "(E (c::'a::{field,recpower,ring_char_0}))^n = E (of_nat n * c)"
+lemma E_power_mult: "(E (c::'a::{field,ring_char_0}))^n = E (of_nat n * c)"
   by (induct n, auto simp add: ring_simps E_add_mult power_Suc)
 
 subsubsection{* Logarithmic series *}
-definition "(L::'a::{field, ring_char_0,recpower} fps)
+definition "(L::'a::{field, ring_char_0} fps)
   = Abs_fps (\<lambda>n. (- 1) ^ Suc n / of_nat n)"
 
 lemma fps_deriv_L: "fps_deriv L = inverse (1 + X)"
@@ -2259,7 +2305,7 @@
   by (simp add: L_def)
 
 lemma L_E_inv:
-  assumes a: "a\<noteq> (0::'a::{field,division_by_zero,ring_char_0,recpower})"
+  assumes a: "a\<noteq> (0::'a::{field,division_by_zero,ring_char_0})"
   shows "L = fps_const a * fps_inv (E a - 1)" (is "?l = ?r")
 proof-
   let ?b = "E a - 1"
@@ -2283,10 +2329,10 @@
 
 subsubsection{* Formal trigonometric functions  *}
 
-definition "fps_sin (c::'a::{field, recpower, ring_char_0}) =
+definition "fps_sin (c::'a::{field, ring_char_0}) =
   Abs_fps (\<lambda>n. if even n then 0 else (- 1) ^((n - 1) div 2) * c^n /(of_nat (fact n)))"
 
-definition "fps_cos (c::'a::{field, recpower, ring_char_0}) = Abs_fps (\<lambda>n. if even n then (- 1) ^ (n div 2) * c^n / (of_nat (fact n)) else 0)"
+definition "fps_cos (c::'a::{field, ring_char_0}) = Abs_fps (\<lambda>n. if even n then (- 1) ^ (n div 2) * c^n / (of_nat (fact n)) else 0)"
 
 lemma fps_sin_deriv:
   "fps_deriv (fps_sin c) = fps_const c * fps_cos c"
@@ -2341,11 +2387,11 @@
 proof-
   have "fps_deriv ?lhs = 0"
     apply (simp add:  fps_deriv_power fps_sin_deriv fps_cos_deriv power_Suc)
-    by (simp add: fps_power_def ring_simps fps_const_neg[symmetric] del: fps_const_neg)
+    by (simp add: ring_simps fps_const_neg[symmetric] del: fps_const_neg)
   then have "?lhs = fps_const (?lhs $ 0)"
     unfolding fps_deriv_eq_0_iff .
   also have "\<dots> = 1"
-    by (auto simp add: fps_eq_iff fps_power_def numeral_2_eq_2 fps_mult_nth fps_cos_def fps_sin_def)
+    by (auto simp add: fps_eq_iff numeral_2_eq_2 fps_mult_nth fps_cos_def fps_sin_def)
   finally show ?thesis .
 qed
 

--- a/src/HOL/Library/FrechetDeriv.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Library/FrechetDeriv.thy	Fri May 15 15:56:28 2009 +0200
@@ -382,7 +382,7 @@
 subsection {* Powers *}
 
 lemma FDERIV_power_Suc:
-  fixes x :: "'a::{real_normed_algebra,recpower,comm_ring_1}"
+  fixes x :: "'a::{real_normed_algebra,comm_ring_1}"
   shows "FDERIV (\<lambda>x. x ^ Suc n) x :> (\<lambda>h. (1 + of_nat n) * x ^ n * h)"
  apply (induct n)
   apply (simp add: power_Suc FDERIV_ident)
@@ -392,7 +392,7 @@
 done
 
 lemma FDERIV_power:
-  fixes x :: "'a::{real_normed_algebra,recpower,comm_ring_1}"
+  fixes x :: "'a::{real_normed_algebra,comm_ring_1}"
   shows "FDERIV (\<lambda>x. x ^ n) x :> (\<lambda>h. of_nat n * x ^ (n - 1) * h)"
   apply (cases n)
    apply (simp add: FDERIV_const)

--- a/src/HOL/Library/Fundamental_Theorem_Algebra.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Library/Fundamental_Theorem_Algebra.thy	Fri May 15 15:56:28 2009 +0200
@@ -560,14 +560,14 @@
   done
 
 lemma poly_replicate_append:
-  "poly (monom 1 n * p) (x::'a::{recpower, comm_ring_1}) = x^n * poly p x"
+  "poly (monom 1 n * p) (x::'a::{comm_ring_1}) = x^n * poly p x"
   by (simp add: poly_monom)
 
 text {* Decomposition of polynomial, skipping zero coefficients
   after the first.  *}
 
 lemma poly_decompose_lemma:
- assumes nz: "\<not>(\<forall>z. z\<noteq>0 \<longrightarrow> poly p z = (0::'a::{recpower,idom}))"
+ assumes nz: "\<not>(\<forall>z. z\<noteq>0 \<longrightarrow> poly p z = (0::'a::{idom}))"
   shows "\<exists>k a q. a\<noteq>0 \<and> Suc (psize q + k) = psize p \<and>
                  (\<forall>z. poly p z = z^k * poly (pCons a q) z)"
 unfolding psize_def
@@ -595,7 +595,7 @@
 
 lemma poly_decompose:
   assumes nc: "~constant(poly p)"
-  shows "\<exists>k a q. a\<noteq>(0::'a::{recpower,idom}) \<and> k\<noteq>0 \<and>
+  shows "\<exists>k a q. a\<noteq>(0::'a::{idom}) \<and> k\<noteq>0 \<and>
                psize q + k + 1 = psize p \<and>
               (\<forall>z. poly p z = poly p 0 + z^k * poly (pCons a q) z)"
 using nc

--- a/src/HOL/Library/Library.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Library/Library.thy	Fri May 15 15:56:28 2009 +0200
@@ -42,6 +42,7 @@
   Pocklington
   Poly_Deriv
   Polynomial
+  Preorder
   Primes
   Product_Vector
   Quickcheck
@@ -52,6 +53,7 @@
   Reflection
   RBT
   State_Monad
+  Sum_Of_Squares
   Topology_Euclidean_Space
   Univ_Poly
   While_Combinator

--- a/src/HOL/Library/Nat_Infinity.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Library/Nat_Infinity.thy	Fri May 15 15:56:28 2009 +0200
@@ -24,6 +24,13 @@
   Infty  ("\<infinity>")
 
 
+lemma not_Infty_eq[iff]: "(x ~= Infty) = (EX i. x = Fin i)"
+by (cases x) auto
+
+lemma not_Fin_eq [iff]: "(ALL y. x ~= Fin y) = (x = Infty)"
+by (cases x) auto
+
+
 subsection {* Constructors and numbers *}
 
 instantiation inat :: "{zero, one, number}"

--- a/src/HOL/Library/Numeral_Type.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Library/Numeral_Type.thy	Fri May 15 15:56:28 2009 +0200
@@ -55,7 +55,7 @@
   unfolding UNIV_Plus_UNIV [symmetric] by (simp only: finite card_Plus)
 
 lemma card_option [simp]: "CARD('a option) = Suc CARD('a::finite)"
-  unfolding insert_None_conv_UNIV [symmetric]
+  unfolding UNIV_option_conv
   apply (subgoal_tac "(None::'a option) \<notin> range Some")
   apply (simp add: card_image)
   apply fast
@@ -154,8 +154,8 @@
 
 locale mod_type =
   fixes n :: int
-  and Rep :: "'a::{zero,one,plus,times,uminus,minus,power} \<Rightarrow> int"
-  and Abs :: "int \<Rightarrow> 'a::{zero,one,plus,times,uminus,minus,power}"
+  and Rep :: "'a::{zero,one,plus,times,uminus,minus} \<Rightarrow> int"
+  and Abs :: "int \<Rightarrow> 'a::{zero,one,plus,times,uminus,minus}"
   assumes type: "type_definition Rep Abs {0..<n}"
   and size1: "1 < n"
   and zero_def: "0 = Abs 0"
@@ -164,14 +164,13 @@
   and mult_def: "x * y = Abs ((Rep x * Rep y) mod n)"
   and diff_def: "x - y = Abs ((Rep x - Rep y) mod n)"
   and minus_def: "- x = Abs ((- Rep x) mod n)"
-  and power_def: "x ^ k = Abs (Rep x ^ k mod n)"
 begin
 
 lemma size0: "0 < n"
 by (cut_tac size1, simp)
 
 lemmas definitions =
-  zero_def one_def add_def mult_def minus_def diff_def power_def
+  zero_def one_def add_def mult_def minus_def diff_def
 
 lemma Rep_less_n: "Rep x < n"
 by (rule type_definition.Rep [OF type, simplified, THEN conjunct2])
@@ -217,18 +216,12 @@
 apply (simp_all add: Rep_simps zmod_simps ring_simps)
 done
 
-lemma recpower: "OFCLASS('a, recpower_class)"
-apply (intro_classes, unfold definitions)
-apply (simp_all add: Rep_simps zmod_simps add_ac mult_assoc
-                     mod_pos_pos_trivial size1)
-done
-
 end
 
 locale mod_ring = mod_type +
   constrains n :: int
-  and Rep :: "'a::{number_ring,power} \<Rightarrow> int"
-  and Abs :: "int \<Rightarrow> 'a::{number_ring,power}"
+  and Rep :: "'a::{number_ring} \<Rightarrow> int"
+  and Abs :: "int \<Rightarrow> 'a::{number_ring}"
 begin
 
 lemma of_nat_eq: "of_nat k = Abs (int k mod n)"
@@ -272,7 +265,7 @@
   @{typ num1}, since 0 and 1 are not distinct.
 *}
 
-instantiation num1 :: "{comm_ring,comm_monoid_mult,number,recpower}"
+instantiation num1 :: "{comm_ring,comm_monoid_mult,number}"
 begin
 
 lemma num1_eq_iff: "(x::num1) = (y::num1) \<longleftrightarrow> True"
@@ -284,7 +277,7 @@
 end
 
 instantiation
-  bit0 and bit1 :: (finite) "{zero,one,plus,times,uminus,minus,power}"
+  bit0 and bit1 :: (finite) "{zero,one,plus,times,uminus,minus}"
 begin
 
 definition Abs_bit0' :: "int \<Rightarrow> 'a bit0" where
@@ -299,7 +292,6 @@
 definition "x * y = Abs_bit0' (Rep_bit0 x * Rep_bit0 y)"
 definition "x - y = Abs_bit0' (Rep_bit0 x - Rep_bit0 y)"
 definition "- x = Abs_bit0' (- Rep_bit0 x)"
-definition "x ^ k = Abs_bit0' (Rep_bit0 x ^ k)"
 
 definition "0 = Abs_bit1 0"
 definition "1 = Abs_bit1 1"
@@ -307,7 +299,6 @@
 definition "x * y = Abs_bit1' (Rep_bit1 x * Rep_bit1 y)"
 definition "x - y = Abs_bit1' (Rep_bit1 x - Rep_bit1 y)"
 definition "- x = Abs_bit1' (- Rep_bit1 x)"
-definition "x ^ k = Abs_bit1' (Rep_bit1 x ^ k)"
 
 instance ..
 
@@ -326,7 +317,6 @@
 apply (rule times_bit0_def [unfolded Abs_bit0'_def])
 apply (rule minus_bit0_def [unfolded Abs_bit0'_def])
 apply (rule uminus_bit0_def [unfolded Abs_bit0'_def])
-apply (rule power_bit0_def [unfolded Abs_bit0'_def])
 done
 
 interpretation bit1:
@@ -342,14 +332,13 @@
 apply (rule times_bit1_def [unfolded Abs_bit1'_def])
 apply (rule minus_bit1_def [unfolded Abs_bit1'_def])
 apply (rule uminus_bit1_def [unfolded Abs_bit1'_def])
-apply (rule power_bit1_def [unfolded Abs_bit1'_def])
 done
 
-instance bit0 :: (finite) "{comm_ring_1,recpower}"
-  by (rule bit0.comm_ring_1 bit0.recpower)+
+instance bit0 :: (finite) comm_ring_1
+  by (rule bit0.comm_ring_1)+
 
-instance bit1 :: (finite) "{comm_ring_1,recpower}"
-  by (rule bit1.comm_ring_1 bit1.recpower)+
+instance bit1 :: (finite) comm_ring_1
+  by (rule bit1.comm_ring_1)+
 
 instantiation bit0 and bit1 :: (finite) number_ring
 begin
@@ -386,9 +375,6 @@
 lemmas bit0_iszero_number_of [simp] = bit0.iszero_number_of
 lemmas bit1_iszero_number_of [simp] = bit1.iszero_number_of
 
-declare power_Suc [where ?'a="'a::finite bit0", standard, simp]
-declare power_Suc [where ?'a="'a::finite bit1", standard, simp]
-
 
 subsection {* Syntax *}
 

--- a/src/HOL/Library/Pocklington.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Library/Pocklington.thy	Fri May 15 15:56:28 2009 +0200
@@ -568,7 +568,7 @@
 
 lemma nproduct_cmul:
   assumes fS:"finite S"
-  shows "setprod (\<lambda>m. (c::'a::{comm_monoid_mult,recpower})* a(m)) S = c ^ (card S) * setprod a S"
+  shows "setprod (\<lambda>m. (c::'a::{comm_monoid_mult})* a(m)) S = c ^ (card S) * setprod a S"
 unfolding setprod_timesf setprod_constant[OF fS, of c] ..
 
 lemma coprime_nproduct:

--- a/src/HOL/Library/Polynomial.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Library/Polynomial.thy	Fri May 15 15:56:28 2009 +0200
@@ -632,20 +632,6 @@
   shows "a \<noteq> 0 \<Longrightarrow> p dvd smult a q \<longleftrightarrow> p dvd q"
   by (safe elim!: dvd_smult dvd_smult_cancel)
 
-instantiation poly :: (comm_semiring_1) recpower
-begin
-
-primrec power_poly where
-  "(p::'a poly) ^ 0 = 1"
-| "(p::'a poly) ^ (Suc n) = p * p ^ n"
-
-instance
-  by default simp_all
-
-declare power_poly.simps [simp del]
-
-end
-
 lemma degree_power_le: "degree (p ^ n) \<le> degree p * n"
 by (induct n, simp, auto intro: order_trans degree_mult_le)
 
@@ -987,6 +973,30 @@
     by (simp add: pdivmod_rel_def left_distrib)
   thus "(x + z * y) div y = z + x div y"
     by (rule div_poly_eq)
+next
+  fix x y z :: "'a poly"
+  assume "x \<noteq> 0"
+  show "(x * y) div (x * z) = y div z"
+  proof (cases "y \<noteq> 0 \<and> z \<noteq> 0")
+    have "\<And>x::'a poly. pdivmod_rel x 0 0 x"
+      by (rule pdivmod_rel_by_0)
+    then have [simp]: "\<And>x::'a poly. x div 0 = 0"
+      by (rule div_poly_eq)
+    have "\<And>x::'a poly. pdivmod_rel 0 x 0 0"
+      by (rule pdivmod_rel_0)
+    then have [simp]: "\<And>x::'a poly. 0 div x = 0"
+      by (rule div_poly_eq)
+    case False then show ?thesis by auto
+  next
+    case True then have "y \<noteq> 0" and "z \<noteq> 0" by auto
+    with `x \<noteq> 0`
+    have "\<And>q r. pdivmod_rel y z q r \<Longrightarrow> pdivmod_rel (x * y) (x * z) q (x * r)"
+      by (auto simp add: pdivmod_rel_def algebra_simps)
+        (rule classical, simp add: degree_mult_eq)
+    moreover from pdivmod_rel have "pdivmod_rel y z (y div z) (y mod z)" .
+    ultimately have "pdivmod_rel (x * y) (x * z) (y div z) (x * (y mod z))" .
+    then show ?thesis by (simp add: div_poly_eq)
+  qed
 qed
 
 end
@@ -1108,7 +1118,7 @@
   unfolding one_poly_def by simp
 
 lemma poly_monom:
-  fixes a x :: "'a::{comm_semiring_1,recpower}"
+  fixes a x :: "'a::{comm_semiring_1}"
   shows "poly (monom a n) x = a * x ^ n"
   by (induct n, simp add: monom_0, simp add: monom_Suc power_Suc mult_ac)
 
@@ -1137,7 +1147,7 @@
   by (induct p, simp_all, simp add: algebra_simps)
 
 lemma poly_power [simp]:
-  fixes p :: "'a::{comm_semiring_1,recpower} poly"
+  fixes p :: "'a::{comm_semiring_1} poly"
   shows "poly (p ^ n) x = poly p x ^ n"
   by (induct n, simp, simp add: power_Suc)
 

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Library/Preorder.thy	Fri May 15 15:56:28 2009 +0200
@@ -0,0 +1,65 @@
+(* Author: Florian Haftmann, TU Muenchen *)
+
+header {* Preorders with explicit equivalence relation *}
+
+theory Preorder
+imports Orderings
+begin
+
+class preorder_equiv = preorder
+begin
+
+definition equiv :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
+  "equiv x y \<longleftrightarrow> x \<le> y \<and> y \<le> x"
+
+notation
+  equiv ("op ~~") and
+  equiv ("(_/ ~~ _)" [51, 51] 50)
+  
+notation (xsymbols)
+  equiv ("op \<approx>") and
+  equiv ("(_/ \<approx> _)"  [51, 51] 50)
+
+notation (HTML output)
+  equiv ("op \<approx>") and
+  equiv ("(_/ \<approx> _)"  [51, 51] 50)
+
+lemma refl [iff]:
+  "x \<approx> x"
+  unfolding equiv_def by simp
+
+lemma trans:
+  "x \<approx> y \<Longrightarrow> y \<approx> z \<Longrightarrow> x \<approx> z"
+  unfolding equiv_def by (auto intro: order_trans)
+
+lemma antisym:
+  "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x \<approx> y"
+  unfolding equiv_def ..
+
+lemma less_le: "x < y \<longleftrightarrow> x \<le> y \<and> \<not> x \<approx> y"
+  by (auto simp add: equiv_def less_le_not_le)
+
+lemma le_less: "x \<le> y \<longleftrightarrow> x < y \<or> x \<approx> y"
+  by (auto simp add: equiv_def less_le)
+
+lemma le_imp_less_or_eq: "x \<le> y \<Longrightarrow> x < y \<or> x \<approx> y"
+  by (simp add: less_le)
+
+lemma less_imp_not_eq: "x < y \<Longrightarrow> x \<approx> y \<longleftrightarrow> False"
+  by (simp add: less_le)
+
+lemma less_imp_not_eq2: "x < y \<Longrightarrow> y \<approx> x \<longleftrightarrow> False"
+  by (simp add: equiv_def less_le)
+
+lemma neq_le_trans: "\<not> a \<approx> b \<Longrightarrow> a \<le> b \<Longrightarrow> a < b"
+  by (simp add: less_le)
+
+lemma le_neq_trans: "a \<le> b \<Longrightarrow> \<not> a \<approx> b \<Longrightarrow> a < b"
+  by (simp add: less_le)
+
+lemma antisym_conv: "y \<le> x \<Longrightarrow> x \<le> y \<longleftrightarrow> x \<approx> y"
+  by (simp add: equiv_def)
+
+end
+
+end

--- a/src/HOL/Library/Primes.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Library/Primes.thy	Fri May 15 15:56:28 2009 +0200
@@ -454,19 +454,11 @@
 qed
 
 lemma euclid: "\<exists>p. prime p \<and> p > n" using euclid_bound by auto
+
 lemma primes_infinite: "\<not> (finite {p. prime p})"
-proof (auto simp add: finite_conv_nat_seg_image)
-  fix n f 
-  assume H: "Collect prime = f ` {i. i < (n::nat)}"
-  let ?P = "Collect prime"
-  let ?m = "Max ?P"
-  have P0: "?P \<noteq> {}" using two_is_prime by auto
-  from H have fP: "finite ?P" using finite_conv_nat_seg_image by blast 
-  from Max_in [OF fP P0] have "?m \<in> ?P" . 
-  from Max_ge [OF fP] have contr: "\<forall> p. prime p \<longrightarrow> p \<le> ?m" by blast
-  from euclid [of ?m] obtain q where q: "prime q" "q > ?m" by blast
-  with contr show False by auto
-qed
+apply(simp add: finite_nat_set_iff_bounded_le)
+apply (metis euclid linorder_not_le)
+done
 
 lemma coprime_prime: assumes ab: "coprime a b"
   shows "~(prime p \<and> p dvd a \<and> p dvd b)"

--- a/src/HOL/Library/Product_ord.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Library/Product_ord.thy	Fri May 15 15:56:28 2009 +0200
@@ -12,25 +12,28 @@
 begin
 
 definition
-  prod_le_def [code del]: "x \<le> y \<longleftrightarrow> fst x < fst y \<or> fst x = fst y \<and> snd x \<le> snd y"
+  prod_le_def [code del]: "x \<le> y \<longleftrightarrow> fst x < fst y \<or> fst x \<le> fst y \<and> snd x \<le> snd y"
 
 definition
-  prod_less_def [code del]: "x < y \<longleftrightarrow> fst x < fst y \<or> fst x = fst y \<and> snd x < snd y"
+  prod_less_def [code del]: "x < y \<longleftrightarrow> fst x < fst y \<or> fst x \<le> fst y \<and> snd x < snd y"
 
 instance ..
 
 end
 
 lemma [code]:
-  "(x1\<Colon>'a\<Colon>{ord, eq}, y1) \<le> (x2, y2) \<longleftrightarrow> x1 < x2 \<or> x1 = x2 \<and> y1 \<le> y2"
-  "(x1\<Colon>'a\<Colon>{ord, eq}, y1) < (x2, y2) \<longleftrightarrow> x1 < x2 \<or> x1 = x2 \<and> y1 < y2"
+  "(x1\<Colon>'a\<Colon>{ord, eq}, y1) \<le> (x2, y2) \<longleftrightarrow> x1 < x2 \<or> x1 \<le> x2 \<and> y1 \<le> y2"
+  "(x1\<Colon>'a\<Colon>{ord, eq}, y1) < (x2, y2) \<longleftrightarrow> x1 < x2 \<or> x1 \<le> x2 \<and> y1 < y2"
   unfolding prod_le_def prod_less_def by simp_all
 
-instance * :: (order, order) order
-  by default (auto simp: prod_le_def prod_less_def intro: order_less_trans)
+instance * :: (preorder, preorder) preorder proof
+qed (auto simp: prod_le_def prod_less_def less_le_not_le intro: order_trans)
 
-instance * :: (linorder, linorder) linorder
-  by default (auto simp: prod_le_def)
+instance * :: (order, order) order proof
+qed (auto simp add: prod_le_def)
+
+instance * :: (linorder, linorder) linorder proof
+qed (auto simp: prod_le_def)
 
 instantiation * :: (linorder, linorder) distrib_lattice
 begin
@@ -41,9 +44,30 @@
 definition
   sup_prod_def: "(sup \<Colon> 'a \<times> 'b \<Rightarrow> _ \<Rightarrow> _) = max"
 
-instance
-  by intro_classes
-    (auto simp add: inf_prod_def sup_prod_def min_max.sup_inf_distrib1)
+instance proof
+qed (auto simp add: inf_prod_def sup_prod_def min_max.sup_inf_distrib1)
+
+end
+
+instantiation * :: (bot, bot) bot
+begin
+
+definition
+  bot_prod_def: "bot = (bot, bot)"
+
+instance proof
+qed (auto simp add: bot_prod_def prod_le_def)
+
+end
+
+instantiation * :: (top, top) top
+begin
+
+definition
+  top_prod_def: "top = (top, top)"
+
+instance proof
+qed (auto simp add: top_prod_def prod_le_def)
 
 end
 

--- a/src/HOL/Library/Quickcheck.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Library/Quickcheck.thy	Fri May 15 15:56:28 2009 +0200
@@ -47,6 +47,8 @@
 
 val eval_ref : (unit -> int -> int * int -> term list option * (int * int)) option ref = ref NONE;
 
+val target = "Quickcheck";
+
 fun mk_generator_expr thy prop tys =
   let
     val bound_max = length tys - 1;
@@ -72,14 +74,75 @@
   let
     val tys = (map snd o fst o strip_abs) t;
     val t' = mk_generator_expr thy t tys;
-    val f = Code_ML.eval_term ("Quickcheck.eval_ref", eval_ref) thy t' [];
-  in f #> Random_Engine.run #> (Option.map o map) (Code.postprocess_term thy) end;
+    val f = Code_ML.eval (SOME target) ("Quickcheck.eval_ref", eval_ref)
+      (fn proc => fn g => fn s => g (s + 1) #>> (Option.map o map) proc) thy t' [];
+  in f #> Random_Engine.run end;
 
 end
 *}
 
 setup {*
-  Quickcheck.add_generator ("code", Quickcheck.compile_generator_expr o ProofContext.theory_of)
+  Code_Target.extend_target (Quickcheck.target, (Code_ML.target_Eval, K I))
+  #> Quickcheck.add_generator ("code", Quickcheck.compile_generator_expr o ProofContext.theory_of)
 *}
 
+
+subsection {* Type @{typ "'a \<Rightarrow> 'b"} *}
+
+ML {*
+structure Random_Engine =
+struct
+
+open Random_Engine;
+
+fun random_fun (T1 : typ) (T2 : typ) (eq : 'a -> 'a -> bool) (term_of : 'a -> term)
+    (random : Random_Engine.seed -> ('b * (unit -> term)) * Random_Engine.seed)
+    (random_split : Random_Engine.seed -> Random_Engine.seed * Random_Engine.seed)
+    (seed : Random_Engine.seed) =
+  let
+    val (seed', seed'') = random_split seed;
+    val state = ref (seed', [], Const (@{const_name undefined}, T1 --> T2));
+    val fun_upd = Const (@{const_name fun_upd},
+      (T1 --> T2) --> T1 --> T2 --> T1 --> T2);
+    fun random_fun' x =
+      let
+        val (seed, fun_map, f_t) = ! state;
+      in case AList.lookup (uncurry eq) fun_map x
+       of SOME y => y
+        | NONE => let
+              val t1 = term_of x;
+              val ((y, t2), seed') = random seed;
+              val fun_map' = (x, y) :: fun_map;
+              val f_t' = fun_upd $ f_t $ t1 $ t2 ();
+              val _ = state := (seed', fun_map', f_t');
+            in y end
+      end;
+    fun term_fun' () = #3 (! state);
+  in ((random_fun', term_fun'), seed'') end;
+
 end
+*}
+
+axiomatization
+  random_fun_aux :: "typerep \<Rightarrow> typerep \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> term)
+    \<Rightarrow> (seed \<Rightarrow> ('b \<times> (unit \<Rightarrow> term)) \<times> seed) \<Rightarrow> (seed \<Rightarrow> seed \<times> seed)
+    \<Rightarrow> seed \<Rightarrow> (('a \<Rightarrow> 'b) \<times> (unit \<Rightarrow> term)) \<times> seed"
+
+code_const random_fun_aux (Quickcheck "Random'_Engine.random'_fun")
+  -- {* With enough criminal energy this can be abused to derive @{prop False};
+  for this reason we use a distinguished target @{text Quickcheck}
+  not spoiling the regular trusted code generation *}
+
+instantiation "fun" :: ("{eq, term_of}", "{type, random}") random
+begin
+
+definition random_fun :: "index \<Rightarrow> seed \<Rightarrow> (('a \<Rightarrow> 'b) \<times> (unit \<Rightarrow> term)) \<times> seed" where
+  "random n = random_fun_aux TYPEREP('a) TYPEREP('b) (op =) Code_Eval.term_of (random n) split_seed"
+
+instance ..
+
+end
+
+code_reserved Quickcheck Random_Engine
+
+end

--- a/src/HOL/Library/State_Monad.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Library/State_Monad.thy	Fri May 15 15:56:28 2009 +0200
@@ -190,7 +190,7 @@
 *}
 
 text {*
-  For an example, see HOL/ex/Random.thy.
+  For an example, see HOL/Extraction/Higman.thy.
 *}
 
 end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Library/Sum_Of_Squares.thy	Fri May 15 15:56:28 2009 +0200
@@ -0,0 +1,119 @@
+(* Title:      Library/Sum_Of_Squares
+   Author:     Amine Chaieb, University of Cambridge
+*)
+
+header {* A decision method for universal multivariate real arithmetic with addition, 
+          multiplication and ordering using semidefinite programming*}
+theory Sum_Of_Squares
+  imports Complex_Main (* "~~/src/HOL/Decision_Procs/Dense_Linear_Order" *)
+  uses "positivstellensatz.ML" "sum_of_squares.ML"
+  begin
+
+(* Note: 
+
+In order to use the method sos, install CSDP (https://projects.coin-or.org/Csdp/) and put the executable csdp on your path. 
+
+*)
+
+
+method_setup sos = {* Scan.succeed (SIMPLE_METHOD' o Sos.sos_tac) *} 
+  "Prove universal problems over the reals using sums of squares"
+
+text{* Tests -- commented since they work only when csdp is installed -- see above *}
+
+(*
+lemma "(3::real) * x + 7 * a < 4 & 3 < 2 * x \<Longrightarrow> a < 0" by sos
+
+lemma "a1 >= 0 & a2 >= 0 \<and> (a1 * a1 + a2 * a2 = b1 * b1 + b2 * b2 + 2) \<and> (a1 * b1 + a2 * b2 = 0) --> a1 * a2 - b1 * b2 >= (0::real)" by sos
+
+lemma "(3::real) * x + 7 * a < 4 & 3 < 2 * x --> a < 0" by sos
+
+lemma "(0::real) <= x & x <= 1 & 0 <= y & y <= 1  --> x^2 + y^2 < 1 |(x - 1)^2 + y^2 < 1 | x^2 + (y - 1)^2 < 1 | (x - 1)^2 + (y - 1)^2 < 1" by sos
+
+lemma "(0::real) <= x & 0 <= y & 0 <= z & x + y + z <= 3 --> x * y + x * z + y * z >= 3 * x * y * z" by sos
+
+lemma "((x::real)^2 + y^2 + z^2 = 1) --> (x + y + z)^2 <= 3" by sos
+
+lemma "(w^2 + x^2 + y^2 + z^2 = 1) --> (w + x + y + z)^2 <= (4::real)" by sos
+
+lemma "(x::real) >= 1 & y >= 1 --> x * y >= x + y - 1" by sos
+
+lemma "(x::real) > 1 & y > 1 --> x * y > x + y - 1" by sos; 
+
+lemma "abs(x) <= 1 --> abs(64 * x^7 - 112 * x^5 + 56 * x^3 - 7 * x) <= (1::real)" by sos  
+*)
+(* ------------------------------------------------------------------------- *)
+(* One component of denominator in dodecahedral example.                     *)
+(* ------------------------------------------------------------------------- *)
+(*
+lemma "2 <= x & x <= 125841 / 50000 & 2 <= y & y <= 125841 / 50000 & 2 <= z & z <= 125841 / 50000 --> 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z) >= (0::real)" by sos;
+*)
+(* ------------------------------------------------------------------------- *)
+(* Over a larger but simpler interval.                                       *)
+(* ------------------------------------------------------------------------- *)
+(*
+lemma "(2::real) <= x & x <= 4 & 2 <= y & y <= 4 & 2 <= z & z <= 4 --> 0 <= 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)" by sos
+*)
+(* ------------------------------------------------------------------------- *)
+(* We can do 12. I think 12 is a sharp bound; see PP's certificate.          *)
+(* ------------------------------------------------------------------------- *)
+(*
+lemma "2 <= (x::real) & x <= 4 & 2 <= y & y <= 4 & 2 <= z & z <= 4 --> 12 <= 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)" by sos
+
+*)
+(* ------------------------------------------------------------------------- *)
+(* Inequality from sci.math (see "Leon-Sotelo, por favor").                  *)
+(* ------------------------------------------------------------------------- *)
+(*
+lemma "0 <= (x::real) & 0 <= y & (x * y = 1) --> x + y <= x^2 + y^2" by sos 
+
+lemma "0 <= (x::real) & 0 <= y & (x * y = 1) --> x * y * (x + y) <= x^2 + y^2" by sos 
+
+lemma "0 <= (x::real) & 0 <= y --> x * y * (x + y)^2 <= (x^2 + y^2)^2" by sos
+
+lemma "(0::real) <= a & 0 <= b & 0 <= c & c * (2 * a + b)^3/ 27 <= x \<longrightarrow> c * a^2 * b <= x" by sos
+ 
+lemma "(0::real) < x --> 0 < 1 + x + x^2" by sos
+
+lemma "(0::real) <= x --> 0 < 1 + x + x^2" by sos
+
+lemma "(0::real) < 1 + x^2" by sos
+
+lemma "(0::real) <= 1 + 2 * x + x^2" by sos
+
+lemma "(0::real) < 1 + abs x" by sos
+
+lemma "(0::real) < 1 + (1 + x)^2 * (abs x)" by sos
+
+
+
+lemma "abs ((1::real) + x^2) = (1::real) + x^2" by sos
+lemma "(3::real) * x + 7 * a < 4 \<and> 3 < 2 * x \<longrightarrow> a < 0" by sos
+
+lemma "(0::real) < x --> 1 < y --> y * x <= z --> x < z" by sos
+lemma "(1::real) < x --> x^2 < y --> 1 < y" by sos
+lemma "(b::real)^2 < 4 * a * c --> ~(a * x^2 + b * x + c = 0)" by sos
+lemma "(b::real)^2 < 4 * a * c --> ~(a * x^2 + b * x + c = 0)" by sos
+lemma "((a::real) * x^2 + b * x + c = 0) --> b^2 >= 4 * a * c" by sos
+lemma "(0::real) <= b & 0 <= c & 0 <= x & 0 <= y & (x^2 = c) & (y^2 = a^2 * c + b) --> a * c <= y * x" by sos
+lemma "abs(x - z) <= e & abs(y - z) <= e & 0 <= u & 0 <= v & (u + v = 1) --> abs((u * x + v * y) - z) <= (e::real)" by sos
+*)
+(*
+lemma "((x::real) - y - 2 * x^4 = 0) & 0 <= x & x <= 2 & 0 <= y & y <= 3 --> y^2 - 7 * y - 12 * x + 17 >= 0" by sos *) (* Too hard?*)
+(*
+lemma "(0::real) <= x --> (1 + x + x^2)/(1 + x^2) <= 1 + x"
+apply sos
+done
+
+lemma "(0::real) <= x --> 1 - x <= 1 / (1 + x + x^2)"
+apply sos
+done
+
+lemma "(x::real) <= 1 / 2 --> - x - 2 * x^2 <= - x / (1 - x)"
+apply sos
+done 
+
+lemma "4*r^2 = p^2 - 4*q & r >= (0::real) & x^2 + p*x + q = 0 --> 2*(x::real) = - p + 2*r | 2*x = -p - 2*r" by sos
+*)
+
+end

--- a/src/HOL/Library/Topology_Euclidean_Space.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Library/Topology_Euclidean_Space.thy	Fri May 15 15:56:28 2009 +0200
@@ -5441,7 +5441,7 @@
   have "1 - c > 0" using c by auto
 
   from s(2) obtain z0 where "z0 \<in> s" by auto
-  def z \<equiv> "\<lambda> n::nat. fun_pow n f z0"
+  def z \<equiv> "\<lambda>n. (f ^^ n) z0"
   { fix n::nat
     have "z n \<in> s" unfolding z_def
     proof(induct n) case 0 thus ?case using `z0 \<in>s` by auto
@@ -5580,7 +5580,7 @@
       using dist[THEN bspec[where x=x], THEN bspec[where x=y]] by auto } note dist' = this
   def y \<equiv> "g x"
   have [simp]:"y\<in>s" unfolding y_def using gs[unfolded image_subset_iff] and `x\<in>s` by blast
-  def f \<equiv> "\<lambda> n. fun_pow n g"
+  def f \<equiv> "\<lambda>n. g ^^ n"
   have [simp]:"\<And>n z. g (f n z) = f (Suc n) z" unfolding f_def by auto
   have [simp]:"\<And>z. f 0 z = z" unfolding f_def by auto
   { fix n::nat and z assume "z\<in>s"

--- a/src/HOL/Library/Univ_Poly.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Library/Univ_Poly.thy	Fri May 15 15:56:28 2009 +0200
@@ -167,22 +167,9 @@
     simp_all add: poly_cmult poly_add left_distrib right_distrib mult_ac)
 qed
 
-class recpower_semiring = semiring + recpower
-class recpower_semiring_1 = semiring_1 + recpower
-class recpower_semiring_0 = semiring_0 + recpower
-class recpower_ring = ring + recpower
-class recpower_ring_1 = ring_1 + recpower
-subclass (in recpower_ring_1) recpower_ring ..
-class recpower_comm_semiring_1 = recpower + comm_semiring_1
-class recpower_comm_ring_1 = recpower + comm_ring_1
-subclass (in recpower_comm_ring_1) recpower_comm_semiring_1 ..
-class recpower_idom = recpower + idom
-subclass (in recpower_idom) recpower_comm_ring_1 ..
 class idom_char_0 = idom + ring_char_0
-class recpower_idom_char_0 = recpower + idom_char_0
-subclass (in recpower_idom_char_0) recpower_idom ..
 
-lemma (in recpower_comm_ring_1) poly_exp: "poly (p %^ n) x = (poly p x) ^ n"
+lemma (in comm_ring_1) poly_exp: "poly (p %^ n) x = (poly p x) ^ n"
 apply (induct "n")
 apply (auto simp add: poly_cmult poly_mult power_Suc)
 done
@@ -418,7 +405,7 @@
   finally show ?thesis .
 qed
 
-lemma (in recpower_idom) poly_exp_eq_zero[simp]:
+lemma (in idom) poly_exp_eq_zero[simp]:
      "(poly (p %^ n) = poly []) = (poly p = poly [] & n \<noteq> 0)"
 apply (simp only: fun_eq add: all_simps [symmetric])
 apply (rule arg_cong [where f = All])
@@ -437,7 +424,7 @@
 apply simp
 done
 
-lemma (in recpower_idom) poly_exp_prime_eq_zero: "(poly ([a, 1] %^ n) \<noteq> poly [])"
+lemma (in idom) poly_exp_prime_eq_zero: "(poly ([a, 1] %^ n) \<noteq> poly [])"
 by auto
 
 text{*A more constructive notion of polynomials being trivial*}
@@ -507,7 +494,7 @@
 done
 
 
-lemma (in recpower_comm_semiring_1) poly_divides_exp: "m \<le> n ==> (p %^ m) divides (p %^ n)"
+lemma (in comm_semiring_1) poly_divides_exp: "m \<le> n ==> (p %^ m) divides (p %^ n)"
 apply (auto simp add: le_iff_add)
 apply (induct_tac k)
 apply (rule_tac [2] poly_divides_trans)
@@ -516,7 +503,7 @@
 apply (auto simp add: poly_mult fun_eq mult_ac)
 done
 
-lemma (in recpower_comm_semiring_1) poly_exp_divides: "[| (p %^ n) divides q;  m\<le>n |] ==> (p %^ m) divides q"
+lemma (in comm_semiring_1) poly_exp_divides: "[| (p %^ n) divides q;  m\<le>n |] ==> (p %^ m) divides q"
 by (blast intro: poly_divides_exp poly_divides_trans)
 
 lemma (in comm_semiring_0) poly_divides_add:
@@ -583,7 +570,7 @@
 qed
 
 
-lemma (in recpower_comm_semiring_1) poly_mulexp: "poly (mulexp n p q) x = (poly p x) ^ n * poly q x"
+lemma (in comm_semiring_1) poly_mulexp: "poly (mulexp n p q) x = (poly p x) ^ n * poly q x"
 by(induct n, auto simp add: poly_mult power_Suc mult_ac)
 
 lemma (in comm_semiring_1) divides_left_mult:
@@ -600,11 +587,11 @@
 
 (* FIXME: Tidy up *)
 
-lemma (in recpower_semiring_1)
+lemma (in semiring_1)
   zero_power_iff: "0 ^ n = (if n = 0 then 1 else 0)"
   by (induct n, simp_all add: power_Suc)
 
-lemma (in recpower_idom_char_0) poly_order_exists:
+lemma (in idom_char_0) poly_order_exists:
   assumes lp: "length p = d" and p0: "poly p \<noteq> poly []"
   shows "\<exists>n. ([-a, 1] %^ n) divides p & ~(([-a, 1] %^ (Suc n)) divides p)"
 proof-
@@ -637,7 +624,7 @@
 lemma (in semiring_1) poly_one_divides[simp]: "[1] divides p"
 by (simp add: divides_def, auto)
 
-lemma (in recpower_idom_char_0) poly_order: "poly p \<noteq> poly []
+lemma (in idom_char_0) poly_order: "poly p \<noteq> poly []
       ==> EX! n. ([-a, 1] %^ n) divides p &
                  ~(([-a, 1] %^ (Suc n)) divides p)"
 apply (auto intro: poly_order_exists simp add: less_linear simp del: pmult_Cons pexp_Suc)
@@ -652,7 +639,7 @@
 lemma some1_equalityD: "[| n = (@n. P n); EX! n. P n |] ==> P n"
 by (blast intro: someI2)
 
-lemma (in recpower_idom_char_0) order:
+lemma (in idom_char_0) order:
       "(([-a, 1] %^ n) divides p &
         ~(([-a, 1] %^ (Suc n)) divides p)) =
         ((n = order a p) & ~(poly p = poly []))"
@@ -662,17 +649,17 @@
 apply (blast intro!: poly_order [THEN [2] some1_equalityD])
 done
 
-lemma (in recpower_idom_char_0) order2: "[| poly p \<noteq> poly [] |]
+lemma (in idom_char_0) order2: "[| poly p \<noteq> poly [] |]
       ==> ([-a, 1] %^ (order a p)) divides p &
               ~(([-a, 1] %^ (Suc(order a p))) divides p)"
 by (simp add: order del: pexp_Suc)
 
-lemma (in recpower_idom_char_0) order_unique: "[| poly p \<noteq> poly []; ([-a, 1] %^ n) divides p;
+lemma (in idom_char_0) order_unique: "[| poly p \<noteq> poly []; ([-a, 1] %^ n) divides p;
          ~(([-a, 1] %^ (Suc n)) divides p)
       |] ==> (n = order a p)"
 by (insert order [of a n p], auto)
 
-lemma (in recpower_idom_char_0) order_unique_lemma: "(poly p \<noteq> poly [] & ([-a, 1] %^ n) divides p &
+lemma (in idom_char_0) order_unique_lemma: "(poly p \<noteq> poly [] & ([-a, 1] %^ n) divides p &
          ~(([-a, 1] %^ (Suc n)) divides p))
       ==> (n = order a p)"
 by (blast intro: order_unique)
@@ -692,7 +679,7 @@
 apply (auto simp add: divides_def poly_mult simp del: pmult_Cons)
 done
 
-lemma (in recpower_idom_char_0) order_root: "(poly p a = 0) = ((poly p = poly []) | order a p \<noteq> 0)"
+lemma (in idom_char_0) order_root: "(poly p a = 0) = ((poly p = poly []) | order a p \<noteq> 0)"
 proof-
   let ?poly = poly
   show ?thesis
@@ -706,7 +693,7 @@
 done
 qed
 
-lemma (in recpower_idom_char_0) order_divides: "(([-a, 1] %^ n) divides p) = ((poly p = poly []) | n \<le> order a p)"
+lemma (in idom_char_0) order_divides: "(([-a, 1] %^ n) divides p) = ((poly p = poly []) | n \<le> order a p)"
 proof-
   let ?poly = poly
   show ?thesis
@@ -718,7 +705,7 @@
 done
 qed
 
-lemma (in recpower_idom_char_0) order_decomp:
+lemma (in idom_char_0) order_decomp:
      "poly p \<noteq> poly []
       ==> \<exists>q. (poly p = poly (([-a, 1] %^ (order a p)) *** q)) &
                 ~([-a, 1] divides q)"
@@ -732,7 +719,7 @@
 
 text{*Important composition properties of orders.*}
 lemma order_mult: "poly (p *** q) \<noteq> poly []
-      ==> order a (p *** q) = order a p + order (a::'a::{recpower_idom_char_0}) q"
+      ==> order a (p *** q) = order a p + order (a::'a::{idom_char_0}) q"
 apply (cut_tac a = a and p = "p *** q" and n = "order a p + order a q" in order)
 apply (auto simp add: poly_entire simp del: pmult_Cons)
 apply (drule_tac a = a in order2)+
@@ -753,7 +740,7 @@
 apply (simp add: fun_eq poly_exp_add poly_mult mult_ac del: pmult_Cons)
 done
 
-lemma (in recpower_idom_char_0) order_mult:
+lemma (in idom_char_0) order_mult:
   assumes pq0: "poly (p *** q) \<noteq> poly []"
   shows "order a (p *** q) = order a p + order a q"
 proof-
@@ -783,7 +770,7 @@
 done
 qed
 
-lemma (in recpower_idom_char_0) order_root2: "poly p \<noteq> poly [] ==> (poly p a = 0) = (order a p \<noteq> 0)"
+lemma (in idom_char_0) order_root2: "poly p \<noteq> poly [] ==> (poly p a = 0) = (order a p \<noteq> 0)"
 by (rule order_root [THEN ssubst], auto)
 
 lemma (in semiring_1) pmult_one[simp]: "[1] *** p = p" by auto
@@ -791,7 +778,7 @@
 lemma (in semiring_0) poly_Nil_zero: "poly [] = poly [0]"
 by (simp add: fun_eq)
 
-lemma (in recpower_idom_char_0) rsquarefree_decomp:
+lemma (in idom_char_0) rsquarefree_decomp:
      "[| rsquarefree p; poly p a = 0 |]
       ==> \<exists>q. (poly p = poly ([-a, 1] *** q)) & poly q a \<noteq> 0"
 apply (simp add: rsquarefree_def, safe)
@@ -999,7 +986,7 @@
   ultimately show ?case by blast
 qed
 
-lemma (in recpower_idom_char_0) order_degree:
+lemma (in idom_char_0) order_degree:
   assumes p0: "poly p \<noteq> poly []"
   shows "order a p \<le> degree p"
 proof-

--- a/src/HOL/Library/Word.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Library/Word.thy	Fri May 15 15:56:28 2009 +0200
@@ -1,5 +1,4 @@
 (*  Title:      HOL/Library/Word.thy
-    ID:         $Id$
     Author:     Sebastian Skalberg (TU Muenchen)
 *)
 
@@ -40,10 +39,8 @@
     Zero ("\<zero>")
   | One ("\<one>")
 
-primrec
-  bitval :: "bit => nat"
-where
-  "bitval \<zero> = 0"
+primrec bitval :: "bit => nat" where
+    "bitval \<zero> = 0"
   | "bitval \<one> = 1"
 
 consts
@@ -1531,7 +1528,7 @@
     show ?thesis
       apply simp
       apply (subst power_Suc [symmetric])
-      apply (simp del: power_int.simps)
+      apply simp
       done
   qed
   finally show ?thesis .

--- a/src/HOL/Library/comm_ring.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Library/comm_ring.ML	Fri May 15 15:56:28 2009 +0200
@@ -65,7 +65,7 @@
   | reif_polex T vs t = polex_pol T $ reif_pol T vs t;
 
 (* reification of the equation *)
-val TFree (_, cr_sort) = @{typ "'a :: {comm_ring, recpower}"};
+val cr_sort = @{sort "comm_ring_1"};
 
 fun reif_eq thy (eq as Const("op =", Type("fun", [T, _])) $ lhs $ rhs) =
       if Sign.of_sort thy (T, cr_sort) then

--- a/src/HOL/Library/normarith.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Library/normarith.ML	Fri May 15 15:56:28 2009 +0200
@@ -1,786 +1,7 @@
-(* A functor for finite mappings based on Tables *)
-signature FUNC = 
-sig
- type 'a T
- type key
- val apply : 'a T -> key -> 'a
- val applyd :'a T -> (key -> 'a) -> key -> 'a
- val combine : ('a -> 'a -> 'a) -> ('a -> bool) -> 'a T -> 'a T -> 'a T
- val defined : 'a T -> key -> bool
- val dom : 'a T -> key list
- val fold : (key * 'a -> 'b -> 'b) -> 'a T -> 'b -> 'b
- val graph : 'a T -> (key * 'a) list
- val is_undefined : 'a T -> bool
- val mapf : ('a -> 'b) -> 'a T -> 'b T
- val tryapplyd : 'a T -> key -> 'a -> 'a
- val undefine :  key -> 'a T -> 'a T
- val undefined : 'a T
- val update : key * 'a -> 'a T -> 'a T
- val updatep : (key * 'a -> bool) -> key * 'a -> 'a T -> 'a T
- val choose : 'a T -> key * 'a
- val onefunc : key * 'a -> 'a T
- val get_first: (key*'a -> 'a option) -> 'a T -> 'a option
- val fns: 
-   {key_ord: key*key -> order,
-    apply : 'a T -> key -> 'a,
-    applyd :'a T -> (key -> 'a) -> key -> 'a,
-    combine : ('a -> 'a -> 'a) -> ('a -> bool) -> 'a T -> 'a T -> 'a T,
-    defined : 'a T -> key -> bool,
-    dom : 'a T -> key list,
-    fold : (key * 'a -> 'b -> 'b) -> 'a T -> 'b -> 'b,
-    graph : 'a T -> (key * 'a) list,
-    is_undefined : 'a T -> bool,
-    mapf : ('a -> 'b) -> 'a T -> 'b T,
-    tryapplyd : 'a T -> key -> 'a -> 'a,
-    undefine :  key -> 'a T -> 'a T,
-    undefined : 'a T,
-    update : key * 'a -> 'a T -> 'a T,
-    updatep : (key * 'a -> bool) -> key * 'a -> 'a T -> 'a T,
-    choose : 'a T -> key * 'a,
-    onefunc : key * 'a -> 'a T,
-    get_first: (key*'a -> 'a option) -> 'a T -> 'a option}
-end;
-
-functor FuncFun(Key: KEY) : FUNC=
-struct
-
-type key = Key.key;
-structure Tab = TableFun(Key);
-type 'a T = 'a Tab.table;
-
-val undefined = Tab.empty;
-val is_undefined = Tab.is_empty;
-val mapf = Tab.map;
-val fold = Tab.fold;
-val graph = Tab.dest;
-val dom = Tab.keys;
-fun applyd f d x = case Tab.lookup f x of 
-   SOME y => y
- | NONE => d x;
-
-fun apply f x = applyd f (fn _ => raise Tab.UNDEF x) x;
-fun tryapplyd f a d = applyd f (K d) a;
-val defined = Tab.defined;
-fun undefine x t = (Tab.delete x t handle UNDEF => t);
-val update = Tab.update;
-fun updatep p (k,v) t = if p (k, v) then t else update (k,v) t
-fun combine f z a b = 
- let
-  fun h (k,v) t = case Tab.lookup t k of
-     NONE => Tab.update (k,v) t
-   | SOME v' => let val w = f v v'
-     in if z w then Tab.delete k t else Tab.update (k,w) t end;
-  in Tab.fold h a b end;
-
-fun choose f = case Tab.max_key f of 
-   SOME k => (k,valOf (Tab.lookup f k))
- | NONE => error "FuncFun.choose : Completely undefined function"
-
-fun onefunc kv = update kv undefined
-
-local
-fun  find f (k,v) NONE = f (k,v)
-   | find f (k,v) r = r
-in
-fun get_first f t = fold (find f) t NONE
-end
-
-val fns = 
-   {key_ord = Key.ord,
-    apply = apply,
-    applyd = applyd,
-    combine = combine,
-    defined = defined,
-    dom = dom,
-    fold = fold,
-    graph = graph,
-    is_undefined = is_undefined,
-    mapf = mapf,
-    tryapplyd = tryapplyd,
-    undefine = undefine,
-    undefined = undefined,
-    update = update,
-    updatep = updatep,
-    choose = choose,
-    onefunc = onefunc,
-    get_first = get_first}
-
-end;
-
-structure Intfunc = FuncFun(type key = int val ord = int_ord);
-structure Symfunc = FuncFun(type key = string val ord = fast_string_ord);
-structure Termfunc = FuncFun(type key = term val ord = TermOrd.fast_term_ord);
-structure Ctermfunc = FuncFun(type key = cterm val ord = (fn (s,t) => TermOrd.fast_term_ord(term_of s, term_of t)));
-structure Ratfunc = FuncFun(type key = Rat.rat val ord = Rat.ord);
-
-    (* Some conversions-related stuff which has been forbidden entrance into Pure/conv.ML*)
-structure Conv2 = 
-struct
- open Conv
-fun instantiate_cterm' ty tms = Drule.cterm_rule (Drule.instantiate' ty tms)
-fun is_comb t = case (term_of t) of _$_ => true | _ => false;
-fun is_abs t = case (term_of t) of Abs _ => true | _ => false;
-
-fun end_itlist f l =
- case l of 
-   []     => error "end_itlist"
- | [x]    => x
- | (h::t) => f h (end_itlist f t);
-
- fun absc cv ct = case term_of ct of 
- Abs (v,_, _) => 
-  let val (x,t) = Thm.dest_abs (SOME v) ct
-  in Thm.abstract_rule ((fst o dest_Free o term_of) x) x (cv t)
-  end
- | _ => all_conv ct;
-
-fun cache_conv conv =
- let 
-  val tab = ref Termtab.empty
-  fun cconv t =  
-    case Termtab.lookup (!tab) (term_of t) of
-     SOME th => th
-   | NONE => let val th = conv t
-             in ((tab := Termtab.insert Thm.eq_thm (term_of t, th) (!tab)); th) end
- in cconv end;
-fun is_binop ct ct' = ct aconvc (Thm.dest_fun (Thm.dest_fun ct'))
-  handle CTERM _ => false;
-
-local
- fun thenqc conv1 conv2 tm =
-   case try conv1 tm of
-    SOME th1 => (case try conv2 (Thm.rhs_of th1) of SOME th2 => Thm.transitive th1 th2 | NONE => th1)
-  | NONE => conv2 tm
-
- fun thencqc conv1 conv2 tm =
-    let val th1 = conv1 tm 
-    in (case try conv2 (Thm.rhs_of th1) of SOME th2 => Thm.transitive th1 th2 | NONE => th1)
-    end
- fun comb_qconv conv tm =
-   let val (l,r) = Thm.dest_comb tm 
-   in (case try conv l of 
-        SOME th1 => (case try conv r of SOME th2 => Thm.combination th1 th2 
-                                      | NONE => Drule.fun_cong_rule th1 r)
-      | NONE => Drule.arg_cong_rule l (conv r))
-   end
- fun repeatqc conv tm = thencqc conv (repeatqc conv) tm 
- fun sub_qconv conv tm =  if is_abs tm then absc conv tm else comb_qconv conv tm 
- fun once_depth_qconv conv tm =
-      (conv else_conv (sub_qconv (once_depth_qconv conv))) tm
- fun depth_qconv conv tm =
-    thenqc (sub_qconv (depth_qconv conv))
-           (repeatqc conv) tm
- fun redepth_qconv conv tm =
-    thenqc (sub_qconv (redepth_qconv conv))
-           (thencqc conv (redepth_qconv conv)) tm
- fun top_depth_qconv conv tm =
-    thenqc (repeatqc conv)
-           (thencqc (sub_qconv (top_depth_qconv conv))
-                    (thencqc conv (top_depth_qconv conv))) tm
- fun top_sweep_qconv conv tm =
-    thenqc (repeatqc conv)
-           (sub_qconv (top_sweep_qconv conv)) tm
-in 
-val (once_depth_conv, depth_conv, rdepth_conv, top_depth_conv, top_sweep_conv) = 
-  (fn c => try_conv (once_depth_qconv c),
-   fn c => try_conv (depth_qconv c),
-   fn c => try_conv (redepth_qconv c),
-   fn c => try_conv (top_depth_qconv c),
-   fn c => try_conv (top_sweep_qconv c));
-end;
-end;
-
-
-    (* Some useful derived rules *)
-fun deduct_antisym_rule tha thb = 
-    equal_intr (implies_intr (cprop_of thb) tha) 
-     (implies_intr (cprop_of tha) thb);
-
-fun prove_hyp tha thb = 
-  if exists (curry op aconv (concl_of tha)) (#hyps (rep_thm thb)) 
-  then equal_elim (symmetric (deduct_antisym_rule tha thb)) tha else thb;
-
-
-
-signature REAL_ARITH = 
-sig
-  datatype positivstellensatz =
-   Axiom_eq of int
- | Axiom_le of int
- | Axiom_lt of int
- | Rational_eq of Rat.rat
- | Rational_le of Rat.rat
- | Rational_lt of Rat.rat
- | Square of cterm
- | Eqmul of cterm * positivstellensatz
- | Sum of positivstellensatz * positivstellensatz
- | Product of positivstellensatz * positivstellensatz;
-
-val gen_gen_real_arith :
-  Proof.context -> (Rat.rat -> Thm.cterm) * conv * conv * conv * 
-   conv * conv * conv * conv * conv * conv * 
-    ( (thm list * thm list * thm list -> positivstellensatz -> thm) ->
-        thm list * thm list * thm list -> thm) -> conv
-val real_linear_prover : 
-  (thm list * thm list * thm list -> positivstellensatz -> thm) ->
-   thm list * thm list * thm list -> thm
-
-val gen_real_arith : Proof.context ->
-   (Rat.rat -> cterm) * conv * conv * conv * conv * conv * conv * conv *
-   ( (thm list * thm list * thm list -> positivstellensatz -> thm) ->
-       thm list * thm list * thm list -> thm) -> conv
-val gen_prover_real_arith : Proof.context ->
-   ((thm list * thm list * thm list -> positivstellensatz -> thm) ->
-     thm list * thm list * thm list -> thm) -> conv
-val real_arith : Proof.context -> conv
-end
-
-structure RealArith (* : REAL_ARITH *)=
-struct
-
- open Conv Thm Conv2;;
-(* ------------------------------------------------------------------------- *)
-(* Data structure for Positivstellensatz refutations.                        *)
-(* ------------------------------------------------------------------------- *)
-
-datatype positivstellensatz =
-   Axiom_eq of int
- | Axiom_le of int
- | Axiom_lt of int
- | Rational_eq of Rat.rat
- | Rational_le of Rat.rat
- | Rational_lt of Rat.rat
- | Square of cterm
- | Eqmul of cterm * positivstellensatz
- | Sum of positivstellensatz * positivstellensatz
- | Product of positivstellensatz * positivstellensatz;
-         (* Theorems used in the procedure *)
-
-fun conjunctions th = case try Conjunction.elim th of
-   SOME (th1,th2) => (conjunctions th1) @ conjunctions th2
- | NONE => [th];
-
-val pth = @{lemma "(((x::real) < y) == (y - x > 0)) &&& ((x <= y) == (y - x >= 0)) 
-     &&& ((x = y) == (x - y = 0)) &&& ((~(x < y)) == (x - y >= 0)) &&& ((~(x <= y)) == (x - y > 0))
-     &&& ((~(x = y)) == (x - y > 0 | -(x - y) > 0))"
-  by (atomize (full), auto simp add: less_diff_eq le_diff_eq not_less)} |> 
-conjunctions;
-
-val pth_final = @{lemma "(~p ==> False) ==> p" by blast}
-val pth_add = 
- @{lemma "(x = (0::real) ==> y = 0 ==> x + y = 0 ) &&& ( x = 0 ==> y >= 0 ==> x + y >= 0) 
-    &&& (x = 0 ==> y > 0 ==> x + y > 0) &&& (x >= 0 ==> y = 0 ==> x + y >= 0) 
-    &&& (x >= 0 ==> y >= 0 ==> x + y >= 0) &&& (x >= 0 ==> y > 0 ==> x + y > 0) 
-    &&& (x > 0 ==> y = 0 ==> x + y > 0) &&& (x > 0 ==> y >= 0 ==> x + y > 0) 
-    &&& (x > 0 ==> y > 0 ==> x + y > 0)"  by simp_all} |> conjunctions ;
-
-val pth_mul = 
-  @{lemma "(x = (0::real) ==> y = 0 ==> x * y = 0) &&& (x = 0 ==> y >= 0 ==> x * y = 0) &&& 
-           (x = 0 ==> y > 0 ==> x * y = 0) &&& (x >= 0 ==> y = 0 ==> x * y = 0) &&& 
-           (x >= 0 ==> y >= 0 ==> x * y >= 0 ) &&& ( x >= 0 ==> y > 0 ==> x * y >= 0 ) &&&
-           (x > 0 ==>  y = 0 ==> x * y = 0 ) &&& ( x > 0 ==> y >= 0 ==> x * y >= 0 ) &&&
-           (x > 0 ==>  y > 0 ==> x * y > 0)"
-  by (auto intro: mult_mono[where a="0::real" and b="x" and d="y" and c="0", simplified]
-    mult_strict_mono[where b="x" and d="y" and a="0" and c="0", simplified])} |> conjunctions;
-
-val pth_emul = @{lemma "y = (0::real) ==> x * y = 0"  by simp};
-val pth_square = @{lemma "x * x >= (0::real)"  by simp};
-
-val weak_dnf_simps = List.take (simp_thms, 34) 
-    @ conjunctions @{lemma "((P & (Q | R)) = ((P&Q) | (P&R))) &&& ((Q | R) & P) = ((Q&P) | (R&P)) &&& (P & Q) = (Q & P) &&& ((P | Q) = (Q | P))" by blast+};
-
-val nnfD_simps = conjunctions @{lemma "((~(P & Q)) = (~P | ~Q)) &&& ((~(P | Q)) = (~P & ~Q) ) &&& ((P --> Q) = (~P | Q) ) &&& ((P = Q) = ((P & Q) | (~P & ~ Q))) &&& ((~(P = Q)) = ((P & ~ Q) | (~P & Q)) ) &&& ((~ ~(P)) = P)" by blast+}
-
-val choice_iff = @{lemma "(ALL x. EX y. P x y) = (EX f. ALL x. P x (f x))" by metis};
-val prenex_simps = map (fn th => th RS sym) ([@{thm "all_conj_distrib"}, @{thm "ex_disj_distrib"}] @ @{thms "all_simps"(1-4)} @ @{thms "ex_simps"(1-4)});
-
-val real_abs_thms1 = conjunctions @{lemma
-  "((-1 * abs(x::real) >= r) = (-1 * x >= r & 1 * x >= r)) &&&
-  ((-1 * abs(x) + a >= r) = (a + -1 * x >= r & a + 1 * x >= r)) &&&
-  ((a + -1 * abs(x) >= r) = (a + -1 * x >= r & a + 1 * x >= r)) &&&
-  ((a + -1 * abs(x) + b >= r) = (a + -1 * x + b >= r & a + 1 * x + b >= r)) &&&
-  ((a + b + -1 * abs(x) >= r) = (a + b + -1 * x >= r & a + b + 1 * x >= r)) &&&
-  ((a + b + -1 * abs(x) + c >= r) = (a + b + -1 * x + c >= r & a + b + 1 * x + c >= r)) &&&
-  ((-1 * max x y >= r) = (-1 * x >= r & -1 * y >= r)) &&&
-  ((-1 * max x y + a >= r) = (a + -1 * x >= r & a + -1 * y >= r)) &&&
-  ((a + -1 * max x y >= r) = (a + -1 * x >= r & a + -1 * y >= r)) &&&
-  ((a + -1 * max x y + b >= r) = (a + -1 * x + b >= r & a + -1 * y  + b >= r)) &&&
-  ((a + b + -1 * max x y >= r) = (a + b + -1 * x >= r & a + b + -1 * y >= r)) &&&
-  ((a + b + -1 * max x y + c >= r) = (a + b + -1 * x + c >= r & a + b + -1 * y  + c >= r)) &&&
-  ((1 * min x y >= r) = (1 * x >= r & 1 * y >= r)) &&&
-  ((1 * min x y + a >= r) = (a + 1 * x >= r & a + 1 * y >= r)) &&&
-  ((a + 1 * min x y >= r) = (a + 1 * x >= r & a + 1 * y >= r)) &&&
-  ((a + 1 * min x y + b >= r) = (a + 1 * x + b >= r & a + 1 * y  + b >= r) )&&&
-  ((a + b + 1 * min x y >= r) = (a + b + 1 * x >= r & a + b + 1 * y >= r)) &&&
-  ((a + b + 1 * min x y + c >= r) = (a + b + 1 * x + c >= r & a + b + 1 * y  + c >= r)) &&&
-  ((min x y >= r) = (x >= r &  y >= r)) &&&
-  ((min x y + a >= r) = (a + x >= r & a + y >= r)) &&&
-  ((a + min x y >= r) = (a + x >= r & a + y >= r)) &&&
-  ((a + min x y + b >= r) = (a + x + b >= r & a + y  + b >= r)) &&&
-  ((a + b + min x y >= r) = (a + b + x >= r & a + b + y >= r) )&&&
-  ((a + b + min x y + c >= r) = (a + b + x + c >= r & a + b + y + c >= r)) &&&
-  ((-1 * abs(x) > r) = (-1 * x > r & 1 * x > r)) &&&
-  ((-1 * abs(x) + a > r) = (a + -1 * x > r & a + 1 * x > r)) &&&
-  ((a + -1 * abs(x) > r) = (a + -1 * x > r & a + 1 * x > r)) &&&
-  ((a + -1 * abs(x) + b > r) = (a + -1 * x + b > r & a + 1 * x + b > r)) &&&
-  ((a + b + -1 * abs(x) > r) = (a + b + -1 * x > r & a + b + 1 * x > r)) &&&
-  ((a + b + -1 * abs(x) + c > r) = (a + b + -1 * x + c > r & a + b + 1 * x + c > r)) &&&
-  ((-1 * max x y > r) = ((-1 * x > r) & -1 * y > r)) &&&
-  ((-1 * max x y + a > r) = (a + -1 * x > r & a + -1 * y > r)) &&&
-  ((a + -1 * max x y > r) = (a + -1 * x > r & a + -1 * y > r)) &&&
-  ((a + -1 * max x y + b > r) = (a + -1 * x + b > r & a + -1 * y  + b > r)) &&&
-  ((a + b + -1 * max x y > r) = (a + b + -1 * x > r & a + b + -1 * y > r)) &&&
-  ((a + b + -1 * max x y + c > r) = (a + b + -1 * x + c > r & a + b + -1 * y  + c > r)) &&&
-  ((min x y > r) = (x > r &  y > r)) &&&
-  ((min x y + a > r) = (a + x > r & a + y > r)) &&&
-  ((a + min x y > r) = (a + x > r & a + y > r)) &&&
-  ((a + min x y + b > r) = (a + x + b > r & a + y  + b > r)) &&&
-  ((a + b + min x y > r) = (a + b + x > r & a + b + y > r)) &&&
-  ((a + b + min x y + c > r) = (a + b + x + c > r & a + b + y + c > r))"
-  by auto};
-
-val abs_split' = @{lemma "P (abs (x::'a::ordered_idom)) == (x >= 0 & P x | x < 0 & P (-x))"
-  by (atomize (full)) (auto split add: abs_split)};
-
-val max_split = @{lemma "P (max x y) == ((x::'a::linorder) <= y & P y | x > y & P x)"
-  by (atomize (full)) (cases "x <= y", auto simp add: max_def)};
-
-val min_split = @{lemma "P (min x y) == ((x::'a::linorder) <= y & P x | x > y & P y)"
-  by (atomize (full)) (cases "x <= y", auto simp add: min_def)};
-
-
-         (* Miscalineous *)
-fun literals_conv bops uops cv = 
- let fun h t =
-  case (term_of t) of 
-   b$_$_ => if member (op aconv) bops b then binop_conv h t else cv t
- | u$_ => if member (op aconv) uops u then arg_conv h t else cv t
- | _ => cv t
- in h end;
-
-fun cterm_of_rat x = 
-let val (a, b) = Rat.quotient_of_rat x
-in 
- if b = 1 then Numeral.mk_cnumber @{ctyp "real"} a
-  else Thm.capply (Thm.capply @{cterm "op / :: real => _"} 
-                   (Numeral.mk_cnumber @{ctyp "real"} a))
-        (Numeral.mk_cnumber @{ctyp "real"} b)
-end;
-
-  fun dest_ratconst t = case term_of t of
-   Const(@{const_name divide}, _)$a$b => Rat.rat_of_quotient(HOLogic.dest_number a |> snd, HOLogic.dest_number b |> snd)
- | Const(@{const_name inverse}, _)$a => Rat.rat_of_quotient(1, HOLogic.dest_number a |> snd)
- | _ => Rat.rat_of_int (HOLogic.dest_number (term_of t) |> snd)
- fun is_ratconst t = can dest_ratconst t
-
-fun find_term p t = if p t then t else 
- case t of
-  a$b => (find_term p a handle TERM _ => find_term p b)
- | Abs (_,_,t') => find_term p t'
- | _ => raise TERM ("find_term",[t]);
-
-fun find_cterm p t = if p t then t else 
- case term_of t of
-  a$b => (find_cterm p (Thm.dest_fun t) handle CTERM _ => find_cterm p (Thm.dest_arg t))
- | Abs (_,_,t') => find_cterm p (Thm.dest_abs NONE t |> snd)
- | _ => raise CTERM ("find_cterm",[t]);
-
-
-    (* A general real arithmetic prover *)
-
-fun gen_gen_real_arith ctxt (mk_numeric,
-       numeric_eq_conv,numeric_ge_conv,numeric_gt_conv,
-       poly_conv,poly_neg_conv,poly_add_conv,poly_mul_conv,
-       absconv1,absconv2,prover) = 
-let
- open Conv Thm; 
- val pre_ss = HOL_basic_ss addsimps simp_thms@ ex_simps@ all_simps@[@{thm not_all},@{thm not_ex},ex_disj_distrib, all_conj_distrib, @{thm if_bool_eq_disj}]
- val prenex_ss = HOL_basic_ss addsimps prenex_simps
- val skolemize_ss = HOL_basic_ss addsimps [choice_iff]
- val presimp_conv = Simplifier.rewrite (Simplifier.context ctxt pre_ss)
- val prenex_conv = Simplifier.rewrite (Simplifier.context ctxt prenex_ss)
- val skolemize_conv = Simplifier.rewrite (Simplifier.context ctxt skolemize_ss)
- val weak_dnf_ss = HOL_basic_ss addsimps weak_dnf_simps
- val weak_dnf_conv = Simplifier.rewrite (Simplifier.context ctxt weak_dnf_ss)
- fun eqT_elim th = equal_elim (symmetric th) @{thm TrueI}
- fun oprconv cv ct = 
-  let val g = Thm.dest_fun2 ct
-  in if g aconvc @{cterm "op <= :: real => _"} 
-       orelse g aconvc @{cterm "op < :: real => _"} 
-     then arg_conv cv ct else arg1_conv cv ct
-  end
-
- fun real_ineq_conv th ct =
-  let
-   val th' = (instantiate (match (lhs_of th, ct)) th 
-      handle MATCH => raise CTERM ("real_ineq_conv", [ct]))
-  in transitive th' (oprconv poly_conv (Thm.rhs_of th'))
-  end 
-  val [real_lt_conv, real_le_conv, real_eq_conv,
-       real_not_lt_conv, real_not_le_conv, _] =
-       map real_ineq_conv pth
-  fun match_mp_rule ths ths' = 
-   let
-     fun f ths ths' = case ths of [] => raise THM("match_mp_rule",0,ths)
-      | th::ths => (ths' MRS th handle THM _ => f ths ths')
-   in f ths ths' end
-  fun mul_rule th th' = fconv_rule (arg_conv (oprconv poly_mul_conv))
-         (match_mp_rule pth_mul [th, th'])
-  fun add_rule th th' = fconv_rule (arg_conv (oprconv poly_add_conv))
-         (match_mp_rule pth_add [th, th'])
-  fun emul_rule ct th = fconv_rule (arg_conv (oprconv poly_mul_conv)) 
-       (instantiate' [] [SOME ct] (th RS pth_emul)) 
-  fun square_rule t = fconv_rule (arg_conv (oprconv poly_mul_conv))
-       (instantiate' [] [SOME t] pth_square)
-
-  fun hol_of_positivstellensatz(eqs,les,lts) =
-   let 
-    fun translate prf = case prf of
-        Axiom_eq n => nth eqs n
-      | Axiom_le n => nth les n
-      | Axiom_lt n => nth lts n
-      | Rational_eq x => eqT_elim(numeric_eq_conv(capply @{cterm Trueprop} 
-                          (capply (capply @{cterm "op =::real => _"} (mk_numeric x)) 
-                               @{cterm "0::real"})))
-      | Rational_le x => eqT_elim(numeric_ge_conv(capply @{cterm Trueprop} 
-                          (capply (capply @{cterm "op <=::real => _"} 
-                                     @{cterm "0::real"}) (mk_numeric x))))
-      | Rational_lt x => eqT_elim(numeric_gt_conv(capply @{cterm Trueprop} 
-                      (capply (capply @{cterm "op <::real => _"} @{cterm "0::real"})
-                        (mk_numeric x))))
-      | Square t => square_rule t
-      | Eqmul(t,p) => emul_rule t (translate p)
-      | Sum(p1,p2) => add_rule (translate p1) (translate p2)
-      | Product(p1,p2) => mul_rule (translate p1) (translate p2)
-   in fn prf => 
-      fconv_rule (first_conv [numeric_ge_conv, numeric_gt_conv, numeric_eq_conv, all_conv]) 
-          (translate prf)
-   end
-  
-  val init_conv = presimp_conv then_conv
-      nnf_conv then_conv skolemize_conv then_conv prenex_conv then_conv
-      weak_dnf_conv
-
-  val concl = dest_arg o cprop_of
-  fun is_binop opr ct = (dest_fun2 ct aconvc opr handle CTERM _ => false)
-  val is_req = is_binop @{cterm "op =:: real => _"}
-  val is_ge = is_binop @{cterm "op <=:: real => _"}
-  val is_gt = is_binop @{cterm "op <:: real => _"}
-  val is_conj = is_binop @{cterm "op &"}
-  val is_disj = is_binop @{cterm "op |"}
-  fun conj_pair th = (th RS @{thm conjunct1}, th RS @{thm conjunct2})
-  fun disj_cases th th1 th2 = 
-   let val (p,q) = dest_binop (concl th)
-       val c = concl th1
-       val _ = if c aconvc (concl th2) then () else error "disj_cases : conclusions not alpha convertible"
-   in implies_elim (implies_elim (implies_elim (instantiate' [] (map SOME [p,q,c]) @{thm disjE}) th) (implies_intr (capply @{cterm Trueprop} p) th1)) (implies_intr (capply @{cterm Trueprop} q) th2)
-   end
- fun overall dun ths = case ths of
-  [] =>
-   let 
-    val (eq,ne) = List.partition (is_req o concl) dun
-     val (le,nl) = List.partition (is_ge o concl) ne
-     val lt = filter (is_gt o concl) nl 
-    in prover hol_of_positivstellensatz (eq,le,lt) end
- | th::oths =>
-   let 
-    val ct = concl th 
-   in 
-    if is_conj ct  then
-     let 
-      val (th1,th2) = conj_pair th in
-      overall dun (th1::th2::oths) end
-    else if is_disj ct then
-      let 
-       val th1 = overall dun (assume (capply @{cterm Trueprop} (dest_arg1 ct))::oths)
-       val th2 = overall dun (assume (capply @{cterm Trueprop} (dest_arg ct))::oths)
-      in disj_cases th th1 th2 end
-   else overall (th::dun) oths
-  end
-  fun dest_binary b ct = if is_binop b ct then dest_binop ct 
-                         else raise CTERM ("dest_binary",[b,ct])
-  val dest_eq = dest_binary @{cterm "op = :: real => _"}
-  val neq_th = nth pth 5
-  fun real_not_eq_conv ct = 
-   let 
-    val (l,r) = dest_eq (dest_arg ct)
-    val th = instantiate ([],[(@{cpat "?x::real"},l),(@{cpat "?y::real"},r)]) neq_th
-    val th_p = poly_conv(dest_arg(dest_arg1(Thm.rhs_of th)))
-    val th_x = Drule.arg_cong_rule @{cterm "uminus :: real => _"} th_p
-    val th_n = fconv_rule (arg_conv poly_neg_conv) th_x
-    val th' = Drule.binop_cong_rule @{cterm "op |"} 
-     (Drule.arg_cong_rule (capply @{cterm "op <::real=>_"} @{cterm "0::real"}) th_p)
-     (Drule.arg_cong_rule (capply @{cterm "op <::real=>_"} @{cterm "0::real"}) th_n)
-    in transitive th th' 
-  end
- fun equal_implies_1_rule PQ = 
-  let 
-   val P = lhs_of PQ
-  in implies_intr P (equal_elim PQ (assume P))
-  end
- (* FIXME!!! Copied from groebner.ml *)
- val strip_exists =
-  let fun h (acc, t) =
-   case (term_of t) of
-    Const("Ex",_)$Abs(x,T,p) => h (dest_abs NONE (dest_arg t) |>> (fn v => v::acc))
-  | _ => (acc,t)
-  in fn t => h ([],t)
-  end
-  fun name_of x = case term_of x of
-   Free(s,_) => s
- | Var ((s,_),_) => s
- | _ => "x"
-
-  fun mk_forall x th = Drule.arg_cong_rule (instantiate_cterm' [SOME (ctyp_of_term x)] [] @{cpat "All :: (?'a => bool) => _" }) (abstract_rule (name_of x) x th)
-
-  val specl = fold_rev (fn x => fn th => instantiate' [] [SOME x] (th RS spec));
-
- fun ext T = Drule.cterm_rule (instantiate' [SOME T] []) @{cpat Ex}
- fun mk_ex v t = Thm.capply (ext (ctyp_of_term v)) (Thm.cabs v t)
-
- fun choose v th th' = case concl_of th of 
-   @{term Trueprop} $ (Const("Ex",_)$_) => 
-    let
-     val p = (funpow 2 Thm.dest_arg o cprop_of) th
-     val T = (hd o Thm.dest_ctyp o ctyp_of_term) p
-     val th0 = fconv_rule (Thm.beta_conversion true)
-         (instantiate' [SOME T] [SOME p, (SOME o Thm.dest_arg o cprop_of) th'] exE)
-     val pv = (Thm.rhs_of o Thm.beta_conversion true) 
-           (Thm.capply @{cterm Trueprop} (Thm.capply p v))
-     val th1 = forall_intr v (implies_intr pv th')
-    in implies_elim (implies_elim th0 th) th1  end
- | _ => raise THM ("choose",0,[th, th'])
-
-  fun simple_choose v th = 
-     choose v (assume ((Thm.capply @{cterm Trueprop} o mk_ex v) ((Thm.dest_arg o hd o #hyps o Thm.crep_thm) th))) th
-
- val strip_forall =
-  let fun h (acc, t) =
-   case (term_of t) of
-    Const("All",_)$Abs(x,T,p) => h (dest_abs NONE (dest_arg t) |>> (fn v => v::acc))
-  | _ => (acc,t)
-  in fn t => h ([],t)
-  end
-
- fun f ct =
-  let 
-   val nnf_norm_conv' = 
-     nnf_conv then_conv 
-     literals_conv [@{term "op &"}, @{term "op |"}] [] 
-     (cache_conv 
-       (first_conv [real_lt_conv, real_le_conv, 
-                    real_eq_conv, real_not_lt_conv, 
-                    real_not_le_conv, real_not_eq_conv, all_conv]))
-  fun absremover ct = (literals_conv [@{term "op &"}, @{term "op |"}] [] 
-                  (try_conv (absconv1 then_conv binop_conv (arg_conv poly_conv))) then_conv 
-        try_conv (absconv2 then_conv nnf_norm_conv' then_conv binop_conv absremover)) ct
-  val nct = capply @{cterm Trueprop} (capply @{cterm "Not"} ct)
-  val th0 = (init_conv then_conv arg_conv nnf_norm_conv') nct
-  val tm0 = dest_arg (Thm.rhs_of th0)
-  val th = if tm0 aconvc @{cterm False} then equal_implies_1_rule th0 else
-   let 
-    val (evs,bod) = strip_exists tm0
-    val (avs,ibod) = strip_forall bod
-    val th1 = Drule.arg_cong_rule @{cterm Trueprop} (fold mk_forall avs (absremover ibod))
-    val th2 = overall [] [specl avs (assume (Thm.rhs_of th1))]
-    val th3 = fold simple_choose evs (prove_hyp (equal_elim th1 (assume (capply @{cterm Trueprop} bod))) th2)
-   in  Drule.implies_intr_hyps (prove_hyp (equal_elim th0 (assume nct)) th3)
-   end
-  in implies_elim (instantiate' [] [SOME ct] pth_final) th
- end
-in f
-end;
-
-(* A linear arithmetic prover *)
-local
-  val linear_add = Ctermfunc.combine (curry op +/) (fn z => z =/ Rat.zero)
-  fun linear_cmul c = Ctermfunc.mapf (fn x => c */ x)
-  val one_tm = @{cterm "1::real"}
-  fun contradictory p (e,_) = ((Ctermfunc.is_undefined e) andalso not(p Rat.zero)) orelse
-     ((gen_eq_set (op aconvc) (Ctermfunc.dom e, [one_tm])) andalso not(p(Ctermfunc.apply e one_tm)))
-
-  fun linear_ineqs vars (les,lts) = 
-   case find_first (contradictory (fn x => x >/ Rat.zero)) lts of
-    SOME r => r
-  | NONE => 
-   (case find_first (contradictory (fn x => x >/ Rat.zero)) les of
-     SOME r => r
-   | NONE => 
-     if null vars then error "linear_ineqs: no contradiction" else
-     let 
-      val ineqs = les @ lts
-      fun blowup v =
-       length(filter (fn (e,_) => Ctermfunc.tryapplyd e v Rat.zero =/ Rat.zero) ineqs) +
-       length(filter (fn (e,_) => Ctermfunc.tryapplyd e v Rat.zero >/ Rat.zero) ineqs) *
-       length(filter (fn (e,_) => Ctermfunc.tryapplyd e v Rat.zero </ Rat.zero) ineqs)
-      val  v = fst(hd(sort (fn ((_,i),(_,j)) => int_ord (i,j))
-                 (map (fn v => (v,blowup v)) vars)))
-      fun addup (e1,p1) (e2,p2) acc =
-       let 
-        val c1 = Ctermfunc.tryapplyd e1 v Rat.zero 
-        val c2 = Ctermfunc.tryapplyd e2 v Rat.zero
-       in if c1 */ c2 >=/ Rat.zero then acc else
-        let 
-         val e1' = linear_cmul (Rat.abs c2) e1
-         val e2' = linear_cmul (Rat.abs c1) e2
-         val p1' = Product(Rational_lt(Rat.abs c2),p1)
-         val p2' = Product(Rational_lt(Rat.abs c1),p2)
-        in (linear_add e1' e2',Sum(p1',p2'))::acc
-        end
-       end
-      val (les0,les1) = 
-         List.partition (fn (e,_) => Ctermfunc.tryapplyd e v Rat.zero =/ Rat.zero) les
-      val (lts0,lts1) = 
-         List.partition (fn (e,_) => Ctermfunc.tryapplyd e v Rat.zero =/ Rat.zero) lts
-      val (lesp,lesn) = 
-         List.partition (fn (e,_) => Ctermfunc.tryapplyd e v Rat.zero >/ Rat.zero) les1
-      val (ltsp,ltsn) = 
-         List.partition (fn (e,_) => Ctermfunc.tryapplyd e v Rat.zero >/ Rat.zero) lts1
-      val les' = fold_rev (fn ep1 => fold_rev (addup ep1) lesp) lesn les0
-      val lts' = fold_rev (fn ep1 => fold_rev (addup ep1) (lesp@ltsp)) ltsn
-                      (fold_rev (fn ep1 => fold_rev (addup ep1) (lesn@ltsn)) ltsp lts0)
-     in linear_ineqs (remove (op aconvc) v vars) (les',lts')
-     end)
-
-  fun linear_eqs(eqs,les,lts) = 
-   case find_first (contradictory (fn x => x =/ Rat.zero)) eqs of
-    SOME r => r
-  | NONE => (case eqs of 
-    [] => 
-     let val vars = remove (op aconvc) one_tm 
-           (fold_rev (curry (gen_union (op aconvc)) o Ctermfunc.dom o fst) (les@lts) []) 
-     in linear_ineqs vars (les,lts) end
-   | (e,p)::es => 
-     if Ctermfunc.is_undefined e then linear_eqs (es,les,lts) else
-     let 
-      val (x,c) = Ctermfunc.choose (Ctermfunc.undefine one_tm e)
-      fun xform (inp as (t,q)) =
-       let val d = Ctermfunc.tryapplyd t x Rat.zero in
-        if d =/ Rat.zero then inp else
-        let 
-         val k = (Rat.neg d) */ Rat.abs c // c
-         val e' = linear_cmul k e
-         val t' = linear_cmul (Rat.abs c) t
-         val p' = Eqmul(cterm_of_rat k,p)
-         val q' = Product(Rational_lt(Rat.abs c),q) 
-        in (linear_add e' t',Sum(p',q')) 
-        end 
-      end
-     in linear_eqs(map xform es,map xform les,map xform lts)
-     end)
-
-  fun linear_prover (eq,le,lt) = 
-   let 
-    val eqs = map2 (fn p => fn n => (p,Axiom_eq n)) eq (0 upto (length eq - 1))
-    val les = map2 (fn p => fn n => (p,Axiom_le n)) le (0 upto (length le - 1))
-    val lts = map2 (fn p => fn n => (p,Axiom_lt n)) lt (0 upto (length lt - 1))
-   in linear_eqs(eqs,les,lts)
-   end 
-  
-  fun lin_of_hol ct = 
-   if ct aconvc @{cterm "0::real"} then Ctermfunc.undefined
-   else if not (is_comb ct) then Ctermfunc.onefunc (ct, Rat.one)
-   else if is_ratconst ct then Ctermfunc.onefunc (one_tm, dest_ratconst ct)
-   else
-    let val (lop,r) = Thm.dest_comb ct 
-    in if not (is_comb lop) then Ctermfunc.onefunc (ct, Rat.one)
-       else
-        let val (opr,l) = Thm.dest_comb lop 
-        in if opr aconvc @{cterm "op + :: real =>_"} 
-           then linear_add (lin_of_hol l) (lin_of_hol r)
-           else if opr aconvc @{cterm "op * :: real =>_"} 
-                   andalso is_ratconst l then Ctermfunc.onefunc (r, dest_ratconst l)
-           else Ctermfunc.onefunc (ct, Rat.one)
-        end
-    end
-
-  fun is_alien ct = case term_of ct of 
-   Const(@{const_name "real"}, _)$ n => 
-     if can HOLogic.dest_number n then false else true
-  | _ => false
- open Thm
-in 
-fun real_linear_prover translator (eq,le,lt) = 
- let 
-  val lhs = lin_of_hol o dest_arg1 o dest_arg o cprop_of
-  val rhs = lin_of_hol o dest_arg o dest_arg o cprop_of
-  val eq_pols = map lhs eq
-  val le_pols = map rhs le
-  val lt_pols = map rhs lt 
-  val aliens =  filter is_alien
-      (fold_rev (curry (gen_union (op aconvc)) o Ctermfunc.dom) 
-          (eq_pols @ le_pols @ lt_pols) [])
-  val le_pols' = le_pols @ map (fn v => Ctermfunc.onefunc (v,Rat.one)) aliens
-  val (_,proof) = linear_prover (eq_pols,le_pols',lt_pols)
-  val le' = le @ map (fn a => instantiate' [] [SOME (dest_arg a)] @{thm real_of_nat_ge_zero}) aliens 
- in (translator (eq,le',lt) proof) : thm
- end
-end;
-
-(* A less general generic arithmetic prover dealing with abs,max and min*)
-
-local
- val absmaxmin_elim_ss1 = HOL_basic_ss addsimps real_abs_thms1
- fun absmaxmin_elim_conv1 ctxt = 
-    Simplifier.rewrite (Simplifier.context ctxt absmaxmin_elim_ss1)
-
- val absmaxmin_elim_conv2 =
-  let 
-   val pth_abs = instantiate' [SOME @{ctyp real}] [] abs_split'
-   val pth_max = instantiate' [SOME @{ctyp real}] [] max_split
-   val pth_min = instantiate' [SOME @{ctyp real}] [] min_split
-   val abs_tm = @{cterm "abs :: real => _"}
-   val p_tm = @{cpat "?P :: real => bool"}
-   val x_tm = @{cpat "?x :: real"}
-   val y_tm = @{cpat "?y::real"}
-   val is_max = is_binop @{cterm "max :: real => _"}
-   val is_min = is_binop @{cterm "min :: real => _"} 
-   fun is_abs t = is_comb t andalso dest_fun t aconvc abs_tm
-   fun eliminate_construct p c tm =
-    let 
-     val t = find_cterm p tm
-     val th0 = (symmetric o beta_conversion false) (capply (cabs t tm) t)
-     val (p,ax) = (dest_comb o Thm.rhs_of) th0
-    in fconv_rule(arg_conv(binop_conv (arg_conv (beta_conversion false))))
-               (transitive th0 (c p ax))
-   end
-
-   val elim_abs = eliminate_construct is_abs
-    (fn p => fn ax => 
-       instantiate ([], [(p_tm,p), (x_tm, dest_arg ax)]) pth_abs)
-   val elim_max = eliminate_construct is_max
-    (fn p => fn ax => 
-      let val (ax,y) = dest_comb ax 
-      in  instantiate ([], [(p_tm,p), (x_tm, dest_arg ax), (y_tm,y)]) 
-      pth_max end)
-   val elim_min = eliminate_construct is_min
-    (fn p => fn ax => 
-      let val (ax,y) = dest_comb ax 
-      in  instantiate ([], [(p_tm,p), (x_tm, dest_arg ax), (y_tm,y)]) 
-      pth_min end)
-   in first_conv [elim_abs, elim_max, elim_min, all_conv]
-  end;
-in fun gen_real_arith ctxt (mkconst,eq,ge,gt,norm,neg,add,mul,prover) =
-        gen_gen_real_arith ctxt (mkconst,eq,ge,gt,norm,neg,add,mul,
-                       absmaxmin_elim_conv1 ctxt,absmaxmin_elim_conv2,prover)
-end;
-
-(* An instance for reals*) 
-
-fun gen_prover_real_arith ctxt prover = 
- let
-  fun simple_cterm_ord t u = TermOrd.term_ord (term_of t, term_of u) = LESS
-  val {add,mul,neg,pow,sub,main} = 
-     Normalizer.semiring_normalizers_ord_wrapper ctxt
-      (valOf (NormalizerData.match ctxt @{cterm "(0::real) + 1"})) 
-     simple_cterm_ord
-in gen_real_arith ctxt
-   (cterm_of_rat, field_comp_conv, field_comp_conv,field_comp_conv,
-    main,neg,add,mul, prover)
-end;
-
-fun real_arith ctxt = gen_prover_real_arith ctxt real_linear_prover;
-end
+(* Title:      Library/normarith.ML
+   Author:     Amine Chaieb, University of Cambridge
+   Description: A simple decision procedure for linear problems in euclidean space
+*)
 
   (* Now the norm procedure for euclidean spaces *)
 

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Library/positivstellensatz.ML	Fri May 15 15:56:28 2009 +0200
@@ -0,0 +1,787 @@
+(* Title:      Library/positivstellensatz
+   Author:     Amine Chaieb, University of Cambridge
+   Description: A generic arithmetic prover based on Positivstellensatz certificates --- 
+    also implements Fourrier-Motzkin elimination as a special case Fourrier-Motzkin elimination.
+*)
+
+(* A functor for finite mappings based on Tables *)
+signature FUNC = 
+sig
+ type 'a T
+ type key
+ val apply : 'a T -> key -> 'a
+ val applyd :'a T -> (key -> 'a) -> key -> 'a
+ val combine : ('a -> 'a -> 'a) -> ('a -> bool) -> 'a T -> 'a T -> 'a T
+ val defined : 'a T -> key -> bool
+ val dom : 'a T -> key list
+ val fold : (key * 'a -> 'b -> 'b) -> 'a T -> 'b -> 'b
+ val fold_rev : (key * 'a -> 'b -> 'b) -> 'a T -> 'b -> 'b
+ val graph : 'a T -> (key * 'a) list
+ val is_undefined : 'a T -> bool
+ val mapf : ('a -> 'b) -> 'a T -> 'b T
+ val tryapplyd : 'a T -> key -> 'a -> 'a
+ val undefine :  key -> 'a T -> 'a T
+ val undefined : 'a T
+ val update : key * 'a -> 'a T -> 'a T
+ val updatep : (key * 'a -> bool) -> key * 'a -> 'a T -> 'a T
+ val choose : 'a T -> key * 'a
+ val onefunc : key * 'a -> 'a T
+ val get_first: (key*'a -> 'a option) -> 'a T -> 'a option
+end;
+
+functor FuncFun(Key: KEY) : FUNC=
+struct
+
+type key = Key.key;
+structure Tab = TableFun(Key);
+type 'a T = 'a Tab.table;
+
+val undefined = Tab.empty;
+val is_undefined = Tab.is_empty;
+val mapf = Tab.map;
+val fold = Tab.fold;
+val fold_rev = Tab.fold_rev;
+val graph = Tab.dest;
+fun dom a = sort Key.ord (Tab.keys a);
+fun applyd f d x = case Tab.lookup f x of 
+   SOME y => y
+ | NONE => d x;
+
+fun apply f x = applyd f (fn _ => raise Tab.UNDEF x) x;
+fun tryapplyd f a d = applyd f (K d) a;
+val defined = Tab.defined;
+fun undefine x t = (Tab.delete x t handle UNDEF => t);
+val update = Tab.update;
+fun updatep p (k,v) t = if p (k, v) then t else update (k,v) t
+fun combine f z a b = 
+ let
+  fun h (k,v) t = case Tab.lookup t k of
+     NONE => Tab.update (k,v) t
+   | SOME v' => let val w = f v v'
+     in if z w then Tab.delete k t else Tab.update (k,w) t end;
+  in Tab.fold h a b end;
+
+fun choose f = case Tab.min_key f of 
+   SOME k => (k,valOf (Tab.lookup f k))
+ | NONE => error "FuncFun.choose : Completely undefined function"
+
+fun onefunc kv = update kv undefined
+
+local
+fun  find f (k,v) NONE = f (k,v)
+   | find f (k,v) r = r
+in
+fun get_first f t = fold (find f) t NONE
+end
+end;
+
+structure Intfunc = FuncFun(type key = int val ord = int_ord);
+structure Symfunc = FuncFun(type key = string val ord = fast_string_ord);
+structure Termfunc = FuncFun(type key = term val ord = TermOrd.fast_term_ord);
+structure Ctermfunc = FuncFun(type key = cterm val ord = (fn (s,t) => TermOrd.fast_term_ord(term_of s, term_of t)));
+
+structure Ratfunc = FuncFun(type key = Rat.rat val ord = Rat.ord);
+    (* Some conversions-related stuff which has been forbidden entrance into Pure/conv.ML*)
+structure Conv2 = 
+struct
+ open Conv
+fun instantiate_cterm' ty tms = Drule.cterm_rule (Drule.instantiate' ty tms)
+fun is_comb t = case (term_of t) of _$_ => true | _ => false;
+fun is_abs t = case (term_of t) of Abs _ => true | _ => false;
+
+fun end_itlist f l =
+ case l of 
+   []     => error "end_itlist"
+ | [x]    => x
+ | (h::t) => f h (end_itlist f t);
+
+ fun absc cv ct = case term_of ct of 
+ Abs (v,_, _) => 
+  let val (x,t) = Thm.dest_abs (SOME v) ct
+  in Thm.abstract_rule ((fst o dest_Free o term_of) x) x (cv t)
+  end
+ | _ => all_conv ct;
+
+fun cache_conv conv =
+ let 
+  val tab = ref Termtab.empty
+  fun cconv t =  
+    case Termtab.lookup (!tab) (term_of t) of
+     SOME th => th
+   | NONE => let val th = conv t
+             in ((tab := Termtab.insert Thm.eq_thm (term_of t, th) (!tab)); th) end
+ in cconv end;
+fun is_binop ct ct' = ct aconvc (Thm.dest_fun (Thm.dest_fun ct'))
+  handle CTERM _ => false;
+
+local
+ fun thenqc conv1 conv2 tm =
+   case try conv1 tm of
+    SOME th1 => (case try conv2 (Thm.rhs_of th1) of SOME th2 => Thm.transitive th1 th2 | NONE => th1)
+  | NONE => conv2 tm
+
+ fun thencqc conv1 conv2 tm =
+    let val th1 = conv1 tm 
+    in (case try conv2 (Thm.rhs_of th1) of SOME th2 => Thm.transitive th1 th2 | NONE => th1)
+    end
+ fun comb_qconv conv tm =
+   let val (l,r) = Thm.dest_comb tm 
+   in (case try conv l of 
+        SOME th1 => (case try conv r of SOME th2 => Thm.combination th1 th2 
+                                      | NONE => Drule.fun_cong_rule th1 r)
+      | NONE => Drule.arg_cong_rule l (conv r))
+   end
+ fun repeatqc conv tm = thencqc conv (repeatqc conv) tm 
+ fun sub_qconv conv tm =  if is_abs tm then absc conv tm else comb_qconv conv tm 
+ fun once_depth_qconv conv tm =
+      (conv else_conv (sub_qconv (once_depth_qconv conv))) tm
+ fun depth_qconv conv tm =
+    thenqc (sub_qconv (depth_qconv conv))
+           (repeatqc conv) tm
+ fun redepth_qconv conv tm =
+    thenqc (sub_qconv (redepth_qconv conv))
+           (thencqc conv (redepth_qconv conv)) tm
+ fun top_depth_qconv conv tm =
+    thenqc (repeatqc conv)
+           (thencqc (sub_qconv (top_depth_qconv conv))
+                    (thencqc conv (top_depth_qconv conv))) tm
+ fun top_sweep_qconv conv tm =
+    thenqc (repeatqc conv)
+           (sub_qconv (top_sweep_qconv conv)) tm
+in 
+val (once_depth_conv, depth_conv, rdepth_conv, top_depth_conv, top_sweep_conv) = 
+  (fn c => try_conv (once_depth_qconv c),
+   fn c => try_conv (depth_qconv c),
+   fn c => try_conv (redepth_qconv c),
+   fn c => try_conv (top_depth_qconv c),
+   fn c => try_conv (top_sweep_qconv c));
+end;
+end;
+
+
+    (* Some useful derived rules *)
+fun deduct_antisym_rule tha thb = 
+    equal_intr (implies_intr (cprop_of thb) tha) 
+     (implies_intr (cprop_of tha) thb);
+
+fun prove_hyp tha thb = 
+  if exists (curry op aconv (concl_of tha)) (#hyps (rep_thm thb)) 
+  then equal_elim (symmetric (deduct_antisym_rule tha thb)) tha else thb;
+
+
+
+signature REAL_ARITH = 
+sig
+  datatype positivstellensatz =
+   Axiom_eq of int
+ | Axiom_le of int
+ | Axiom_lt of int
+ | Rational_eq of Rat.rat
+ | Rational_le of Rat.rat
+ | Rational_lt of Rat.rat
+ | Square of cterm
+ | Eqmul of cterm * positivstellensatz
+ | Sum of positivstellensatz * positivstellensatz
+ | Product of positivstellensatz * positivstellensatz;
+
+val gen_gen_real_arith :
+  Proof.context -> (Rat.rat -> Thm.cterm) * conv * conv * conv * 
+   conv * conv * conv * conv * conv * conv * 
+    ( (thm list * thm list * thm list -> positivstellensatz -> thm) ->
+        thm list * thm list * thm list -> thm) -> conv
+val real_linear_prover : 
+  (thm list * thm list * thm list -> positivstellensatz -> thm) ->
+   thm list * thm list * thm list -> thm
+
+val gen_real_arith : Proof.context ->
+   (Rat.rat -> cterm) * conv * conv * conv * conv * conv * conv * conv *
+   ( (thm list * thm list * thm list -> positivstellensatz -> thm) ->
+       thm list * thm list * thm list -> thm) -> conv
+val gen_prover_real_arith : Proof.context ->
+   ((thm list * thm list * thm list -> positivstellensatz -> thm) ->
+     thm list * thm list * thm list -> thm) -> conv
+val real_arith : Proof.context -> conv
+end
+
+structure RealArith (* : REAL_ARITH *)=
+struct
+
+ open Conv Thm;;
+(* ------------------------------------------------------------------------- *)
+(* Data structure for Positivstellensatz refutations.                        *)
+(* ------------------------------------------------------------------------- *)
+
+datatype positivstellensatz =
+   Axiom_eq of int
+ | Axiom_le of int
+ | Axiom_lt of int
+ | Rational_eq of Rat.rat
+ | Rational_le of Rat.rat
+ | Rational_lt of Rat.rat
+ | Square of cterm
+ | Eqmul of cterm * positivstellensatz
+ | Sum of positivstellensatz * positivstellensatz
+ | Product of positivstellensatz * positivstellensatz;
+         (* Theorems used in the procedure *)
+
+
+val my_eqs = ref ([] : thm list);
+val my_les = ref ([] : thm list);
+val my_lts = ref ([] : thm list);
+val my_proof = ref (Axiom_eq 0);
+val my_context = ref @{context};
+
+val my_mk_numeric = ref ((K @{cterm True}) :Rat.rat -> cterm);
+val my_numeric_eq_conv = ref no_conv;
+val my_numeric_ge_conv = ref no_conv;
+val my_numeric_gt_conv = ref no_conv;
+val my_poly_conv = ref no_conv;
+val my_poly_neg_conv = ref no_conv;
+val my_poly_add_conv = ref no_conv;
+val my_poly_mul_conv = ref no_conv;
+
+fun conjunctions th = case try Conjunction.elim th of
+   SOME (th1,th2) => (conjunctions th1) @ conjunctions th2
+ | NONE => [th];
+
+val pth = @{lemma "(((x::real) < y) == (y - x > 0)) &&& ((x <= y) == (y - x >= 0)) 
+     &&& ((x = y) == (x - y = 0)) &&& ((~(x < y)) == (x - y >= 0)) &&& ((~(x <= y)) == (x - y > 0))
+     &&& ((~(x = y)) == (x - y > 0 | -(x - y) > 0))"
+  by (atomize (full), auto simp add: less_diff_eq le_diff_eq not_less)} |> 
+conjunctions;
+
+val pth_final = @{lemma "(~p ==> False) ==> p" by blast}
+val pth_add = 
+ @{lemma "(x = (0::real) ==> y = 0 ==> x + y = 0 ) &&& ( x = 0 ==> y >= 0 ==> x + y >= 0) 
+    &&& (x = 0 ==> y > 0 ==> x + y > 0) &&& (x >= 0 ==> y = 0 ==> x + y >= 0) 
+    &&& (x >= 0 ==> y >= 0 ==> x + y >= 0) &&& (x >= 0 ==> y > 0 ==> x + y > 0) 
+    &&& (x > 0 ==> y = 0 ==> x + y > 0) &&& (x > 0 ==> y >= 0 ==> x + y > 0) 
+    &&& (x > 0 ==> y > 0 ==> x + y > 0)"  by simp_all} |> conjunctions ;
+
+val pth_mul = 
+  @{lemma "(x = (0::real) ==> y = 0 ==> x * y = 0) &&& (x = 0 ==> y >= 0 ==> x * y = 0) &&& 
+           (x = 0 ==> y > 0 ==> x * y = 0) &&& (x >= 0 ==> y = 0 ==> x * y = 0) &&& 
+           (x >= 0 ==> y >= 0 ==> x * y >= 0 ) &&& ( x >= 0 ==> y > 0 ==> x * y >= 0 ) &&&
+           (x > 0 ==>  y = 0 ==> x * y = 0 ) &&& ( x > 0 ==> y >= 0 ==> x * y >= 0 ) &&&
+           (x > 0 ==>  y > 0 ==> x * y > 0)"
+  by (auto intro: mult_mono[where a="0::real" and b="x" and d="y" and c="0", simplified]
+    mult_strict_mono[where b="x" and d="y" and a="0" and c="0", simplified])} |> conjunctions;
+
+val pth_emul = @{lemma "y = (0::real) ==> x * y = 0"  by simp};
+val pth_square = @{lemma "x * x >= (0::real)"  by simp};
+
+val weak_dnf_simps = List.take (simp_thms, 34) 
+    @ conjunctions @{lemma "((P & (Q | R)) = ((P&Q) | (P&R))) &&& ((Q | R) & P) = ((Q&P) | (R&P)) &&& (P & Q) = (Q & P) &&& ((P | Q) = (Q | P))" by blast+};
+
+val nnfD_simps = conjunctions @{lemma "((~(P & Q)) = (~P | ~Q)) &&& ((~(P | Q)) = (~P & ~Q) ) &&& ((P --> Q) = (~P | Q) ) &&& ((P = Q) = ((P & Q) | (~P & ~ Q))) &&& ((~(P = Q)) = ((P & ~ Q) | (~P & Q)) ) &&& ((~ ~(P)) = P)" by blast+}
+
+val choice_iff = @{lemma "(ALL x. EX y. P x y) = (EX f. ALL x. P x (f x))" by metis};
+val prenex_simps = map (fn th => th RS sym) ([@{thm "all_conj_distrib"}, @{thm "ex_disj_distrib"}] @ @{thms "all_simps"(1-4)} @ @{thms "ex_simps"(1-4)});
+
+val real_abs_thms1 = conjunctions @{lemma
+  "((-1 * abs(x::real) >= r) = (-1 * x >= r & 1 * x >= r)) &&&
+  ((-1 * abs(x) + a >= r) = (a + -1 * x >= r & a + 1 * x >= r)) &&&
+  ((a + -1 * abs(x) >= r) = (a + -1 * x >= r & a + 1 * x >= r)) &&&
+  ((a + -1 * abs(x) + b >= r) = (a + -1 * x + b >= r & a + 1 * x + b >= r)) &&&
+  ((a + b + -1 * abs(x) >= r) = (a + b + -1 * x >= r & a + b + 1 * x >= r)) &&&
+  ((a + b + -1 * abs(x) + c >= r) = (a + b + -1 * x + c >= r & a + b + 1 * x + c >= r)) &&&
+  ((-1 * max x y >= r) = (-1 * x >= r & -1 * y >= r)) &&&
+  ((-1 * max x y + a >= r) = (a + -1 * x >= r & a + -1 * y >= r)) &&&
+  ((a + -1 * max x y >= r) = (a + -1 * x >= r & a + -1 * y >= r)) &&&
+  ((a + -1 * max x y + b >= r) = (a + -1 * x + b >= r & a + -1 * y  + b >= r)) &&&
+  ((a + b + -1 * max x y >= r) = (a + b + -1 * x >= r & a + b + -1 * y >= r)) &&&
+  ((a + b + -1 * max x y + c >= r) = (a + b + -1 * x + c >= r & a + b + -1 * y  + c >= r)) &&&
+  ((1 * min x y >= r) = (1 * x >= r & 1 * y >= r)) &&&
+  ((1 * min x y + a >= r) = (a + 1 * x >= r & a + 1 * y >= r)) &&&
+  ((a + 1 * min x y >= r) = (a + 1 * x >= r & a + 1 * y >= r)) &&&
+  ((a + 1 * min x y + b >= r) = (a + 1 * x + b >= r & a + 1 * y  + b >= r) )&&&
+  ((a + b + 1 * min x y >= r) = (a + b + 1 * x >= r & a + b + 1 * y >= r)) &&&
+  ((a + b + 1 * min x y + c >= r) = (a + b + 1 * x + c >= r & a + b + 1 * y  + c >= r)) &&&
+  ((min x y >= r) = (x >= r &  y >= r)) &&&
+  ((min x y + a >= r) = (a + x >= r & a + y >= r)) &&&
+  ((a + min x y >= r) = (a + x >= r & a + y >= r)) &&&
+  ((a + min x y + b >= r) = (a + x + b >= r & a + y  + b >= r)) &&&
+  ((a + b + min x y >= r) = (a + b + x >= r & a + b + y >= r) )&&&
+  ((a + b + min x y + c >= r) = (a + b + x + c >= r & a + b + y + c >= r)) &&&
+  ((-1 * abs(x) > r) = (-1 * x > r & 1 * x > r)) &&&
+  ((-1 * abs(x) + a > r) = (a + -1 * x > r & a + 1 * x > r)) &&&
+  ((a + -1 * abs(x) > r) = (a + -1 * x > r & a + 1 * x > r)) &&&
+  ((a + -1 * abs(x) + b > r) = (a + -1 * x + b > r & a + 1 * x + b > r)) &&&
+  ((a + b + -1 * abs(x) > r) = (a + b + -1 * x > r & a + b + 1 * x > r)) &&&
+  ((a + b + -1 * abs(x) + c > r) = (a + b + -1 * x + c > r & a + b + 1 * x + c > r)) &&&
+  ((-1 * max x y > r) = ((-1 * x > r) & -1 * y > r)) &&&
+  ((-1 * max x y + a > r) = (a + -1 * x > r & a + -1 * y > r)) &&&
+  ((a + -1 * max x y > r) = (a + -1 * x > r & a + -1 * y > r)) &&&
+  ((a + -1 * max x y + b > r) = (a + -1 * x + b > r & a + -1 * y  + b > r)) &&&
+  ((a + b + -1 * max x y > r) = (a + b + -1 * x > r & a + b + -1 * y > r)) &&&
+  ((a + b + -1 * max x y + c > r) = (a + b + -1 * x + c > r & a + b + -1 * y  + c > r)) &&&
+  ((min x y > r) = (x > r &  y > r)) &&&
+  ((min x y + a > r) = (a + x > r & a + y > r)) &&&
+  ((a + min x y > r) = (a + x > r & a + y > r)) &&&
+  ((a + min x y + b > r) = (a + x + b > r & a + y  + b > r)) &&&
+  ((a + b + min x y > r) = (a + b + x > r & a + b + y > r)) &&&
+  ((a + b + min x y + c > r) = (a + b + x + c > r & a + b + y + c > r))"
+  by auto};
+
+val abs_split' = @{lemma "P (abs (x::'a::ordered_idom)) == (x >= 0 & P x | x < 0 & P (-x))"
+  by (atomize (full)) (auto split add: abs_split)};
+
+val max_split = @{lemma "P (max x y) == ((x::'a::linorder) <= y & P y | x > y & P x)"
+  by (atomize (full)) (cases "x <= y", auto simp add: max_def)};
+
+val min_split = @{lemma "P (min x y) == ((x::'a::linorder) <= y & P x | x > y & P y)"
+  by (atomize (full)) (cases "x <= y", auto simp add: min_def)};
+
+
+         (* Miscalineous *)
+fun literals_conv bops uops cv = 
+ let fun h t =
+  case (term_of t) of 
+   b$_$_ => if member (op aconv) bops b then binop_conv h t else cv t
+ | u$_ => if member (op aconv) uops u then arg_conv h t else cv t
+ | _ => cv t
+ in h end;
+
+fun cterm_of_rat x = 
+let val (a, b) = Rat.quotient_of_rat x
+in 
+ if b = 1 then Numeral.mk_cnumber @{ctyp "real"} a
+  else Thm.capply (Thm.capply @{cterm "op / :: real => _"} 
+                   (Numeral.mk_cnumber @{ctyp "real"} a))
+        (Numeral.mk_cnumber @{ctyp "real"} b)
+end;
+
+  fun dest_ratconst t = case term_of t of
+   Const(@{const_name divide}, _)$a$b => Rat.rat_of_quotient(HOLogic.dest_number a |> snd, HOLogic.dest_number b |> snd)
+ | _ => Rat.rat_of_int (HOLogic.dest_number (term_of t) |> snd)
+ fun is_ratconst t = can dest_ratconst t
+
+fun find_term p t = if p t then t else 
+ case t of
+  a$b => (find_term p a handle TERM _ => find_term p b)
+ | Abs (_,_,t') => find_term p t'
+ | _ => raise TERM ("find_term",[t]);
+
+fun find_cterm p t = if p t then t else 
+ case term_of t of
+  a$b => (find_cterm p (Thm.dest_fun t) handle CTERM _ => find_cterm p (Thm.dest_arg t))
+ | Abs (_,_,t') => find_cterm p (Thm.dest_abs NONE t |> snd)
+ | _ => raise CTERM ("find_cterm",[t]);
+
+
+    (* Some conversions-related stuff which has been forbidden entrance into Pure/conv.ML*)
+fun instantiate_cterm' ty tms = Drule.cterm_rule (Drule.instantiate' ty tms)
+fun is_comb t = case (term_of t) of _$_ => true | _ => false;
+
+fun cache_conv conv =
+ let 
+  val tab = ref Termtab.empty
+  fun cconv t =  
+    case Termtab.lookup (!tab) (term_of t) of
+     SOME th => th
+   | NONE => let val th = conv t
+             in ((tab := Termtab.insert Thm.eq_thm (term_of t, th) (!tab)); th) end
+ in cconv end;
+fun is_binop ct ct' = ct aconvc (Thm.dest_fun (Thm.dest_fun ct'))
+  handle CTERM _ => false;
+
+    (* A general real arithmetic prover *)
+
+fun gen_gen_real_arith ctxt (mk_numeric,
+       numeric_eq_conv,numeric_ge_conv,numeric_gt_conv,
+       poly_conv,poly_neg_conv,poly_add_conv,poly_mul_conv,
+       absconv1,absconv2,prover) = 
+let
+ open Conv Thm;
+ val _ = my_context := ctxt 
+ val _ = (my_mk_numeric := mk_numeric ; my_numeric_eq_conv := numeric_eq_conv ; 
+          my_numeric_ge_conv := numeric_ge_conv; my_numeric_gt_conv := numeric_gt_conv ;
+          my_poly_conv := poly_conv; my_poly_neg_conv := poly_neg_conv; 
+          my_poly_add_conv := poly_add_conv; my_poly_mul_conv := poly_mul_conv)
+ val pre_ss = HOL_basic_ss addsimps simp_thms@ ex_simps@ all_simps@[@{thm not_all},@{thm not_ex},ex_disj_distrib, all_conj_distrib, @{thm if_bool_eq_disj}]
+ val prenex_ss = HOL_basic_ss addsimps prenex_simps
+ val skolemize_ss = HOL_basic_ss addsimps [choice_iff]
+ val presimp_conv = Simplifier.rewrite (Simplifier.context ctxt pre_ss)
+ val prenex_conv = Simplifier.rewrite (Simplifier.context ctxt prenex_ss)
+ val skolemize_conv = Simplifier.rewrite (Simplifier.context ctxt skolemize_ss)
+ val weak_dnf_ss = HOL_basic_ss addsimps weak_dnf_simps
+ val weak_dnf_conv = Simplifier.rewrite (Simplifier.context ctxt weak_dnf_ss)
+ fun eqT_elim th = equal_elim (symmetric th) @{thm TrueI}
+ fun oprconv cv ct = 
+  let val g = Thm.dest_fun2 ct
+  in if g aconvc @{cterm "op <= :: real => _"} 
+       orelse g aconvc @{cterm "op < :: real => _"} 
+     then arg_conv cv ct else arg1_conv cv ct
+  end
+
+ fun real_ineq_conv th ct =
+  let
+   val th' = (instantiate (match (lhs_of th, ct)) th 
+      handle MATCH => raise CTERM ("real_ineq_conv", [ct]))
+  in transitive th' (oprconv poly_conv (Thm.rhs_of th'))
+  end 
+  val [real_lt_conv, real_le_conv, real_eq_conv,
+       real_not_lt_conv, real_not_le_conv, _] =
+       map real_ineq_conv pth
+  fun match_mp_rule ths ths' = 
+   let
+     fun f ths ths' = case ths of [] => raise THM("match_mp_rule",0,ths)
+      | th::ths => (ths' MRS th handle THM _ => f ths ths')
+   in f ths ths' end
+  fun mul_rule th th' = fconv_rule (arg_conv (oprconv poly_mul_conv))
+         (match_mp_rule pth_mul [th, th'])
+  fun add_rule th th' = fconv_rule (arg_conv (oprconv poly_add_conv))
+         (match_mp_rule pth_add [th, th'])
+  fun emul_rule ct th = fconv_rule (arg_conv (oprconv poly_mul_conv)) 
+       (instantiate' [] [SOME ct] (th RS pth_emul)) 
+  fun square_rule t = fconv_rule (arg_conv (oprconv poly_conv))
+       (instantiate' [] [SOME t] pth_square)
+
+  fun hol_of_positivstellensatz(eqs,les,lts) proof =
+   let 
+    val _ = (my_eqs := eqs ; my_les := les ; my_lts := lts ; my_proof := proof)
+    fun translate prf = case prf of
+        Axiom_eq n => nth eqs n
+      | Axiom_le n => nth les n
+      | Axiom_lt n => nth lts n
+      | Rational_eq x => eqT_elim(numeric_eq_conv(capply @{cterm Trueprop} 
+                          (capply (capply @{cterm "op =::real => _"} (mk_numeric x)) 
+                               @{cterm "0::real"})))
+      | Rational_le x => eqT_elim(numeric_ge_conv(capply @{cterm Trueprop} 
+                          (capply (capply @{cterm "op <=::real => _"} 
+                                     @{cterm "0::real"}) (mk_numeric x))))
+      | Rational_lt x => eqT_elim(numeric_gt_conv(capply @{cterm Trueprop} 
+                      (capply (capply @{cterm "op <::real => _"} @{cterm "0::real"})
+                        (mk_numeric x))))
+      | Square t => square_rule t
+      | Eqmul(t,p) => emul_rule t (translate p)
+      | Sum(p1,p2) => add_rule (translate p1) (translate p2)
+      | Product(p1,p2) => mul_rule (translate p1) (translate p2)
+   in fconv_rule (first_conv [numeric_ge_conv, numeric_gt_conv, numeric_eq_conv, all_conv]) 
+          (translate proof)
+   end
+  
+  val init_conv = presimp_conv then_conv
+      nnf_conv then_conv skolemize_conv then_conv prenex_conv then_conv
+      weak_dnf_conv
+
+  val concl = dest_arg o cprop_of
+  fun is_binop opr ct = (dest_fun2 ct aconvc opr handle CTERM _ => false)
+  val is_req = is_binop @{cterm "op =:: real => _"}
+  val is_ge = is_binop @{cterm "op <=:: real => _"}
+  val is_gt = is_binop @{cterm "op <:: real => _"}
+  val is_conj = is_binop @{cterm "op &"}
+  val is_disj = is_binop @{cterm "op |"}
+  fun conj_pair th = (th RS @{thm conjunct1}, th RS @{thm conjunct2})
+  fun disj_cases th th1 th2 = 
+   let val (p,q) = dest_binop (concl th)
+       val c = concl th1
+       val _ = if c aconvc (concl th2) then () else error "disj_cases : conclusions not alpha convertible"
+   in implies_elim (implies_elim (implies_elim (instantiate' [] (map SOME [p,q,c]) @{thm disjE}) th) (implies_intr (capply @{cterm Trueprop} p) th1)) (implies_intr (capply @{cterm Trueprop} q) th2)
+   end
+ fun overall dun ths = case ths of
+  [] =>
+   let 
+    val (eq,ne) = List.partition (is_req o concl) dun
+     val (le,nl) = List.partition (is_ge o concl) ne
+     val lt = filter (is_gt o concl) nl 
+    in prover hol_of_positivstellensatz (eq,le,lt) end
+ | th::oths =>
+   let 
+    val ct = concl th 
+   in 
+    if is_conj ct  then
+     let 
+      val (th1,th2) = conj_pair th in
+      overall dun (th1::th2::oths) end
+    else if is_disj ct then
+      let 
+       val th1 = overall dun (assume (capply @{cterm Trueprop} (dest_arg1 ct))::oths)
+       val th2 = overall dun (assume (capply @{cterm Trueprop} (dest_arg ct))::oths)
+      in disj_cases th th1 th2 end
+   else overall (th::dun) oths
+  end
+  fun dest_binary b ct = if is_binop b ct then dest_binop ct 
+                         else raise CTERM ("dest_binary",[b,ct])
+  val dest_eq = dest_binary @{cterm "op = :: real => _"}
+  val neq_th = nth pth 5
+  fun real_not_eq_conv ct = 
+   let 
+    val (l,r) = dest_eq (dest_arg ct)
+    val th = instantiate ([],[(@{cpat "?x::real"},l),(@{cpat "?y::real"},r)]) neq_th
+    val th_p = poly_conv(dest_arg(dest_arg1(rhs_of th)))
+    val th_x = Drule.arg_cong_rule @{cterm "uminus :: real => _"} th_p
+    val th_n = fconv_rule (arg_conv poly_neg_conv) th_x
+    val th' = Drule.binop_cong_rule @{cterm "op |"} 
+     (Drule.arg_cong_rule (capply @{cterm "op <::real=>_"} @{cterm "0::real"}) th_p)
+     (Drule.arg_cong_rule (capply @{cterm "op <::real=>_"} @{cterm "0::real"}) th_n)
+    in transitive th th' 
+  end
+ fun equal_implies_1_rule PQ = 
+  let 
+   val P = lhs_of PQ
+  in implies_intr P (equal_elim PQ (assume P))
+  end
+ (* FIXME!!! Copied from groebner.ml *)
+ val strip_exists =
+  let fun h (acc, t) =
+   case (term_of t) of
+    Const("Ex",_)$Abs(x,T,p) => h (dest_abs NONE (dest_arg t) |>> (fn v => v::acc))
+  | _ => (acc,t)
+  in fn t => h ([],t)
+  end
+  fun name_of x = case term_of x of
+   Free(s,_) => s
+ | Var ((s,_),_) => s
+ | _ => "x"
+
+  fun mk_forall x th = Drule.arg_cong_rule (instantiate_cterm' [SOME (ctyp_of_term x)] [] @{cpat "All :: (?'a => bool) => _" }) (abstract_rule (name_of x) x th)
+
+  val specl = fold_rev (fn x => fn th => instantiate' [] [SOME x] (th RS spec));
+
+ fun ext T = Drule.cterm_rule (instantiate' [SOME T] []) @{cpat Ex}
+ fun mk_ex v t = Thm.capply (ext (ctyp_of_term v)) (Thm.cabs v t)
+
+ fun choose v th th' = case concl_of th of 
+   @{term Trueprop} $ (Const("Ex",_)$_) => 
+    let
+     val p = (funpow 2 Thm.dest_arg o cprop_of) th
+     val T = (hd o Thm.dest_ctyp o ctyp_of_term) p
+     val th0 = fconv_rule (Thm.beta_conversion true)
+         (instantiate' [SOME T] [SOME p, (SOME o Thm.dest_arg o cprop_of) th'] exE)
+     val pv = (Thm.rhs_of o Thm.beta_conversion true) 
+           (Thm.capply @{cterm Trueprop} (Thm.capply p v))
+     val th1 = forall_intr v (implies_intr pv th')
+    in implies_elim (implies_elim th0 th) th1  end
+ | _ => raise THM ("choose",0,[th, th'])
+
+  fun simple_choose v th = 
+     choose v (assume ((Thm.capply @{cterm Trueprop} o mk_ex v) ((Thm.dest_arg o hd o #hyps o Thm.crep_thm) th))) th
+
+ val strip_forall =
+  let fun h (acc, t) =
+   case (term_of t) of
+    Const("All",_)$Abs(x,T,p) => h (dest_abs NONE (dest_arg t) |>> (fn v => v::acc))
+  | _ => (acc,t)
+  in fn t => h ([],t)
+  end
+
+ fun f ct =
+  let 
+   val nnf_norm_conv' = 
+     nnf_conv then_conv 
+     literals_conv [@{term "op &"}, @{term "op |"}] [] 
+     (cache_conv 
+       (first_conv [real_lt_conv, real_le_conv, 
+                    real_eq_conv, real_not_lt_conv, 
+                    real_not_le_conv, real_not_eq_conv, all_conv]))
+  fun absremover ct = (literals_conv [@{term "op &"}, @{term "op |"}] [] 
+                  (try_conv (absconv1 then_conv binop_conv (arg_conv poly_conv))) then_conv 
+        try_conv (absconv2 then_conv nnf_norm_conv' then_conv binop_conv absremover)) ct
+  val nct = capply @{cterm Trueprop} (capply @{cterm "Not"} ct)
+  val th0 = (init_conv then_conv arg_conv nnf_norm_conv') nct
+  val tm0 = dest_arg (rhs_of th0)
+  val th = if tm0 aconvc @{cterm False} then equal_implies_1_rule th0 else
+   let 
+    val (evs,bod) = strip_exists tm0
+    val (avs,ibod) = strip_forall bod
+    val th1 = Drule.arg_cong_rule @{cterm Trueprop} (fold mk_forall avs (absremover ibod))
+    val th2 = overall [] [specl avs (assume (rhs_of th1))]
+    val th3 = fold simple_choose evs (prove_hyp (equal_elim th1 (assume (capply @{cterm Trueprop} bod))) th2)
+   in  Drule.implies_intr_hyps (prove_hyp (equal_elim th0 (assume nct)) th3)
+   end
+  in implies_elim (instantiate' [] [SOME ct] pth_final) th
+ end
+in f
+end;
+
+(* A linear arithmetic prover *)
+local
+  val linear_add = Ctermfunc.combine (curry op +/) (fn z => z =/ Rat.zero)
+  fun linear_cmul c = Ctermfunc.mapf (fn x => c */ x)
+  val one_tm = @{cterm "1::real"}
+  fun contradictory p (e,_) = ((Ctermfunc.is_undefined e) andalso not(p Rat.zero)) orelse
+     ((gen_eq_set (op aconvc) (Ctermfunc.dom e, [one_tm])) andalso not(p(Ctermfunc.apply e one_tm)))
+
+  fun linear_ineqs vars (les,lts) = 
+   case find_first (contradictory (fn x => x >/ Rat.zero)) lts of
+    SOME r => r
+  | NONE => 
+   (case find_first (contradictory (fn x => x >/ Rat.zero)) les of
+     SOME r => r
+   | NONE => 
+     if null vars then error "linear_ineqs: no contradiction" else
+     let 
+      val ineqs = les @ lts
+      fun blowup v =
+       length(filter (fn (e,_) => Ctermfunc.tryapplyd e v Rat.zero =/ Rat.zero) ineqs) +
+       length(filter (fn (e,_) => Ctermfunc.tryapplyd e v Rat.zero >/ Rat.zero) ineqs) *
+       length(filter (fn (e,_) => Ctermfunc.tryapplyd e v Rat.zero </ Rat.zero) ineqs)
+      val  v = fst(hd(sort (fn ((_,i),(_,j)) => int_ord (i,j))
+                 (map (fn v => (v,blowup v)) vars)))
+      fun addup (e1,p1) (e2,p2) acc =
+       let 
+        val c1 = Ctermfunc.tryapplyd e1 v Rat.zero 
+        val c2 = Ctermfunc.tryapplyd e2 v Rat.zero
+       in if c1 */ c2 >=/ Rat.zero then acc else
+        let 
+         val e1' = linear_cmul (Rat.abs c2) e1
+         val e2' = linear_cmul (Rat.abs c1) e2
+         val p1' = Product(Rational_lt(Rat.abs c2),p1)
+         val p2' = Product(Rational_lt(Rat.abs c1),p2)
+        in (linear_add e1' e2',Sum(p1',p2'))::acc
+        end
+       end
+      val (les0,les1) = 
+         List.partition (fn (e,_) => Ctermfunc.tryapplyd e v Rat.zero =/ Rat.zero) les
+      val (lts0,lts1) = 
+         List.partition (fn (e,_) => Ctermfunc.tryapplyd e v Rat.zero =/ Rat.zero) lts
+      val (lesp,lesn) = 
+         List.partition (fn (e,_) => Ctermfunc.tryapplyd e v Rat.zero >/ Rat.zero) les1
+      val (ltsp,ltsn) = 
+         List.partition (fn (e,_) => Ctermfunc.tryapplyd e v Rat.zero >/ Rat.zero) lts1
+      val les' = fold_rev (fn ep1 => fold_rev (addup ep1) lesp) lesn les0
+      val lts' = fold_rev (fn ep1 => fold_rev (addup ep1) (lesp@ltsp)) ltsn
+                      (fold_rev (fn ep1 => fold_rev (addup ep1) (lesn@ltsn)) ltsp lts0)
+     in linear_ineqs (remove (op aconvc) v vars) (les',lts')
+     end)
+
+  fun linear_eqs(eqs,les,lts) = 
+   case find_first (contradictory (fn x => x =/ Rat.zero)) eqs of
+    SOME r => r
+  | NONE => (case eqs of 
+    [] => 
+     let val vars = remove (op aconvc) one_tm 
+           (fold_rev (curry (gen_union (op aconvc)) o Ctermfunc.dom o fst) (les@lts) []) 
+     in linear_ineqs vars (les,lts) end
+   | (e,p)::es => 
+     if Ctermfunc.is_undefined e then linear_eqs (es,les,lts) else
+     let 
+      val (x,c) = Ctermfunc.choose (Ctermfunc.undefine one_tm e)
+      fun xform (inp as (t,q)) =
+       let val d = Ctermfunc.tryapplyd t x Rat.zero in
+        if d =/ Rat.zero then inp else
+        let 
+         val k = (Rat.neg d) */ Rat.abs c // c
+         val e' = linear_cmul k e
+         val t' = linear_cmul (Rat.abs c) t
+         val p' = Eqmul(cterm_of_rat k,p)
+         val q' = Product(Rational_lt(Rat.abs c),q) 
+        in (linear_add e' t',Sum(p',q')) 
+        end 
+      end
+     in linear_eqs(map xform es,map xform les,map xform lts)
+     end)
+
+  fun linear_prover (eq,le,lt) = 
+   let 
+    val eqs = map2 (fn p => fn n => (p,Axiom_eq n)) eq (0 upto (length eq - 1))
+    val les = map2 (fn p => fn n => (p,Axiom_le n)) le (0 upto (length le - 1))
+    val lts = map2 (fn p => fn n => (p,Axiom_lt n)) lt (0 upto (length lt - 1))
+   in linear_eqs(eqs,les,lts)
+   end 
+  
+  fun lin_of_hol ct = 
+   if ct aconvc @{cterm "0::real"} then Ctermfunc.undefined
+   else if not (is_comb ct) then Ctermfunc.onefunc (ct, Rat.one)
+   else if is_ratconst ct then Ctermfunc.onefunc (one_tm, dest_ratconst ct)
+   else
+    let val (lop,r) = Thm.dest_comb ct 
+    in if not (is_comb lop) then Ctermfunc.onefunc (ct, Rat.one)
+       else
+        let val (opr,l) = Thm.dest_comb lop 
+        in if opr aconvc @{cterm "op + :: real =>_"} 
+           then linear_add (lin_of_hol l) (lin_of_hol r)
+           else if opr aconvc @{cterm "op * :: real =>_"} 
+                   andalso is_ratconst l then Ctermfunc.onefunc (r, dest_ratconst l)
+           else Ctermfunc.onefunc (ct, Rat.one)
+        end
+    end
+
+  fun is_alien ct = case term_of ct of 
+   Const(@{const_name "real"}, _)$ n => 
+     if can HOLogic.dest_number n then false else true
+  | _ => false
+ open Thm
+in 
+fun real_linear_prover translator (eq,le,lt) = 
+ let 
+  val lhs = lin_of_hol o dest_arg1 o dest_arg o cprop_of
+  val rhs = lin_of_hol o dest_arg o dest_arg o cprop_of
+  val eq_pols = map lhs eq
+  val le_pols = map rhs le
+  val lt_pols = map rhs lt 
+  val aliens =  filter is_alien
+      (fold_rev (curry (gen_union (op aconvc)) o Ctermfunc.dom) 
+          (eq_pols @ le_pols @ lt_pols) [])
+  val le_pols' = le_pols @ map (fn v => Ctermfunc.onefunc (v,Rat.one)) aliens
+  val (_,proof) = linear_prover (eq_pols,le_pols',lt_pols)
+  val le' = le @ map (fn a => instantiate' [] [SOME (dest_arg a)] @{thm real_of_nat_ge_zero}) aliens 
+ in (translator (eq,le',lt) proof) : thm
+ end
+end;
+
+(* A less general generic arithmetic prover dealing with abs,max and min*)
+
+local
+ val absmaxmin_elim_ss1 = HOL_basic_ss addsimps real_abs_thms1
+ fun absmaxmin_elim_conv1 ctxt = 
+    Simplifier.rewrite (Simplifier.context ctxt absmaxmin_elim_ss1)
+
+ val absmaxmin_elim_conv2 =
+  let 
+   val pth_abs = instantiate' [SOME @{ctyp real}] [] abs_split'
+   val pth_max = instantiate' [SOME @{ctyp real}] [] max_split
+   val pth_min = instantiate' [SOME @{ctyp real}] [] min_split
+   val abs_tm = @{cterm "abs :: real => _"}
+   val p_tm = @{cpat "?P :: real => bool"}
+   val x_tm = @{cpat "?x :: real"}
+   val y_tm = @{cpat "?y::real"}
+   val is_max = is_binop @{cterm "max :: real => _"}
+   val is_min = is_binop @{cterm "min :: real => _"} 
+   fun is_abs t = is_comb t andalso dest_fun t aconvc abs_tm
+   fun eliminate_construct p c tm =
+    let 
+     val t = find_cterm p tm
+     val th0 = (symmetric o beta_conversion false) (capply (cabs t tm) t)
+     val (p,ax) = (dest_comb o rhs_of) th0
+    in fconv_rule(arg_conv(binop_conv (arg_conv (beta_conversion false))))
+               (transitive th0 (c p ax))
+   end
+
+   val elim_abs = eliminate_construct is_abs
+    (fn p => fn ax => 
+       instantiate ([], [(p_tm,p), (x_tm, dest_arg ax)]) pth_abs)
+   val elim_max = eliminate_construct is_max
+    (fn p => fn ax => 
+      let val (ax,y) = dest_comb ax 
+      in  instantiate ([], [(p_tm,p), (x_tm, dest_arg ax), (y_tm,y)]) 
+      pth_max end)
+   val elim_min = eliminate_construct is_min
+    (fn p => fn ax => 
+      let val (ax,y) = dest_comb ax 
+      in  instantiate ([], [(p_tm,p), (x_tm, dest_arg ax), (y_tm,y)]) 
+      pth_min end)
+   in first_conv [elim_abs, elim_max, elim_min, all_conv]
+  end;
+in fun gen_real_arith ctxt (mkconst,eq,ge,gt,norm,neg,add,mul,prover) =
+        gen_gen_real_arith ctxt (mkconst,eq,ge,gt,norm,neg,add,mul,
+                       absmaxmin_elim_conv1 ctxt,absmaxmin_elim_conv2,prover)
+end;
+
+(* An instance for reals*) 
+
+fun gen_prover_real_arith ctxt prover = 
+ let
+  fun simple_cterm_ord t u = TermOrd.term_ord (term_of t, term_of u) = LESS
+  val {add,mul,neg,pow,sub,main} = 
+     Normalizer.semiring_normalizers_ord_wrapper ctxt
+      (valOf (NormalizerData.match ctxt @{cterm "(0::real) + 1"})) 
+     simple_cterm_ord
+in gen_real_arith ctxt
+   (cterm_of_rat, field_comp_conv, field_comp_conv,field_comp_conv,
+    main,neg,add,mul, prover)
+end;
+
+fun real_arith ctxt = gen_prover_real_arith ctxt real_linear_prover;
+end

--- a/src/HOL/Library/reflection.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Library/reflection.ML	Fri May 15 15:56:28 2009 +0200
@@ -314,5 +314,6 @@
   in (rtac th i THEN TRY(rtac TrueI i)) st end);
 
 fun reflection_tac ctxt = gen_reflection_tac ctxt Codegen.evaluation_conv;
+  (*FIXME why Codegen.evaluation_conv?  very specific...*)
 
 end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Library/sum_of_squares.ML	Fri May 15 15:56:28 2009 +0200
@@ -0,0 +1,1665 @@
+structure Sos = 
+struct
+
+val rat_0 = Rat.zero;
+val rat_1 = Rat.one;
+val rat_2 = Rat.two;
+val rat_10 = Rat.rat_of_int 10;
+val rat_1_2 = rat_1 // rat_2;
+val max = curry IntInf.max;
+val min = curry IntInf.min;
+
+val denominator_rat = Rat.quotient_of_rat #> snd #> Rat.rat_of_int;
+val numerator_rat = Rat.quotient_of_rat #> fst #> Rat.rat_of_int;
+fun int_of_rat a = 
+    case Rat.quotient_of_rat a of (i,1) => i | _ => error "int_of_rat: not an int";
+fun lcm_rat x y = Rat.rat_of_int (Integer.lcm (int_of_rat x) (int_of_rat y));
+
+fun rat_pow r i = 
+ let fun pow r i = 
+   if i = 0 then rat_1 else 
+   let val d = pow r (i div 2)
+   in d */ d */ (if i mod 2 = 0 then rat_1 else r)
+   end
+ in if i < 0 then pow (Rat.inv r) (~ i) else pow r i end;
+
+fun round_rat r = 
+ let val (a,b) = Rat.quotient_of_rat (Rat.abs r)
+     val d = a div b
+     val s = if r </ rat_0 then (Rat.neg o Rat.rat_of_int) else Rat.rat_of_int
+     val x2 = 2 * (a - (b * d))
+ in s (if x2 >= b then d + 1 else d) end
+
+val abs_rat = Rat.abs;
+val pow2 = rat_pow rat_2;
+val pow10 = rat_pow rat_10;
+
+val debugging = ref false;
+
+exception Sanity;
+
+exception Unsolvable;
+
+(* Turn a rational into a decimal string with d sig digits.                  *)
+
+local
+fun normalize y =
+  if abs_rat y </ (rat_1 // rat_10) then normalize (rat_10 */ y) - 1
+  else if abs_rat y >=/ rat_1 then normalize (y // rat_10) + 1
+  else 0 
+ in
+fun decimalize d x =
+  if x =/ rat_0 then "0.0" else
+  let 
+   val y = Rat.abs x
+   val e = normalize y
+   val z = pow10(~ e) */ y +/ rat_1
+   val k = int_of_rat (round_rat(pow10 d */ z))
+  in (if x </ rat_0 then "-0." else "0.") ^
+     implode(tl(explode(string_of_int k))) ^
+     (if e = 0 then "" else "e"^string_of_int e)
+  end
+end;
+
+(* Iterations over numbers, and lists indexed by numbers.                    *)
+
+fun itern k l f a =
+  case l of
+    [] => a
+  | h::t => itern (k + 1) t f (f h k a);
+
+fun iter (m,n) f a =
+  if n < m then a
+  else iter (m+1,n) f (f m a);
+
+(* The main types.                                                           *)
+
+fun strict_ord ord (x,y) = case ord (x,y) of LESS => LESS | _ => GREATER
+
+structure Intpairfunc = FuncFun(type key = int*int val ord = prod_ord int_ord int_ord);
+
+type vector = int* Rat.rat Intfunc.T;
+
+type matrix = (int*int)*(Rat.rat Intpairfunc.T);
+
+type monomial = int Ctermfunc.T;
+
+val cterm_ord = (fn (s,t) => TermOrd.fast_term_ord(term_of s, term_of t))
+ fun monomial_ord (m1,m2) = list_ord (prod_ord cterm_ord int_ord) (Ctermfunc.graph m1, Ctermfunc.graph m2)
+structure Monomialfunc = FuncFun(type key = monomial val ord = monomial_ord)
+
+type poly = Rat.rat Monomialfunc.T;
+
+ fun iszero (k,r) = r =/ rat_0;
+
+fun fold_rev2 f l1 l2 b =
+  case (l1,l2) of
+    ([],[]) => b
+  | (h1::t1,h2::t2) => f h1 h2 (fold_rev2 f t1 t2 b)
+  | _ => error "fold_rev2";
+ 
+(* Vectors. Conventionally indexed 1..n.                                     *)
+
+fun vector_0 n = (n,Intfunc.undefined):vector;
+
+fun dim (v:vector) = fst v;
+
+fun vector_const c n =
+  if c =/ rat_0 then vector_0 n
+  else (n,fold_rev (fn k => Intfunc.update (k,c)) (1 upto n) Intfunc.undefined) :vector;
+
+val vector_1 = vector_const rat_1;
+
+fun vector_cmul c (v:vector) =
+ let val n = dim v 
+ in if c =/ rat_0 then vector_0 n
+    else (n,Intfunc.mapf (fn x => c */ x) (snd v))
+ end;
+
+fun vector_neg (v:vector) = (fst v,Intfunc.mapf Rat.neg (snd v)) :vector;
+
+fun vector_add (v1:vector) (v2:vector) =
+ let val m = dim v1  
+     val n = dim v2 
+ in if m <> n then error "vector_add: incompatible dimensions"
+    else (n,Intfunc.combine (curry op +/) (fn x => x =/ rat_0) (snd v1) (snd v2)) :vector 
+ end;
+
+fun vector_sub v1 v2 = vector_add v1 (vector_neg v2);
+
+fun vector_dot (v1:vector) (v2:vector) =
+ let val m = dim v1 
+     val n = dim v2 
+ in if m <> n then error "vector_dot: incompatible dimensions" 
+    else Intfunc.fold (fn (i,x) => fn a => x +/ a) 
+        (Intfunc.combine (curry op */) (fn x => x =/ rat_0) (snd v1) (snd v2)) rat_0
+ end;
+
+fun vector_of_list l =
+ let val n = length l 
+ in (n,fold_rev2 (curry Intfunc.update) (1 upto n) l Intfunc.undefined) :vector
+ end;
+
+(* Matrices; again rows and columns indexed from 1.                          *)
+
+fun matrix_0 (m,n) = ((m,n),Intpairfunc.undefined):matrix;
+
+fun dimensions (m:matrix) = fst m;
+
+fun matrix_const c (mn as (m,n)) =
+  if m <> n then error "matrix_const: needs to be square"
+  else if c =/ rat_0 then matrix_0 mn
+  else (mn,fold_rev (fn k => Intpairfunc.update ((k,k), c)) (1 upto n) Intpairfunc.undefined) :matrix;;
+
+val matrix_1 = matrix_const rat_1;
+
+fun matrix_cmul c (m:matrix) =
+ let val (i,j) = dimensions m 
+ in if c =/ rat_0 then matrix_0 (i,j)
+    else ((i,j),Intpairfunc.mapf (fn x => c */ x) (snd m))
+ end;
+
+fun matrix_neg (m:matrix) = 
+  (dimensions m, Intpairfunc.mapf Rat.neg (snd m)) :matrix;
+
+fun matrix_add (m1:matrix) (m2:matrix) =
+ let val d1 = dimensions m1 
+     val d2 = dimensions m2 
+ in if d1 <> d2 
+     then error "matrix_add: incompatible dimensions"
+    else (d1,Intpairfunc.combine (curry op +/) (fn x => x =/ rat_0) (snd m1) (snd m2)) :matrix
+ end;;
+
+fun matrix_sub m1 m2 = matrix_add m1 (matrix_neg m2);
+
+fun row k (m:matrix) =
+ let val (i,j) = dimensions m 
+ in (j,
+   Intpairfunc.fold (fn ((i,j), c) => fn a => if i = k then Intfunc.update (j,c) a else a) (snd m) Intfunc.undefined ) : vector
+ end;
+
+fun column k (m:matrix) =
+  let val (i,j) = dimensions m 
+  in (i,
+   Intpairfunc.fold (fn ((i,j), c) => fn a => if j = k then Intfunc.update (i,c) a else a) (snd m)  Intfunc.undefined)
+   : vector
+ end;
+
+fun transp (m:matrix) =
+  let val (i,j) = dimensions m 
+  in
+  ((j,i),Intpairfunc.fold (fn ((i,j), c) => fn a => Intpairfunc.update ((j,i), c) a) (snd m) Intpairfunc.undefined) :matrix
+ end;
+
+fun diagonal (v:vector) =
+ let val n = dim v 
+ in ((n,n),Intfunc.fold (fn (i, c) => fn a => Intpairfunc.update ((i,i), c) a) (snd v) Intpairfunc.undefined) : matrix
+ end;
+
+fun matrix_of_list l =
+ let val m = length l 
+ in if m = 0 then matrix_0 (0,0) else
+   let val n = length (hd l) 
+   in ((m,n),itern 1 l (fn v => fn i => itern 1 v (fn c => fn j => Intpairfunc.update ((i,j), c))) Intpairfunc.undefined)
+   end
+ end;
+
+(* Monomials.                                                                *)
+
+fun monomial_eval assig (m:monomial) =
+  Ctermfunc.fold (fn (x, k) => fn a => a */ rat_pow (Ctermfunc.apply assig x) k)
+        m rat_1;
+val monomial_1 = (Ctermfunc.undefined:monomial);
+
+fun monomial_var x = Ctermfunc.onefunc (x, 1) :monomial;
+
+val (monomial_mul:monomial->monomial->monomial) =
+  Ctermfunc.combine (curry op +) (K false);
+
+fun monomial_pow (m:monomial) k =
+  if k = 0 then monomial_1
+  else Ctermfunc.mapf (fn x => k * x) m;
+
+fun monomial_divides (m1:monomial) (m2:monomial) =
+  Ctermfunc.fold (fn (x, k) => fn a => Ctermfunc.tryapplyd m2 x 0 >= k andalso a) m1 true;;
+
+fun monomial_div (m1:monomial) (m2:monomial) =
+ let val m = Ctermfunc.combine (curry op +) 
+   (fn x => x = 0) m1 (Ctermfunc.mapf (fn x => ~ x) m2) 
+ in if Ctermfunc.fold (fn (x, k) => fn a => k >= 0 andalso a) m true then m
+  else error "monomial_div: non-divisible"
+ end;
+
+fun monomial_degree x (m:monomial) = 
+  Ctermfunc.tryapplyd m x 0;;
+
+fun monomial_lcm (m1:monomial) (m2:monomial) =
+  fold_rev (fn x => Ctermfunc.update (x, max (monomial_degree x m1) (monomial_degree x m2)))
+          (gen_union (is_equal o  cterm_ord) (Ctermfunc.dom m1, Ctermfunc.dom m2)) (Ctermfunc.undefined :monomial);
+
+fun monomial_multidegree (m:monomial) = 
+ Ctermfunc.fold (fn (x, k) => fn a => k + a) m 0;;
+
+fun monomial_variables m = Ctermfunc.dom m;;
+
+(* Polynomials.                                                              *)
+
+fun eval assig (p:poly) =
+  Monomialfunc.fold (fn (m, c) => fn a => a +/ c */ monomial_eval assig m) p rat_0;
+
+val poly_0 = (Monomialfunc.undefined:poly);
+
+fun poly_isconst (p:poly) = 
+  Monomialfunc.fold (fn (m, c) => fn a => Ctermfunc.is_undefined m andalso a) p true;
+
+fun poly_var x = Monomialfunc.onefunc (monomial_var x,rat_1) :poly;
+
+fun poly_const c =
+  if c =/ rat_0 then poly_0 else Monomialfunc.onefunc(monomial_1, c);
+
+fun poly_cmul c (p:poly) =
+  if c =/ rat_0 then poly_0
+  else Monomialfunc.mapf (fn x => c */ x) p;
+
+fun poly_neg (p:poly) = (Monomialfunc.mapf Rat.neg p :poly);;
+
+fun poly_add (p1:poly) (p2:poly) =
+  (Monomialfunc.combine (curry op +/) (fn x => x =/ rat_0) p1 p2 :poly);
+
+fun poly_sub p1 p2 = poly_add p1 (poly_neg p2);
+
+fun poly_cmmul (c,m) (p:poly) =
+ if c =/ rat_0 then poly_0
+ else if Ctermfunc.is_undefined m 
+      then Monomialfunc.mapf (fn d => c */ d) p
+      else Monomialfunc.fold (fn (m', d) => fn a => (Monomialfunc.update (monomial_mul m m', c */ d) a)) p poly_0;
+
+fun poly_mul (p1:poly) (p2:poly) =
+  Monomialfunc.fold (fn (m, c) => fn a => poly_add (poly_cmmul (c,m) p2) a) p1 poly_0;
+
+fun poly_div (p1:poly) (p2:poly) =
+ if not(poly_isconst p2) 
+ then error "poly_div: non-constant" else
+ let val c = eval Ctermfunc.undefined p2 
+ in if c =/ rat_0 then error "poly_div: division by zero"
+    else poly_cmul (Rat.inv c) p1
+ end;
+
+fun poly_square p = poly_mul p p;
+
+fun poly_pow p k =
+ if k = 0 then poly_const rat_1
+ else if k = 1 then p
+ else let val q = poly_square(poly_pow p (k div 2)) in
+      if k mod 2 = 1 then poly_mul p q else q end;
+
+fun poly_exp p1 p2 =
+  if not(poly_isconst p2) 
+  then error "poly_exp: not a constant" 
+  else poly_pow p1 (int_of_rat (eval Ctermfunc.undefined p2));
+
+fun degree x (p:poly) = 
+ Monomialfunc.fold (fn (m,c) => fn a => max (monomial_degree x m) a) p 0;
+
+fun multidegree (p:poly) =
+  Monomialfunc.fold (fn (m, c) => fn a => max (monomial_multidegree m) a) p 0;
+
+fun poly_variables (p:poly) =
+  sort cterm_ord (Monomialfunc.fold_rev (fn (m, c) => curry (gen_union (is_equal o  cterm_ord)) (monomial_variables m)) p []);;
+
+(* Order monomials for human presentation.                                   *)
+
+fun cterm_ord (t,t') = TermOrd.fast_term_ord (term_of t, term_of t');
+
+val humanorder_varpow = prod_ord cterm_ord (rev_order o int_ord);
+
+local
+ fun ord (l1,l2) = case (l1,l2) of
+  (_,[]) => LESS 
+ | ([],_) => GREATER
+ | (h1::t1,h2::t2) => 
+   (case humanorder_varpow (h1, h2) of 
+     LESS => LESS
+   | EQUAL => ord (t1,t2)
+   | GREATER => GREATER)
+in fun humanorder_monomial m1 m2 = 
+ ord (sort humanorder_varpow (Ctermfunc.graph m1),
+  sort humanorder_varpow (Ctermfunc.graph m2))
+end;
+
+fun fold1 f l =  case l of
+   []     => error "fold1"
+ | [x]    => x
+ | (h::t) => f h (fold1 f t);
+
+(* Conversions to strings.                                                   *)
+
+fun string_of_vector min_size max_size (v:vector) =
+ let val n_raw = dim v 
+ in if n_raw = 0 then "[]" else
+  let 
+   val n = max min_size (min n_raw max_size) 
+   val xs = map (Rat.string_of_rat o (fn i => Intfunc.tryapplyd (snd v) i rat_0)) (1 upto n) 
+  in "[" ^ fold1 (fn s => fn t => s ^ ", " ^ t) xs ^
+  (if n_raw > max_size then ", ...]" else "]")
+  end
+ end;
+
+fun string_of_matrix max_size (m:matrix) =
+ let 
+  val (i_raw,j_raw) = dimensions m
+  val i = min max_size i_raw 
+  val j = min max_size j_raw
+  val rstr = map (fn k => string_of_vector j j (row k m)) (1 upto i) 
+ in "["^ fold1 (fn s => fn t => s^";\n "^t) rstr ^
+  (if j > max_size then "\n ...]" else "]")
+ end;
+
+fun string_of_term t = 
+ case t of
+   a$b => "("^(string_of_term a)^" "^(string_of_term b)^")"
+ | Abs x => 
+    let val (xn, b) = Term.dest_abs x
+    in "(\\"^xn^"."^(string_of_term b)^")"
+    end
+ | Const(s,_) => s
+ | Free (s,_) => s
+ | Var((s,_),_) => s
+ | _ => error "string_of_term";
+
+val string_of_cterm = string_of_term o term_of;
+
+fun string_of_varpow x k =
+  if k = 1 then string_of_cterm x 
+  else string_of_cterm x^"^"^string_of_int k;
+
+fun string_of_monomial m =
+ if Ctermfunc.is_undefined m then "1" else
+ let val vps = fold_rev (fn (x,k) => fn a => string_of_varpow x k :: a)
+  (sort humanorder_varpow (Ctermfunc.graph m)) [] 
+ in fold1 (fn s => fn t => s^"*"^t) vps
+ end;
+
+fun string_of_cmonomial (c,m) =
+ if Ctermfunc.is_undefined m then Rat.string_of_rat c
+ else if c =/ rat_1 then string_of_monomial m
+ else Rat.string_of_rat c ^ "*" ^ string_of_monomial m;;
+
+fun string_of_poly (p:poly) =
+ if Monomialfunc.is_undefined p then "<<0>>" else
+ let 
+  val cms = sort (fn ((m1,_),(m2,_)) => humanorder_monomial m1  m2) (Monomialfunc.graph p)
+  val s = fold (fn (m,c) => fn a =>
+             if c </ rat_0 then a ^ " - " ^ string_of_cmonomial(Rat.neg c,m)
+             else a ^ " + " ^ string_of_cmonomial(c,m))
+          cms ""
+  val s1 = String.substring (s, 0, 3)
+  val s2 = String.substring (s, 3, String.size s - 3) 
+ in "<<" ^(if s1 = " + " then s2 else "-"^s2)^">>"
+ end;
+
+(* Conversion from HOL term.                                                 *)
+
+local
+ val neg_tm = @{cterm "uminus :: real => _"}
+ val add_tm = @{cterm "op + :: real => _"}
+ val sub_tm = @{cterm "op - :: real => _"}
+ val mul_tm = @{cterm "op * :: real => _"}
+ val inv_tm = @{cterm "inverse :: real => _"}
+ val div_tm = @{cterm "op / :: real => _"}
+ val pow_tm = @{cterm "op ^ :: real => _"}
+ val zero_tm = @{cterm "0:: real"}
+ val is_numeral = can (HOLogic.dest_number o term_of)
+ fun is_comb t = case t of _$_ => true | _ => false
+ fun poly_of_term tm =
+  if tm aconvc zero_tm then poly_0
+  else if RealArith.is_ratconst tm 
+       then poly_const(RealArith.dest_ratconst tm)
+  else 
+  (let val (lop,r) = Thm.dest_comb tm
+   in if lop aconvc neg_tm then poly_neg(poly_of_term r)
+      else if lop aconvc inv_tm then
+       let val p = poly_of_term r 
+       in if poly_isconst p 
+          then poly_const(Rat.inv (eval Ctermfunc.undefined p))
+          else error "poly_of_term: inverse of non-constant polyomial"
+       end
+   else (let val (opr,l) = Thm.dest_comb lop
+         in 
+          if opr aconvc pow_tm andalso is_numeral r 
+          then poly_pow (poly_of_term l) ((snd o HOLogic.dest_number o term_of) r)
+          else if opr aconvc add_tm 
+           then poly_add (poly_of_term l) (poly_of_term r)
+          else if opr aconvc sub_tm 
+           then poly_sub (poly_of_term l) (poly_of_term r)
+          else if opr aconvc mul_tm 
+           then poly_mul (poly_of_term l) (poly_of_term r)
+          else if opr aconvc div_tm 
+           then let 
+                  val p = poly_of_term l 
+                  val q = poly_of_term r 
+                in if poly_isconst q then poly_cmul (Rat.inv (eval Ctermfunc.undefined q)) p
+                   else error "poly_of_term: division by non-constant polynomial"
+                end
+          else poly_var tm
+ 
+         end
+         handle CTERM ("dest_comb",_) => poly_var tm)
+   end
+   handle CTERM ("dest_comb",_) => poly_var tm)
+in
+val poly_of_term = fn tm =>
+ if type_of (term_of tm) = @{typ real} then poly_of_term tm
+ else error "poly_of_term: term does not have real type"
+end;
+
+(* String of vector (just a list of space-separated numbers).                *)
+
+fun sdpa_of_vector (v:vector) =
+ let 
+  val n = dim v
+  val strs = map (decimalize 20 o (fn i => Intfunc.tryapplyd (snd v) i rat_0)) (1 upto n) 
+ in fold1 (fn x => fn y => x ^ " " ^ y) strs ^ "\n"
+ end;
+
+fun increasing f ord (x,y) = ord (f x, f y);
+fun triple_int_ord ((a,b,c),(a',b',c')) = 
+ prod_ord int_ord (prod_ord int_ord int_ord) 
+    ((a,(b,c)),(a',(b',c')));
+structure Inttriplefunc = FuncFun(type key = int*int*int val ord = triple_int_ord);
+
+(* String for block diagonal matrix numbered k.                              *)
+
+fun sdpa_of_blockdiagonal k m =
+ let 
+  val pfx = string_of_int k ^" "
+  val ents =
+    Inttriplefunc.fold (fn ((b,i,j), c) => fn a => if i > j then a else ((b,i,j),c)::a) m []
+  val entss = sort (increasing fst triple_int_ord ) ents
+ in  fold_rev (fn ((b,i,j),c) => fn a =>
+     pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^
+     " " ^ decimalize 20 c ^ "\n" ^ a) entss ""
+ end;
+
+(* String for a matrix numbered k, in SDPA sparse format.                    *)
+
+fun sdpa_of_matrix k (m:matrix) =
+ let 
+  val pfx = string_of_int k ^ " 1 "
+  val ms = Intpairfunc.fold (fn ((i,j), c) => fn  a => if i > j then a else ((i,j),c)::a) (snd m) [] 
+  val mss = sort (increasing fst (prod_ord int_ord int_ord)) ms 
+ in fold_rev (fn ((i,j),c) => fn a =>
+     pfx ^ string_of_int i ^ " " ^ string_of_int j ^
+     " " ^ decimalize 20 c ^ "\n" ^ a) mss ""
+ end;;
+
+(* ------------------------------------------------------------------------- *)
+(* String in SDPA sparse format for standard SDP problem:                    *)
+(*                                                                           *)
+(*    X = v_1 * [M_1] + ... + v_m * [M_m] - [M_0] must be PSD                *)
+(*    Minimize obj_1 * v_1 + ... obj_m * v_m                                 *)
+(* ------------------------------------------------------------------------- *)
+
+fun sdpa_of_problem comment obj mats =
+ let 
+  val m = length mats - 1
+  val (n,_) = dimensions (hd mats) 
+ in "\"" ^ comment ^ "\"\n" ^
+  string_of_int m ^ "\n" ^
+  "1\n" ^
+  string_of_int n ^ "\n" ^
+  sdpa_of_vector obj ^
+  fold_rev2 (fn k => fn m => fn a => sdpa_of_matrix (k - 1) m ^ a) (1 upto length mats) mats ""
+ end;
+
+fun index_char str chr pos =
+  if pos >= String.size str then ~1
+  else if String.sub(str,pos) = chr then pos
+  else index_char str chr (pos + 1);
+fun rat_of_quotient (a,b) = if b = 0 then rat_0 else Rat.rat_of_quotient (a,b);
+fun rat_of_string s = 
+ let val n = index_char s #"/" 0 in
+  if n = ~1 then s |> IntInf.fromString |> valOf |> Rat.rat_of_int
+  else 
+   let val SOME numer = IntInf.fromString(String.substring(s,0,n))
+       val SOME den = IntInf.fromString (String.substring(s,n+1,String.size s - n - 1))
+   in rat_of_quotient(numer, den)
+   end
+ end;
+
+fun isspace x = x = " " ;
+fun isnum x = x mem_string ["0","1","2","3","4","5","6","7","8","9"]
+
+(* More parser basics.                                                       *)
+
+local
+ open Scan
+in 
+ val word = this_string
+ fun token s =
+  repeat ($$ " ") |-- word s --| repeat ($$ " ")
+ val numeral = one isnum
+ val decimalint = bulk numeral >> (rat_of_string o implode)
+ val decimalfrac = bulk numeral
+    >> (fn s => rat_of_string(implode s) // pow10 (length s))
+ val decimalsig =
+    decimalint -- option (Scan.$$ "." |-- decimalfrac)
+    >> (fn (h,NONE) => h | (h,SOME x) => h +/ x)
+ fun signed prs =
+       $$ "-" |-- prs >> Rat.neg 
+    || $$ "+" |-- prs
+    || prs;
+
+fun emptyin def xs = if null xs then (def,xs) else Scan.fail xs
+
+ val exponent = ($$ "e" || $$ "E") |-- signed decimalint;
+
+ val decimal = signed decimalsig -- (emptyin rat_0|| exponent)
+    >> (fn (h, x) => h */ pow10 (int_of_rat x));
+end;
+
+ fun mkparser p s =
+  let val (x,rst) = p (explode s) 
+  in if null rst then x 
+     else error "mkparser: unparsed input"
+  end;;
+val parse_decimal = mkparser decimal;
+
+fun fix err prs = 
+  prs || (fn x=> error err);
+
+fun listof prs sep err =
+  prs -- Scan.bulk (sep |-- fix err prs) >> uncurry cons;
+
+(* Parse back a vector.                                                      *)
+
+ val vector = 
+    token "{" |-- listof decimal (token ",") "decimal" --| token "}"
+               >> vector_of_list 
+ val parse_vector = mkparser vector
+ fun skipupto dscr prs inp =
+   (dscr |-- prs 
+    || Scan.one (K true) |-- skipupto dscr prs) inp 
+ fun ignore inp = ((),[])
+ fun sdpaoutput inp =  skipupto (word "xVec" -- token "=")
+             (vector --| ignore) inp
+ fun csdpoutput inp =  ((decimal -- Scan.bulk (Scan.$$ " " |-- Scan.option decimal) >> (fn (h,to) => map_filter I ((SOME h)::to))) --| ignore >> vector_of_list) inp
+ val parse_sdpaoutput = mkparser sdpaoutput
+ val parse_csdpoutput = mkparser csdpoutput
+
+(* Also parse the SDPA output to test success (CSDP yields a return code).   *)
+
+local
+ val prs = 
+  skipupto (word "phase.value" -- token "=")
+   (Scan.option (Scan.$$ "p") -- Scan.option (Scan.$$ "d") 
+    -- (word "OPT" || word "FEAS")) 
+in
+ fun sdpa_run_succeeded s = 
+  (prs (explode s); true) handle _ => false
+end;
+
+(* The default parameters. Unfortunately this goes to a fixed file.          *)
+
+val sdpa_default_parameters =
+"100     unsigned int maxIteration; \n1.0E-7  double 0.0 < epsilonStar;\n1.0E2   double 0.0 < lambdaStar;\n2.0     double 1.0 < omegaStar;\n-1.0E5  double lowerBound;\n1.0E5   double upperBound;\n0.1     double 0.0 <= betaStar <  1.0;\n0.2     double 0.0 <= betaBar  <  1.0, betaStar <= betaBar;\n0.9     double 0.0 < gammaStar  <  1.0;\n1.0E-7  double 0.0 < epsilonDash;\n";;
+
+(* These were suggested by Makoto Yamashita for problems where we are        *)
+(* right at the edge of the semidefinite cone, as sometimes happens.         *)
+
+val sdpa_alt_parameters =
+"1000    unsigned int maxIteration;\n1.0E-7  double 0.0 < epsilonStar;\n1.0E4   double 0.0 < lambdaStar;\n2.0     double 1.0 < omegaStar;\n-1.0E5  double lowerBound;\n1.0E5   double upperBound;\n0.1     double 0.0 <= betaStar <  1.0;\n0.2     double 0.0 <= betaBar  <  1.0, betaStar <= betaBar;\n0.9     double 0.0 < gammaStar  <  1.0;\n1.0E-7  double 0.0 < epsilonDash;\n";;
+
+val sdpa_params = sdpa_alt_parameters;;
+
+(* CSDP parameters; so far I'm sticking with the defaults.                   *)
+
+val csdp_default_parameters =
+"axtol=1.0e-8\natytol=1.0e-8\nobjtol=1.0e-8\npinftol=1.0e8\ndinftol=1.0e8\nmaxiter=100\nminstepfrac=0.9\nmaxstepfrac=0.97\nminstepp=1.0e-8\nminstepd=1.0e-8\nusexzgap=1\ntweakgap=0\naffine=0\nprintlevel=1\n";;
+
+val csdp_params = csdp_default_parameters;;
+
+fun tmp_file pre suf =
+ let val i = string_of_int (round (random()))
+   val name = Path.append (Path.variable "ISABELLE_TMP") (Path.explode (pre ^ i ^ suf))
+ in 
+   if File.exists name then tmp_file pre suf 
+   else name 
+ end;
+
+(* Now call SDPA on a problem and parse back the output.                     *)
+
+fun run_sdpa dbg obj mats =
+ let 
+  val input_file = tmp_file "sos" ".dat-s"
+  val output_file = tmp_file "sos" ".out"
+  val params_file = tmp_file "param" ".sdpa" 
+  val current_dir = File.pwd()
+  val _ = File.write input_file 
+                         (sdpa_of_problem "" obj mats)
+  val _ = File.write params_file sdpa_params
+  val _ = File.cd (Path.variable "ISABELLE_TMP")
+  val _ = File.system_command ("sdpa "^ (Path.implode input_file) ^ " " ^ 
+                               (Path.implode output_file) ^
+                               (if dbg then "" else "> /dev/null"))
+  val opr = File.read output_file 
+ in if not(sdpa_run_succeeded opr) then error "sdpa: call failed" 
+    else
+      let val res = parse_sdpaoutput opr 
+      in ((if dbg then ()
+           else (File.rm input_file; File.rm output_file ; File.cd current_dir));
+          res)
+      end
+ end;
+
+fun sdpa obj mats = run_sdpa (!debugging) obj mats;
+
+(* The same thing with CSDP.                                                 *)
+
+fun run_csdp dbg obj mats =
+ let 
+  val input_file = tmp_file "sos" ".dat-s"
+  val output_file = tmp_file "sos" ".out"
+  val params_file = tmp_file "param" ".csdp"
+  val current_dir = File.pwd()
+  val _ = File.write input_file (sdpa_of_problem "" obj mats)
+  val _ = File.write params_file csdp_params
+  val _ = File.cd (Path.variable "ISABELLE_TMP")
+  val rv = system ("csdp "^(Path.implode input_file) ^ " " 
+                   ^ (Path.implode output_file) ^
+                   (if dbg then "" else "> /dev/null"))
+  val  opr = File.read output_file 
+  val res = parse_csdpoutput opr 
+ in
+    ((if dbg then ()
+      else (File.rm input_file; File.rm output_file ; File.cd current_dir));
+     (rv,res))
+ end;
+
+fun csdp obj mats =
+ let 
+  val (rv,res) = run_csdp (!debugging) obj mats 
+ in
+   ((if rv = 1 orelse rv = 2 then error "csdp: Problem is infeasible"
+    else if rv = 3 then writeln "csdp warning: Reduced accuracy"
+    else if rv <> 0 then error ("csdp: error "^string_of_int rv)
+    else ());
+   res)
+ end;
+
+(* Try some apparently sensible scaling first. Note that this is purely to   *)
+(* get a cleaner translation to floating-point, and doesn't affect any of    *)
+(* the results, in principle. In practice it seems a lot better when there   *)
+(* are extreme numbers in the original problem.                              *)
+
+  (* Version for (int*int) keys *)
+local
+  fun max_rat x y = if x </ y then y else x
+  fun common_denominator fld amat acc =
+      fld (fn (m,c) => fn a => lcm_rat (denominator_rat c) a) amat acc
+  fun maximal_element fld amat acc =
+    fld (fn (m,c) => fn maxa => max_rat maxa (abs_rat c)) amat acc 
+fun float_of_rat x = let val (a,b) = Rat.quotient_of_rat x
+                     in Real.fromLargeInt a / Real.fromLargeInt b end;
+in
+
+fun pi_scale_then solver (obj:vector)  mats =
+ let 
+  val cd1 = fold_rev (common_denominator Intpairfunc.fold) mats (rat_1)
+  val cd2 = common_denominator Intfunc.fold (snd obj)  (rat_1) 
+  val mats' = map (Intpairfunc.mapf (fn x => cd1 */ x)) mats
+  val obj' = vector_cmul cd2 obj
+  val max1 = fold_rev (maximal_element Intpairfunc.fold) mats' (rat_0)
+  val max2 = maximal_element Intfunc.fold (snd obj') (rat_0) 
+  val scal1 = pow2 (20 - trunc(Math.ln (float_of_rat max1) / Math.ln 2.0))
+  val scal2 = pow2 (20 - trunc(Math.ln (float_of_rat max2) / Math.ln 2.0)) 
+  val mats'' = map (Intpairfunc.mapf (fn x => x */ scal1)) mats'
+  val obj'' = vector_cmul scal2 obj' 
+ in solver obj'' mats''
+  end
+end;
+
+(* Try some apparently sensible scaling first. Note that this is purely to   *)
+(* get a cleaner translation to floating-point, and doesn't affect any of    *)
+(* the results, in principle. In practice it seems a lot better when there   *)
+(* are extreme numbers in the original problem.                              *)
+
+  (* Version for (int*int*int) keys *)
+local
+  fun max_rat x y = if x </ y then y else x
+  fun common_denominator fld amat acc =
+      fld (fn (m,c) => fn a => lcm_rat (denominator_rat c) a) amat acc
+  fun maximal_element fld amat acc =
+    fld (fn (m,c) => fn maxa => max_rat maxa (abs_rat c)) amat acc 
+fun float_of_rat x = let val (a,b) = Rat.quotient_of_rat x
+                     in Real.fromLargeInt a / Real.fromLargeInt b end;
+fun int_of_float x = (trunc x handle Overflow => 0 | Domain => 0)
+in
+
+fun tri_scale_then solver (obj:vector)  mats =
+ let 
+  val cd1 = fold_rev (common_denominator Inttriplefunc.fold) mats (rat_1)
+  val cd2 = common_denominator Intfunc.fold (snd obj)  (rat_1) 
+  val mats' = map (Inttriplefunc.mapf (fn x => cd1 */ x)) mats
+  val obj' = vector_cmul cd2 obj
+  val max1 = fold_rev (maximal_element Inttriplefunc.fold) mats' (rat_0)
+  val max2 = maximal_element Intfunc.fold (snd obj') (rat_0) 
+  val scal1 = pow2 (20 - int_of_float(Math.ln (float_of_rat max1) / Math.ln 2.0))
+  val scal2 = pow2 (20 - int_of_float(Math.ln (float_of_rat max2) / Math.ln 2.0)) 
+  val mats'' = map (Inttriplefunc.mapf (fn x => x */ scal1)) mats'
+  val obj'' = vector_cmul scal2 obj' 
+ in solver obj'' mats''
+  end
+end;
+
+(* Round a vector to "nice" rationals.                                       *)
+
+fun nice_rational n x = round_rat (n */ x) // n;;
+fun nice_vector n ((d,v) : vector) = 
+ (d, Intfunc.fold (fn (i,c) => fn a => 
+   let val y = nice_rational n c 
+   in if c =/ rat_0 then a 
+      else Intfunc.update (i,y) a end) v Intfunc.undefined):vector
+
+
+(* Reduce linear program to SDP (diagonal matrices) and test with CSDP. This *)
+(* one tests A [-1;x1;..;xn] >= 0 (i.e. left column is negated constants).   *)
+
+fun linear_program_basic a =
+ let 
+  val (m,n) = dimensions a
+  val mats =  map (fn j => diagonal (column j a)) (1 upto n)
+  val obj = vector_const rat_1 m 
+  val (rv,res) = run_csdp false obj mats 
+ in if rv = 1 orelse rv = 2 then false
+    else if rv = 0 then true
+    else error "linear_program: An error occurred in the SDP solver"
+ end;
+
+(* Alternative interface testing A x >= b for matrix A, vector b.            *)
+
+fun linear_program a b =
+ let val (m,n) = dimensions a 
+ in if dim b <> m then error "linear_program: incompatible dimensions" 
+    else
+    let 
+     val mats = diagonal b :: map (fn j => diagonal (column j a)) (1 upto n)
+     val obj = vector_const rat_1 m 
+     val (rv,res) = run_csdp false obj mats 
+    in if rv = 1 orelse rv = 2 then false
+       else if rv = 0 then true
+       else error "linear_program: An error occurred in the SDP solver"
+    end
+ end;
+
+(* Test whether a point is in the convex hull of others. Rather than use     *)
+(* computational geometry, express as linear inequalities and call CSDP.     *)
+(* This is a bit lazy of me, but it's easy and not such a bottleneck so far. *)
+
+fun in_convex_hull pts pt =
+ let 
+  val pts1 = (1::pt) :: map (fn x => 1::x) pts 
+  val pts2 = map (fn p => map (fn x => ~x) p @ p) pts1
+  val n = length pts + 1
+  val v = 2 * (length pt + 1)
+  val m = v + n - 1 
+  val mat = ((m,n),
+  itern 1 pts2 (fn pts => fn j => itern 1 pts 
+               (fn x => fn i => Intpairfunc.update ((i,j), Rat.rat_of_int x)))
+  (iter (1,n) (fn i => Intpairfunc.update((v + i,i+1), rat_1)) 
+      Intpairfunc.undefined))
+ in linear_program_basic mat
+ end;
+
+(* Filter down a set of points to a minimal set with the same convex hull.   *)
+
+local
+ fun augment1 (m::ms) = if in_convex_hull ms m then ms else ms@[m]
+ fun augment m ms = funpow 3 augment1 (m::ms)
+in
+fun minimal_convex_hull mons =
+ let val mons' = fold_rev augment (tl mons) [hd mons] 
+ in funpow (length mons') augment1 mons'
+ end
+end;
+
+fun dest_ord f x = is_equal (f x);
+
+(* Stuff for "equations" ((int*int*int)->num functions).                         *)
+
+fun tri_equation_cmul c eq =
+  if c =/ rat_0 then Inttriplefunc.undefined else Inttriplefunc.mapf (fn d => c */ d) eq;
+
+fun tri_equation_add eq1 eq2 = Inttriplefunc.combine (curry op +/) (fn x => x =/ rat_0) eq1 eq2;
+
+fun tri_equation_eval assig eq =
+ let fun value v = Inttriplefunc.apply assig v 
+ in Inttriplefunc.fold (fn (v, c) => fn a => a +/ value v */ c) eq rat_0
+ end;
+
+(* Eliminate among linear equations: return unconstrained variables and      *)
+(* assignments for the others in terms of them. We give one pseudo-variable  *)
+(* "one" that's used for a constant term.                                    *)
+
+local
+  fun extract_first p l = case l of  (* FIXME : use find_first instead *)
+   [] => error "extract_first"
+ | h::t => if p h then (h,t) else
+          let val (k,s) = extract_first p t in (k,h::s) end
+fun eliminate vars dun eqs = case vars of 
+  [] => if forall Inttriplefunc.is_undefined eqs then dun
+        else raise Unsolvable
+ | v::vs =>
+  ((let 
+    val (eq,oeqs) = extract_first (fn e => Inttriplefunc.defined e v) eqs 
+    val a = Inttriplefunc.apply eq v
+    val eq' = tri_equation_cmul ((Rat.neg rat_1) // a) (Inttriplefunc.undefine v eq)
+    fun elim e =
+     let val b = Inttriplefunc.tryapplyd e v rat_0 
+     in if b =/ rat_0 then e else
+        tri_equation_add e (tri_equation_cmul (Rat.neg b // a) eq)
+     end
+   in eliminate vs (Inttriplefunc.update (v,eq') (Inttriplefunc.mapf elim dun)) (map elim oeqs)
+   end)
+  handle ERROR _ => eliminate vs dun eqs)
+in
+fun tri_eliminate_equations one vars eqs =
+ let 
+  val assig = eliminate vars Inttriplefunc.undefined eqs
+  val vs = Inttriplefunc.fold (fn (x, f) => fn a => remove (dest_ord triple_int_ord) one (Inttriplefunc.dom f) @ a) assig []
+  in (distinct (dest_ord triple_int_ord) vs, assig)
+  end
+end;
+
+(* Eliminate all variables, in an essentially arbitrary order.               *)
+
+fun tri_eliminate_all_equations one =
+ let 
+  fun choose_variable eq =
+   let val (v,_) = Inttriplefunc.choose eq 
+   in if is_equal (triple_int_ord(v,one)) then
+      let val eq' = Inttriplefunc.undefine v eq 
+      in if Inttriplefunc.is_undefined eq' then error "choose_variable" 
+         else fst (Inttriplefunc.choose eq')
+      end
+    else v 
+   end
+  fun eliminate dun eqs = case eqs of 
+    [] => dun
+  | eq::oeqs =>
+    if Inttriplefunc.is_undefined eq then eliminate dun oeqs else
+    let val v = choose_variable eq
+        val a = Inttriplefunc.apply eq v
+        val eq' = tri_equation_cmul ((Rat.rat_of_int ~1) // a) 
+                   (Inttriplefunc.undefine v eq)
+        fun elim e =
+         let val b = Inttriplefunc.tryapplyd e v rat_0 
+         in if b =/ rat_0 then e 
+            else tri_equation_add e (tri_equation_cmul (Rat.neg b // a) eq)
+         end
+    in eliminate (Inttriplefunc.update(v, eq') (Inttriplefunc.mapf elim dun)) 
+                 (map elim oeqs) 
+    end
+in fn eqs =>
+ let 
+  val assig = eliminate Inttriplefunc.undefined eqs
+  val vs = Inttriplefunc.fold (fn (x, f) => fn a => remove (dest_ord triple_int_ord) one (Inttriplefunc.dom f) @ a) assig []
+ in (distinct (dest_ord triple_int_ord) vs,assig)
+ end
+end;
+ 
+(* Solve equations by assigning arbitrary numbers.                           *)
+
+fun tri_solve_equations one eqs =
+ let 
+  val (vars,assigs) = tri_eliminate_all_equations one eqs
+  val vfn = fold_rev (fn v => Inttriplefunc.update(v,rat_0)) vars 
+            (Inttriplefunc.onefunc(one, Rat.rat_of_int ~1))
+  val ass =
+    Inttriplefunc.combine (curry op +/) (K false) 
+    (Inttriplefunc.mapf (tri_equation_eval vfn) assigs) vfn 
+ in if forall (fn e => tri_equation_eval ass e =/ rat_0) eqs
+    then Inttriplefunc.undefine one ass else raise Sanity
+ end;
+
+(* Multiply equation-parametrized poly by regular poly and add accumulator.  *)
+
+fun tri_epoly_pmul p q acc =
+ Monomialfunc.fold (fn (m1, c) => fn a =>
+  Monomialfunc.fold (fn (m2,e) => fn b =>
+   let val m =  monomial_mul m1 m2
+       val es = Monomialfunc.tryapplyd b m Inttriplefunc.undefined 
+   in Monomialfunc.update (m,tri_equation_add (tri_equation_cmul c e) es) b 
+   end) q a) p acc ;
+
+(* Usual operations on equation-parametrized poly.                           *)
+
+fun tri_epoly_cmul c l =
+  if c =/ rat_0 then Inttriplefunc.undefined else Inttriplefunc.mapf (tri_equation_cmul c) l;;
+
+val tri_epoly_neg = tri_epoly_cmul (Rat.rat_of_int ~1);
+
+val tri_epoly_add = Inttriplefunc.combine tri_equation_add Inttriplefunc.is_undefined;
+
+fun tri_epoly_sub p q = tri_epoly_add p (tri_epoly_neg q);;
+
+(* Stuff for "equations" ((int*int)->num functions).                         *)
+
+fun pi_equation_cmul c eq =
+  if c =/ rat_0 then Inttriplefunc.undefined else Inttriplefunc.mapf (fn d => c */ d) eq;
+
+fun pi_equation_add eq1 eq2 = Inttriplefunc.combine (curry op +/) (fn x => x =/ rat_0) eq1 eq2;
+
+fun pi_equation_eval assig eq =
+ let fun value v = Inttriplefunc.apply assig v 
+ in Inttriplefunc.fold (fn (v, c) => fn a => a +/ value v */ c) eq rat_0
+ end;
+
+(* Eliminate among linear equations: return unconstrained variables and      *)
+(* assignments for the others in terms of them. We give one pseudo-variable  *)
+(* "one" that's used for a constant term.                                    *)
+
+local
+fun extract_first p l = case l of 
+   [] => error "extract_first"
+ | h::t => if p h then (h,t) else
+          let val (k,s) = extract_first p t in (k,h::s) end
+fun eliminate vars dun eqs = case vars of 
+  [] => if forall Inttriplefunc.is_undefined eqs then dun
+        else raise Unsolvable
+ | v::vs =>
+   let 
+    val (eq,oeqs) = extract_first (fn e => Inttriplefunc.defined e v) eqs 
+    val a = Inttriplefunc.apply eq v
+    val eq' = pi_equation_cmul ((Rat.neg rat_1) // a) (Inttriplefunc.undefine v eq)
+    fun elim e =
+     let val b = Inttriplefunc.tryapplyd e v rat_0 
+     in if b =/ rat_0 then e else
+        pi_equation_add e (pi_equation_cmul (Rat.neg b // a) eq)
+     end
+   in eliminate vs (Inttriplefunc.update (v,eq') (Inttriplefunc.mapf elim dun)) (map elim oeqs)
+   end
+  handle ERROR _ => eliminate vs dun eqs
+in
+fun pi_eliminate_equations one vars eqs =
+ let 
+  val assig = eliminate vars Inttriplefunc.undefined eqs
+  val vs = Inttriplefunc.fold (fn (x, f) => fn a => remove (dest_ord triple_int_ord) one (Inttriplefunc.dom f) @ a) assig []
+  in (distinct (dest_ord triple_int_ord) vs, assig)
+  end
+end;
+
+(* Eliminate all variables, in an essentially arbitrary order.               *)
+
+fun pi_eliminate_all_equations one =
+ let 
+  fun choose_variable eq =
+   let val (v,_) = Inttriplefunc.choose eq 
+   in if is_equal (triple_int_ord(v,one)) then
+      let val eq' = Inttriplefunc.undefine v eq 
+      in if Inttriplefunc.is_undefined eq' then error "choose_variable" 
+         else fst (Inttriplefunc.choose eq')
+      end
+    else v 
+   end
+  fun eliminate dun eqs = case eqs of 
+    [] => dun
+  | eq::oeqs =>
+    if Inttriplefunc.is_undefined eq then eliminate dun oeqs else
+    let val v = choose_variable eq
+        val a = Inttriplefunc.apply eq v
+        val eq' = pi_equation_cmul ((Rat.rat_of_int ~1) // a) 
+                   (Inttriplefunc.undefine v eq)
+        fun elim e =
+         let val b = Inttriplefunc.tryapplyd e v rat_0 
+         in if b =/ rat_0 then e 
+            else pi_equation_add e (pi_equation_cmul (Rat.neg b // a) eq)
+         end
+    in eliminate (Inttriplefunc.update(v, eq') (Inttriplefunc.mapf elim dun)) 
+                 (map elim oeqs) 
+    end
+in fn eqs =>
+ let 
+  val assig = eliminate Inttriplefunc.undefined eqs
+  val vs = Inttriplefunc.fold (fn (x, f) => fn a => remove (dest_ord triple_int_ord) one (Inttriplefunc.dom f) @ a) assig []
+ in (distinct (dest_ord triple_int_ord) vs,assig)
+ end
+end;
+ 
+(* Solve equations by assigning arbitrary numbers.                           *)
+
+fun pi_solve_equations one eqs =
+ let 
+  val (vars,assigs) = pi_eliminate_all_equations one eqs
+  val vfn = fold_rev (fn v => Inttriplefunc.update(v,rat_0)) vars 
+            (Inttriplefunc.onefunc(one, Rat.rat_of_int ~1))
+  val ass =
+    Inttriplefunc.combine (curry op +/) (K false) 
+    (Inttriplefunc.mapf (pi_equation_eval vfn) assigs) vfn 
+ in if forall (fn e => pi_equation_eval ass e =/ rat_0) eqs
+    then Inttriplefunc.undefine one ass else raise Sanity
+ end;
+
+(* Multiply equation-parametrized poly by regular poly and add accumulator.  *)
+
+fun pi_epoly_pmul p q acc =
+ Monomialfunc.fold (fn (m1, c) => fn a =>
+  Monomialfunc.fold (fn (m2,e) => fn b =>
+   let val m =  monomial_mul m1 m2
+       val es = Monomialfunc.tryapplyd b m Inttriplefunc.undefined 
+   in Monomialfunc.update (m,pi_equation_add (pi_equation_cmul c e) es) b 
+   end) q a) p acc ;
+
+(* Usual operations on equation-parametrized poly.                           *)
+
+fun pi_epoly_cmul c l =
+  if c =/ rat_0 then Inttriplefunc.undefined else Inttriplefunc.mapf (pi_equation_cmul c) l;;
+
+val pi_epoly_neg = pi_epoly_cmul (Rat.rat_of_int ~1);
+
+val pi_epoly_add = Inttriplefunc.combine pi_equation_add Inttriplefunc.is_undefined;
+
+fun pi_epoly_sub p q = pi_epoly_add p (pi_epoly_neg q);;
+
+fun allpairs f l1 l2 =  fold_rev (fn x => (curry (op @)) (map (f x) l2)) l1 [];
+
+(* Hence produce the "relevant" monomials: those whose squares lie in the    *)
+(* Newton polytope of the monomials in the input. (This is enough according  *)
+(* to Reznik: "Extremal PSD forms with few terms", Duke Math. Journal,       *)
+(* vol 45, pp. 363--374, 1978.                                               *)
+(*                                                                           *)
+(* These are ordered in sort of decreasing degree. In particular the         *)
+(* constant monomial is last; this gives an order in diagonalization of the  *)
+(* quadratic form that will tend to display constants.                       *)
+
+fun newton_polytope pol =
+ let 
+  val vars = poly_variables pol
+  val mons = map (fn m => map (fn x => monomial_degree x m) vars) 
+             (Monomialfunc.dom pol)
+  val ds = map (fn x => (degree x pol + 1) div 2) vars
+  val all = fold_rev (fn n => allpairs cons (0 upto n)) ds [[]]
+  val mons' = minimal_convex_hull mons
+  val all' =
+    filter (fn m => in_convex_hull mons' (map (fn x => 2 * x) m)) all 
+ in map (fn m => fold_rev2 (fn v => fn i => fn a => if i = 0 then a else Ctermfunc.update (v,i) a)
+                        vars m monomial_1) (rev all')
+ end;
+
+(* Diagonalize (Cholesky/LDU) the matrix corresponding to a quadratic form.  *)
+
+local
+fun diagonalize n i m =
+ if Intpairfunc.is_undefined (snd m) then [] 
+ else
+  let val a11 = Intpairfunc.tryapplyd (snd m) (i,i) rat_0 
+  in if a11 </ rat_0 then error "diagonalize: not PSD"
+    else if a11 =/ rat_0 then
+          if Intfunc.is_undefined (snd (row i m)) then diagonalize n (i + 1) m
+          else error "diagonalize: not PSD ___ "
+    else
+     let 
+      val v = row i m
+      val v' = (fst v, Intfunc.fold (fn (i, c) => fn a => 
+       let val y = c // a11 
+       in if y = rat_0 then a else Intfunc.update (i,y) a 
+       end)  (snd v) Intfunc.undefined)
+      fun upt0 x y a = if y = rat_0 then a else Intpairfunc.update (x,y) a
+      val m' =
+      ((n,n),
+      iter (i+1,n) (fn j =>
+          iter (i+1,n) (fn k =>
+              (upt0 (j,k) (Intpairfunc.tryapplyd (snd m) (j,k) rat_0 -/ Intfunc.tryapplyd (snd v) j rat_0 */ Intfunc.tryapplyd (snd v') k rat_0))))
+          Intpairfunc.undefined)
+     in (a11,v')::diagonalize n (i + 1) m' 
+     end
+  end
+in
+fun diag m =
+ let 
+   val nn = dimensions m 
+   val n = fst nn 
+ in if snd nn <> n then error "diagonalize: non-square matrix" 
+    else diagonalize n 1 m
+ end
+end;
+
+fun gcd_rat a b = Rat.rat_of_int (Integer.gcd (int_of_rat a) (int_of_rat b));
+
+(* Adjust a diagonalization to collect rationals at the start.               *)
+  (* FIXME : Potentially polymorphic keys, but here only: integers!! *)
+local
+ fun upd0 x y a = if y =/ rat_0 then a else Intfunc.update(x,y) a;
+ fun mapa f (d,v) = 
+  (d, Intfunc.fold (fn (i,c) => fn a => upd0 i (f c) a) v Intfunc.undefined)
+ fun adj (c,l) =
+ let val a = 
+  Intfunc.fold (fn (i,c) => fn a => lcm_rat a (denominator_rat c)) 
+    (snd l) rat_1 //
+  Intfunc.fold (fn (i,c) => fn a => gcd_rat a (numerator_rat c)) 
+    (snd l) rat_0
+  in ((c // (a */ a)),mapa (fn x => a */ x) l)
+  end
+in
+fun deration d = if null d then (rat_0,d) else
+ let val d' = map adj d
+     val a = fold (lcm_rat o denominator_rat o fst) d' rat_1 //
+          fold (gcd_rat o numerator_rat o fst) d' rat_0 
+ in ((rat_1 // a),map (fn (c,l) => (a */ c,l)) d')
+ end
+end;
+ 
+(* Enumeration of monomials with given multidegree bound.                    *)
+
+fun enumerate_monomials d vars = 
+ if d < 0 then []
+ else if d = 0 then [Ctermfunc.undefined]
+ else if null vars then [monomial_1] else
+ let val alts =
+  map (fn k => let val oths = enumerate_monomials (d - k) (tl vars) 
+               in map (fn ks => if k = 0 then ks else Ctermfunc.update (hd vars, k) ks) oths end) (0 upto d) 
+ in fold1 (curry op @) alts
+ end;
+
+(* Enumerate products of distinct input polys with degree <= d.              *)
+(* We ignore any constant input polynomials.                                 *)
+(* Give the output polynomial and a record of how it was derived.            *)
+
+local
+ open RealArith
+in
+fun enumerate_products d pols =
+if d = 0 then [(poly_const rat_1,Rational_lt rat_1)] 
+else if d < 0 then [] else
+case pols of 
+   [] => [(poly_const rat_1,Rational_lt rat_1)]
+ | (p,b)::ps => 
+    let val e = multidegree p 
+    in if e = 0 then enumerate_products d ps else
+       enumerate_products d ps @
+       map (fn (q,c) => (poly_mul p q,Product(b,c)))
+         (enumerate_products (d - e) ps)
+    end
+end;
+
+(* Convert regular polynomial. Note that we treat (0,0,0) as -1.             *)
+
+fun epoly_of_poly p =
+  Monomialfunc.fold (fn (m,c) => fn a => Monomialfunc.update (m, Inttriplefunc.onefunc ((0,0,0), Rat.neg c)) a) p Monomialfunc.undefined;
+
+(* String for block diagonal matrix numbered k.                              *)
+
+fun sdpa_of_blockdiagonal k m =
+ let 
+  val pfx = string_of_int k ^" "
+  val ents =
+    Inttriplefunc.fold 
+      (fn ((b,i,j),c) => fn a => if i > j then a else ((b,i,j),c)::a) 
+      m [] 
+  val entss = sort (increasing fst triple_int_ord) ents 
+ in fold_rev (fn ((b,i,j),c) => fn a =>
+     pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^
+     " " ^ decimalize 20 c ^ "\n" ^ a) entss ""
+ end;
+
+(* SDPA for problem using block diagonal (i.e. multiple SDPs)                *)
+
+fun sdpa_of_blockproblem comment nblocks blocksizes obj mats =
+ let val m = length mats - 1 
+ in  "\"" ^ comment ^ "\"\n" ^
+  string_of_int m ^ "\n" ^
+  string_of_int nblocks ^ "\n" ^
+  (fold1 (fn s => fn t => s^" "^t) (map string_of_int blocksizes)) ^
+  "\n" ^
+  sdpa_of_vector obj ^
+  fold_rev2 (fn k => fn m => fn a => sdpa_of_blockdiagonal (k - 1) m ^ a)
+    (1 upto length mats) mats ""
+ end;
+
+(* Hence run CSDP on a problem in block diagonal form.                       *)
+
+fun run_csdp dbg nblocks blocksizes obj mats =
+ let 
+  val input_file = tmp_file "sos" ".dat-s" 
+  val output_file = tmp_file "sos" ".out"
+  val params_file = tmp_file "param" ".csdp" 
+  val _ = File.write input_file
+   (sdpa_of_blockproblem "" nblocks blocksizes obj mats)
+  val _ = File.write params_file csdp_params
+  val current_dir = File.pwd()
+  val _ = File.cd (Path.variable "ISABELLE_TMP")
+  val rv = system ("csdp "^(Path.implode input_file) ^ " " 
+                   ^ (Path.implode output_file) ^
+                   (if dbg then "" else "> /dev/null"))
+  val  opr = File.read output_file 
+  val res = parse_csdpoutput opr 
+ in
+   ((if dbg then ()
+     else (File.rm input_file ; File.rm output_file ; File.cd current_dir));
+    (rv,res))
+ end;
+
+fun csdp nblocks blocksizes obj mats =
+ let 
+  val (rv,res) = run_csdp (!debugging) nblocks blocksizes obj mats 
+ in ((if rv = 1 orelse rv = 2 then error "csdp: Problem is infeasible"
+     else if rv = 3 then writeln "csdp warning: Reduced accuracy"
+     else if rv <> 0 then error ("csdp: error "^string_of_int rv)
+     else ());
+     res)
+ end;
+
+(* 3D versions of matrix operations to consider blocks separately.           *)
+
+val bmatrix_add = Inttriplefunc.combine (curry op +/) (fn x => x =/ rat_0);
+fun bmatrix_cmul c bm =
+  if c =/ rat_0 then Inttriplefunc.undefined
+  else Inttriplefunc.mapf (fn x => c */ x) bm;
+
+val bmatrix_neg = bmatrix_cmul (Rat.rat_of_int ~1);
+fun bmatrix_sub m1 m2 = bmatrix_add m1 (bmatrix_neg m2);;
+
+(* Smash a block matrix into components.                                     *)
+
+fun blocks blocksizes bm =
+ map (fn (bs,b0) =>
+      let val m = Inttriplefunc.fold
+          (fn ((b,i,j),c) => fn a => if b = b0 then Intpairfunc.update ((i,j),c) a else a) bm Intpairfunc.undefined
+          val d = Intpairfunc.fold (fn ((i,j),c) => fn a => max a (max i j)) m 0 
+      in (((bs,bs),m):matrix) end)
+ (blocksizes ~~ (1 upto length blocksizes));;
+
+(* FIXME : Get rid of this !!!*)
+fun tryfind f [] = error "tryfind"
+  | tryfind f (x::xs) = (f x handle ERROR _ => tryfind f xs);
+
+
+(* Positiv- and Nullstellensatz. Flag "linf" forces a linear representation. *)
+
+
+local
+ open RealArith
+in
+fun real_positivnullstellensatz_general linf d eqs leqs pol =
+let 
+ val vars = fold_rev (curry (gen_union (op aconvc)) o poly_variables) 
+              (pol::eqs @ map fst leqs) []
+ val monoid = if linf then 
+      (poly_const rat_1,Rational_lt rat_1)::
+      (filter (fn (p,c) => multidegree p <= d) leqs)
+    else enumerate_products d leqs
+ val nblocks = length monoid
+ fun mk_idmultiplier k p =
+  let 
+   val e = d - multidegree p
+   val mons = enumerate_monomials e vars
+   val nons = mons ~~ (1 upto length mons) 
+  in (mons,
+      fold_rev (fn (m,n) => Monomialfunc.update(m,Inttriplefunc.onefunc((~k,~n,n),rat_1))) nons Monomialfunc.undefined)
+  end
+
+ fun mk_sqmultiplier k (p,c) =
+  let 
+   val e = (d - multidegree p) div 2
+   val mons = enumerate_monomials e vars
+   val nons = mons ~~ (1 upto length mons) 
+  in (mons, 
+      fold_rev (fn (m1,n1) =>
+       fold_rev (fn (m2,n2) => fn  a =>
+        let val m = monomial_mul m1 m2 
+        in if n1 > n2 then a else
+          let val c = if n1 = n2 then rat_1 else rat_2
+              val e = Monomialfunc.tryapplyd a m Inttriplefunc.undefined 
+          in Monomialfunc.update(m, tri_equation_add (Inttriplefunc.onefunc((k,n1,n2), c)) e) a
+          end
+        end)  nons)
+       nons Monomialfunc.undefined)
+  end
+
+  val (sqmonlist,sqs) = split_list (map2 mk_sqmultiplier (1 upto length monoid) monoid)
+  val (idmonlist,ids) =  split_list(map2 mk_idmultiplier (1 upto length eqs) eqs)
+  val blocksizes = map length sqmonlist
+  val bigsum =
+    fold_rev2 (fn p => fn q => fn a => tri_epoly_pmul p q a) eqs ids
+            (fold_rev2 (fn (p,c) => fn s => fn a => tri_epoly_pmul p s a) monoid sqs
+                     (epoly_of_poly(poly_neg pol)))
+  val eqns = Monomialfunc.fold (fn (m,e) => fn a => e::a) bigsum []
+  val (pvs,assig) = tri_eliminate_all_equations (0,0,0) eqns
+  val qvars = (0,0,0)::pvs
+  val allassig = fold_rev (fn v => Inttriplefunc.update(v,(Inttriplefunc.onefunc(v,rat_1)))) pvs assig
+  fun mk_matrix v =
+    Inttriplefunc.fold (fn ((b,i,j), ass) => fn m => 
+        if b < 0 then m else
+         let val c = Inttriplefunc.tryapplyd ass v rat_0
+         in if c = rat_0 then m else
+            Inttriplefunc.update ((b,j,i), c) (Inttriplefunc.update ((b,i,j), c) m)
+         end)
+          allassig Inttriplefunc.undefined
+  val diagents = Inttriplefunc.fold
+    (fn ((b,i,j), e) => fn a => if b > 0 andalso i = j then tri_equation_add e a else a)
+    allassig Inttriplefunc.undefined
+
+  val mats = map mk_matrix qvars
+  val obj = (length pvs,
+            itern 1 pvs (fn v => fn i => Intfunc.updatep iszero (i,Inttriplefunc.tryapplyd diagents v rat_0))
+                        Intfunc.undefined)
+  val raw_vec = if null pvs then vector_0 0
+                else tri_scale_then (csdp nblocks blocksizes) obj mats
+  fun int_element (d,v) i = Intfunc.tryapplyd v i rat_0
+  fun cterm_element (d,v) i = Ctermfunc.tryapplyd v i rat_0
+
+  fun find_rounding d =
+   let 
+    val _ = if !debugging 
+          then writeln ("Trying rounding with limit "^Rat.string_of_rat d ^ "\n") 
+          else ()
+    val vec = nice_vector d raw_vec
+    val blockmat = iter (1,dim vec)
+     (fn i => fn a => bmatrix_add (bmatrix_cmul (int_element vec i) (nth mats i)) a)
+     (bmatrix_neg (nth mats 0))
+    val allmats = blocks blocksizes blockmat 
+   in (vec,map diag allmats)
+   end
+  val (vec,ratdias) =
+    if null pvs then find_rounding rat_1
+    else tryfind find_rounding (map Rat.rat_of_int (1 upto 31) @
+                                map pow2 (5 upto 66))
+  val newassigs =
+    fold_rev (fn k => Inttriplefunc.update (nth pvs (k - 1), int_element vec k))
+           (1 upto dim vec) (Inttriplefunc.onefunc ((0,0,0), Rat.rat_of_int ~1))
+  val finalassigs =
+    Inttriplefunc.fold (fn (v,e) => fn a => Inttriplefunc.update(v, tri_equation_eval newassigs e) a) allassig newassigs
+  fun poly_of_epoly p =
+    Monomialfunc.fold (fn (v,e) => fn a => Monomialfunc.updatep iszero (v,tri_equation_eval finalassigs e) a)
+          p Monomialfunc.undefined
+  fun  mk_sos mons =
+   let fun mk_sq (c,m) =
+    (c,fold_rev (fn k=> fn a => Monomialfunc.updatep iszero (nth mons (k - 1), int_element m k) a)
+                 (1 upto length mons) Monomialfunc.undefined)
+   in map mk_sq
+   end
+  val sqs = map2 mk_sos sqmonlist ratdias
+  val cfs = map poly_of_epoly ids
+  val msq = filter (fn (a,b) => not (null b)) (map2 pair monoid sqs)
+  fun eval_sq sqs = fold_rev (fn (c,q) => poly_add (poly_cmul c (poly_mul q q))) sqs poly_0
+  val sanity =
+    fold_rev (fn ((p,c),s) => poly_add (poly_mul p (eval_sq s))) msq
+           (fold_rev2 (fn p => fn q => poly_add (poly_mul p q)) cfs eqs
+                    (poly_neg pol))
+
+in if not(Monomialfunc.is_undefined sanity) then raise Sanity else
+  (cfs,map (fn (a,b) => (snd a,b)) msq)
+ end
+
+
+end;
+
+(* Iterative deepening.                                                      *)
+
+fun deepen f n = 
+  (writeln ("Searching with depth limit " ^ string_of_int n) ; (f n handle ERROR s => (writeln ("failed with message: " ^ s) ; deepen f (n+1))))
+
+(* The ordering so we can create canonical HOL polynomials.                  *)
+
+fun dest_monomial mon = sort (increasing fst cterm_ord) (Ctermfunc.graph mon);
+
+fun monomial_order (m1,m2) =
+ if Ctermfunc.is_undefined m2 then LESS 
+ else if Ctermfunc.is_undefined m1 then GREATER 
+ else
+  let val mon1 = dest_monomial m1 
+      val mon2 = dest_monomial m2
+      val deg1 = fold (curry op + o snd) mon1 0
+      val deg2 = fold (curry op + o snd) mon2 0 
+  in if deg1 < deg2 then GREATER else if deg1 > deg2 then LESS
+     else list_ord (prod_ord cterm_ord int_ord) (mon1,mon2)
+  end;
+
+fun dest_poly p =
+  map (fn (m,c) => (c,dest_monomial m))
+      (sort (prod_ord monomial_order (K EQUAL)) (Monomialfunc.graph p));
+
+(* Map back polynomials and their composites to HOL.                         *)
+
+local
+ open Thm Numeral RealArith
+in
+
+fun cterm_of_varpow x k = if k = 1 then x else capply (capply @{cterm "op ^ :: real => _"} x) 
+  (mk_cnumber @{ctyp nat} k)
+
+fun cterm_of_monomial m = 
+ if Ctermfunc.is_undefined m then @{cterm "1::real"} 
+ else 
+  let 
+   val m' = dest_monomial m
+   val vps = fold_rev (fn (x,k) => cons (cterm_of_varpow x k)) m' [] 
+  in fold1 (fn s => fn t => capply (capply @{cterm "op * :: real => _"} s) t) vps
+  end
+
+fun cterm_of_cmonomial (m,c) = if Ctermfunc.is_undefined m then cterm_of_rat c
+    else if c = Rat.one then cterm_of_monomial m
+    else capply (capply @{cterm "op *::real => _"} (cterm_of_rat c)) (cterm_of_monomial m);
+
+fun cterm_of_poly p = 
+ if Monomialfunc.is_undefined p then @{cterm "0::real"} 
+ else
+  let 
+   val cms = map cterm_of_cmonomial
+     (sort (prod_ord monomial_order (K EQUAL)) (Monomialfunc.graph p))
+  in fold1 (fn t1 => fn t2 => capply(capply @{cterm "op + :: real => _"} t1) t2) cms
+  end;
+
+fun cterm_of_sqterm (c,p) = Product(Rational_lt c,Square(cterm_of_poly p));
+
+fun cterm_of_sos (pr,sqs) = if null sqs then pr
+  else Product(pr,fold1 (fn a => fn b => Sum(a,b)) (map cterm_of_sqterm sqs));
+
+end
+
+(* Interface to HOL.                                                         *)
+local
+  open Thm Conv RealArith
+  val concl = dest_arg o cprop_of
+  fun simple_cterm_ord t u = TermOrd.fast_term_ord (term_of t, term_of u) = LESS
+in
+  (* FIXME: Replace tryfind by get_first !! *)
+fun real_nonlinear_prover ctxt =
+ let 
+  val {add,mul,neg,pow,sub,main} =  Normalizer.semiring_normalizers_ord_wrapper ctxt
+      (valOf (NormalizerData.match ctxt @{cterm "(0::real) + 1"})) 
+     simple_cterm_ord
+  val (real_poly_add_conv,real_poly_mul_conv,real_poly_neg_conv,
+       real_poly_pow_conv,real_poly_sub_conv,real_poly_conv) = (add,mul,neg,pow,sub,main)
+  fun mainf  translator (eqs,les,lts) = 
+  let 
+   val eq0 = map (poly_of_term o dest_arg1 o concl) eqs
+   val le0 = map (poly_of_term o dest_arg o concl) les
+   val lt0 = map (poly_of_term o dest_arg o concl) lts
+   val eqp0 = map (fn (t,i) => (t,Axiom_eq i)) (eq0 ~~ (0 upto (length eq0 - 1)))
+   val lep0 = map (fn (t,i) => (t,Axiom_le i)) (le0 ~~ (0 upto (length le0 - 1)))
+   val ltp0 = map (fn (t,i) => (t,Axiom_lt i)) (lt0 ~~ (0 upto (length lt0 - 1)))
+   val (keq,eq) = List.partition (fn (p,_) => multidegree p = 0) eqp0
+   val (klep,lep) = List.partition (fn (p,_) => multidegree p = 0) lep0
+   val (kltp,ltp) = List.partition (fn (p,_) => multidegree p = 0) ltp0
+   fun trivial_axiom (p,ax) =
+    case ax of
+       Axiom_eq n => if eval Ctermfunc.undefined p <>/ Rat.zero then nth eqs n 
+                     else error "trivial_axiom: Not a trivial axiom"
+     | Axiom_le n => if eval Ctermfunc.undefined p </ Rat.zero then nth les n 
+                     else error "trivial_axiom: Not a trivial axiom"
+     | Axiom_lt n => if eval Ctermfunc.undefined p <=/ Rat.zero then nth lts n 
+                     else error "trivial_axiom: Not a trivial axiom"
+     | _ => error "trivial_axiom: Not a trivial axiom"
+   in 
+  ((let val th = tryfind trivial_axiom (keq @ klep @ kltp)
+   in fconv_rule (arg_conv (arg1_conv real_poly_conv) then_conv field_comp_conv) th end)
+   handle ERROR _ => (
+    let 
+     val pol = fold_rev poly_mul (map fst ltp) (poly_const Rat.one)
+     val leq = lep @ ltp
+     fun tryall d =
+      let val e = multidegree pol
+          val k = if e = 0 then 0 else d div e
+          val eq' = map fst eq 
+      in tryfind (fn i => (d,i,real_positivnullstellensatz_general false d eq' leq
+                            (poly_neg(poly_pow pol i))))
+              (0 upto k)
+      end
+    val (d,i,(cert_ideal,cert_cone)) = deepen tryall 0
+    val proofs_ideal =
+      map2 (fn q => fn (p,ax) => Eqmul(cterm_of_poly q,ax)) cert_ideal eq
+    val proofs_cone = map cterm_of_sos cert_cone
+    val proof_ne = if null ltp then Rational_lt Rat.one else
+      let val p = fold1 (fn s => fn t => Product(s,t)) (map snd ltp) 
+      in  funpow i (fn q => Product(p,q)) (Rational_lt Rat.one)
+      end
+    val proof = fold1 (fn s => fn t => Sum(s,t))
+                           (proof_ne :: proofs_ideal @ proofs_cone) 
+    in writeln "Translating proof certificate to HOL";
+       translator (eqs,les,lts) proof
+    end))
+   end
+ in mainf end
+end
+
+fun C f x y = f y x;
+  (* FIXME : This is very bad!!!*)
+fun subst_conv eqs t = 
+ let 
+  val t' = fold (Thm.cabs o Thm.lhs_of) eqs t
+ in Conv.fconv_rule (Thm.beta_conversion true) (fold (C combination) eqs (reflexive t'))
+ end
+
+(* A wrapper that tries to substitute away variables first.                  *)
+
+local
+ open Thm Conv RealArith
+  fun simple_cterm_ord t u = TermOrd.fast_term_ord (term_of t, term_of u) = LESS
+ val concl = dest_arg o cprop_of
+ val shuffle1 = 
+   fconv_rule (rewr_conv @{lemma "(a + x == y) == (x == y - (a::real))" by (atomize (full)) (simp add: ring_simps) })
+ val shuffle2 =
+    fconv_rule (rewr_conv @{lemma "(x + a == y) ==  (x == y - (a::real))" by (atomize (full)) (simp add: ring_simps)})
+ fun substitutable_monomial fvs tm = case term_of tm of
+    Free(_,@{typ real}) => if not (member (op aconvc) fvs tm) then (Rat.one,tm) 
+                           else error "substitutable_monomial"
+  | @{term "op * :: real => _"}$c$(t as Free _ ) => 
+     if is_ratconst (dest_arg1 tm) andalso not (member (op aconvc) fvs (dest_arg tm))
+         then (dest_ratconst (dest_arg1 tm),dest_arg tm) else error "substitutable_monomial"
+  | @{term "op + :: real => _"}$s$t => 
+       (substitutable_monomial (add_cterm_frees (dest_arg tm) fvs) (dest_arg1 tm)
+        handle ERROR _ => substitutable_monomial (add_cterm_frees (dest_arg1 tm) fvs) (dest_arg tm))
+  | _ => error "substitutable_monomial"
+
+  fun isolate_variable v th = 
+   let val w = dest_arg1 (cprop_of th)
+   in if v aconvc w then th
+      else case term_of w of
+           @{term "op + :: real => _"}$s$t => 
+              if dest_arg1 w aconvc v then shuffle2 th 
+              else isolate_variable v (shuffle1 th)
+          | _ => error "isolate variable : This should not happen?"
+   end 
+in
+
+fun real_nonlinear_subst_prover ctxt =
+ let 
+  val {add,mul,neg,pow,sub,main} =  Normalizer.semiring_normalizers_ord_wrapper ctxt
+      (valOf (NormalizerData.match ctxt @{cterm "(0::real) + 1"})) 
+     simple_cterm_ord
+
+  val (real_poly_add_conv,real_poly_mul_conv,real_poly_neg_conv,
+       real_poly_pow_conv,real_poly_sub_conv,real_poly_conv) = (add,mul,neg,pow,sub,main)
+
+  fun make_substitution th =
+   let 
+    val (c,v) = substitutable_monomial [] (dest_arg1(concl th))
+    val th1 = Drule.arg_cong_rule (capply @{cterm "op * :: real => _"} (cterm_of_rat (Rat.inv c))) (mk_meta_eq th)
+    val th2 = fconv_rule (binop_conv real_poly_mul_conv) th1
+   in fconv_rule (arg_conv real_poly_conv) (isolate_variable v th2)
+   end
+   fun oprconv cv ct = 
+    let val g = Thm.dest_fun2 ct
+    in if g aconvc @{cterm "op <= :: real => _"} 
+         orelse g aconvc @{cterm "op < :: real => _"} 
+       then arg_conv cv ct else arg1_conv cv ct
+    end
+  fun mainf translator =
+   let 
+    fun substfirst(eqs,les,lts) =
+      ((let 
+           val eth = tryfind make_substitution eqs
+           val modify = fconv_rule (arg_conv (oprconv(subst_conv [eth] then_conv real_poly_conv)))
+       in  substfirst
+             (filter_out (fn t => (Thm.dest_arg1 o Thm.dest_arg o cprop_of) t 
+                                   aconvc @{cterm "0::real"}) (map modify eqs),
+                                   map modify les,map modify lts)
+       end)
+       handle ERROR  _ => real_nonlinear_prover ctxt translator (rev eqs, rev les, rev lts))
+    in substfirst
+   end
+
+
+ in mainf
+ end
+
+(* Overall function. *)
+
+fun real_sos ctxt t = gen_prover_real_arith ctxt (real_nonlinear_subst_prover ctxt) t;
+end;
+
+(* A tactic *)
+fun strip_all ct = 
+ case term_of ct of 
+  Const("all",_) $ Abs (xn,xT,p) => 
+   let val (a,(v,t')) = (apsnd (Thm.dest_abs (SOME xn)) o Thm.dest_comb) ct
+   in apfst (cons v) (strip_all t')
+   end
+| _ => ([],ct)
+
+fun core_sos_conv ctxt t = Drule.arg_cong_rule @{cterm Trueprop} (real_sos ctxt (Thm.dest_arg t) RS @{thm Eq_TrueI})
+fun core_sos_tac ctxt = CSUBGOAL (fn (ct, i) => 
+  let val (avs, p) = strip_all ct
+      val th = standard (fold_rev forall_intr avs (real_sos ctxt (Thm.dest_arg p)))
+  in rtac th i end);
+
+fun default_SOME f NONE v = SOME v
+  | default_SOME f (SOME v) _ = SOME v;
+
+fun lift_SOME f NONE a = f a
+  | lift_SOME f (SOME a) _ = SOME a;
+
+
+local
+ val is_numeral = can (HOLogic.dest_number o term_of)
+in
+fun get_denom b ct = case term_of ct of
+  @{term "op / :: real => _"} $ _ $ _ => 
+     if is_numeral (Thm.dest_arg ct) then get_denom b (Thm.dest_arg1 ct)
+     else default_SOME (get_denom b) (get_denom b (Thm.dest_arg ct))   (Thm.dest_arg ct, b)
+ | @{term "op < :: real => _"} $ _ $ _ => lift_SOME (get_denom true) (get_denom true (Thm.dest_arg ct)) (Thm.dest_arg1 ct)
+ | @{term "op <= :: real => _"} $ _ $ _ => lift_SOME (get_denom true) (get_denom true (Thm.dest_arg ct)) (Thm.dest_arg1 ct)
+ | _ $ _ => lift_SOME (get_denom b) (get_denom b (Thm.dest_fun ct)) (Thm.dest_arg ct)
+ | _ => NONE
+end;
+
+fun elim_one_denom_tac ctxt = 
+CSUBGOAL (fn (P,i) => 
+ case get_denom false P of 
+   NONE => no_tac
+ | SOME (d,ord) => 
+     let 
+      val ss = simpset_of (ProofContext.theory_of ctxt) addsimps @{thms field_simps} 
+               addsimps [@{thm nonzero_power_divide}, @{thm power_divide}]
+      val th = instantiate' [] [SOME d, SOME (Thm.dest_arg P)] 
+         (if ord then @{lemma "(d=0 --> P) & (d>0 --> P) & (d<(0::real) --> P) ==> P" by auto}
+          else @{lemma "(d=0 --> P) & (d ~= (0::real) --> P) ==> P" by blast})
+     in (rtac th i THEN Simplifier.asm_full_simp_tac ss i) end);
+
+fun elim_denom_tac ctxt i = REPEAT (elim_one_denom_tac ctxt i);
+
+fun sos_tac ctxt = ObjectLogic.full_atomize_tac THEN' elim_denom_tac ctxt THEN' core_sos_tac ctxt
+
+
+end;
\ No newline at end of file

--- a/src/HOL/Lim.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Lim.thy	Fri May 15 15:56:28 2009 +0200
@@ -383,7 +383,7 @@
 lemmas LIM_of_real = of_real.LIM
 
 lemma LIM_power:
-  fixes f :: "'a::real_normed_vector \<Rightarrow> 'b::{recpower,real_normed_algebra}"
+  fixes f :: "'a::real_normed_vector \<Rightarrow> 'b::{power,real_normed_algebra}"
   assumes f: "f -- a --> l"
   shows "(\<lambda>x. f x ^ n) -- a --> l ^ n"
 by (induct n, simp, simp add: LIM_mult f)
@@ -530,7 +530,7 @@
   unfolding isCont_def by (rule LIM_of_real)
 
 lemma isCont_power:
-  fixes f :: "'a::real_normed_vector \<Rightarrow> 'b::{recpower,real_normed_algebra}"
+  fixes f :: "'a::real_normed_vector \<Rightarrow> 'b::{power,real_normed_algebra}"
   shows "isCont f a \<Longrightarrow> isCont (\<lambda>x. f x ^ n) a"
   unfolding isCont_def by (rule LIM_power)
 

--- a/src/HOL/List.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/List.thy	Fri May 15 15:56:28 2009 +0200
@@ -5,8 +5,8 @@
 header {* The datatype of finite lists *}
 
 theory List
-imports Plain Relation_Power Presburger Recdef ATP_Linkup
-uses "Tools/string_syntax.ML"
+imports Plain Presburger Recdef ATP_Linkup
+uses ("Tools/list_code.ML")
 begin
 
 datatype 'a list =
@@ -198,7 +198,7 @@
 
 definition
   rotate :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
-  "rotate n = rotate1 ^ n"
+  "rotate n = rotate1 ^^ n"
 
 definition
   list_all2 :: "('a => 'b => bool) => 'a list => 'b list => bool" where
@@ -1299,6 +1299,25 @@
   show ?case by (clarsimp simp add: Cons nth_append)
 qed
 
+lemma Skolem_list_nth:
+  "(ALL i<k. EX x. P i x) = (EX xs. size xs = k & (ALL i<k. P i (xs!i)))"
+  (is "_ = (EX xs. ?P k xs)")
+proof(induct k)
+  case 0 show ?case by simp
+next
+  case (Suc k)
+  show ?case (is "?L = ?R" is "_ = (EX xs. ?P' xs)")
+  proof
+    assume "?R" thus "?L" using Suc by auto
+  next
+    assume "?L"
+    with Suc obtain x xs where "?P k xs & P k x" by (metis less_Suc_eq)
+    hence "?P'(xs@[x])" by(simp add:nth_append less_Suc_eq)
+    thus "?R" ..
+  qed
+qed
+
+
 subsubsection {* @{text list_update} *}
 
 lemma length_list_update [simp]: "length(xs[i:=x]) = length xs"
@@ -1324,6 +1343,9 @@
 apply simp_all
 done
 
+lemma list_update_nonempty[simp]: "xs[k:=x] = [] \<longleftrightarrow> xs=[]"
+by(metis length_0_conv length_list_update)
+
 lemma list_update_same_conv:
 "i < length xs ==> (xs[i := x] = xs) = (xs!i = x)"
 by (induct xs arbitrary: i) (auto split: nat.split)
@@ -1344,8 +1366,7 @@
 by (induct xs, auto)
 
 lemma update_zip:
-  "length xs = length ys ==>
-  (zip xs ys)[i:=xy] = zip (xs[i:=fst xy]) (ys[i:=snd xy])"
+  "(zip xs ys)[i:=xy] = zip (xs[i:=fst xy]) (ys[i:=snd xy])"
 by (induct ys arbitrary: i xy xs) (auto, case_tac xs, auto split: nat.split)
 
 lemma set_update_subset_insert: "set(xs[i:=x]) <= insert x (set xs)"
@@ -1357,12 +1378,10 @@
 lemma set_update_memI: "n < length xs \<Longrightarrow> x \<in> set (xs[n := x])"
 by (induct xs arbitrary: n) (auto split:nat.splits)
 
-lemma list_update_overwrite:
+lemma list_update_overwrite[simp]:
   "xs [i := x, i := y] = xs [i := y]"
-apply (induct xs arbitrary: i)
-apply simp
-apply (case_tac i)
-apply simp_all
+apply (induct xs arbitrary: i) apply simp
+apply (case_tac i, simp_all)
 done
 
 lemma list_update_swap:
@@ -1444,6 +1463,18 @@
 lemma butlast_conv_take: "butlast xs = take (length xs - 1) xs"
 by (induct xs, simp, case_tac xs, simp_all)
 
+lemma last_list_update:
+  "xs \<noteq> [] \<Longrightarrow> last(xs[k:=x]) = (if k = size xs - 1 then x else last xs)"
+by (auto simp: last_conv_nth)
+
+lemma butlast_list_update:
+  "butlast(xs[k:=x]) =
+ (if k = size xs - 1 then butlast xs else (butlast xs)[k:=x])"
+apply(cases xs rule:rev_cases)
+apply simp
+apply(simp add:list_update_append split:nat.splits)
+done
+
 
 subsubsection {* @{text take} and @{text drop} *}
 
@@ -1723,6 +1754,13 @@
  "(dropWhile P xs = y#ys) = (xs = takeWhile P xs @ y # ys & \<not> P y)"
 by(induct xs, auto)
 
+lemma distinct_takeWhile[simp]: "distinct xs ==> distinct (takeWhile P xs)"
+by (induct xs) (auto dest: set_takeWhileD)
+
+lemma distinct_dropWhile[simp]: "distinct xs ==> distinct (dropWhile P xs)"
+by (induct xs) auto
+
+
 text{* The following two lemmmas could be generalized to an arbitrary
 property. *}
 
@@ -1809,6 +1847,10 @@
 apply simp_all
 done
 
+text{* Courtesy of Andreas Lochbihler: *}
+lemma zip_same_conv_map: "zip xs xs = map (\<lambda>x. (x, x)) xs"
+by(induct xs) auto
+
 lemma nth_zip [simp]:
 "[| i < length xs; i < length ys|] ==> (zip xs ys)!i = (xs!i, ys!i)"
 apply (induct ys arbitrary: i xs, simp)
@@ -1818,11 +1860,11 @@
 
 lemma set_zip:
 "set (zip xs ys) = {(xs!i, ys!i) | i. i < min (length xs) (length ys)}"
-by (simp add: set_conv_nth cong: rev_conj_cong)
+by(simp add: set_conv_nth cong: rev_conj_cong)
 
 lemma zip_update:
-"length xs = length ys ==> zip (xs[i:=x]) (ys[i:=y]) = (zip xs ys)[i:=(x,y)]"
-by (rule sym, simp add: update_zip)
+  "zip (xs[i:=x]) (ys[i:=y]) = (zip xs ys)[i:=(x,y)]"
+by(rule sym, simp add: update_zip)
 
 lemma zip_replicate [simp]:
   "zip (replicate i x) (replicate j y) = replicate (min i j) (x,y)"
@@ -2120,6 +2162,15 @@
   shows "listsum (rev xs) = listsum xs"
 by (induct xs) (simp_all add:add_ac)
 
+lemma listsum_map_remove1:
+fixes f :: "'a \<Rightarrow> ('b::comm_monoid_add)"
+shows "x : set xs \<Longrightarrow> listsum(map f xs) = f x + listsum(map f (remove1 x xs))"
+by (induct xs)(auto simp add:add_ac)
+
+lemma list_size_conv_listsum:
+  "list_size f xs = listsum (map f xs) + size xs"
+by(induct xs) auto
+
 lemma listsum_foldr: "listsum xs = foldr (op +) xs 0"
 by (induct xs) auto
 
@@ -2131,6 +2182,10 @@
 lemma listsum[code unfold]: "listsum xs = foldl (op +) 0 xs"
 by(simp add:listsum_foldr foldl_foldr1)
 
+lemma distinct_listsum_conv_Setsum:
+  "distinct xs \<Longrightarrow> listsum xs = Setsum(set xs)"
+by (induct xs) simp_all
+
 
 text{* Some syntactic sugar for summing a function over a list: *}
 
@@ -2544,6 +2599,11 @@
 apply (simp add: add_commute)
 done
 
+text{* Courtesy of Andreas Lochbihler: *}
+lemma filter_replicate:
+  "filter P (replicate n x) = (if P x then replicate n x else [])"
+by(induct n) auto
+
 lemma hd_replicate [simp]: "n \<noteq> 0 ==> hd (replicate n x) = x"
 by (induct n) auto
 
@@ -3424,77 +3484,6 @@
 by (auto simp add: set_Cons_def intro: listrel.intros) 
 
 
-subsection{*Miscellany*}
-
-subsubsection {* Characters and strings *}
-
-datatype nibble =
-    Nibble0 | Nibble1 | Nibble2 | Nibble3 | Nibble4 | Nibble5 | Nibble6 | Nibble7
-  | Nibble8 | Nibble9 | NibbleA | NibbleB | NibbleC | NibbleD | NibbleE | NibbleF
-
-lemma UNIV_nibble:
-  "UNIV = {Nibble0, Nibble1, Nibble2, Nibble3, Nibble4, Nibble5, Nibble6, Nibble7,
-    Nibble8, Nibble9, NibbleA, NibbleB, NibbleC, NibbleD, NibbleE, NibbleF}" (is "_ = ?A")
-proof (rule UNIV_eq_I)
-  fix x show "x \<in> ?A" by (cases x) simp_all
-qed
-
-instance nibble :: finite
-  by default (simp add: UNIV_nibble)
-
-datatype char = Char nibble nibble
-  -- "Note: canonical order of character encoding coincides with standard term ordering"
-
-lemma UNIV_char:
-  "UNIV = image (split Char) (UNIV \<times> UNIV)"
-proof (rule UNIV_eq_I)
-  fix x show "x \<in> image (split Char) (UNIV \<times> UNIV)" by (cases x) auto
-qed
-
-instance char :: finite
-  by default (simp add: UNIV_char)
-
-lemma size_char [code, simp]:
-  "size (c::char) = 0" by (cases c) simp
-
-lemma char_size [code, simp]:
-  "char_size (c::char) = 0" by (cases c) simp
-
-primrec nibble_pair_of_char :: "char \<Rightarrow> nibble \<times> nibble" where
-  "nibble_pair_of_char (Char n m) = (n, m)"
-
-declare nibble_pair_of_char.simps [code del]
-
-setup {*
-let
-  val nibbles = map (Thm.cterm_of @{theory} o HOLogic.mk_nibble) (0 upto 15);
-  val thms = map_product
-   (fn n => fn m => Drule.instantiate' [] [SOME n, SOME m] @{thm nibble_pair_of_char.simps})
-      nibbles nibbles;
-in
-  PureThy.note_thmss Thm.lemmaK [((Binding.name "nibble_pair_of_char_simps", []), [(thms, [])])]
-  #-> (fn [(_, thms)] => fold_rev Code.add_eqn thms)
-end
-*}
-
-lemma char_case_nibble_pair [code, code inline]:
-  "char_case f = split f o nibble_pair_of_char"
-  by (simp add: expand_fun_eq split: char.split)
-
-lemma char_rec_nibble_pair [code, code inline]:
-  "char_rec f = split f o nibble_pair_of_char"
-  unfolding char_case_nibble_pair [symmetric]
-  by (simp add: expand_fun_eq split: char.split)
-
-types string = "char list"
-
-syntax
-  "_Char" :: "xstr => char"    ("CHR _")
-  "_String" :: "xstr => string"    ("_")
-
-setup StringSyntax.setup
-
-
 subsection {* Size function *}
 
 lemma [measure_function]: "is_measure f \<Longrightarrow> is_measure (list_size f)"
@@ -3518,10 +3507,35 @@
   "(\<And>x. x \<in> set xs \<Longrightarrow> f x < g x) \<Longrightarrow> list_size f xs \<le> list_size g xs"
 by (induct xs) force+
 
+
 subsection {* Code generator *}
 
 subsubsection {* Setup *}
 
+use "Tools/list_code.ML"
+
+code_type list
+  (SML "_ list")
+  (OCaml "_ list")
+  (Haskell "![_]")
+
+code_const Nil
+  (SML "[]")
+  (OCaml "[]")
+  (Haskell "[]")
+
+code_instance list :: eq
+  (Haskell -)
+
+code_const "eq_class.eq \<Colon> 'a\<Colon>eq list \<Rightarrow> 'a list \<Rightarrow> bool"
+  (Haskell infixl 4 "==")
+
+code_reserved SML
+  list
+
+code_reserved OCaml
+  list
+
 types_code
   "list" ("_ list")
 attach (term_of) {*
@@ -3537,206 +3551,23 @@
    (1, fn () => ([], fn () => HOLogic.nil_const aT))] ()
 and gen_list aG aT i = gen_list' aG aT i i;
 *}
-  "char" ("string")
-attach (term_of) {*
-val term_of_char = HOLogic.mk_char o ord;
-*}
-attach (test) {*
-fun gen_char i =
-  let val j = random_range (ord "a") (Int.min (ord "a" + i, ord "z"))
-  in (chr j, fn () => HOLogic.mk_char j) end;
-*}
-
-consts_code "Cons" ("(_ ::/ _)")
-
-code_type list
-  (SML "_ list")
-  (OCaml "_ list")
-  (Haskell "![_]")
-
-code_reserved SML
-  list
-
-code_reserved OCaml
-  list
-
-code_const Nil
-  (SML "[]")
-  (OCaml "[]")
-  (Haskell "[]")
-
-ML {*
-local
-
-open Basic_Code_Thingol;
-
-fun implode_list naming t = case pairself
-  (Code_Thingol.lookup_const naming) (@{const_name Nil}, @{const_name Cons})
-   of (SOME nil', SOME cons') => let
-          fun dest_cons (IConst (c, _) `$ t1 `$ t2) =
-                if c = cons'
-                then SOME (t1, t2)
-                else NONE
-            | dest_cons _ = NONE;
-          val (ts, t') = Code_Thingol.unfoldr dest_cons t;
-        in case t'
-         of IConst (c, _) => if c = nil' then SOME ts else NONE
-          | _ => NONE
-        end
-    | _ => NONE
-
-fun decode_char naming (IConst (c1, _), IConst (c2, _)) = (case map_filter
-  (Code_Thingol.lookup_const naming)[@{const_name Nibble0}, @{const_name Nibble1},
-   @{const_name Nibble2}, @{const_name Nibble3},
-   @{const_name Nibble4}, @{const_name Nibble5},
-   @{const_name Nibble6}, @{const_name Nibble7},
-   @{const_name Nibble8}, @{const_name Nibble9},
-   @{const_name NibbleA}, @{const_name NibbleB},
-   @{const_name NibbleC}, @{const_name NibbleD},
-   @{const_name NibbleE}, @{const_name NibbleF}]
-   of nibbles' as [_, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _] => let
-          fun idx c = find_index (curry (op =) c) nibbles';
-          fun decode ~1 _ = NONE
-            | decode _ ~1 = NONE
-            | decode n m = SOME (chr (n * 16 + m));
-        in decode (idx c1) (idx c2) end
-    | _ => NONE)
- | decode_char _ _ = NONE
-   
-fun implode_string naming mk_char mk_string ts = case
-  Code_Thingol.lookup_const naming @{const_name Char}
-   of SOME char' => let
-        fun implode_char (IConst (c, _) `$ t1 `$ t2) =
-              if c = char' then decode_char naming (t1, t2) else NONE
-          | implode_char _ = NONE;
-        val ts' = map implode_char ts;
-      in if forall is_some ts'
-        then (SOME o Code_Printer.str o mk_string o implode o map_filter I) ts'
-        else NONE
-      end
-    | _ => NONE;
-
-fun default_list (target_fxy, target_cons) pr fxy t1 t2 =
-  Code_Printer.brackify_infix (target_fxy, Code_Printer.R) fxy [
-    pr (Code_Printer.INFX (target_fxy, Code_Printer.X)) t1,
-    Code_Printer.str target_cons,
-    pr (Code_Printer.INFX (target_fxy, Code_Printer.R)) t2
-  ];
-
-fun pretty_list literals =
-  let
-    val mk_list = Code_Printer.literal_list literals;
-    fun pretty pr naming thm vars fxy [(t1, _), (t2, _)] =
-      case Option.map (cons t1) (implode_list naming t2)
-       of SOME ts => mk_list (map (pr vars Code_Printer.NOBR) ts)
-        | NONE => default_list (Code_Printer.infix_cons literals) (pr vars) fxy t1 t2;
-  in (2, pretty) end;
-
-fun pretty_list_string literals =
-  let
-    val mk_list = Code_Printer.literal_list literals;
-    val mk_char = Code_Printer.literal_char literals;
-    val mk_string = Code_Printer.literal_string literals;
-    fun pretty pr naming thm vars fxy [(t1, _), (t2, _)] =
-      case Option.map (cons t1) (implode_list naming t2)
-       of SOME ts => (case implode_string naming mk_char mk_string ts
-           of SOME p => p
-            | NONE => mk_list (map (pr vars Code_Printer.NOBR) ts))
-        | NONE => default_list (Code_Printer.infix_cons literals) (pr vars) fxy t1 t2;
-  in (2, pretty) end;
-
-fun pretty_char literals =
-  let
-    val mk_char = Code_Printer.literal_char literals;
-    fun pretty _ naming thm _ _ [(t1, _), (t2, _)] =
-      case decode_char naming (t1, t2)
-       of SOME c => (Code_Printer.str o mk_char) c
-        | NONE => Code_Printer.nerror thm "Illegal character expression";
-  in (2, pretty) end;
-
-fun pretty_message literals =
-  let
-    val mk_char = Code_Printer.literal_char literals;
-    val mk_string = Code_Printer.literal_string literals;
-    fun pretty _ naming thm _ _ [(t, _)] =
-      case implode_list naming t
-       of SOME ts => (case implode_string naming mk_char mk_string ts
-           of SOME p => p
-            | NONE => Code_Printer.nerror thm "Illegal message expression")
-        | NONE => Code_Printer.nerror thm "Illegal message expression";
-  in (1, pretty) end;
-
-in
-
-fun add_literal_list target thy =
-  let
-    val pr = pretty_list (Code_Target.the_literals thy target);
-  in
-    thy
-    |> Code_Target.add_syntax_const target @{const_name Cons} (SOME pr)
-  end;
-
-fun add_literal_list_string target thy =
-  let
-    val pr = pretty_list_string (Code_Target.the_literals thy target);
-  in
-    thy
-    |> Code_Target.add_syntax_const target @{const_name Cons} (SOME pr)
-  end;
-
-fun add_literal_char target thy =
-  let
-    val pr = pretty_char (Code_Target.the_literals thy target);
-  in
-    thy
-    |> Code_Target.add_syntax_const target @{const_name Char} (SOME pr)
-  end;
-
-fun add_literal_message str target thy =
-  let
-    val pr = pretty_message (Code_Target.the_literals thy target);
-  in
-    thy
-    |> Code_Target.add_syntax_const target str (SOME pr)
-  end;
-
-end;
-*}
-
-setup {*
-  fold (fn target => add_literal_list target) ["SML", "OCaml", "Haskell"]
-*}
-
-code_instance list :: eq
-  (Haskell -)
-
-code_const "eq_class.eq \<Colon> 'a\<Colon>eq list \<Rightarrow> 'a list \<Rightarrow> bool"
-  (Haskell infixl 4 "==")
+
+consts_code Cons ("(_ ::/ _)")
 
 setup {*
 let
-
-fun list_codegen thy defs dep thyname b t gr =
-  let
-    val ts = HOLogic.dest_list t;
-    val (_, gr') = Codegen.invoke_tycodegen thy defs dep thyname false
-      (fastype_of t) gr;
-    val (ps, gr'') = fold_map
-      (Codegen.invoke_codegen thy defs dep thyname false) ts gr'
-  in SOME (Pretty.list "[" "]" ps, gr'') end handle TERM _ => NONE;
-
-fun char_codegen thy defs dep thyname b t gr =
-  let
-    val i = HOLogic.dest_char t;
-    val (_, gr') = Codegen.invoke_tycodegen thy defs dep thyname false
-      (fastype_of t) gr;
-  in SOME (Codegen.str (ML_Syntax.print_string (chr i)), gr')
-  end handle TERM _ => NONE;
-
+  fun list_codegen thy defs dep thyname b t gr =
+    let
+      val ts = HOLogic.dest_list t;
+      val (_, gr') = Codegen.invoke_tycodegen thy defs dep thyname false
+        (fastype_of t) gr;
+      val (ps, gr'') = fold_map
+        (Codegen.invoke_codegen thy defs dep thyname false) ts gr'
+    in SOME (Pretty.list "[" "]" ps, gr'') end handle TERM _ => NONE;
 in
-  Codegen.add_codegen "list_codegen" list_codegen
-  #> Codegen.add_codegen "char_codegen" char_codegen
-end;
+  fold (List_Code.add_literal_list) ["SML", "OCaml", "Haskell"]
+  #> Codegen.add_codegen "list_codegen" list_codegen
+end
 *}
 
 
@@ -3834,10 +3665,14 @@
 
 lemmas in_set_code [code unfold] = mem_iff [symmetric]
 
-lemma empty_null [code inline]:
+lemma empty_null:
   "xs = [] \<longleftrightarrow> null xs"
 by (cases xs) simp_all
 
+lemma [code inline]:
+  "eq_class.eq xs [] \<longleftrightarrow> null xs"
+by (simp add: eq empty_null)
+
 lemmas null_empty [code post] =
   empty_null [symmetric]
 

--- a/src/HOL/MacLaurin.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/MacLaurin.thy	Fri May 15 15:56:28 2009 +0200
@@ -552,10 +552,6 @@
     "[|x = y; abs u \<le> (v::real) |] ==> \<bar>(x + u) - y\<bar> \<le> v"
 by auto
 
-text {* TODO: move to Parity.thy *}
-lemma nat_odd_1 [simp]: "odd (1::nat)"
-  unfolding even_nat_def by simp
-
 lemma Maclaurin_sin_bound:
   "abs(sin x - (\<Sum>m=0..<n. (if even m then 0 else (-1 ^ ((m - Suc 0) div 2)) / real (fact m)) *
   x ^ m))  \<le> inverse(real (fact n)) * \<bar>x\<bar> ^ n"

--- a/src/HOL/Map.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Map.thy	Fri May 15 15:56:28 2009 +0200
@@ -11,7 +11,7 @@
 imports List
 begin
 
-types ('a,'b) "~=>" = "'a => 'b option"  (infixr 0)
+types ('a,'b) "~=>" = "'a => 'b option"  (infixr "~=>" 0)
 translations (type) "a ~=> b " <= (type) "a => b option"
 
 syntax (xsymbols)
@@ -452,6 +452,9 @@
 
 subsection {* @{term [source] dom} *}
 
+lemma dom_eq_empty_conv [simp]: "dom f = {} \<longleftrightarrow> f = empty"
+by(auto intro!:ext simp: dom_def)
+
 lemma domI: "m a = Some b ==> a : dom m"
 by(simp add:dom_def)
 (* declare domI [intro]? *)
@@ -593,4 +596,19 @@
 lemma map_add_le_mapI: "\<lbrakk> f \<subseteq>\<^sub>m h; g \<subseteq>\<^sub>m h; f \<subseteq>\<^sub>m f++g \<rbrakk> \<Longrightarrow> f++g \<subseteq>\<^sub>m h"
 by (clarsimp simp add: map_le_def map_add_def dom_def split: option.splits)
 
+
+lemma dom_eq_singleton_conv: "dom f = {x} \<longleftrightarrow> (\<exists>v. f = [x \<mapsto> v])"
+proof(rule iffI)
+  assume "\<exists>v. f = [x \<mapsto> v]"
+  thus "dom f = {x}" by(auto split: split_if_asm)
+next
+  assume "dom f = {x}"
+  then obtain v where "f x = Some v" by auto
+  hence "[x \<mapsto> v] \<subseteq>\<^sub>m f" by(auto simp add: map_le_def)
+  moreover have "f \<subseteq>\<^sub>m [x \<mapsto> v]" using `dom f = {x}` `f x = Some v`
+    by(auto simp add: map_le_def)
+  ultimately have "f = [x \<mapsto> v]" by-(rule map_le_antisym)
+  thus "\<exists>v. f = [x \<mapsto> v]" by blast
+qed
+
 end

--- a/src/HOL/MicroJava/Comp/CorrCompTp.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/MicroJava/Comp/CorrCompTp.thy	Fri May 15 15:56:28 2009 +0200
@@ -454,7 +454,7 @@
 apply (simp add: max_of_list_def)
 apply (induct xs)
 apply simp
-using [[fast_arith_split_limit = 0]]
+using [[linarith_split_limit = 0]]
 apply simp
 apply arith
 done

--- a/src/HOL/NSA/HDeriv.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/NSA/HDeriv.thy	Fri May 15 15:56:28 2009 +0200
@@ -1,5 +1,4 @@
 (*  Title       : Deriv.thy
-    ID          : $Id$
     Author      : Jacques D. Fleuriot
     Copyright   : 1998  University of Cambridge
     Conversion to Isar and new proofs by Lawrence C Paulson, 2004
@@ -345,7 +344,7 @@
 
 (*Can't get rid of x \<noteq> 0 because it isn't continuous at zero*)
 lemma NSDERIV_inverse:
-  fixes x :: "'a::{real_normed_field,recpower}"
+  fixes x :: "'a::{real_normed_field}"
   shows "x \<noteq> 0 ==> NSDERIV (%x. inverse(x)) x :> (- (inverse x ^ Suc (Suc 0)))"
 apply (simp add: nsderiv_def)
 apply (rule ballI, simp, clarify)
@@ -383,7 +382,7 @@
 text{*Derivative of inverse*}
 
 lemma NSDERIV_inverse_fun:
-  fixes x :: "'a::{real_normed_field,recpower}"
+  fixes x :: "'a::{real_normed_field}"
   shows "[| NSDERIV f x :> d; f(x) \<noteq> 0 |]
       ==> NSDERIV (%x. inverse(f x)) x :> (- (d * inverse(f(x) ^ Suc (Suc 0))))"
 by (simp add: NSDERIV_DERIV_iff DERIV_inverse_fun del: power_Suc)
@@ -391,7 +390,7 @@
 text{*Derivative of quotient*}
 
 lemma NSDERIV_quotient:
-  fixes x :: "'a::{real_normed_field,recpower}"
+  fixes x :: "'a::{real_normed_field}"
   shows "[| NSDERIV f x :> d; NSDERIV g x :> e; g(x) \<noteq> 0 |]
        ==> NSDERIV (%y. f(y) / (g y)) x :> (d*g(x)
                             - (e*f(x))) / (g(x) ^ Suc (Suc 0))"

--- a/src/HOL/NSA/HSEQ.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/NSA/HSEQ.thy	Fri May 15 15:56:28 2009 +0200
@@ -110,7 +110,7 @@
 done
 
 lemma NSLIMSEQ_pow [rule_format]:
-  fixes a :: "'a::{real_normed_algebra,recpower}"
+  fixes a :: "'a::{real_normed_algebra,power}"
   shows "(X ----NS> a) --> ((%n. (X n) ^ m) ----NS> a ^ m)"
 apply (induct "m")
 apply (auto simp add: power_Suc intro: NSLIMSEQ_mult NSLIMSEQ_const)

--- a/src/HOL/NSA/HyperDef.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/NSA/HyperDef.thy	Fri May 15 15:56:28 2009 +0200
@@ -8,7 +8,6 @@
 
 theory HyperDef
 imports HyperNat Real
-uses ("hypreal_arith.ML")
 begin
 
 types hypreal = "real star"
@@ -343,8 +342,17 @@
 Addsimps [symmetric hypreal_diff_def]
 *)
 
-use "hypreal_arith.ML"
-declaration {* K hypreal_arith_setup *}
+declaration {*
+  K (Lin_Arith.add_inj_thms [@{thm star_of_le} RS iffD2,
+    @{thm star_of_less} RS iffD2, @{thm star_of_eq} RS iffD2]
+  #> Lin_Arith.add_simps [@{thm star_of_zero}, @{thm star_of_one},
+      @{thm star_of_number_of}, @{thm star_of_add}, @{thm star_of_minus},
+      @{thm star_of_diff}, @{thm star_of_mult}]
+  #> Lin_Arith.add_inj_const (@{const_name "StarDef.star_of"}, @{typ "real \<Rightarrow> hypreal"})
+  #> Simplifier.map_ss (fn simpset => simpset addsimprocs [Simplifier.simproc @{theory}
+      "fast_hypreal_arith" ["(m::hypreal) < n", "(m::hypreal) <= n", "(m::hypreal) = n"]
+      (K Lin_Arith.simproc)]))
+*}
 
 
 subsection {* Exponentials on the Hyperreals *}
@@ -417,7 +425,7 @@
 declare power_hypreal_of_real_number_of [of _ "number_of w", standard, simp]
 (*
 lemma hrealpow_HFinite:
-  fixes x :: "'a::{real_normed_algebra,recpower} star"
+  fixes x :: "'a::{real_normed_algebra,power} star"
   shows "x \<in> HFinite ==> x ^ n \<in> HFinite"
 apply (induct_tac "n")
 apply (auto simp add: power_Suc intro: HFinite_mult)
@@ -438,71 +446,71 @@
 by (simp add: hyperpow_def starfun2_star_n)
 
 lemma hyperpow_zero [simp]:
-  "\<And>n. (0::'a::{recpower,semiring_0} star) pow (n + (1::hypnat)) = 0"
+  "\<And>n. (0::'a::{power,semiring_0} star) pow (n + (1::hypnat)) = 0"
 by transfer simp
 
 lemma hyperpow_not_zero:
-  "\<And>r n. r \<noteq> (0::'a::{recpower,field} star) ==> r pow n \<noteq> 0"
+  "\<And>r n. r \<noteq> (0::'a::{field} star) ==> r pow n \<noteq> 0"
 by transfer (rule field_power_not_zero)
 
 lemma hyperpow_inverse:
-  "\<And>r n. r \<noteq> (0::'a::{recpower,division_by_zero,field} star)
+  "\<And>r n. r \<noteq> (0::'a::{division_by_zero,field} star)
    \<Longrightarrow> inverse (r pow n) = (inverse r) pow n"
 by transfer (rule power_inverse)
-
+  
 lemma hyperpow_hrabs:
-  "\<And>r n. abs (r::'a::{recpower,ordered_idom} star) pow n = abs (r pow n)"
+  "\<And>r n. abs (r::'a::{ordered_idom} star) pow n = abs (r pow n)"
 by transfer (rule power_abs [symmetric])
 
 lemma hyperpow_add:
-  "\<And>r n m. (r::'a::recpower star) pow (n + m) = (r pow n) * (r pow m)"
+  "\<And>r n m. (r::'a::monoid_mult star) pow (n + m) = (r pow n) * (r pow m)"
 by transfer (rule power_add)
 
 lemma hyperpow_one [simp]:
-  "\<And>r. (r::'a::recpower star) pow (1::hypnat) = r"
+  "\<And>r. (r::'a::monoid_mult star) pow (1::hypnat) = r"
 by transfer (rule power_one_right)
 
 lemma hyperpow_two:
-  "\<And>r. (r::'a::recpower star) pow ((1::hypnat) + (1::hypnat)) = r * r"
-by transfer (simp add: power_Suc)
+  "\<And>r. (r::'a::monoid_mult star) pow ((1::hypnat) + (1::hypnat)) = r * r"
+by transfer simp
 
 lemma hyperpow_gt_zero:
-  "\<And>r n. (0::'a::{recpower,ordered_semidom} star) < r \<Longrightarrow> 0 < r pow n"
+  "\<And>r n. (0::'a::{ordered_semidom} star) < r \<Longrightarrow> 0 < r pow n"
 by transfer (rule zero_less_power)
 
 lemma hyperpow_ge_zero:
-  "\<And>r n. (0::'a::{recpower,ordered_semidom} star) \<le> r \<Longrightarrow> 0 \<le> r pow n"
+  "\<And>r n. (0::'a::{ordered_semidom} star) \<le> r \<Longrightarrow> 0 \<le> r pow n"
 by transfer (rule zero_le_power)
 
 lemma hyperpow_le:
-  "\<And>x y n. \<lbrakk>(0::'a::{recpower,ordered_semidom} star) < x; x \<le> y\<rbrakk>
+  "\<And>x y n. \<lbrakk>(0::'a::{ordered_semidom} star) < x; x \<le> y\<rbrakk>
    \<Longrightarrow> x pow n \<le> y pow n"
 by transfer (rule power_mono [OF _ order_less_imp_le])
 
 lemma hyperpow_eq_one [simp]:
-  "\<And>n. 1 pow n = (1::'a::recpower star)"
+  "\<And>n. 1 pow n = (1::'a::monoid_mult star)"
 by transfer (rule power_one)
 
 lemma hrabs_hyperpow_minus_one [simp]:
-  "\<And>n. abs(-1 pow n) = (1::'a::{number_ring,recpower,ordered_idom} star)"
+  "\<And>n. abs(-1 pow n) = (1::'a::{number_ring,ordered_idom} star)"
 by transfer (rule abs_power_minus_one)
 
 lemma hyperpow_mult:
-  "\<And>r s n. (r * s::'a::{comm_monoid_mult,recpower} star) pow n
+  "\<And>r s n. (r * s::'a::{comm_monoid_mult} star) pow n
    = (r pow n) * (s pow n)"
 by transfer (rule power_mult_distrib)
 
 lemma hyperpow_two_le [simp]:
-  "(0::'a::{recpower,ordered_ring_strict} star) \<le> r pow (1 + 1)"
+  "(0::'a::{monoid_mult,ordered_ring_strict} star) \<le> r pow (1 + 1)"
 by (auto simp add: hyperpow_two zero_le_mult_iff)
 
 lemma hrabs_hyperpow_two [simp]:
   "abs(x pow (1 + 1)) =
-   (x::'a::{recpower,ordered_ring_strict} star) pow (1 + 1)"
+   (x::'a::{monoid_mult,ordered_ring_strict} star) pow (1 + 1)"
 by (simp only: abs_of_nonneg hyperpow_two_le)
 
 lemma hyperpow_two_hrabs [simp]:
-  "abs(x::'a::{recpower,ordered_idom} star) pow (1 + 1)  = x pow (1 + 1)"
+  "abs(x::'a::{ordered_idom} star) pow (1 + 1)  = x pow (1 + 1)"
 by (simp add: hyperpow_hrabs)
 
 text{*The precondition could be weakened to @{term "0\<le>x"}*}
@@ -511,11 +519,11 @@
  by (simp add: Ring_and_Field.mult_strict_mono order_less_imp_le)
 
 lemma hyperpow_two_gt_one:
-  "\<And>r::'a::{recpower,ordered_semidom} star. 1 < r \<Longrightarrow> 1 < r pow (1 + 1)"
+  "\<And>r::'a::{ordered_semidom} star. 1 < r \<Longrightarrow> 1 < r pow (1 + 1)"
 by transfer (simp add: power_gt1 del: power_Suc)
 
 lemma hyperpow_two_ge_one:
-  "\<And>r::'a::{recpower,ordered_semidom} star. 1 \<le> r \<Longrightarrow> 1 \<le> r pow (1 + 1)"
+  "\<And>r::'a::{ordered_semidom} star. 1 \<le> r \<Longrightarrow> 1 \<le> r pow (1 + 1)"
 by transfer (simp add: one_le_power del: power_Suc)
 
 lemma two_hyperpow_ge_one [simp]: "(1::hypreal) \<le> 2 pow n"
@@ -565,7 +573,7 @@
 
 lemma of_hypreal_hyperpow:
   "\<And>x n. of_hypreal (x pow n) =
-   (of_hypreal x::'a::{real_algebra_1,recpower} star) pow n"
+   (of_hypreal x::'a::{real_algebra_1} star) pow n"
 by transfer (rule of_real_power)
 
 end

--- a/src/HOL/NSA/NSA.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/NSA/NSA.thy	Fri May 15 15:56:28 2009 +0200
@@ -101,7 +101,7 @@
 by transfer (rule norm_mult)
 
 lemma hnorm_hyperpow:
-  "\<And>(x::'a::{real_normed_div_algebra,recpower} star) n.
+  "\<And>(x::'a::{real_normed_div_algebra} star) n.
    hnorm (x pow n) = hnorm x pow n"
 by transfer (rule norm_power)
 
@@ -304,15 +304,15 @@
 unfolding star_one_def by (rule HFinite_star_of)
 
 lemma hrealpow_HFinite:
-  fixes x :: "'a::{real_normed_algebra,recpower} star"
+  fixes x :: "'a::{real_normed_algebra,monoid_mult} star"
   shows "x \<in> HFinite ==> x ^ n \<in> HFinite"
-apply (induct_tac "n")
+apply (induct n)
 apply (auto simp add: power_Suc intro: HFinite_mult)
 done
 
 lemma HFinite_bounded:
   "[|(x::hypreal) \<in> HFinite; y \<le> x; 0 \<le> y |] ==> y \<in> HFinite"
-apply (case_tac "x \<le> 0")
+apply (cases "x \<le> 0")
 apply (drule_tac y = x in order_trans)
 apply (drule_tac [2] order_antisym)
 apply (auto simp add: linorder_not_le)

--- a/src/HOL/NSA/NSComplex.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/NSA/NSComplex.thy	Fri May 15 15:56:28 2009 +0200
@@ -383,7 +383,7 @@
 by transfer (rule power_mult_distrib)
 
 lemma hcpow_zero2 [simp]:
-  "\<And>n. 0 pow (hSuc n) = (0::'a::{recpower,semiring_0} star)"
+  "\<And>n. 0 pow (hSuc n) = (0::'a::{power,semiring_0} star)"
 by transfer (rule power_0_Suc)
 
 lemma hcpow_not_zero [simp,intro]:

--- a/src/HOL/NSA/StarDef.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/NSA/StarDef.thy	Fri May 15 15:56:28 2009 +0200
@@ -1,5 +1,4 @@
 (*  Title       : HOL/Hyperreal/StarDef.thy
-    ID          : $Id$
     Author      : Jacques D. Fleuriot and Brian Huffman
 *)
 
@@ -546,16 +545,6 @@
 
 end
 
-instantiation star :: (power) power
-begin
-
-definition
-  star_power_def:   "(op ^) \<equiv> \<lambda>x n. ( *f* (\<lambda>x. x ^ n)) x"
-
-instance ..
-
-end
-
 instantiation star :: (ord) ord
 begin
 
@@ -574,7 +563,7 @@
   star_add_def      star_diff_def     star_minus_def
   star_mult_def     star_divide_def   star_inverse_def
   star_le_def       star_less_def     star_abs_def       star_sgn_def
-  star_div_def      star_mod_def      star_power_def
+  star_div_def      star_mod_def
 
 text {* Class operations preserve standard elements *}
 
@@ -614,15 +603,11 @@
 lemma Standard_mod: "\<lbrakk>x \<in> Standard; y \<in> Standard\<rbrakk> \<Longrightarrow> x mod y \<in> Standard"
 by (simp add: star_mod_def)
 
-lemma Standard_power: "x \<in> Standard \<Longrightarrow> x ^ n \<in> Standard"
-by (simp add: star_power_def)
-
 lemmas Standard_simps [simp] =
   Standard_zero  Standard_one  Standard_number_of
   Standard_add  Standard_diff  Standard_minus
   Standard_mult  Standard_divide  Standard_inverse
   Standard_abs  Standard_div  Standard_mod
-  Standard_power
 
 text {* @{term star_of} preserves class operations *}
 
@@ -650,9 +635,6 @@
 lemma star_of_mod: "star_of (x mod y) = star_of x mod star_of y"
 by transfer (rule refl)
 
-lemma star_of_power: "star_of (x ^ n) = star_of x ^ n"
-by transfer (rule refl)
-
 lemma star_of_abs: "star_of (abs x) = abs (star_of x)"
 by transfer (rule refl)
 
@@ -717,8 +699,7 @@
 lemmas star_of_simps [simp] =
   star_of_add     star_of_diff    star_of_minus
   star_of_mult    star_of_divide  star_of_inverse
-  star_of_div     star_of_mod
-  star_of_power   star_of_abs
+  star_of_div     star_of_mod     star_of_abs
   star_of_zero    star_of_one     star_of_number_of
   star_of_less    star_of_le      star_of_eq
   star_of_0_less  star_of_0_le    star_of_0_eq
@@ -970,25 +951,33 @@
 instance star :: (ordered_idom) ordered_idom ..
 instance star :: (ordered_field) ordered_field ..
 
-subsection {* Power classes *}
+
+subsection {* Power *}
 
-text {*
-  Proving the class axiom @{thm [source] power_Suc} for type
-  @{typ "'a star"} is a little tricky, because it quantifies
-  over values of type @{typ nat}. The transfer principle does
-  not handle quantification over non-star types in general,
-  but we can work around this by fixing an arbitrary @{typ nat}
-  value, and then applying the transfer principle.
-*}
+lemma star_power_def [transfer_unfold]:
+  "(op ^) \<equiv> \<lambda>x n. ( *f* (\<lambda>x. x ^ n)) x"
+proof (rule eq_reflection, rule ext, rule ext)
+  fix n :: nat
+  show "\<And>x::'a star. x ^ n = ( *f* (\<lambda>x. x ^ n)) x" 
+  proof (induct n)
+    case 0
+    have "\<And>x::'a star. ( *f* (\<lambda>x. 1)) x = 1"
+      by transfer simp
+    then show ?case by simp
+  next
+    case (Suc n)
+    have "\<And>x::'a star. x * ( *f* (\<lambda>x\<Colon>'a. x ^ n)) x = ( *f* (\<lambda>x\<Colon>'a. x * x ^ n)) x"
+      by transfer simp
+    with Suc show ?case by simp
+  qed
+qed
 
-instance star :: (recpower) recpower
-proof
-  show "\<And>a::'a star. a ^ 0 = 1"
-    by transfer (rule power_0)
-next
-  fix n show "\<And>a::'a star. a ^ Suc n = a * a ^ n"
-    by transfer (rule power_Suc)
-qed
+lemma Standard_power [simp]: "x \<in> Standard \<Longrightarrow> x ^ n \<in> Standard"
+  by (simp add: star_power_def)
+
+lemma star_of_power [simp]: "star_of (x ^ n) = star_of x ^ n"
+  by transfer (rule refl)
+
 
 subsection {* Number classes *}
 

--- a/src/HOL/NSA/hypreal_arith.ML	Fri May 15 15:29:34 2009 +0200
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,46 +0,0 @@
-(*  Title:      HOL/NSA/hypreal_arith.ML
-    ID:         $Id$
-    Author:     Tobias Nipkow, TU Muenchen
-    Copyright   1999 TU Muenchen
-
-Simprocs for common factor cancellation & Rational coefficient handling
-
-Instantiation of the generic linear arithmetic package for type hypreal.
-*)
-
-local
-
-val simps = [thm "star_of_zero",
-             thm "star_of_one",
-             thm "star_of_number_of",
-             thm "star_of_add",
-             thm "star_of_minus",
-             thm "star_of_diff",
-             thm "star_of_mult"]
-
-val real_inj_thms = [thm "star_of_le" RS iffD2,
-                     thm "star_of_less" RS iffD2,
-                     thm "star_of_eq" RS iffD2]
-
-in
-
-val hyprealT = Type ("StarDef.star", [HOLogic.realT]);
-
-val fast_hypreal_arith_simproc =
-    Simplifier.simproc (the_context ())
-      "fast_hypreal_arith" 
-      ["(m::hypreal) < n", "(m::hypreal) <= n", "(m::hypreal) = n"]
-    (K Lin_Arith.lin_arith_simproc);
-
-val hypreal_arith_setup =
-  Lin_Arith.map_data (fn {add_mono_thms, mult_mono_thms, inj_thms, lessD, neqE, simpset} =>
-   {add_mono_thms = add_mono_thms,
-    mult_mono_thms = mult_mono_thms,
-    inj_thms = real_inj_thms @ inj_thms,
-    lessD = lessD,  (*Can't change lessD: the hypreals are dense!*)
-    neqE = neqE,
-    simpset = simpset addsimps simps}) #>
-  arith_inj_const ("StarDef.star_of", HOLogic.realT --> hyprealT) #>
-  Simplifier.map_ss (fn ss => ss addsimprocs [fast_hypreal_arith_simproc]);
-
-end;

--- a/src/HOL/Nat.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Nat.thy	Fri May 15 15:56:28 2009 +0200
@@ -1164,6 +1164,64 @@
 end
 
 
+subsection {* Natural operation of natural numbers on functions *}
+
+text {*
+  We use the same logical constant for the power operations on
+  functions and relations, in order to share the same syntax.
+*}
+
+consts compow :: "nat \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)"
+
+abbreviation compower :: "('a \<Rightarrow> 'b) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'b" (infixr "^^" 80) where
+  "f ^^ n \<equiv> compow n f"
+
+notation (latex output)
+  compower ("(_\<^bsup>_\<^esup>)" [1000] 1000)
+
+notation (HTML output)
+  compower ("(_\<^bsup>_\<^esup>)" [1000] 1000)
+
+text {* @{text "f ^^ n = f o ... o f"}, the n-fold composition of @{text f} *}
+
+overloading
+  funpow == "compow :: nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)"
+begin
+
+primrec funpow :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" where
+    "funpow 0 f = id"
+  | "funpow (Suc n) f = f o funpow n f"
+
+end
+
+text {* for code generation *}
+
+definition funpow :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" where
+  funpow_code_def [code post]: "funpow = compow"
+
+lemmas [code unfold] = funpow_code_def [symmetric]
+
+lemma [code]:
+  "funpow 0 f = id"
+  "funpow (Suc n) f = f o funpow n f"
+  unfolding funpow_code_def by simp_all
+
+hide (open) const funpow
+
+lemma funpow_add:
+  "f ^^ (m + n) = f ^^ m \<circ> f ^^ n"
+  by (induct m) simp_all
+
+lemma funpow_swap1:
+  "f ((f ^^ n) x) = (f ^^ n) (f x)"
+proof -
+  have "f ((f ^^ n) x) = (f ^^ (n + 1)) x" by simp
+  also have "\<dots>  = (f ^^ n o f ^^ 1) x" by (simp only: funpow_add)
+  also have "\<dots> = (f ^^ n) (f x)" by simp
+  finally show ?thesis .
+qed
+
+
 subsection {* Embedding of the Naturals into any
   @{text semiring_1}: @{term of_nat} *}
 
@@ -1189,7 +1247,7 @@
   "of_nat_aux inc 0 i = i"
   | "of_nat_aux inc (Suc n) i = of_nat_aux inc n (inc i)" -- {* tail recursive *}
 
-lemma of_nat_code [code, code unfold, code inline del]:
+lemma of_nat_code:
   "of_nat n = of_nat_aux (\<lambda>i. i + 1) n 0"
 proof (induct n)
   case 0 then show ?case by simp
@@ -1201,9 +1259,11 @@
     by simp
   with Suc show ?case by (simp add: add_commute)
 qed
-    
+
 end
 
+declare of_nat_code [code, code unfold, code inline del]
+
 text{*Class for unital semirings with characteristic zero.
  Includes non-ordered rings like the complex numbers.*}
 
@@ -1214,10 +1274,10 @@
 text{*Special cases where either operand is zero*}
 
 lemma of_nat_0_eq_iff [simp, noatp]: "0 = of_nat n \<longleftrightarrow> 0 = n"
-  by (rule of_nat_eq_iff [of 0, simplified])
+  by (rule of_nat_eq_iff [of 0 n, unfolded of_nat_0])
 
 lemma of_nat_eq_0_iff [simp, noatp]: "of_nat m = 0 \<longleftrightarrow> m = 0"
-  by (rule of_nat_eq_iff [of _ 0, simplified])
+  by (rule of_nat_eq_iff [of m 0, unfolded of_nat_0])
 
 lemma inj_of_nat: "inj of_nat"
   by (simp add: inj_on_def)
@@ -1350,6 +1410,7 @@
 declaration {* K Nat_Arith.setup *}
 
 use "Tools/lin_arith.ML"
+setup {* Lin_Arith.global_setup *}
 declaration {* K Lin_Arith.setup *}
 
 lemmas [arith_split] = nat_diff_split split_min split_max

--- a/src/HOL/NatBin.thy	Fri May 15 15:29:34 2009 +0200
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,975 +0,0 @@
-(*  Title:      HOL/NatBin.thy
-    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
-    Copyright   1999  University of Cambridge
-*)
-
-header {* Binary arithmetic for the natural numbers *}
-
-theory NatBin
-imports IntDiv
-uses ("Tools/nat_simprocs.ML")
-begin
-
-text {*
-  Arithmetic for naturals is reduced to that for the non-negative integers.
-*}
-
-instantiation nat :: number
-begin
-
-definition
-  nat_number_of_def [code inline, code del]: "number_of v = nat (number_of v)"
-
-instance ..
-
-end
-
-lemma [code post]:
-  "nat (number_of v) = number_of v"
-  unfolding nat_number_of_def ..
-
-abbreviation (xsymbols)
-  power2 :: "'a::power => 'a"  ("(_\<twosuperior>)" [1000] 999) where
-  "x\<twosuperior> == x^2"
-
-notation (latex output)
-  power2  ("(_\<twosuperior>)" [1000] 999)
-
-notation (HTML output)
-  power2  ("(_\<twosuperior>)" [1000] 999)
-
-
-subsection {* Predicate for negative binary numbers *}
-
-definition neg  :: "int \<Rightarrow> bool" where
-  "neg Z \<longleftrightarrow> Z < 0"
-
-lemma not_neg_int [simp]: "~ neg (of_nat n)"
-by (simp add: neg_def)
-
-lemma neg_zminus_int [simp]: "neg (- (of_nat (Suc n)))"
-by (simp add: neg_def neg_less_0_iff_less del: of_nat_Suc)
-
-lemmas neg_eq_less_0 = neg_def
-
-lemma not_neg_eq_ge_0: "(~neg x) = (0 \<le> x)"
-by (simp add: neg_def linorder_not_less)
-
-text{*To simplify inequalities when Numeral1 can get simplified to 1*}
-
-lemma not_neg_0: "~ neg 0"
-by (simp add: One_int_def neg_def)
-
-lemma not_neg_1: "~ neg 1"
-by (simp add: neg_def linorder_not_less zero_le_one)
-
-lemma neg_nat: "neg z ==> nat z = 0"
-by (simp add: neg_def order_less_imp_le) 
-
-lemma not_neg_nat: "~ neg z ==> of_nat (nat z) = z"
-by (simp add: linorder_not_less neg_def)
-
-text {*
-  If @{term Numeral0} is rewritten to 0 then this rule can't be applied:
-  @{term Numeral0} IS @{term "number_of Pls"}
-*}
-
-lemma not_neg_number_of_Pls: "~ neg (number_of Int.Pls)"
-  by (simp add: neg_def)
-
-lemma neg_number_of_Min: "neg (number_of Int.Min)"
-  by (simp add: neg_def)
-
-lemma neg_number_of_Bit0:
-  "neg (number_of (Int.Bit0 w)) = neg (number_of w)"
-  by (simp add: neg_def)
-
-lemma neg_number_of_Bit1:
-  "neg (number_of (Int.Bit1 w)) = neg (number_of w)"
-  by (simp add: neg_def)
-
-lemmas neg_simps [simp] =
-  not_neg_0 not_neg_1
-  not_neg_number_of_Pls neg_number_of_Min
-  neg_number_of_Bit0 neg_number_of_Bit1
-
-
-subsection{*Function @{term nat}: Coercion from Type @{typ int} to @{typ nat}*}
-
-declare nat_0 [simp] nat_1 [simp]
-
-lemma nat_number_of [simp]: "nat (number_of w) = number_of w"
-by (simp add: nat_number_of_def)
-
-lemma nat_numeral_0_eq_0 [simp]: "Numeral0 = (0::nat)"
-by (simp add: nat_number_of_def)
-
-lemma nat_numeral_1_eq_1 [simp]: "Numeral1 = (1::nat)"
-by (simp add: nat_1 nat_number_of_def)
-
-lemma numeral_1_eq_Suc_0: "Numeral1 = Suc 0"
-by (simp add: nat_numeral_1_eq_1)
-
-lemma numeral_2_eq_2: "2 = Suc (Suc 0)"
-apply (unfold nat_number_of_def)
-apply (rule nat_2)
-done
-
-
-subsection{*Function @{term int}: Coercion from Type @{typ nat} to @{typ int}*}
-
-lemma int_nat_number_of [simp]:
-     "int (number_of v) =  
-         (if neg (number_of v :: int) then 0  
-          else (number_of v :: int))"
-  unfolding nat_number_of_def number_of_is_id neg_def
-  by simp
-
-
-subsubsection{*Successor *}
-
-lemma Suc_nat_eq_nat_zadd1: "(0::int) <= z ==> Suc (nat z) = nat (1 + z)"
-apply (rule sym)
-apply (simp add: nat_eq_iff int_Suc)
-done
-
-lemma Suc_nat_number_of_add:
-     "Suc (number_of v + n) =  
-        (if neg (number_of v :: int) then 1+n else number_of (Int.succ v) + n)"
-  unfolding nat_number_of_def number_of_is_id neg_def numeral_simps
-  by (simp add: Suc_nat_eq_nat_zadd1 add_ac)
-
-lemma Suc_nat_number_of [simp]:
-     "Suc (number_of v) =  
-        (if neg (number_of v :: int) then 1 else number_of (Int.succ v))"
-apply (cut_tac n = 0 in Suc_nat_number_of_add)
-apply (simp cong del: if_weak_cong)
-done
-
-
-subsubsection{*Addition *}
-
-lemma add_nat_number_of [simp]:
-     "(number_of v :: nat) + number_of v' =  
-         (if v < Int.Pls then number_of v'  
-          else if v' < Int.Pls then number_of v  
-          else number_of (v + v'))"
-  unfolding nat_number_of_def number_of_is_id numeral_simps
-  by (simp add: nat_add_distrib)
-
-lemma nat_number_of_add_1 [simp]:
-  "number_of v + (1::nat) =
-    (if v < Int.Pls then 1 else number_of (Int.succ v))"
-  unfolding nat_number_of_def number_of_is_id numeral_simps
-  by (simp add: nat_add_distrib)
-
-lemma nat_1_add_number_of [simp]:
-  "(1::nat) + number_of v =
-    (if v < Int.Pls then 1 else number_of (Int.succ v))"
-  unfolding nat_number_of_def number_of_is_id numeral_simps
-  by (simp add: nat_add_distrib)
-
-lemma nat_1_add_1 [simp]: "1 + 1 = (2::nat)"
-  by (rule int_int_eq [THEN iffD1]) simp
-
-
-subsubsection{*Subtraction *}
-
-lemma diff_nat_eq_if:
-     "nat z - nat z' =  
-        (if neg z' then nat z   
-         else let d = z-z' in     
-              if neg d then 0 else nat d)"
-by (simp add: Let_def nat_diff_distrib [symmetric] neg_eq_less_0 not_neg_eq_ge_0)
-
-
-lemma diff_nat_number_of [simp]: 
-     "(number_of v :: nat) - number_of v' =  
-        (if v' < Int.Pls then number_of v  
-         else let d = number_of (v + uminus v') in     
-              if neg d then 0 else nat d)"
-  unfolding nat_number_of_def number_of_is_id numeral_simps neg_def
-  by auto
-
-lemma nat_number_of_diff_1 [simp]:
-  "number_of v - (1::nat) =
-    (if v \<le> Int.Pls then 0 else number_of (Int.pred v))"
-  unfolding nat_number_of_def number_of_is_id numeral_simps
-  by auto
-
-
-subsubsection{*Multiplication *}
-
-lemma mult_nat_number_of [simp]:
-     "(number_of v :: nat) * number_of v' =  
-       (if v < Int.Pls then 0 else number_of (v * v'))"
-  unfolding nat_number_of_def number_of_is_id numeral_simps
-  by (simp add: nat_mult_distrib)
-
-
-subsubsection{*Quotient *}
-
-lemma div_nat_number_of [simp]:
-     "(number_of v :: nat)  div  number_of v' =  
-          (if neg (number_of v :: int) then 0  
-           else nat (number_of v div number_of v'))"
-  unfolding nat_number_of_def number_of_is_id neg_def
-  by (simp add: nat_div_distrib)
-
-lemma one_div_nat_number_of [simp]:
-     "Suc 0 div number_of v' = nat (1 div number_of v')" 
-by (simp del: nat_numeral_1_eq_1 add: numeral_1_eq_Suc_0 [symmetric]) 
-
-
-subsubsection{*Remainder *}
-
-lemma mod_nat_number_of [simp]:
-     "(number_of v :: nat)  mod  number_of v' =  
-        (if neg (number_of v :: int) then 0  
-         else if neg (number_of v' :: int) then number_of v  
-         else nat (number_of v mod number_of v'))"
-  unfolding nat_number_of_def number_of_is_id neg_def
-  by (simp add: nat_mod_distrib)
-
-lemma one_mod_nat_number_of [simp]:
-     "Suc 0 mod number_of v' =  
-        (if neg (number_of v' :: int) then Suc 0
-         else nat (1 mod number_of v'))"
-by (simp del: nat_numeral_1_eq_1 add: numeral_1_eq_Suc_0 [symmetric]) 
-
-
-subsubsection{* Divisibility *}
-
-lemmas dvd_eq_mod_eq_0_number_of =
-  dvd_eq_mod_eq_0 [of "number_of x" "number_of y", standard]
-
-declare dvd_eq_mod_eq_0_number_of [simp]
-
-ML
-{*
-val nat_number_of_def = thm"nat_number_of_def";
-
-val nat_number_of = thm"nat_number_of";
-val nat_numeral_0_eq_0 = thm"nat_numeral_0_eq_0";
-val nat_numeral_1_eq_1 = thm"nat_numeral_1_eq_1";
-val numeral_1_eq_Suc_0 = thm"numeral_1_eq_Suc_0";
-val numeral_2_eq_2 = thm"numeral_2_eq_2";
-val nat_div_distrib = thm"nat_div_distrib";
-val nat_mod_distrib = thm"nat_mod_distrib";
-val int_nat_number_of = thm"int_nat_number_of";
-val Suc_nat_eq_nat_zadd1 = thm"Suc_nat_eq_nat_zadd1";
-val Suc_nat_number_of_add = thm"Suc_nat_number_of_add";
-val Suc_nat_number_of = thm"Suc_nat_number_of";
-val add_nat_number_of = thm"add_nat_number_of";
-val diff_nat_eq_if = thm"diff_nat_eq_if";
-val diff_nat_number_of = thm"diff_nat_number_of";
-val mult_nat_number_of = thm"mult_nat_number_of";
-val div_nat_number_of = thm"div_nat_number_of";
-val mod_nat_number_of = thm"mod_nat_number_of";
-*}
-
-
-subsection{*Comparisons*}
-
-subsubsection{*Equals (=) *}
-
-lemma eq_nat_nat_iff:
-     "[| (0::int) <= z;  0 <= z' |] ==> (nat z = nat z') = (z=z')"
-by (auto elim!: nonneg_eq_int)
-
-lemma eq_nat_number_of [simp]:
-     "((number_of v :: nat) = number_of v') =  
-      (if neg (number_of v :: int) then (number_of v' :: int) \<le> 0
-       else if neg (number_of v' :: int) then (number_of v :: int) = 0
-       else v = v')"
-  unfolding nat_number_of_def number_of_is_id neg_def
-  by auto
-
-
-subsubsection{*Less-than (<) *}
-
-lemma less_nat_number_of [simp]:
-  "(number_of v :: nat) < number_of v' \<longleftrightarrow>
-    (if v < v' then Int.Pls < v' else False)"
-  unfolding nat_number_of_def number_of_is_id numeral_simps
-  by auto
-
-
-subsubsection{*Less-than-or-equal *}
-
-lemma le_nat_number_of [simp]:
-  "(number_of v :: nat) \<le> number_of v' \<longleftrightarrow>
-    (if v \<le> v' then True else v \<le> Int.Pls)"
-  unfolding nat_number_of_def number_of_is_id numeral_simps
-  by auto
-
-(*Maps #n to n for n = 0, 1, 2*)
-lemmas numerals = nat_numeral_0_eq_0 nat_numeral_1_eq_1 numeral_2_eq_2
-
-
-subsection{*Powers with Numeric Exponents*}
-
-text{*We cannot refer to the number @{term 2} in @{text Ring_and_Field.thy}.
-We cannot prove general results about the numeral @{term "-1"}, so we have to
-use @{term "- 1"} instead.*}
-
-lemma power2_eq_square: "(a::'a::recpower)\<twosuperior> = a * a"
-  by (simp add: numeral_2_eq_2 Power.power_Suc)
-
-lemma zero_power2 [simp]: "(0::'a::{semiring_1,recpower})\<twosuperior> = 0"
-  by (simp add: power2_eq_square)
-
-lemma one_power2 [simp]: "(1::'a::{semiring_1,recpower})\<twosuperior> = 1"
-  by (simp add: power2_eq_square)
-
-lemma power3_eq_cube: "(x::'a::recpower) ^ 3 = x * x * x"
-  apply (subgoal_tac "3 = Suc (Suc (Suc 0))")
-  apply (erule ssubst)
-  apply (simp add: power_Suc mult_ac)
-  apply (unfold nat_number_of_def)
-  apply (subst nat_eq_iff)
-  apply simp
-done
-
-text{*Squares of literal numerals will be evaluated.*}
-lemmas power2_eq_square_number_of =
-    power2_eq_square [of "number_of w", standard]
-declare power2_eq_square_number_of [simp]
-
-
-lemma zero_le_power2[simp]: "0 \<le> (a\<twosuperior>::'a::{ordered_idom,recpower})"
-  by (simp add: power2_eq_square)
-
-lemma zero_less_power2[simp]:
-     "(0 < a\<twosuperior>) = (a \<noteq> (0::'a::{ordered_idom,recpower}))"
-  by (force simp add: power2_eq_square zero_less_mult_iff linorder_neq_iff)
-
-lemma power2_less_0[simp]:
-  fixes a :: "'a::{ordered_idom,recpower}"
-  shows "~ (a\<twosuperior> < 0)"
-by (force simp add: power2_eq_square mult_less_0_iff) 
-
-lemma zero_eq_power2[simp]:
-     "(a\<twosuperior> = 0) = (a = (0::'a::{ordered_idom,recpower}))"
-  by (force simp add: power2_eq_square mult_eq_0_iff)
-
-lemma abs_power2[simp]:
-     "abs(a\<twosuperior>) = (a\<twosuperior>::'a::{ordered_idom,recpower})"
-  by (simp add: power2_eq_square abs_mult abs_mult_self)
-
-lemma power2_abs[simp]:
-     "(abs a)\<twosuperior> = (a\<twosuperior>::'a::{ordered_idom,recpower})"
-  by (simp add: power2_eq_square abs_mult_self)
-
-lemma power2_minus[simp]:
-     "(- a)\<twosuperior> = (a\<twosuperior>::'a::{comm_ring_1,recpower})"
-  by (simp add: power2_eq_square)
-
-lemma power2_le_imp_le:
-  fixes x y :: "'a::{ordered_semidom,recpower}"
-  shows "\<lbrakk>x\<twosuperior> \<le> y\<twosuperior>; 0 \<le> y\<rbrakk> \<Longrightarrow> x \<le> y"
-unfolding numeral_2_eq_2 by (rule power_le_imp_le_base)
-
-lemma power2_less_imp_less:
-  fixes x y :: "'a::{ordered_semidom,recpower}"
-  shows "\<lbrakk>x\<twosuperior> < y\<twosuperior>; 0 \<le> y\<rbrakk> \<Longrightarrow> x < y"
-by (rule power_less_imp_less_base)
-
-lemma power2_eq_imp_eq:
-  fixes x y :: "'a::{ordered_semidom,recpower}"
-  shows "\<lbrakk>x\<twosuperior> = y\<twosuperior>; 0 \<le> x; 0 \<le> y\<rbrakk> \<Longrightarrow> x = y"
-unfolding numeral_2_eq_2 by (erule (2) power_eq_imp_eq_base, simp)
-
-lemma power_minus1_even[simp]: "(- 1) ^ (2*n) = (1::'a::{comm_ring_1,recpower})"
-proof (induct n)
-  case 0 show ?case by simp
-next
-  case (Suc n) then show ?case by (simp add: power_Suc power_add)
-qed
-
-lemma power_minus1_odd: "(- 1) ^ Suc(2*n) = -(1::'a::{comm_ring_1,recpower})"
-  by (simp add: power_Suc) 
-
-lemma power_even_eq: "(a::'a::recpower) ^ (2*n) = (a^n)^2"
-by (subst mult_commute) (simp add: power_mult)
-
-lemma power_odd_eq: "(a::int) ^ Suc(2*n) = a * (a^n)^2"
-by (simp add: power_even_eq) 
-
-lemma power_minus_even [simp]:
-     "(-a) ^ (2*n) = (a::'a::{comm_ring_1,recpower}) ^ (2*n)"
-by (simp add: power_minus1_even power_minus [of a]) 
-
-lemma zero_le_even_power'[simp]:
-     "0 \<le> (a::'a::{ordered_idom,recpower}) ^ (2*n)"
-proof (induct "n")
-  case 0
-    show ?case by (simp add: zero_le_one)
-next
-  case (Suc n)
-    have "a ^ (2 * Suc n) = (a*a) * a ^ (2*n)" 
-      by (simp add: mult_ac power_add power2_eq_square)
-    thus ?case
-      by (simp add: prems zero_le_mult_iff)
-qed
-
-lemma odd_power_less_zero:
-     "(a::'a::{ordered_idom,recpower}) < 0 ==> a ^ Suc(2*n) < 0"
-proof (induct "n")
-  case 0
-  then show ?case by simp
-next
-  case (Suc n)
-  have "a ^ Suc (2 * Suc n) = (a*a) * a ^ Suc(2*n)"
-    by (simp add: mult_ac power_add power2_eq_square)
-  thus ?case
-    by (simp del: power_Suc add: prems mult_less_0_iff mult_neg_neg)
-qed
-
-lemma odd_0_le_power_imp_0_le:
-     "0 \<le> a  ^ Suc(2*n) ==> 0 \<le> (a::'a::{ordered_idom,recpower})"
-apply (insert odd_power_less_zero [of a n]) 
-apply (force simp add: linorder_not_less [symmetric]) 
-done
-
-text{*Simprules for comparisons where common factors can be cancelled.*}
-lemmas zero_compare_simps =
-    add_strict_increasing add_strict_increasing2 add_increasing
-    zero_le_mult_iff zero_le_divide_iff 
-    zero_less_mult_iff zero_less_divide_iff 
-    mult_le_0_iff divide_le_0_iff 
-    mult_less_0_iff divide_less_0_iff 
-    zero_le_power2 power2_less_0
-
-subsubsection{*Nat *}
-
-lemma Suc_pred': "0 < n ==> n = Suc(n - 1)"
-by (simp add: numerals)
-
-(*Expresses a natural number constant as the Suc of another one.
-  NOT suitable for rewriting because n recurs in the condition.*)
-lemmas expand_Suc = Suc_pred' [of "number_of v", standard]
-
-subsubsection{*Arith *}
-
-lemma Suc_eq_add_numeral_1: "Suc n = n + 1"
-by (simp add: numerals)
-
-lemma Suc_eq_add_numeral_1_left: "Suc n = 1 + n"
-by (simp add: numerals)
-
-(* These two can be useful when m = number_of... *)
-
-lemma add_eq_if: "(m::nat) + n = (if m=0 then n else Suc ((m - 1) + n))"
-  unfolding One_nat_def by (cases m) simp_all
-
-lemma mult_eq_if: "(m::nat) * n = (if m=0 then 0 else n + ((m - 1) * n))"
-  unfolding One_nat_def by (cases m) simp_all
-
-lemma power_eq_if: "(p ^ m :: nat) = (if m=0 then 1 else p * (p ^ (m - 1)))"
-  unfolding One_nat_def by (cases m) simp_all
-
-
-subsection{*Comparisons involving (0::nat) *}
-
-text{*Simplification already does @{term "n<0"}, @{term "n\<le>0"} and @{term "0\<le>n"}.*}
-
-lemma eq_number_of_0 [simp]:
-  "number_of v = (0::nat) \<longleftrightarrow> v \<le> Int.Pls"
-  unfolding nat_number_of_def number_of_is_id numeral_simps
-  by auto
-
-lemma eq_0_number_of [simp]:
-  "(0::nat) = number_of v \<longleftrightarrow> v \<le> Int.Pls"
-by (rule trans [OF eq_sym_conv eq_number_of_0])
-
-lemma less_0_number_of [simp]:
-   "(0::nat) < number_of v \<longleftrightarrow> Int.Pls < v"
-  unfolding nat_number_of_def number_of_is_id numeral_simps
-  by simp
-
-lemma neg_imp_number_of_eq_0: "neg (number_of v :: int) ==> number_of v = (0::nat)"
-by (simp del: nat_numeral_0_eq_0 add: nat_numeral_0_eq_0 [symmetric])
-
-
-
-subsection{*Comparisons involving  @{term Suc} *}
-
-lemma eq_number_of_Suc [simp]:
-     "(number_of v = Suc n) =  
-        (let pv = number_of (Int.pred v) in  
-         if neg pv then False else nat pv = n)"
-apply (simp only: simp_thms Let_def neg_eq_less_0 linorder_not_less 
-                  number_of_pred nat_number_of_def 
-            split add: split_if)
-apply (rule_tac x = "number_of v" in spec)
-apply (auto simp add: nat_eq_iff)
-done
-
-lemma Suc_eq_number_of [simp]:
-     "(Suc n = number_of v) =  
-        (let pv = number_of (Int.pred v) in  
-         if neg pv then False else nat pv = n)"
-by (rule trans [OF eq_sym_conv eq_number_of_Suc])
-
-lemma less_number_of_Suc [simp]:
-     "(number_of v < Suc n) =  
-        (let pv = number_of (Int.pred v) in  
-         if neg pv then True else nat pv < n)"
-apply (simp only: simp_thms Let_def neg_eq_less_0 linorder_not_less 
-                  number_of_pred nat_number_of_def  
-            split add: split_if)
-apply (rule_tac x = "number_of v" in spec)
-apply (auto simp add: nat_less_iff)
-done
-
-lemma less_Suc_number_of [simp]:
-     "(Suc n < number_of v) =  
-        (let pv = number_of (Int.pred v) in  
-         if neg pv then False else n < nat pv)"
-apply (simp only: simp_thms Let_def neg_eq_less_0 linorder_not_less 
-                  number_of_pred nat_number_of_def
-            split add: split_if)
-apply (rule_tac x = "number_of v" in spec)
-apply (auto simp add: zless_nat_eq_int_zless)
-done
-
-lemma le_number_of_Suc [simp]:
-     "(number_of v <= Suc n) =  
-        (let pv = number_of (Int.pred v) in  
-         if neg pv then True else nat pv <= n)"
-by (simp add: Let_def less_Suc_number_of linorder_not_less [symmetric])
-
-lemma le_Suc_number_of [simp]:
-     "(Suc n <= number_of v) =  
-        (let pv = number_of (Int.pred v) in  
-         if neg pv then False else n <= nat pv)"
-by (simp add: Let_def less_number_of_Suc linorder_not_less [symmetric])
-
-
-lemma eq_number_of_Pls_Min: "(Numeral0 ::int) ~= number_of Int.Min"
-by auto
-
-
-
-subsection{*Max and Min Combined with @{term Suc} *}
-
-lemma max_number_of_Suc [simp]:
-     "max (Suc n) (number_of v) =  
-        (let pv = number_of (Int.pred v) in  
-         if neg pv then Suc n else Suc(max n (nat pv)))"
-apply (simp only: Let_def neg_eq_less_0 number_of_pred nat_number_of_def 
-            split add: split_if nat.split)
-apply (rule_tac x = "number_of v" in spec) 
-apply auto
-done
- 
-lemma max_Suc_number_of [simp]:
-     "max (number_of v) (Suc n) =  
-        (let pv = number_of (Int.pred v) in  
-         if neg pv then Suc n else Suc(max (nat pv) n))"
-apply (simp only: Let_def neg_eq_less_0 number_of_pred nat_number_of_def 
-            split add: split_if nat.split)
-apply (rule_tac x = "number_of v" in spec) 
-apply auto
-done
- 
-lemma min_number_of_Suc [simp]:
-     "min (Suc n) (number_of v) =  
-        (let pv = number_of (Int.pred v) in  
-         if neg pv then 0 else Suc(min n (nat pv)))"
-apply (simp only: Let_def neg_eq_less_0 number_of_pred nat_number_of_def 
-            split add: split_if nat.split)
-apply (rule_tac x = "number_of v" in spec) 
-apply auto
-done
- 
-lemma min_Suc_number_of [simp]:
-     "min (number_of v) (Suc n) =  
-        (let pv = number_of (Int.pred v) in  
-         if neg pv then 0 else Suc(min (nat pv) n))"
-apply (simp only: Let_def neg_eq_less_0 number_of_pred nat_number_of_def 
-            split add: split_if nat.split)
-apply (rule_tac x = "number_of v" in spec) 
-apply auto
-done
- 
-subsection{*Literal arithmetic involving powers*}
-
-lemma nat_power_eq: "(0::int) <= z ==> nat (z^n) = nat z ^ n"
-apply (induct "n")
-apply (simp_all (no_asm_simp) add: nat_mult_distrib)
-done
-
-lemma power_nat_number_of:
-     "(number_of v :: nat) ^ n =  
-       (if neg (number_of v :: int) then 0^n else nat ((number_of v :: int) ^ n))"
-by (simp only: simp_thms neg_nat not_neg_eq_ge_0 nat_number_of_def nat_power_eq
-         split add: split_if cong: imp_cong)
-
-
-lemmas power_nat_number_of_number_of = power_nat_number_of [of _ "number_of w", standard]
-declare power_nat_number_of_number_of [simp]
-
-
-
-text{*For arbitrary rings*}
-
-lemma power_number_of_even:
-  fixes z :: "'a::{number_ring,recpower}"
-  shows "z ^ number_of (Int.Bit0 w) = (let w = z ^ (number_of w) in w * w)"
-unfolding Let_def nat_number_of_def number_of_Bit0
-apply (rule_tac x = "number_of w" in spec, clarify)
-apply (case_tac " (0::int) <= x")
-apply (auto simp add: nat_mult_distrib power_even_eq power2_eq_square)
-done
-
-lemma power_number_of_odd:
-  fixes z :: "'a::{number_ring,recpower}"
-  shows "z ^ number_of (Int.Bit1 w) = (if (0::int) <= number_of w
-     then (let w = z ^ (number_of w) in z * w * w) else 1)"
-unfolding Let_def nat_number_of_def number_of_Bit1
-apply (rule_tac x = "number_of w" in spec, auto)
-apply (simp only: nat_add_distrib nat_mult_distrib)
-apply simp
-apply (auto simp add: nat_add_distrib nat_mult_distrib power_even_eq power2_eq_square neg_nat power_Suc)
-done
-
-lemmas zpower_number_of_even = power_number_of_even [where 'a=int]
-lemmas zpower_number_of_odd = power_number_of_odd [where 'a=int]
-
-lemmas power_number_of_even_number_of [simp] =
-    power_number_of_even [of "number_of v", standard]
-
-lemmas power_number_of_odd_number_of [simp] =
-    power_number_of_odd [of "number_of v", standard]
-
-
-
-ML
-{*
-val numeral_ss = @{simpset} addsimps @{thms numerals};
-
-val nat_bin_arith_setup =
- Lin_Arith.map_data
-   (fn {add_mono_thms, mult_mono_thms, inj_thms, lessD, neqE, simpset} =>
-     {add_mono_thms = add_mono_thms, mult_mono_thms = mult_mono_thms,
-      inj_thms = inj_thms,
-      lessD = lessD, neqE = neqE,
-      simpset = simpset addsimps @{thms neg_simps} @
-        [@{thm Suc_nat_number_of}, @{thm int_nat_number_of}]})
-*}
-
-declaration {* K nat_bin_arith_setup *}
-
-(* Enable arith to deal with div/mod k where k is a numeral: *)
-declare split_div[of _ _ "number_of k", standard, arith_split]
-declare split_mod[of _ _ "number_of k", standard, arith_split]
-
-lemma nat_number_of_Pls: "Numeral0 = (0::nat)"
-  by (simp add: number_of_Pls nat_number_of_def)
-
-lemma nat_number_of_Min: "number_of Int.Min = (0::nat)"
-  apply (simp only: number_of_Min nat_number_of_def nat_zminus_int)
-  done
-
-lemma nat_number_of_Bit0:
-    "number_of (Int.Bit0 w) = (let n::nat = number_of w in n + n)"
-  unfolding nat_number_of_def number_of_is_id numeral_simps Let_def
-  by auto
-
-lemma nat_number_of_Bit1:
-  "number_of (Int.Bit1 w) =
-    (if neg (number_of w :: int) then 0
-     else let n = number_of w in Suc (n + n))"
-  unfolding nat_number_of_def number_of_is_id numeral_simps neg_def Let_def
-  by auto
-
-lemmas nat_number =
-  nat_number_of_Pls nat_number_of_Min
-  nat_number_of_Bit0 nat_number_of_Bit1
-
-lemma Let_Suc [simp]: "Let (Suc n) f == f (Suc n)"
-  by (simp add: Let_def)
-
-lemma power_m1_even: "(-1) ^ (2*n) = (1::'a::{number_ring,recpower})"
-by (simp add: power_mult power_Suc); 
-
-lemma power_m1_odd: "(-1) ^ Suc(2*n) = (-1::'a::{number_ring,recpower})"
-by (simp add: power_mult power_Suc); 
-
-
-subsection{*Literal arithmetic and @{term of_nat}*}
-
-lemma of_nat_double:
-     "0 \<le> x ==> of_nat (nat (2 * x)) = of_nat (nat x) + of_nat (nat x)"
-by (simp only: mult_2 nat_add_distrib of_nat_add) 
-
-lemma nat_numeral_m1_eq_0: "-1 = (0::nat)"
-by (simp only: nat_number_of_def)
-
-lemma of_nat_number_of_lemma:
-     "of_nat (number_of v :: nat) =  
-         (if 0 \<le> (number_of v :: int) 
-          then (number_of v :: 'a :: number_ring)
-          else 0)"
-by (simp add: int_number_of_def nat_number_of_def number_of_eq of_nat_nat);
-
-lemma of_nat_number_of_eq [simp]:
-     "of_nat (number_of v :: nat) =  
-         (if neg (number_of v :: int) then 0  
-          else (number_of v :: 'a :: number_ring))"
-by (simp only: of_nat_number_of_lemma neg_def, simp) 
-
-
-subsection {*Lemmas for the Combination and Cancellation Simprocs*}
-
-lemma nat_number_of_add_left:
-     "number_of v + (number_of v' + (k::nat)) =  
-         (if neg (number_of v :: int) then number_of v' + k  
-          else if neg (number_of v' :: int) then number_of v + k  
-          else number_of (v + v') + k)"
-  unfolding nat_number_of_def number_of_is_id neg_def
-  by auto
-
-lemma nat_number_of_mult_left:
-     "number_of v * (number_of v' * (k::nat)) =  
-         (if v < Int.Pls then 0
-          else number_of (v * v') * k)"
-by simp
-
-
-subsubsection{*For @{text combine_numerals}*}
-
-lemma left_add_mult_distrib: "i*u + (j*u + k) = (i+j)*u + (k::nat)"
-by (simp add: add_mult_distrib)
-
-
-subsubsection{*For @{text cancel_numerals}*}
-
-lemma nat_diff_add_eq1:
-     "j <= (i::nat) ==> ((i*u + m) - (j*u + n)) = (((i-j)*u + m) - n)"
-by (simp split add: nat_diff_split add: add_mult_distrib)
-
-lemma nat_diff_add_eq2:
-     "i <= (j::nat) ==> ((i*u + m) - (j*u + n)) = (m - ((j-i)*u + n))"
-by (simp split add: nat_diff_split add: add_mult_distrib)
-
-lemma nat_eq_add_iff1:
-     "j <= (i::nat) ==> (i*u + m = j*u + n) = ((i-j)*u + m = n)"
-by (auto split add: nat_diff_split simp add: add_mult_distrib)
-
-lemma nat_eq_add_iff2:
-     "i <= (j::nat) ==> (i*u + m = j*u + n) = (m = (j-i)*u + n)"
-by (auto split add: nat_diff_split simp add: add_mult_distrib)
-
-lemma nat_less_add_iff1:
-     "j <= (i::nat) ==> (i*u + m < j*u + n) = ((i-j)*u + m < n)"
-by (auto split add: nat_diff_split simp add: add_mult_distrib)
-
-lemma nat_less_add_iff2:
-     "i <= (j::nat) ==> (i*u + m < j*u + n) = (m < (j-i)*u + n)"
-by (auto split add: nat_diff_split simp add: add_mult_distrib)
-
-lemma nat_le_add_iff1:
-     "j <= (i::nat) ==> (i*u + m <= j*u + n) = ((i-j)*u + m <= n)"
-by (auto split add: nat_diff_split simp add: add_mult_distrib)
-
-lemma nat_le_add_iff2:
-     "i <= (j::nat) ==> (i*u + m <= j*u + n) = (m <= (j-i)*u + n)"
-by (auto split add: nat_diff_split simp add: add_mult_distrib)
-
-
-subsubsection{*For @{text cancel_numeral_factors} *}
-
-lemma nat_mult_le_cancel1: "(0::nat) < k ==> (k*m <= k*n) = (m<=n)"
-by auto
-
-lemma nat_mult_less_cancel1: "(0::nat) < k ==> (k*m < k*n) = (m<n)"
-by auto
-
-lemma nat_mult_eq_cancel1: "(0::nat) < k ==> (k*m = k*n) = (m=n)"
-by auto
-
-lemma nat_mult_div_cancel1: "(0::nat) < k ==> (k*m) div (k*n) = (m div n)"
-by auto
-
-lemma nat_mult_dvd_cancel_disj[simp]:
-  "(k*m) dvd (k*n) = (k=0 | m dvd (n::nat))"
-by(auto simp: dvd_eq_mod_eq_0 mod_mult_distrib2[symmetric])
-
-lemma nat_mult_dvd_cancel1: "0 < k \<Longrightarrow> (k*m) dvd (k*n::nat) = (m dvd n)"
-by(auto)
-
-
-subsubsection{*For @{text cancel_factor} *}
-
-lemma nat_mult_le_cancel_disj: "(k*m <= k*n) = ((0::nat) < k --> m<=n)"
-by auto
-
-lemma nat_mult_less_cancel_disj: "(k*m < k*n) = ((0::nat) < k & m<n)"
-by auto
-
-lemma nat_mult_eq_cancel_disj: "(k*m = k*n) = (k = (0::nat) | m=n)"
-by auto
-
-lemma nat_mult_div_cancel_disj[simp]:
-     "(k*m) div (k*n) = (if k = (0::nat) then 0 else m div n)"
-by (simp add: nat_mult_div_cancel1)
-
-
-subsection {* Simprocs for the Naturals *}
-
-use "Tools/nat_simprocs.ML"
-declaration {* K nat_simprocs_setup *}
-
-subsubsection{*For simplifying @{term "Suc m - K"} and  @{term "K - Suc m"}*}
-
-text{*Where K above is a literal*}
-
-lemma Suc_diff_eq_diff_pred: "Numeral0 < n ==> Suc m - n = m - (n - Numeral1)"
-by (simp add: numeral_0_eq_0 numeral_1_eq_1 split add: nat_diff_split)
-
-text {*Now just instantiating @{text n} to @{text "number_of v"} does
-  the right simplification, but with some redundant inequality
-  tests.*}
-lemma neg_number_of_pred_iff_0:
-  "neg (number_of (Int.pred v)::int) = (number_of v = (0::nat))"
-apply (subgoal_tac "neg (number_of (Int.pred v)) = (number_of v < Suc 0) ")
-apply (simp only: less_Suc_eq_le le_0_eq)
-apply (subst less_number_of_Suc, simp)
-done
-
-text{*No longer required as a simprule because of the @{text inverse_fold}
-   simproc*}
-lemma Suc_diff_number_of:
-     "Int.Pls < v ==>
-      Suc m - (number_of v) = m - (number_of (Int.pred v))"
-apply (subst Suc_diff_eq_diff_pred)
-apply simp
-apply (simp del: nat_numeral_1_eq_1)
-apply (auto simp only: diff_nat_number_of less_0_number_of [symmetric]
-                        neg_number_of_pred_iff_0)
-done
-
-lemma diff_Suc_eq_diff_pred: "m - Suc n = (m - 1) - n"
-by (simp add: numerals split add: nat_diff_split)
-
-
-subsubsection{*For @{term nat_case} and @{term nat_rec}*}
-
-lemma nat_case_number_of [simp]:
-     "nat_case a f (number_of v) =
-        (let pv = number_of (Int.pred v) in
-         if neg pv then a else f (nat pv))"
-by (simp split add: nat.split add: Let_def neg_number_of_pred_iff_0)
-
-lemma nat_case_add_eq_if [simp]:
-     "nat_case a f ((number_of v) + n) =
-       (let pv = number_of (Int.pred v) in
-         if neg pv then nat_case a f n else f (nat pv + n))"
-apply (subst add_eq_if)
-apply (simp split add: nat.split
-            del: nat_numeral_1_eq_1
-            add: nat_numeral_1_eq_1 [symmetric]
-                 numeral_1_eq_Suc_0 [symmetric]
-                 neg_number_of_pred_iff_0)
-done
-
-lemma nat_rec_number_of [simp]:
-     "nat_rec a f (number_of v) =
-        (let pv = number_of (Int.pred v) in
-         if neg pv then a else f (nat pv) (nat_rec a f (nat pv)))"
-apply (case_tac " (number_of v) ::nat")
-apply (simp_all (no_asm_simp) add: Let_def neg_number_of_pred_iff_0)
-apply (simp split add: split_if_asm)
-done
-
-lemma nat_rec_add_eq_if [simp]:
-     "nat_rec a f (number_of v + n) =
-        (let pv = number_of (Int.pred v) in
-         if neg pv then nat_rec a f n
-                   else f (nat pv + n) (nat_rec a f (nat pv + n)))"
-apply (subst add_eq_if)
-apply (simp split add: nat.split
-            del: nat_numeral_1_eq_1
-            add: nat_numeral_1_eq_1 [symmetric]
-                 numeral_1_eq_Suc_0 [symmetric]
-                 neg_number_of_pred_iff_0)
-done
-
-
-subsubsection{*Various Other Lemmas*}
-
-text {*Evens and Odds, for Mutilated Chess Board*}
-
-text{*Lemmas for specialist use, NOT as default simprules*}
-lemma nat_mult_2: "2 * z = (z+z::nat)"
-proof -
-  have "2*z = (1 + 1)*z" by simp
-  also have "... = z+z" by (simp add: left_distrib)
-  finally show ?thesis .
-qed
-
-lemma nat_mult_2_right: "z * 2 = (z+z::nat)"
-by (subst mult_commute, rule nat_mult_2)
-
-text{*Case analysis on @{term "n<2"}*}
-lemma less_2_cases: "(n::nat) < 2 ==> n = 0 | n = Suc 0"
-by arith
-
-lemma div2_Suc_Suc [simp]: "Suc(Suc m) div 2 = Suc (m div 2)"
-by arith
-
-lemma add_self_div_2 [simp]: "(m + m) div 2 = (m::nat)"
-by (simp add: nat_mult_2 [symmetric])
-
-lemma mod2_Suc_Suc [simp]: "Suc(Suc(m)) mod 2 = m mod 2"
-apply (subgoal_tac "m mod 2 < 2")
-apply (erule less_2_cases [THEN disjE])
-apply (simp_all (no_asm_simp) add: Let_def mod_Suc nat_1)
-done
-
-lemma mod2_gr_0 [simp]: "!!m::nat. (0 < m mod 2) = (m mod 2 = 1)"
-apply (subgoal_tac "m mod 2 < 2")
-apply (force simp del: mod_less_divisor, simp)
-done
-
-text{*Removal of Small Numerals: 0, 1 and (in additive positions) 2*}
-
-lemma add_2_eq_Suc [simp]: "2 + n = Suc (Suc n)"
-by simp
-
-lemma add_2_eq_Suc' [simp]: "n + 2 = Suc (Suc n)"
-by simp
-
-text{*Can be used to eliminate long strings of Sucs, but not by default*}
-lemma Suc3_eq_add_3: "Suc (Suc (Suc n)) = 3 + n"
-by simp
-
-
-text{*These lemmas collapse some needless occurrences of Suc:
-    at least three Sucs, since two and fewer are rewritten back to Suc again!
-    We already have some rules to simplify operands smaller than 3.*}
-
-lemma div_Suc_eq_div_add3 [simp]: "m div (Suc (Suc (Suc n))) = m div (3+n)"
-by (simp add: Suc3_eq_add_3)
-
-lemma mod_Suc_eq_mod_add3 [simp]: "m mod (Suc (Suc (Suc n))) = m mod (3+n)"
-by (simp add: Suc3_eq_add_3)
-
-lemma Suc_div_eq_add3_div: "(Suc (Suc (Suc m))) div n = (3+m) div n"
-by (simp add: Suc3_eq_add_3)
-
-lemma Suc_mod_eq_add3_mod: "(Suc (Suc (Suc m))) mod n = (3+m) mod n"
-by (simp add: Suc3_eq_add_3)
-
-lemmas Suc_div_eq_add3_div_number_of =
-    Suc_div_eq_add3_div [of _ "number_of v", standard]
-declare Suc_div_eq_add3_div_number_of [simp]
-
-lemmas Suc_mod_eq_add3_mod_number_of =
-    Suc_mod_eq_add3_mod [of _ "number_of v", standard]
-declare Suc_mod_eq_add3_mod_number_of [simp]
-
-end

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Nat_Numeral.thy	Fri May 15 15:56:28 2009 +0200
@@ -0,0 +1,1047 @@
+(*  Title:      HOL/Nat_Numeral.thy
+    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
+    Copyright   1999  University of Cambridge
+*)
+
+header {* Binary numerals for the natural numbers *}
+
+theory Nat_Numeral
+imports IntDiv
+uses ("Tools/nat_numeral_simprocs.ML")
+begin
+
+subsection {* Numerals for natural numbers *}
+
+text {*
+  Arithmetic for naturals is reduced to that for the non-negative integers.
+*}
+
+instantiation nat :: number
+begin
+
+definition
+  nat_number_of_def [code inline, code del]: "number_of v = nat (number_of v)"
+
+instance ..
+
+end
+
+lemma [code post]:
+  "nat (number_of v) = number_of v"
+  unfolding nat_number_of_def ..
+
+
+subsection {* Special case: squares and cubes *}
+
+lemma numeral_2_eq_2: "2 = Suc (Suc 0)"
+  by (simp add: nat_number_of_def)
+
+lemma numeral_3_eq_3: "3 = Suc (Suc (Suc 0))"
+  by (simp add: nat_number_of_def)
+
+context power
+begin
+
+abbreviation (xsymbols)
+  power2 :: "'a \<Rightarrow> 'a"  ("(_\<twosuperior>)" [1000] 999) where
+  "x\<twosuperior> \<equiv> x ^ 2"
+
+notation (latex output)
+  power2  ("(_\<twosuperior>)" [1000] 999)
+
+notation (HTML output)
+  power2  ("(_\<twosuperior>)" [1000] 999)
+
+end
+
+context monoid_mult
+begin
+
+lemma power2_eq_square: "a\<twosuperior> = a * a"
+  by (simp add: numeral_2_eq_2)
+
+lemma power3_eq_cube: "a ^ 3 = a * a * a"
+  by (simp add: numeral_3_eq_3 mult_assoc)
+
+lemma power_even_eq:
+  "a ^ (2*n) = (a ^ n) ^ 2"
+  by (subst OrderedGroup.mult_commute) (simp add: power_mult)
+
+lemma power_odd_eq:
+  "a ^ Suc (2*n) = a * (a ^ n) ^ 2"
+  by (simp add: power_even_eq)
+
+end
+
+context semiring_1
+begin
+
+lemma zero_power2 [simp]: "0\<twosuperior> = 0"
+  by (simp add: power2_eq_square)
+
+lemma one_power2 [simp]: "1\<twosuperior> = 1"
+  by (simp add: power2_eq_square)
+
+end
+
+context comm_ring_1
+begin
+
+lemma power2_minus [simp]:
+  "(- a)\<twosuperior> = a\<twosuperior>"
+  by (simp add: power2_eq_square)
+
+text{*
+  We cannot prove general results about the numeral @{term "-1"},
+  so we have to use @{term "- 1"} instead.
+*}
+
+lemma power_minus1_even [simp]:
+  "(- 1) ^ (2*n) = 1"
+proof (induct n)
+  case 0 show ?case by simp
+next
+  case (Suc n) then show ?case by (simp add: power_add)
+qed
+
+lemma power_minus1_odd:
+  "(- 1) ^ Suc (2*n) = - 1"
+  by simp
+
+lemma power_minus_even [simp]:
+  "(-a) ^ (2*n) = a ^ (2*n)"
+  by (simp add: power_minus [of a]) 
+
+end
+
+context ordered_ring_strict
+begin
+
+lemma sum_squares_ge_zero:
+  "0 \<le> x * x + y * y"
+  by (intro add_nonneg_nonneg zero_le_square)
+
+lemma not_sum_squares_lt_zero:
+  "\<not> x * x + y * y < 0"
+  by (simp add: not_less sum_squares_ge_zero)
+
+lemma sum_squares_eq_zero_iff:
+  "x * x + y * y = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
+  by (simp add: add_nonneg_eq_0_iff)
+
+lemma sum_squares_le_zero_iff:
+  "x * x + y * y \<le> 0 \<longleftrightarrow> x = 0 \<and> y = 0"
+  by (simp add: le_less not_sum_squares_lt_zero sum_squares_eq_zero_iff)
+
+lemma sum_squares_gt_zero_iff:
+  "0 < x * x + y * y \<longleftrightarrow> x \<noteq> 0 \<or> y \<noteq> 0"
+proof -
+  have "x * x + y * y \<noteq> 0 \<longleftrightarrow> x \<noteq> 0 \<or> y \<noteq> 0"
+    by (simp add: sum_squares_eq_zero_iff)
+  then have "0 \<noteq> x * x + y * y \<longleftrightarrow> x \<noteq> 0 \<or> y \<noteq> 0"
+    by auto
+  then show ?thesis
+    by (simp add: less_le sum_squares_ge_zero)
+qed
+
+end
+
+context ordered_semidom
+begin
+
+lemma power2_le_imp_le:
+  "x\<twosuperior> \<le> y\<twosuperior> \<Longrightarrow> 0 \<le> y \<Longrightarrow> x \<le> y"
+  unfolding numeral_2_eq_2 by (rule power_le_imp_le_base)
+
+lemma power2_less_imp_less:
+  "x\<twosuperior> < y\<twosuperior> \<Longrightarrow> 0 \<le> y \<Longrightarrow> x < y"
+  by (rule power_less_imp_less_base)
+
+lemma power2_eq_imp_eq:
+  "x\<twosuperior> = y\<twosuperior> \<Longrightarrow> 0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> x = y"
+  unfolding numeral_2_eq_2 by (erule (2) power_eq_imp_eq_base) simp
+
+end
+
+context ordered_idom
+begin
+
+lemma zero_eq_power2 [simp]:
+  "a\<twosuperior> = 0 \<longleftrightarrow> a = 0"
+  by (force simp add: power2_eq_square)
+
+lemma zero_le_power2 [simp]:
+  "0 \<le> a\<twosuperior>"
+  by (simp add: power2_eq_square)
+
+lemma zero_less_power2 [simp]:
+  "0 < a\<twosuperior> \<longleftrightarrow> a \<noteq> 0"
+  by (force simp add: power2_eq_square zero_less_mult_iff linorder_neq_iff)
+
+lemma power2_less_0 [simp]:
+  "\<not> a\<twosuperior> < 0"
+  by (force simp add: power2_eq_square mult_less_0_iff) 
+
+lemma abs_power2 [simp]:
+  "abs (a\<twosuperior>) = a\<twosuperior>"
+  by (simp add: power2_eq_square abs_mult abs_mult_self)
+
+lemma power2_abs [simp]:
+  "(abs a)\<twosuperior> = a\<twosuperior>"
+  by (simp add: power2_eq_square abs_mult_self)
+
+lemma odd_power_less_zero:
+  "a < 0 \<Longrightarrow> a ^ Suc (2*n) < 0"
+proof (induct n)
+  case 0
+  then show ?case by simp
+next
+  case (Suc n)
+  have "a ^ Suc (2 * Suc n) = (a*a) * a ^ Suc(2*n)"
+    by (simp add: mult_ac power_add power2_eq_square)
+  thus ?case
+    by (simp del: power_Suc add: Suc mult_less_0_iff mult_neg_neg)
+qed
+
+lemma odd_0_le_power_imp_0_le:
+  "0 \<le> a ^ Suc (2*n) \<Longrightarrow> 0 \<le> a"
+  using odd_power_less_zero [of a n]
+    by (force simp add: linorder_not_less [symmetric]) 
+
+lemma zero_le_even_power'[simp]:
+  "0 \<le> a ^ (2*n)"
+proof (induct n)
+  case 0
+    show ?case by (simp add: zero_le_one)
+next
+  case (Suc n)
+    have "a ^ (2 * Suc n) = (a*a) * a ^ (2*n)" 
+      by (simp add: mult_ac power_add power2_eq_square)
+    thus ?case
+      by (simp add: Suc zero_le_mult_iff)
+qed
+
+lemma sum_power2_ge_zero:
+  "0 \<le> x\<twosuperior> + y\<twosuperior>"
+  unfolding power2_eq_square by (rule sum_squares_ge_zero)
+
+lemma not_sum_power2_lt_zero:
+  "\<not> x\<twosuperior> + y\<twosuperior> < 0"
+  unfolding power2_eq_square by (rule not_sum_squares_lt_zero)
+
+lemma sum_power2_eq_zero_iff:
+  "x\<twosuperior> + y\<twosuperior> = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
+  unfolding power2_eq_square by (rule sum_squares_eq_zero_iff)
+
+lemma sum_power2_le_zero_iff:
+  "x\<twosuperior> + y\<twosuperior> \<le> 0 \<longleftrightarrow> x = 0 \<and> y = 0"
+  unfolding power2_eq_square by (rule sum_squares_le_zero_iff)
+
+lemma sum_power2_gt_zero_iff:
+  "0 < x\<twosuperior> + y\<twosuperior> \<longleftrightarrow> x \<noteq> 0 \<or> y \<noteq> 0"
+  unfolding power2_eq_square by (rule sum_squares_gt_zero_iff)
+
+end
+
+lemma power2_sum:
+  fixes x y :: "'a::number_ring"
+  shows "(x + y)\<twosuperior> = x\<twosuperior> + y\<twosuperior> + 2 * x * y"
+  by (simp add: ring_distribs power2_eq_square)
+
+lemma power2_diff:
+  fixes x y :: "'a::number_ring"
+  shows "(x - y)\<twosuperior> = x\<twosuperior> + y\<twosuperior> - 2 * x * y"
+  by (simp add: ring_distribs power2_eq_square)
+
+
+subsection {* Predicate for negative binary numbers *}
+
+definition neg  :: "int \<Rightarrow> bool" where
+  "neg Z \<longleftrightarrow> Z < 0"
+
+lemma not_neg_int [simp]: "~ neg (of_nat n)"
+by (simp add: neg_def)
+
+lemma neg_zminus_int [simp]: "neg (- (of_nat (Suc n)))"
+by (simp add: neg_def neg_less_0_iff_less del: of_nat_Suc)
+
+lemmas neg_eq_less_0 = neg_def
+
+lemma not_neg_eq_ge_0: "(~neg x) = (0 \<le> x)"
+by (simp add: neg_def linorder_not_less)
+
+text{*To simplify inequalities when Numeral1 can get simplified to 1*}
+
+lemma not_neg_0: "~ neg 0"
+by (simp add: One_int_def neg_def)
+
+lemma not_neg_1: "~ neg 1"
+by (simp add: neg_def linorder_not_less zero_le_one)
+
+lemma neg_nat: "neg z ==> nat z = 0"
+by (simp add: neg_def order_less_imp_le) 
+
+lemma not_neg_nat: "~ neg z ==> of_nat (nat z) = z"
+by (simp add: linorder_not_less neg_def)
+
+text {*
+  If @{term Numeral0} is rewritten to 0 then this rule can't be applied:
+  @{term Numeral0} IS @{term "number_of Pls"}
+*}
+
+lemma not_neg_number_of_Pls: "~ neg (number_of Int.Pls)"
+  by (simp add: neg_def)
+
+lemma neg_number_of_Min: "neg (number_of Int.Min)"
+  by (simp add: neg_def)
+
+lemma neg_number_of_Bit0:
+  "neg (number_of (Int.Bit0 w)) = neg (number_of w)"
+  by (simp add: neg_def)
+
+lemma neg_number_of_Bit1:
+  "neg (number_of (Int.Bit1 w)) = neg (number_of w)"
+  by (simp add: neg_def)
+
+lemmas neg_simps [simp] =
+  not_neg_0 not_neg_1
+  not_neg_number_of_Pls neg_number_of_Min
+  neg_number_of_Bit0 neg_number_of_Bit1
+
+
+subsection{*Function @{term nat}: Coercion from Type @{typ int} to @{typ nat}*}
+
+declare nat_0 [simp] nat_1 [simp]
+
+lemma nat_number_of [simp]: "nat (number_of w) = number_of w"
+by (simp add: nat_number_of_def)
+
+lemma nat_numeral_0_eq_0 [simp]: "Numeral0 = (0::nat)"
+by (simp add: nat_number_of_def)
+
+lemma nat_numeral_1_eq_1 [simp]: "Numeral1 = (1::nat)"
+by (simp add: nat_1 nat_number_of_def)
+
+lemma numeral_1_eq_Suc_0: "Numeral1 = Suc 0"
+by (simp add: nat_numeral_1_eq_1)
+
+
+subsection{*Function @{term int}: Coercion from Type @{typ nat} to @{typ int}*}
+
+lemma int_nat_number_of [simp]:
+     "int (number_of v) =  
+         (if neg (number_of v :: int) then 0  
+          else (number_of v :: int))"
+  unfolding nat_number_of_def number_of_is_id neg_def
+  by simp
+
+
+subsubsection{*Successor *}
+
+lemma Suc_nat_eq_nat_zadd1: "(0::int) <= z ==> Suc (nat z) = nat (1 + z)"
+apply (rule sym)
+apply (simp add: nat_eq_iff int_Suc)
+done
+
+lemma Suc_nat_number_of_add:
+     "Suc (number_of v + n) =  
+        (if neg (number_of v :: int) then 1+n else number_of (Int.succ v) + n)"
+  unfolding nat_number_of_def number_of_is_id neg_def numeral_simps
+  by (simp add: Suc_nat_eq_nat_zadd1 add_ac)
+
+lemma Suc_nat_number_of [simp]:
+     "Suc (number_of v) =  
+        (if neg (number_of v :: int) then 1 else number_of (Int.succ v))"
+apply (cut_tac n = 0 in Suc_nat_number_of_add)
+apply (simp cong del: if_weak_cong)
+done
+
+
+subsubsection{*Addition *}
+
+lemma add_nat_number_of [simp]:
+     "(number_of v :: nat) + number_of v' =  
+         (if v < Int.Pls then number_of v'  
+          else if v' < Int.Pls then number_of v  
+          else number_of (v + v'))"
+  unfolding nat_number_of_def number_of_is_id numeral_simps
+  by (simp add: nat_add_distrib)
+
+lemma nat_number_of_add_1 [simp]:
+  "number_of v + (1::nat) =
+    (if v < Int.Pls then 1 else number_of (Int.succ v))"
+  unfolding nat_number_of_def number_of_is_id numeral_simps
+  by (simp add: nat_add_distrib)
+
+lemma nat_1_add_number_of [simp]:
+  "(1::nat) + number_of v =
+    (if v < Int.Pls then 1 else number_of (Int.succ v))"
+  unfolding nat_number_of_def number_of_is_id numeral_simps
+  by (simp add: nat_add_distrib)
+
+lemma nat_1_add_1 [simp]: "1 + 1 = (2::nat)"
+  by (rule int_int_eq [THEN iffD1]) simp
+
+
+subsubsection{*Subtraction *}
+
+lemma diff_nat_eq_if:
+     "nat z - nat z' =  
+        (if neg z' then nat z   
+         else let d = z-z' in     
+              if neg d then 0 else nat d)"
+by (simp add: Let_def nat_diff_distrib [symmetric] neg_eq_less_0 not_neg_eq_ge_0)
+
+
+lemma diff_nat_number_of [simp]: 
+     "(number_of v :: nat) - number_of v' =  
+        (if v' < Int.Pls then number_of v  
+         else let d = number_of (v + uminus v') in     
+              if neg d then 0 else nat d)"
+  unfolding nat_number_of_def number_of_is_id numeral_simps neg_def
+  by auto
+
+lemma nat_number_of_diff_1 [simp]:
+  "number_of v - (1::nat) =
+    (if v \<le> Int.Pls then 0 else number_of (Int.pred v))"
+  unfolding nat_number_of_def number_of_is_id numeral_simps
+  by auto
+
+
+subsubsection{*Multiplication *}
+
+lemma mult_nat_number_of [simp]:
+     "(number_of v :: nat) * number_of v' =  
+       (if v < Int.Pls then 0 else number_of (v * v'))"
+  unfolding nat_number_of_def number_of_is_id numeral_simps
+  by (simp add: nat_mult_distrib)
+
+
+subsubsection{*Quotient *}
+
+lemma div_nat_number_of [simp]:
+     "(number_of v :: nat)  div  number_of v' =  
+          (if neg (number_of v :: int) then 0  
+           else nat (number_of v div number_of v'))"
+  unfolding nat_number_of_def number_of_is_id neg_def
+  by (simp add: nat_div_distrib)
+
+lemma one_div_nat_number_of [simp]:
+     "Suc 0 div number_of v' = nat (1 div number_of v')" 
+by (simp del: nat_numeral_1_eq_1 add: numeral_1_eq_Suc_0 [symmetric]) 
+
+
+subsubsection{*Remainder *}
+
+lemma mod_nat_number_of [simp]:
+     "(number_of v :: nat)  mod  number_of v' =  
+        (if neg (number_of v :: int) then 0  
+         else if neg (number_of v' :: int) then number_of v  
+         else nat (number_of v mod number_of v'))"
+  unfolding nat_number_of_def number_of_is_id neg_def
+  by (simp add: nat_mod_distrib)
+
+lemma one_mod_nat_number_of [simp]:
+     "Suc 0 mod number_of v' =  
+        (if neg (number_of v' :: int) then Suc 0
+         else nat (1 mod number_of v'))"
+by (simp del: nat_numeral_1_eq_1 add: numeral_1_eq_Suc_0 [symmetric]) 
+
+
+subsubsection{* Divisibility *}
+
+lemmas dvd_eq_mod_eq_0_number_of =
+  dvd_eq_mod_eq_0 [of "number_of x" "number_of y", standard]
+
+declare dvd_eq_mod_eq_0_number_of [simp]
+
+
+subsection{*Comparisons*}
+
+subsubsection{*Equals (=) *}
+
+lemma eq_nat_nat_iff:
+     "[| (0::int) <= z;  0 <= z' |] ==> (nat z = nat z') = (z=z')"
+by (auto elim!: nonneg_eq_int)
+
+lemma eq_nat_number_of [simp]:
+     "((number_of v :: nat) = number_of v') =  
+      (if neg (number_of v :: int) then (number_of v' :: int) \<le> 0
+       else if neg (number_of v' :: int) then (number_of v :: int) = 0
+       else v = v')"
+  unfolding nat_number_of_def number_of_is_id neg_def
+  by auto
+
+
+subsubsection{*Less-than (<) *}
+
+lemma less_nat_number_of [simp]:
+  "(number_of v :: nat) < number_of v' \<longleftrightarrow>
+    (if v < v' then Int.Pls < v' else False)"
+  unfolding nat_number_of_def number_of_is_id numeral_simps
+  by auto
+
+
+subsubsection{*Less-than-or-equal *}
+
+lemma le_nat_number_of [simp]:
+  "(number_of v :: nat) \<le> number_of v' \<longleftrightarrow>
+    (if v \<le> v' then True else v \<le> Int.Pls)"
+  unfolding nat_number_of_def number_of_is_id numeral_simps
+  by auto
+
+(*Maps #n to n for n = 0, 1, 2*)
+lemmas numerals = nat_numeral_0_eq_0 nat_numeral_1_eq_1 numeral_2_eq_2
+
+
+subsection{*Powers with Numeric Exponents*}
+
+text{*Squares of literal numerals will be evaluated.*}
+lemmas power2_eq_square_number_of [simp] =
+    power2_eq_square [of "number_of w", standard]
+
+
+text{*Simprules for comparisons where common factors can be cancelled.*}
+lemmas zero_compare_simps =
+    add_strict_increasing add_strict_increasing2 add_increasing
+    zero_le_mult_iff zero_le_divide_iff 
+    zero_less_mult_iff zero_less_divide_iff 
+    mult_le_0_iff divide_le_0_iff 
+    mult_less_0_iff divide_less_0_iff 
+    zero_le_power2 power2_less_0
+
+subsubsection{*Nat *}
+
+lemma Suc_pred': "0 < n ==> n = Suc(n - 1)"
+by (simp add: numerals)
+
+(*Expresses a natural number constant as the Suc of another one.
+  NOT suitable for rewriting because n recurs in the condition.*)
+lemmas expand_Suc = Suc_pred' [of "number_of v", standard]
+
+subsubsection{*Arith *}
+
+lemma Suc_eq_add_numeral_1: "Suc n = n + 1"
+by (simp add: numerals)
+
+lemma Suc_eq_add_numeral_1_left: "Suc n = 1 + n"
+by (simp add: numerals)
+
+(* These two can be useful when m = number_of... *)
+
+lemma add_eq_if: "(m::nat) + n = (if m=0 then n else Suc ((m - 1) + n))"
+  unfolding One_nat_def by (cases m) simp_all
+
+lemma mult_eq_if: "(m::nat) * n = (if m=0 then 0 else n + ((m - 1) * n))"
+  unfolding One_nat_def by (cases m) simp_all
+
+lemma power_eq_if: "(p ^ m :: nat) = (if m=0 then 1 else p * (p ^ (m - 1)))"
+  unfolding One_nat_def by (cases m) simp_all
+
+
+subsection{*Comparisons involving (0::nat) *}
+
+text{*Simplification already does @{term "n<0"}, @{term "n\<le>0"} and @{term "0\<le>n"}.*}
+
+lemma eq_number_of_0 [simp]:
+  "number_of v = (0::nat) \<longleftrightarrow> v \<le> Int.Pls"
+  unfolding nat_number_of_def number_of_is_id numeral_simps
+  by auto
+
+lemma eq_0_number_of [simp]:
+  "(0::nat) = number_of v \<longleftrightarrow> v \<le> Int.Pls"
+by (rule trans [OF eq_sym_conv eq_number_of_0])
+
+lemma less_0_number_of [simp]:
+   "(0::nat) < number_of v \<longleftrightarrow> Int.Pls < v"
+  unfolding nat_number_of_def number_of_is_id numeral_simps
+  by simp
+
+lemma neg_imp_number_of_eq_0: "neg (number_of v :: int) ==> number_of v = (0::nat)"
+by (simp del: nat_numeral_0_eq_0 add: nat_numeral_0_eq_0 [symmetric])
+
+
+
+subsection{*Comparisons involving  @{term Suc} *}
+
+lemma eq_number_of_Suc [simp]:
+     "(number_of v = Suc n) =  
+        (let pv = number_of (Int.pred v) in  
+         if neg pv then False else nat pv = n)"
+apply (simp only: simp_thms Let_def neg_eq_less_0 linorder_not_less 
+                  number_of_pred nat_number_of_def 
+            split add: split_if)
+apply (rule_tac x = "number_of v" in spec)
+apply (auto simp add: nat_eq_iff)
+done
+
+lemma Suc_eq_number_of [simp]:
+     "(Suc n = number_of v) =  
+        (let pv = number_of (Int.pred v) in  
+         if neg pv then False else nat pv = n)"
+by (rule trans [OF eq_sym_conv eq_number_of_Suc])
+
+lemma less_number_of_Suc [simp]:
+     "(number_of v < Suc n) =  
+        (let pv = number_of (Int.pred v) in  
+         if neg pv then True else nat pv < n)"
+apply (simp only: simp_thms Let_def neg_eq_less_0 linorder_not_less 
+                  number_of_pred nat_number_of_def  
+            split add: split_if)
+apply (rule_tac x = "number_of v" in spec)
+apply (auto simp add: nat_less_iff)
+done
+
+lemma less_Suc_number_of [simp]:
+     "(Suc n < number_of v) =  
+        (let pv = number_of (Int.pred v) in  
+         if neg pv then False else n < nat pv)"
+apply (simp only: simp_thms Let_def neg_eq_less_0 linorder_not_less 
+                  number_of_pred nat_number_of_def
+            split add: split_if)
+apply (rule_tac x = "number_of v" in spec)
+apply (auto simp add: zless_nat_eq_int_zless)
+done
+
+lemma le_number_of_Suc [simp]:
+     "(number_of v <= Suc n) =  
+        (let pv = number_of (Int.pred v) in  
+         if neg pv then True else nat pv <= n)"
+by (simp add: Let_def less_Suc_number_of linorder_not_less [symmetric])
+
+lemma le_Suc_number_of [simp]:
+     "(Suc n <= number_of v) =  
+        (let pv = number_of (Int.pred v) in  
+         if neg pv then False else n <= nat pv)"
+by (simp add: Let_def less_number_of_Suc linorder_not_less [symmetric])
+
+
+lemma eq_number_of_Pls_Min: "(Numeral0 ::int) ~= number_of Int.Min"
+by auto
+
+
+
+subsection{*Max and Min Combined with @{term Suc} *}
+
+lemma max_number_of_Suc [simp]:
+     "max (Suc n) (number_of v) =  
+        (let pv = number_of (Int.pred v) in  
+         if neg pv then Suc n else Suc(max n (nat pv)))"
+apply (simp only: Let_def neg_eq_less_0 number_of_pred nat_number_of_def 
+            split add: split_if nat.split)
+apply (rule_tac x = "number_of v" in spec) 
+apply auto
+done
+ 
+lemma max_Suc_number_of [simp]:
+     "max (number_of v) (Suc n) =  
+        (let pv = number_of (Int.pred v) in  
+         if neg pv then Suc n else Suc(max (nat pv) n))"
+apply (simp only: Let_def neg_eq_less_0 number_of_pred nat_number_of_def 
+            split add: split_if nat.split)
+apply (rule_tac x = "number_of v" in spec) 
+apply auto
+done
+ 
+lemma min_number_of_Suc [simp]:
+     "min (Suc n) (number_of v) =  
+        (let pv = number_of (Int.pred v) in  
+         if neg pv then 0 else Suc(min n (nat pv)))"
+apply (simp only: Let_def neg_eq_less_0 number_of_pred nat_number_of_def 
+            split add: split_if nat.split)
+apply (rule_tac x = "number_of v" in spec) 
+apply auto
+done
+ 
+lemma min_Suc_number_of [simp]:
+     "min (number_of v) (Suc n) =  
+        (let pv = number_of (Int.pred v) in  
+         if neg pv then 0 else Suc(min (nat pv) n))"
+apply (simp only: Let_def neg_eq_less_0 number_of_pred nat_number_of_def 
+            split add: split_if nat.split)
+apply (rule_tac x = "number_of v" in spec) 
+apply auto
+done
+ 
+subsection{*Literal arithmetic involving powers*}
+
+lemma nat_power_eq: "(0::int) <= z ==> nat (z^n) = nat z ^ n"
+apply (induct "n")
+apply (simp_all (no_asm_simp) add: nat_mult_distrib)
+done
+
+lemma power_nat_number_of:
+     "(number_of v :: nat) ^ n =  
+       (if neg (number_of v :: int) then 0^n else nat ((number_of v :: int) ^ n))"
+by (simp only: simp_thms neg_nat not_neg_eq_ge_0 nat_number_of_def nat_power_eq
+         split add: split_if cong: imp_cong)
+
+
+lemmas power_nat_number_of_number_of = power_nat_number_of [of _ "number_of w", standard]
+declare power_nat_number_of_number_of [simp]
+
+
+
+text{*For arbitrary rings*}
+
+lemma power_number_of_even:
+  fixes z :: "'a::number_ring"
+  shows "z ^ number_of (Int.Bit0 w) = (let w = z ^ (number_of w) in w * w)"
+unfolding Let_def nat_number_of_def number_of_Bit0
+apply (rule_tac x = "number_of w" in spec, clarify)
+apply (case_tac " (0::int) <= x")
+apply (auto simp add: nat_mult_distrib power_even_eq power2_eq_square)
+done
+
+lemma power_number_of_odd:
+  fixes z :: "'a::number_ring"
+  shows "z ^ number_of (Int.Bit1 w) = (if (0::int) <= number_of w
+     then (let w = z ^ (number_of w) in z * w * w) else 1)"
+unfolding Let_def nat_number_of_def number_of_Bit1
+apply (rule_tac x = "number_of w" in spec, auto)
+apply (simp only: nat_add_distrib nat_mult_distrib)
+apply simp
+apply (auto simp add: nat_add_distrib nat_mult_distrib power_even_eq power2_eq_square neg_nat power_Suc)
+done
+
+lemmas zpower_number_of_even = power_number_of_even [where 'a=int]
+lemmas zpower_number_of_odd = power_number_of_odd [where 'a=int]
+
+lemmas power_number_of_even_number_of [simp] =
+    power_number_of_even [of "number_of v", standard]
+
+lemmas power_number_of_odd_number_of [simp] =
+    power_number_of_odd [of "number_of v", standard]
+
+
+(* Enable arith to deal with div/mod k where k is a numeral: *)
+declare split_div[of _ _ "number_of k", standard, arith_split]
+declare split_mod[of _ _ "number_of k", standard, arith_split]
+
+lemma nat_number_of_Pls: "Numeral0 = (0::nat)"
+  by (simp add: number_of_Pls nat_number_of_def)
+
+lemma nat_number_of_Min: "number_of Int.Min = (0::nat)"
+  apply (simp only: number_of_Min nat_number_of_def nat_zminus_int)
+  done
+
+lemma nat_number_of_Bit0:
+    "number_of (Int.Bit0 w) = (let n::nat = number_of w in n + n)"
+  unfolding nat_number_of_def number_of_is_id numeral_simps Let_def
+  by auto
+
+lemma nat_number_of_Bit1:
+  "number_of (Int.Bit1 w) =
+    (if neg (number_of w :: int) then 0
+     else let n = number_of w in Suc (n + n))"
+  unfolding nat_number_of_def number_of_is_id numeral_simps neg_def Let_def
+  by auto
+
+lemmas nat_number =
+  nat_number_of_Pls nat_number_of_Min
+  nat_number_of_Bit0 nat_number_of_Bit1
+
+lemma Let_Suc [simp]: "Let (Suc n) f == f (Suc n)"
+  by (simp add: Let_def)
+
+lemma power_m1_even: "(-1) ^ (2*n) = (1::'a::{number_ring})"
+  by (simp only: number_of_Min power_minus1_even)
+
+lemma power_m1_odd: "(-1) ^ Suc(2*n) = (-1::'a::{number_ring})"
+  by (simp only: number_of_Min power_minus1_odd)
+
+
+subsection{*Literal arithmetic and @{term of_nat}*}
+
+lemma of_nat_double:
+     "0 \<le> x ==> of_nat (nat (2 * x)) = of_nat (nat x) + of_nat (nat x)"
+by (simp only: mult_2 nat_add_distrib of_nat_add) 
+
+lemma nat_numeral_m1_eq_0: "-1 = (0::nat)"
+by (simp only: nat_number_of_def)
+
+lemma of_nat_number_of_lemma:
+     "of_nat (number_of v :: nat) =  
+         (if 0 \<le> (number_of v :: int) 
+          then (number_of v :: 'a :: number_ring)
+          else 0)"
+by (simp add: int_number_of_def nat_number_of_def number_of_eq of_nat_nat);
+
+lemma of_nat_number_of_eq [simp]:
+     "of_nat (number_of v :: nat) =  
+         (if neg (number_of v :: int) then 0  
+          else (number_of v :: 'a :: number_ring))"
+by (simp only: of_nat_number_of_lemma neg_def, simp) 
+
+
+subsection {*Lemmas for the Combination and Cancellation Simprocs*}
+
+lemma nat_number_of_add_left:
+     "number_of v + (number_of v' + (k::nat)) =  
+         (if neg (number_of v :: int) then number_of v' + k  
+          else if neg (number_of v' :: int) then number_of v + k  
+          else number_of (v + v') + k)"
+  unfolding nat_number_of_def number_of_is_id neg_def
+  by auto
+
+lemma nat_number_of_mult_left:
+     "number_of v * (number_of v' * (k::nat)) =  
+         (if v < Int.Pls then 0
+          else number_of (v * v') * k)"
+by simp
+
+
+subsubsection{*For @{text combine_numerals}*}
+
+lemma left_add_mult_distrib: "i*u + (j*u + k) = (i+j)*u + (k::nat)"
+by (simp add: add_mult_distrib)
+
+
+subsubsection{*For @{text cancel_numerals}*}
+
+lemma nat_diff_add_eq1:
+     "j <= (i::nat) ==> ((i*u + m) - (j*u + n)) = (((i-j)*u + m) - n)"
+by (simp split add: nat_diff_split add: add_mult_distrib)
+
+lemma nat_diff_add_eq2:
+     "i <= (j::nat) ==> ((i*u + m) - (j*u + n)) = (m - ((j-i)*u + n))"
+by (simp split add: nat_diff_split add: add_mult_distrib)
+
+lemma nat_eq_add_iff1:
+     "j <= (i::nat) ==> (i*u + m = j*u + n) = ((i-j)*u + m = n)"
+by (auto split add: nat_diff_split simp add: add_mult_distrib)
+
+lemma nat_eq_add_iff2:
+     "i <= (j::nat) ==> (i*u + m = j*u + n) = (m = (j-i)*u + n)"
+by (auto split add: nat_diff_split simp add: add_mult_distrib)
+
+lemma nat_less_add_iff1:
+     "j <= (i::nat) ==> (i*u + m < j*u + n) = ((i-j)*u + m < n)"
+by (auto split add: nat_diff_split simp add: add_mult_distrib)
+
+lemma nat_less_add_iff2:
+     "i <= (j::nat) ==> (i*u + m < j*u + n) = (m < (j-i)*u + n)"
+by (auto split add: nat_diff_split simp add: add_mult_distrib)
+
+lemma nat_le_add_iff1:
+     "j <= (i::nat) ==> (i*u + m <= j*u + n) = ((i-j)*u + m <= n)"
+by (auto split add: nat_diff_split simp add: add_mult_distrib)
+
+lemma nat_le_add_iff2:
+     "i <= (j::nat) ==> (i*u + m <= j*u + n) = (m <= (j-i)*u + n)"
+by (auto split add: nat_diff_split simp add: add_mult_distrib)
+
+
+subsubsection{*For @{text cancel_numeral_factors} *}
+
+lemma nat_mult_le_cancel1: "(0::nat) < k ==> (k*m <= k*n) = (m<=n)"
+by auto
+
+lemma nat_mult_less_cancel1: "(0::nat) < k ==> (k*m < k*n) = (m<n)"
+by auto
+
+lemma nat_mult_eq_cancel1: "(0::nat) < k ==> (k*m = k*n) = (m=n)"
+by auto
+
+lemma nat_mult_div_cancel1: "(0::nat) < k ==> (k*m) div (k*n) = (m div n)"
+by auto
+
+lemma nat_mult_dvd_cancel_disj[simp]:
+  "(k*m) dvd (k*n) = (k=0 | m dvd (n::nat))"
+by(auto simp: dvd_eq_mod_eq_0 mod_mult_distrib2[symmetric])
+
+lemma nat_mult_dvd_cancel1: "0 < k \<Longrightarrow> (k*m) dvd (k*n::nat) = (m dvd n)"
+by(auto)
+
+
+subsubsection{*For @{text cancel_factor} *}
+
+lemma nat_mult_le_cancel_disj: "(k*m <= k*n) = ((0::nat) < k --> m<=n)"
+by auto
+
+lemma nat_mult_less_cancel_disj: "(k*m < k*n) = ((0::nat) < k & m<n)"
+by auto
+
+lemma nat_mult_eq_cancel_disj: "(k*m = k*n) = (k = (0::nat) | m=n)"
+by auto
+
+lemma nat_mult_div_cancel_disj[simp]:
+     "(k*m) div (k*n) = (if k = (0::nat) then 0 else m div n)"
+by (simp add: nat_mult_div_cancel1)
+
+
+subsection {* Simprocs for the Naturals *}
+
+use "Tools/nat_numeral_simprocs.ML"
+
+declaration {* 
+  K (Lin_Arith.add_simps (@{thms neg_simps} @ [@{thm Suc_nat_number_of}, @{thm int_nat_number_of}])
+  #> Lin_Arith.add_simps (@{thms ring_distribs} @ [@{thm Let_number_of}, @{thm Let_0}, @{thm Let_1},
+     @{thm nat_0}, @{thm nat_1},
+     @{thm add_nat_number_of}, @{thm diff_nat_number_of}, @{thm mult_nat_number_of},
+     @{thm eq_nat_number_of}, @{thm less_nat_number_of}, @{thm le_number_of_eq_not_less},
+     @{thm le_Suc_number_of}, @{thm le_number_of_Suc},
+     @{thm less_Suc_number_of}, @{thm less_number_of_Suc},
+     @{thm Suc_eq_number_of}, @{thm eq_number_of_Suc},
+     @{thm mult_Suc}, @{thm mult_Suc_right},
+     @{thm add_Suc}, @{thm add_Suc_right},
+     @{thm eq_number_of_0}, @{thm eq_0_number_of}, @{thm less_0_number_of},
+     @{thm of_int_number_of_eq}, @{thm of_nat_number_of_eq}, @{thm nat_number_of},
+     @{thm if_True}, @{thm if_False}])
+  #> Lin_Arith.add_simprocs (Nat_Numeral_Simprocs.combine_numerals :: Nat_Numeral_Simprocs.cancel_numerals))
+*}
+
+
+subsubsection{*For simplifying @{term "Suc m - K"} and  @{term "K - Suc m"}*}
+
+text{*Where K above is a literal*}
+
+lemma Suc_diff_eq_diff_pred: "Numeral0 < n ==> Suc m - n = m - (n - Numeral1)"
+by (simp add: numeral_0_eq_0 numeral_1_eq_1 split add: nat_diff_split)
+
+text {*Now just instantiating @{text n} to @{text "number_of v"} does
+  the right simplification, but with some redundant inequality
+  tests.*}
+lemma neg_number_of_pred_iff_0:
+  "neg (number_of (Int.pred v)::int) = (number_of v = (0::nat))"
+apply (subgoal_tac "neg (number_of (Int.pred v)) = (number_of v < Suc 0) ")
+apply (simp only: less_Suc_eq_le le_0_eq)
+apply (subst less_number_of_Suc, simp)
+done
+
+text{*No longer required as a simprule because of the @{text inverse_fold}
+   simproc*}
+lemma Suc_diff_number_of:
+     "Int.Pls < v ==>
+      Suc m - (number_of v) = m - (number_of (Int.pred v))"
+apply (subst Suc_diff_eq_diff_pred)
+apply simp
+apply (simp del: nat_numeral_1_eq_1)
+apply (auto simp only: diff_nat_number_of less_0_number_of [symmetric]
+                        neg_number_of_pred_iff_0)
+done
+
+lemma diff_Suc_eq_diff_pred: "m - Suc n = (m - 1) - n"
+by (simp add: numerals split add: nat_diff_split)
+
+
+subsubsection{*For @{term nat_case} and @{term nat_rec}*}
+
+lemma nat_case_number_of [simp]:
+     "nat_case a f (number_of v) =
+        (let pv = number_of (Int.pred v) in
+         if neg pv then a else f (nat pv))"
+by (simp split add: nat.split add: Let_def neg_number_of_pred_iff_0)
+
+lemma nat_case_add_eq_if [simp]:
+     "nat_case a f ((number_of v) + n) =
+       (let pv = number_of (Int.pred v) in
+         if neg pv then nat_case a f n else f (nat pv + n))"
+apply (subst add_eq_if)
+apply (simp split add: nat.split
+            del: nat_numeral_1_eq_1
+            add: nat_numeral_1_eq_1 [symmetric]
+                 numeral_1_eq_Suc_0 [symmetric]
+                 neg_number_of_pred_iff_0)
+done
+
+lemma nat_rec_number_of [simp]:
+     "nat_rec a f (number_of v) =
+        (let pv = number_of (Int.pred v) in
+         if neg pv then a else f (nat pv) (nat_rec a f (nat pv)))"
+apply (case_tac " (number_of v) ::nat")
+apply (simp_all (no_asm_simp) add: Let_def neg_number_of_pred_iff_0)
+apply (simp split add: split_if_asm)
+done
+
+lemma nat_rec_add_eq_if [simp]:
+     "nat_rec a f (number_of v + n) =
+        (let pv = number_of (Int.pred v) in
+         if neg pv then nat_rec a f n
+                   else f (nat pv + n) (nat_rec a f (nat pv + n)))"
+apply (subst add_eq_if)
+apply (simp split add: nat.split
+            del: nat_numeral_1_eq_1
+            add: nat_numeral_1_eq_1 [symmetric]
+                 numeral_1_eq_Suc_0 [symmetric]
+                 neg_number_of_pred_iff_0)
+done
+
+
+subsubsection{*Various Other Lemmas*}
+
+lemma card_UNIV_bool[simp]: "card (UNIV :: bool set) = 2"
+by(simp add: UNIV_bool)
+
+text {*Evens and Odds, for Mutilated Chess Board*}
+
+text{*Lemmas for specialist use, NOT as default simprules*}
+lemma nat_mult_2: "2 * z = (z+z::nat)"
+proof -
+  have "2*z = (1 + 1)*z" by simp
+  also have "... = z+z" by (simp add: left_distrib)
+  finally show ?thesis .
+qed
+
+lemma nat_mult_2_right: "z * 2 = (z+z::nat)"
+by (subst mult_commute, rule nat_mult_2)
+
+text{*Case analysis on @{term "n<2"}*}
+lemma less_2_cases: "(n::nat) < 2 ==> n = 0 | n = Suc 0"
+by arith
+
+lemma div2_Suc_Suc [simp]: "Suc(Suc m) div 2 = Suc (m div 2)"
+by arith
+
+lemma add_self_div_2 [simp]: "(m + m) div 2 = (m::nat)"
+by (simp add: nat_mult_2 [symmetric])
+
+lemma mod2_Suc_Suc [simp]: "Suc(Suc(m)) mod 2 = m mod 2"
+apply (subgoal_tac "m mod 2 < 2")
+apply (erule less_2_cases [THEN disjE])
+apply (simp_all (no_asm_simp) add: Let_def mod_Suc nat_1)
+done
+
+lemma mod2_gr_0 [simp]: "!!m::nat. (0 < m mod 2) = (m mod 2 = 1)"
+apply (subgoal_tac "m mod 2 < 2")
+apply (force simp del: mod_less_divisor, simp)
+done
+
+text{*Removal of Small Numerals: 0, 1 and (in additive positions) 2*}
+
+lemma add_2_eq_Suc [simp]: "2 + n = Suc (Suc n)"
+by simp
+
+lemma add_2_eq_Suc' [simp]: "n + 2 = Suc (Suc n)"
+by simp
+
+text{*Can be used to eliminate long strings of Sucs, but not by default*}
+lemma Suc3_eq_add_3: "Suc (Suc (Suc n)) = 3 + n"
+by simp
+
+
+text{*These lemmas collapse some needless occurrences of Suc:
+    at least three Sucs, since two and fewer are rewritten back to Suc again!
+    We already have some rules to simplify operands smaller than 3.*}
+
+lemma div_Suc_eq_div_add3 [simp]: "m div (Suc (Suc (Suc n))) = m div (3+n)"
+by (simp add: Suc3_eq_add_3)
+
+lemma mod_Suc_eq_mod_add3 [simp]: "m mod (Suc (Suc (Suc n))) = m mod (3+n)"
+by (simp add: Suc3_eq_add_3)
+
+lemma Suc_div_eq_add3_div: "(Suc (Suc (Suc m))) div n = (3+m) div n"
+by (simp add: Suc3_eq_add_3)
+
+lemma Suc_mod_eq_add3_mod: "(Suc (Suc (Suc m))) mod n = (3+m) mod n"
+by (simp add: Suc3_eq_add_3)
+
+lemmas Suc_div_eq_add3_div_number_of =
+    Suc_div_eq_add3_div [of _ "number_of v", standard]
+declare Suc_div_eq_add3_div_number_of [simp]
+
+lemmas Suc_mod_eq_add3_mod_number_of =
+    Suc_mod_eq_add3_mod [of _ "number_of v", standard]
+declare Suc_mod_eq_add3_mod_number_of [simp]
+
+end

--- a/src/HOL/Nominal/Examples/Fsub.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Nominal/Examples/Fsub.thy	Fri May 15 15:56:28 2009 +0200
@@ -245,7 +245,7 @@
   apply (simp add: dj_perm_forget[OF dj_tyvrs_vrs])
   done
 
-lemma ty_vrs_fresh[fresh]:
+lemma ty_vrs_fresh:
   fixes x::"vrs"
   and   T::"ty"
   shows "x \<sharp> T"
@@ -422,7 +422,7 @@
   by (nominal_induct T avoiding: X T' rule: ty.strong_induct)
      (perm_simp add: fresh_left)+
 
-lemma type_subst_fresh[fresh]:
+lemma type_subst_fresh:
   fixes X::"tyvrs"
   assumes "X \<sharp> T" and "X \<sharp> P"
   shows   "X \<sharp> T[Y \<mapsto> P]\<^sub>\<tau>"
@@ -430,7 +430,7 @@
 by (nominal_induct T avoiding: X Y P rule:ty.strong_induct)
    (auto simp add: abs_fresh)
 
-lemma fresh_type_subst_fresh[fresh]:
+lemma fresh_type_subst_fresh:
     assumes "X\<sharp>T'"
     shows "X\<sharp>T[X \<mapsto> T']\<^sub>\<tau>"
 using assms 
@@ -458,18 +458,19 @@
 | "(VarB  X U)[Y \<mapsto> T]\<^sub>b =  VarB X (U[Y \<mapsto> T]\<^sub>\<tau>)"
 by auto
 
-lemma binding_subst_fresh[fresh]:
+lemma binding_subst_fresh:
   fixes X::"tyvrs"
   assumes "X \<sharp> a"
   and     "X \<sharp> P"
   shows "X \<sharp> a[Y \<mapsto> P]\<^sub>b"
 using assms
-by (nominal_induct a rule:binding.strong_induct)
-   (auto simp add: freshs)
+by (nominal_induct a rule: binding.strong_induct)
+   (auto simp add: type_subst_fresh)
 
-lemma binding_subst_identity: "X \<sharp> B \<Longrightarrow> B[X \<mapsto> U]\<^sub>b = B"
-  by (induct B rule: binding.induct)
-    (simp_all add: fresh_atm type_subst_identity)
+lemma binding_subst_identity: 
+  shows "X \<sharp> B \<Longrightarrow> B[X \<mapsto> U]\<^sub>b = B"
+by (induct B rule: binding.induct)
+   (simp_all add: fresh_atm type_subst_identity)
 
 consts 
   subst_tyc :: "env \<Rightarrow> tyvrs \<Rightarrow> ty \<Rightarrow> env" ("_[_ \<mapsto> _]\<^sub>e" [100,100,100] 100)
@@ -478,14 +479,14 @@
 "([])[Y \<mapsto> T]\<^sub>e= []"
 "(B#\<Gamma>)[Y \<mapsto> T]\<^sub>e = (B[Y \<mapsto> T]\<^sub>b)#(\<Gamma>[Y \<mapsto> T]\<^sub>e)"
 
-lemma ctxt_subst_fresh'[fresh]:
+lemma ctxt_subst_fresh':
   fixes X::"tyvrs"
   assumes "X \<sharp> \<Gamma>"
   and     "X \<sharp> P"
   shows   "X \<sharp> \<Gamma>[Y \<mapsto> P]\<^sub>e"
 using assms
 by (induct \<Gamma>)
-   (auto simp add: fresh_list_cons freshs)
+   (auto simp add: fresh_list_cons binding_subst_fresh)
 
 lemma ctxt_subst_mem_TVarB: "TVarB X T \<in> set \<Gamma> \<Longrightarrow> TVarB X (T[Y \<mapsto> U]\<^sub>\<tau>) \<in> set (\<Gamma>[Y \<mapsto> U]\<^sub>e)"
   by (induct \<Gamma>) auto
@@ -1188,8 +1189,8 @@
 using assms by (induct, auto)
 
 nominal_inductive typing
-  by (auto dest!: typing_ok intro: closed_in_fresh fresh_domain
-    simp: abs_fresh fresh_prod fresh_atm freshs valid_ty_domain_fresh fresh_trm_domain)
+by (auto dest!: typing_ok intro: closed_in_fresh fresh_domain type_subst_fresh
+    simp: abs_fresh fresh_type_subst_fresh ty_vrs_fresh valid_ty_domain_fresh fresh_trm_domain)
 
 lemma ok_imp_VarB_closed_in:
   assumes ok: "\<turnstile> \<Gamma> ok"

--- a/src/HOL/Nominal/Nominal.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Nominal/Nominal.thy	Fri May 15 15:56:28 2009 +0200
@@ -18,25 +18,98 @@
 types 
   'x prm = "('x \<times> 'x) list"
 
-(* polymorphic operations for permutation and swapping *)
+(* polymorphic constants for permutation and swapping *)
 consts 
   perm :: "'x prm \<Rightarrow> 'a \<Rightarrow> 'a"     (infixr "\<bullet>" 80)
   swap :: "('x \<times> 'x) \<Rightarrow> 'x \<Rightarrow> 'x"
 
+(* a "private" copy of the option type used in the abstraction function *)
+datatype 'a noption = nSome 'a | nNone
+
+(* a "private" copy of the product type used in the nominal induct method *)
+datatype ('a,'b) nprod = nPair 'a 'b
+
 (* an auxiliary constant for the decision procedure involving *) 
-(* permutations (to avoid loops when using perm-composition)  *)
+(* permutations (to avoid loops when using perm-compositions)  *)
 constdefs
   "perm_aux pi x \<equiv> pi\<bullet>x"
 
-(* permutation on functions *)
-defs (unchecked overloaded)
-  perm_fun_def: "pi\<bullet>(f::'a\<Rightarrow>'b) \<equiv> (\<lambda>x. pi\<bullet>f((rev pi)\<bullet>x))"
-
-(* permutation on bools *)
-primrec (unchecked perm_bool)
-  true_eqvt:  "pi\<bullet>True  = True"
-  false_eqvt: "pi\<bullet>False = False"
-
+(* overloaded permutation operations *)
+overloading
+  perm_fun    \<equiv> "perm :: 'x prm \<Rightarrow> ('a\<Rightarrow>'b) \<Rightarrow> ('a\<Rightarrow>'b)"   (unchecked)
+  perm_bool   \<equiv> "perm :: 'x prm \<Rightarrow> bool \<Rightarrow> bool"           (unchecked)
+  perm_unit   \<equiv> "perm :: 'x prm \<Rightarrow> unit \<Rightarrow> unit"           (unchecked)
+  perm_prod   \<equiv> "perm :: 'x prm \<Rightarrow> ('a\<times>'b) \<Rightarrow> ('a\<times>'b)"     (unchecked)
+  perm_list   \<equiv> "perm :: 'x prm \<Rightarrow> 'a list \<Rightarrow> 'a list"     (unchecked)
+  perm_option \<equiv> "perm :: 'x prm \<Rightarrow> 'a option \<Rightarrow> 'a option" (unchecked)
+  perm_char   \<equiv> "perm :: 'x prm \<Rightarrow> char \<Rightarrow> char"           (unchecked)
+  perm_nat    \<equiv> "perm :: 'x prm \<Rightarrow> nat \<Rightarrow> nat"             (unchecked)
+  perm_int    \<equiv> "perm :: 'x prm \<Rightarrow> int \<Rightarrow> int"             (unchecked)
+
+  perm_noption \<equiv> "perm :: 'x prm \<Rightarrow> 'a noption \<Rightarrow> 'a noption"   (unchecked)
+  perm_nprod   \<equiv> "perm :: 'x prm \<Rightarrow> ('a, 'b) nprod \<Rightarrow> ('a, 'b) nprod" (unchecked)
+begin
+
+definition
+  perm_fun_def: "perm_fun pi (f::'a\<Rightarrow>'b) \<equiv> (\<lambda>x. pi\<bullet>f((rev pi)\<bullet>x))"
+
+fun
+  perm_bool :: "'x prm \<Rightarrow> bool \<Rightarrow> bool"
+where
+  true_eqvt:  "perm_bool pi True  = True"
+| false_eqvt: "perm_bool pi False = False"
+
+fun
+  perm_unit :: "'x prm \<Rightarrow> unit \<Rightarrow> unit" 
+where 
+  "perm_unit pi () = ()"
+  
+fun
+  perm_prod :: "'x prm \<Rightarrow> ('a\<times>'b) \<Rightarrow> ('a\<times>'b)"
+where
+  "perm_prod pi (x,y) = (pi\<bullet>x,pi\<bullet>y)"
+
+fun
+  perm_list :: "'x prm \<Rightarrow> 'a list \<Rightarrow> 'a list"
+where
+  nil_eqvt:  "perm_list pi []     = []"
+| cons_eqvt: "perm_list pi (x#xs) = (pi\<bullet>x)#(pi\<bullet>xs)"
+
+fun
+  perm_option :: "'x prm \<Rightarrow> 'a option \<Rightarrow> 'a option"
+where
+  some_eqvt:  "perm_option pi (Some x) = Some (pi\<bullet>x)"
+| none_eqvt:  "perm_option pi None     = None"
+
+definition
+  perm_char :: "'x prm \<Rightarrow> char \<Rightarrow> char"
+where
+  perm_char_def: "perm_char pi c \<equiv> c"
+
+definition
+  perm_nat :: "'x prm \<Rightarrow> nat \<Rightarrow> nat"
+where
+  perm_nat_def: "perm_nat pi i \<equiv> i"
+
+definition
+  perm_int :: "'x prm \<Rightarrow> int \<Rightarrow> int"
+where
+  perm_int_def: "perm_int pi i \<equiv> i"
+
+fun
+  perm_noption :: "'x prm \<Rightarrow> 'a noption \<Rightarrow> 'a noption"
+where
+  nsome_eqvt:  "perm_noption pi (nSome x) = nSome (pi\<bullet>x)"
+| nnone_eqvt:  "perm_noption pi nNone     = nNone"
+
+fun
+  perm_nprod :: "'x prm \<Rightarrow> ('a, 'b) nprod \<Rightarrow> ('a, 'b) nprod"
+where
+  "perm_nprod pi (nPair x y) = nPair (pi\<bullet>x) (pi\<bullet>y)"
+end
+
+
+(* permutations on booleans *)
 lemma perm_bool:
   shows "pi\<bullet>(b::bool) = b"
   by (cases b) auto
@@ -54,8 +127,7 @@
 lemma if_eqvt:
   fixes pi::"'a prm"
   shows "pi\<bullet>(if b then c1 else c2) = (if (pi\<bullet>b) then (pi\<bullet>c1) else (pi\<bullet>c2))"
-apply(simp add: perm_fun_def)
-done
+  by (simp add: perm_fun_def)
 
 lemma imp_eqvt:
   shows "pi\<bullet>(A\<longrightarrow>B) = ((pi\<bullet>A)\<longrightarrow>(pi\<bullet>B))"
@@ -82,13 +154,7 @@
   shows "(pi\<bullet>(X\<union>Y)) = (pi\<bullet>X) \<union> (pi\<bullet>Y)"
   by (simp add: perm_fun_def perm_bool Un_iff [unfolded mem_def] expand_fun_eq)
 
-(* permutation on units and products *)
-primrec (unchecked perm_unit)
-  "pi\<bullet>() = ()"
-  
-primrec (unchecked perm_prod)
-  "pi\<bullet>(x,y) = (pi\<bullet>x,pi\<bullet>y)"
-
+(* permutations on products *)
 lemma fst_eqvt:
   "pi\<bullet>(fst x) = fst (pi\<bullet>x)"
  by (cases x) simp
@@ -98,10 +164,6 @@
  by (cases x) simp
 
 (* permutation on lists *)
-primrec (unchecked perm_list)
-  nil_eqvt:  "pi\<bullet>[]     = []"
-  cons_eqvt: "pi\<bullet>(x#xs) = (pi\<bullet>x)#(pi\<bullet>xs)"
-
 lemma append_eqvt:
   fixes pi :: "'x prm"
   and   l1 :: "'a list"
@@ -115,41 +177,12 @@
   shows "pi\<bullet>(rev l) = rev (pi\<bullet>l)"
   by (induct l) (simp_all add: append_eqvt)
 
-(* permutation on options *)
-
-primrec (unchecked perm_option)
-  some_eqvt:  "pi\<bullet>Some(x) = Some(pi\<bullet>x)"
-  none_eqvt:  "pi\<bullet>None    = None"
-
-(* a "private" copy of the option type used in the abstraction function *)
-datatype 'a noption = nSome 'a | nNone
-
-primrec (unchecked perm_noption)
-  nSome_eqvt: "pi\<bullet>nSome(x) = nSome(pi\<bullet>x)"
-  nNone_eqvt: "pi\<bullet>nNone    = nNone"
-
-(* a "private" copy of the product type used in the nominal induct method *)
-datatype ('a,'b) nprod = nPair 'a 'b
-
-primrec (unchecked perm_nprod)
-  perm_nProd_def: "pi\<bullet>(nPair x1 x2)  = nPair (pi\<bullet>x1) (pi\<bullet>x2)"
-
-(* permutation on characters (used in strings) *)
-defs (unchecked overloaded)
-  perm_char_def: "pi\<bullet>(c::char) \<equiv> c"
-
+(* permutation on characters and strings *)
 lemma perm_string:
   fixes s::"string"
   shows "pi\<bullet>s = s"
-by (induct s)(auto simp add: perm_char_def)
-
-(* permutation on ints *)
-defs (unchecked overloaded)
-  perm_int_def:    "pi\<bullet>(i::int) \<equiv> i"
-
-(* permutation on nats *)
-defs (unchecked overloaded)
-  perm_nat_def:    "pi\<bullet>(i::nat) \<equiv> i"
+  by (induct s)(auto simp add: perm_char_def)
+
 
 section {* permutation equality *}
 (*==============================*)
@@ -170,11 +203,12 @@
    supports :: "'x set \<Rightarrow> 'a \<Rightarrow> bool" (infixl "supports" 80)
    "S supports x \<equiv> \<forall>a b. (a\<notin>S \<and> b\<notin>S \<longrightarrow> [(a,b)]\<bullet>x=x)"
 
+(* lemmas about supp *)
 lemma supp_fresh_iff: 
   fixes x :: "'a"
   shows "(supp x) = {a::'x. \<not>a\<sharp>x}"
-apply(simp add: fresh_def)
-done
+  by (simp add: fresh_def)
+
 
 lemma supp_unit:
   shows "supp () = {}"
@@ -205,14 +239,13 @@
   fixes x  :: "'a"
   and   xs :: "'a list"
   shows "supp (x#xs) = (supp x)\<union>(supp xs)"
-apply(auto simp add: supp_def Collect_imp_eq Collect_neg_eq)
-done
+  by (auto simp add: supp_def Collect_imp_eq Collect_neg_eq)
 
 lemma supp_list_append:
   fixes xs :: "'a list"
   and   ys :: "'a list"
   shows "supp (xs@ys) = (supp xs)\<union>(supp ys)"
-  by (induct xs, auto simp add: supp_list_nil supp_list_cons)
+  by (induct xs) (auto simp add: supp_list_nil supp_list_cons)
 
 lemma supp_list_rev:
   fixes xs :: "'a list"
@@ -221,47 +254,40 @@
 
 lemma supp_bool:
   fixes x  :: "bool"
-  shows "supp (x) = {}"
-  apply(case_tac "x")
-  apply(simp_all add: supp_def)
-done
+  shows "supp x = {}"
+  by (cases "x") (simp_all add: supp_def)
 
 lemma supp_some:
   fixes x :: "'a"
   shows "supp (Some x) = (supp x)"
-  apply(simp add: supp_def)
-  done
+  by (simp add: supp_def)
 
 lemma supp_none:
   fixes x :: "'a"
   shows "supp (None) = {}"
-  apply(simp add: supp_def)
-  done
+  by (simp add: supp_def)
 
 lemma supp_int:
   fixes i::"int"
   shows "supp (i) = {}"
-  apply(simp add: supp_def perm_int_def)
-  done
+  by (simp add: supp_def perm_int_def)
 
 lemma supp_nat:
   fixes n::"nat"
-  shows "supp (n) = {}"
-  apply(simp add: supp_def perm_nat_def)
-  done
+  shows "(supp n) = {}"
+  by (simp add: supp_def perm_nat_def)
 
 lemma supp_char:
   fixes c::"char"
-  shows "supp (c) = {}"
-  apply(simp add: supp_def perm_char_def)
-  done
+  shows "(supp c) = {}"
+  by (simp add: supp_def perm_char_def)
   
 lemma supp_string:
   fixes s::"string"
-  shows "supp (s) = {}"
-apply(simp add: supp_def perm_string)
-done
-
+  shows "(supp s) = {}"
+  by (simp add: supp_def perm_string)
+
+(* lemmas about freshness *)
 lemma fresh_set_empty:
   shows "a\<sharp>{}"
   by (simp add: fresh_def supp_set_empty)
@@ -344,7 +370,6 @@
   by (simp add: fresh_def supp_bool)
 
 text {* Normalization of freshness results; cf.\ @{text nominal_induct} *}
-
 lemma fresh_unit_elim: 
   shows "(a\<sharp>() \<Longrightarrow> PROP C) \<equiv> PROP C"
   by (simp add: fresh_def supp_unit)
@@ -371,63 +396,6 @@
   Simplifier.map_ss (fn ss => ss setmksimps (mksimps mksimps_pairs))
 *}
 
-section {* generalisation of freshness to lists and sets of atoms *}
-(*================================================================*)
- 
-consts
-  fresh_star :: "'b \<Rightarrow> 'a \<Rightarrow> bool" ("_ \<sharp>* _" [100,100] 100)
-
-defs (overloaded)
-  fresh_star_set: "xs\<sharp>*c \<equiv> \<forall>x\<in>xs. x\<sharp>c"
-
-defs (overloaded)
-  fresh_star_list: "xs\<sharp>*c \<equiv> \<forall>x\<in>set xs. x\<sharp>c"
-
-lemmas fresh_star_def = fresh_star_list fresh_star_set
-
-lemma fresh_star_prod_set:
-  fixes xs::"'a set"
-  shows "xs\<sharp>*(a,b) = (xs\<sharp>*a \<and> xs\<sharp>*b)"
-by (auto simp add: fresh_star_def fresh_prod)
-
-lemma fresh_star_prod_list:
-  fixes xs::"'a list"
-  shows "xs\<sharp>*(a,b) = (xs\<sharp>*a \<and> xs\<sharp>*b)"
-by (auto simp add: fresh_star_def fresh_prod)
-
-lemmas fresh_star_prod = fresh_star_prod_list fresh_star_prod_set
-
-lemma fresh_star_set_eq: "set xs \<sharp>* c = xs \<sharp>* c"
-  by (simp add: fresh_star_def)
-
-lemma fresh_star_Un_elim:
-  "((S \<union> T) \<sharp>* c \<Longrightarrow> PROP C) \<equiv> (S \<sharp>* c \<Longrightarrow> T \<sharp>* c \<Longrightarrow> PROP C)"
-  apply rule
-  apply (simp_all add: fresh_star_def)
-  apply (erule meta_mp)
-  apply blast
-  done
-
-lemma fresh_star_insert_elim:
-  "(insert x S \<sharp>* c \<Longrightarrow> PROP C) \<equiv> (x \<sharp> c \<Longrightarrow> S \<sharp>* c \<Longrightarrow> PROP C)"
-  by rule (simp_all add: fresh_star_def)
-
-lemma fresh_star_empty_elim:
-  "({} \<sharp>* c \<Longrightarrow> PROP C) \<equiv> PROP C"
-  by (simp add: fresh_star_def)
-
-text {* Normalization of freshness results; cf.\ @{text nominal_induct} *}
-
-lemma fresh_star_unit_elim: 
-  shows "((a::'a set)\<sharp>*() \<Longrightarrow> PROP C) \<equiv> PROP C"
-  and "((b::'a list)\<sharp>*() \<Longrightarrow> PROP C) \<equiv> PROP C"
-  by (simp_all add: fresh_star_def fresh_def supp_unit)
-
-lemma fresh_star_prod_elim: 
-  shows "((a::'a set)\<sharp>*(x,y) \<Longrightarrow> PROP C) \<equiv> (a\<sharp>*x \<Longrightarrow> a\<sharp>*y \<Longrightarrow> PROP C)"
-  and "((b::'a list)\<sharp>*(x,y) \<Longrightarrow> PROP C) \<equiv> (b\<sharp>*x \<Longrightarrow> b\<sharp>*y \<Longrightarrow> PROP C)"
-  by (rule, simp_all add: fresh_star_prod)+
-
 section {* Abstract Properties for Permutations and  Atoms *}
 (*=========================================================*)
 
@@ -487,7 +455,7 @@
   shows "swap (a,b) c = (if a=c then b else (if b=c then a else c))"
   using a by (simp only: at_def)
 
-(* rules to calculate simple premutations *)
+(* rules to calculate simple permutations *)
 lemmas at_calc = at2 at1 at3
 
 lemma at_swap_simps:
@@ -682,7 +650,6 @@
   shows "pi1 \<triangleq> pi2 \<Longrightarrow> (rev pi1) \<triangleq> (rev pi2)"
   by (simp add: at_prm_rev_eq[OF at])
 
-
 lemma at_ds1:
   fixes a  :: "'x"
   assumes at: "at TYPE('x)"
@@ -838,15 +805,18 @@
   by (auto intro: ex_in_inf[OF at, OF fs] simp add: fresh_def)
 
 lemma at_finite_select: 
-  shows "at (TYPE('a)) \<Longrightarrow> finite (S::'a set) \<Longrightarrow> \<exists>x. x \<notin> S"
-  apply (drule Diff_infinite_finite)
-  apply (simp add: at_def)
-  apply blast
-  apply (subgoal_tac "UNIV - S \<noteq> {}")
-  apply (simp only: ex_in_conv [symmetric])
-  apply blast
-  apply (rule notI)
-  apply simp
+  fixes S::"'a set"
+  assumes a: "at TYPE('a)"
+  and     b: "finite S" 
+  shows "\<exists>x. x \<notin> S" 
+  using a b
+  apply(drule_tac S="UNIV::'a set" in Diff_infinite_finite)
+  apply(simp add: at_def)
+  apply(subgoal_tac "UNIV - S \<noteq> {}")
+  apply(simp only: ex_in_conv [symmetric])
+  apply(blast)
+  apply(rule notI)
+  apply(simp)
   done
 
 lemma at_different:
@@ -1222,8 +1192,8 @@
   assumes pt: "pt TYPE('a) TYPE('x)"
   and     at: "at TYPE('x)"
   shows "pi\<bullet>(x=y) = (pi\<bullet>x = pi\<bullet>y)"
-using assms
-by (auto simp add: pt_bij perm_bool)
+  using pt at
+  by (auto simp add: pt_bij perm_bool)
 
 lemma pt_bij3:
   fixes pi :: "'x prm"
@@ -1231,7 +1201,7 @@
   and   y  :: "'a"
   assumes a:  "x=y"
   shows "(pi\<bullet>x = pi\<bullet>y)"
-using a by simp 
+  using a by simp 
 
 lemma pt_bij4:
   fixes pi :: "'x prm"
@@ -1241,7 +1211,7 @@
   and     at: "at TYPE('x)"
   and     a:  "pi\<bullet>x = pi\<bullet>y"
   shows "x = y"
-using a by (simp add: pt_bij[OF pt, OF at])
+  using a by (simp add: pt_bij[OF pt, OF at])
 
 lemma pt_swap_bij:
   fixes a  :: "'x"
@@ -1574,35 +1544,6 @@
 apply(simp add: pt_rev_pi[OF ptb, OF at])
 done
 
-lemma pt_fresh_star_bij_ineq:
-  fixes  pi :: "'x prm"
-  and     x :: "'a"
-  and     a :: "'y set"
-  and     b :: "'y list"
-  assumes pta: "pt TYPE('a) TYPE('x)"
-  and     ptb: "pt TYPE('y) TYPE('x)"
-  and     at:  "at TYPE('x)"
-  and     cp:  "cp TYPE('a) TYPE('x) TYPE('y)"
-  shows "(pi\<bullet>a)\<sharp>*(pi\<bullet>x) = a\<sharp>*x"
-  and   "(pi\<bullet>b)\<sharp>*(pi\<bullet>x) = b\<sharp>*x"
-apply(unfold fresh_star_def)
-apply(auto)
-apply(drule_tac x="pi\<bullet>xa" in bspec)
-apply(rule pt_set_bij2[OF ptb, OF at])
-apply(assumption)
-apply(simp add: fresh_star_def pt_fresh_bij_ineq[OF pta, OF ptb, OF at, OF cp])
-apply(drule_tac x="(rev pi)\<bullet>xa" in bspec)
-apply(simp add: pt_set_bij1[OF ptb, OF at])
-apply(simp add: pt_fresh_left_ineq[OF pta, OF ptb, OF at, OF cp])
-apply(drule_tac x="pi\<bullet>xa" in bspec)
-apply(simp add: pt_set_bij1[OF ptb, OF at])
-apply(simp add: pt_set_eqvt [OF ptb at] pt_rev_pi[OF pt_list_inst[OF ptb], OF at])
-apply(simp add: pt_fresh_bij_ineq[OF pta, OF ptb, OF at, OF cp])
-apply(drule_tac x="(rev pi)\<bullet>xa" in bspec)
-apply(simp add: pt_set_bij1[OF ptb, OF at] pt_set_eqvt [OF ptb at])
-apply(simp add: pt_fresh_left_ineq[OF pta, OF ptb, OF at, OF cp])
-done
-
 lemma pt_fresh_left:  
   fixes  pi :: "'x prm"
   and     x :: "'a"
@@ -1651,56 +1592,6 @@
 apply(rule at)
 done
 
-lemma pt_fresh_star_bij:
-  fixes  pi :: "'x prm"
-  and     x :: "'a"
-  and     a :: "'x set"
-  and     b :: "'x list"
-  assumes pt: "pt TYPE('a) TYPE('x)"
-  and     at: "at TYPE('x)"
-  shows "(pi\<bullet>a)\<sharp>*(pi\<bullet>x) = a\<sharp>*x"
-  and   "(pi\<bullet>b)\<sharp>*(pi\<bullet>x) = b\<sharp>*x"
-apply(rule pt_fresh_star_bij_ineq(1))
-apply(rule pt)
-apply(rule at_pt_inst)
-apply(rule at)+
-apply(rule cp_pt_inst)
-apply(rule pt)
-apply(rule at)
-apply(rule pt_fresh_star_bij_ineq(2))
-apply(rule pt)
-apply(rule at_pt_inst)
-apply(rule at)+
-apply(rule cp_pt_inst)
-apply(rule pt)
-apply(rule at)
-done
-
-lemma pt_fresh_star_eqvt:
-  fixes  pi :: "'x prm"
-  and     x :: "'a"
-  and     a :: "'x set"
-  and     b :: "'x list"
-  assumes pt: "pt TYPE('a) TYPE('x)"
-  and     at: "at TYPE('x)"
-  shows "pi\<bullet>(a\<sharp>*x) = (pi\<bullet>a)\<sharp>*(pi\<bullet>x)"
-  and   "pi\<bullet>(b\<sharp>*x) = (pi\<bullet>b)\<sharp>*(pi\<bullet>x)"
-  by (simp_all add: perm_bool pt_fresh_star_bij[OF pt, OF at])
-
-lemma pt_fresh_star_eqvt_ineq:
-  fixes pi::"'x prm"
-  and   a::"'y set"
-  and   b::"'y list"
-  and   x::"'a"
-  assumes pta: "pt TYPE('a) TYPE('x)"
-  and     ptb: "pt TYPE('y) TYPE('x)"
-  and     at:  "at TYPE('x)"
-  and     cp:  "cp TYPE('a) TYPE('x) TYPE('y)"
-  and     dj:  "disjoint TYPE('y) TYPE('x)"
-  shows "pi\<bullet>(a\<sharp>*x) = (pi\<bullet>a)\<sharp>*(pi\<bullet>x)"
-  and   "pi\<bullet>(b\<sharp>*x) = (pi\<bullet>b)\<sharp>*(pi\<bullet>x)"
-  by (simp_all add: pt_fresh_star_bij_ineq[OF pta, OF ptb, OF at, OF cp] dj_perm_forget[OF dj] perm_bool)
-
 lemma pt_fresh_bij1:
   fixes  pi :: "'x prm"
   and     x :: "'a"
@@ -1753,7 +1644,6 @@
 
 (* the next two lemmas are needed in the proof *)
 (* of the structural induction principle       *)
-
 lemma pt_fresh_aux:
   fixes a::"'x"
   and   b::"'x"
@@ -1857,27 +1747,6 @@
   thus ?thesis using eq3 by simp
 qed
 
-lemma pt_freshs_freshs:
-  assumes pt: "pt TYPE('a) TYPE('x)"
-  and at: "at TYPE ('x)"
-  and pi: "set (pi::'x prm) \<subseteq> Xs \<times> Ys"
-  and Xs: "Xs \<sharp>* (x::'a)"
-  and Ys: "Ys \<sharp>* x"
-  shows "pi \<bullet> x = x"
-  using pi
-proof (induct pi)
-  case Nil
-  show ?case by (simp add: pt1 [OF pt])
-next
-  case (Cons p pi)
-  obtain a b where p: "p = (a, b)" by (cases p)
-  with Cons Xs Ys have "a \<sharp> x" "b \<sharp> x"
-    by (simp_all add: fresh_star_def)
-  with Cons p show ?case
-    by (simp add: pt_fresh_fresh [OF pt at]
-      pt2 [OF pt, of "[(a, b)]" pi, simplified])
-qed
-
 lemma pt_pi_fresh_fresh:
   fixes   x :: "'a"
   and     pi :: "'x prm"
@@ -1943,8 +1812,7 @@
   thus ?thesis by (simp add: pt2[OF pt])
 qed
 
-section {* equivaraince for some connectives *}
-
+section {* equivariance for some connectives *}
 lemma pt_all_eqvt:
   fixes  pi :: "'x prm"
   and     x :: "'a"
@@ -1990,8 +1858,6 @@
   apply(rule theI'[OF unique])
   done
 
-
-
 section {* facts about supports *}
 (*==============================*)
 
@@ -2160,6 +2026,7 @@
   shows "(x \<sharp> X) = (x \<notin> X)"
   by (simp add: at_fin_set_supp fresh_def at fs)
 
+
 section {* Permutations acting on Functions *}
 (*==========================================*)
 
@@ -2540,9 +2407,8 @@
   and     a1:  "a\<sharp>x"
   and     a2:  "a\<sharp>X"
   shows "a\<sharp>(insert x X)"
-using a1 a2
-apply(simp add: fresh_fin_insert[OF pt, OF at, OF fs, OF f])
-done
+  using a1 a2
+  by (simp add: fresh_fin_insert[OF pt, OF at, OF fs, OF f])
 
 lemma pt_list_set_supp:
   fixes xs :: "'a list"
@@ -2571,14 +2437,191 @@
   shows "a\<sharp>(set xs) = a\<sharp>xs"
 by (simp add: fresh_def pt_list_set_supp[OF pt, OF at, OF fs])
 
+
+section {* generalisation of freshness to lists and sets of atoms *}
+(*================================================================*)
+ 
+consts
+  fresh_star :: "'b \<Rightarrow> 'a \<Rightarrow> bool" ("_ \<sharp>* _" [100,100] 100)
+
+defs (overloaded)
+  fresh_star_set: "xs\<sharp>*c \<equiv> \<forall>x\<in>xs. x\<sharp>c"
+
+defs (overloaded)
+  fresh_star_list: "xs\<sharp>*c \<equiv> \<forall>x\<in>set xs. x\<sharp>c"
+
+lemmas fresh_star_def = fresh_star_list fresh_star_set
+
+lemma fresh_star_prod_set:
+  fixes xs::"'a set"
+  shows "xs\<sharp>*(a,b) = (xs\<sharp>*a \<and> xs\<sharp>*b)"
+by (auto simp add: fresh_star_def fresh_prod)
+
+lemma fresh_star_prod_list:
+  fixes xs::"'a list"
+  shows "xs\<sharp>*(a,b) = (xs\<sharp>*a \<and> xs\<sharp>*b)"
+  by (auto simp add: fresh_star_def fresh_prod)
+
+lemmas fresh_star_prod = fresh_star_prod_list fresh_star_prod_set
+
+lemma fresh_star_set_eq: "set xs \<sharp>* c = xs \<sharp>* c"
+  by (simp add: fresh_star_def)
+
+lemma fresh_star_Un_elim:
+  "((S \<union> T) \<sharp>* c \<Longrightarrow> PROP C) \<equiv> (S \<sharp>* c \<Longrightarrow> T \<sharp>* c \<Longrightarrow> PROP C)"
+  apply rule
+  apply (simp_all add: fresh_star_def)
+  apply (erule meta_mp)
+  apply blast
+  done
+
+lemma fresh_star_insert_elim:
+  "(insert x S \<sharp>* c \<Longrightarrow> PROP C) \<equiv> (x \<sharp> c \<Longrightarrow> S \<sharp>* c \<Longrightarrow> PROP C)"
+  by rule (simp_all add: fresh_star_def)
+
+lemma fresh_star_empty_elim:
+  "({} \<sharp>* c \<Longrightarrow> PROP C) \<equiv> PROP C"
+  by (simp add: fresh_star_def)
+
+text {* Normalization of freshness results; see \ @{text nominal_induct} *}
+
+lemma fresh_star_unit_elim: 
+  shows "((a::'a set)\<sharp>*() \<Longrightarrow> PROP C) \<equiv> PROP C"
+  and "((b::'a list)\<sharp>*() \<Longrightarrow> PROP C) \<equiv> PROP C"
+  by (simp_all add: fresh_star_def fresh_def supp_unit)
+
+lemma fresh_star_prod_elim: 
+  shows "((a::'a set)\<sharp>*(x,y) \<Longrightarrow> PROP C) \<equiv> (a\<sharp>*x \<Longrightarrow> a\<sharp>*y \<Longrightarrow> PROP C)"
+  and "((b::'a list)\<sharp>*(x,y) \<Longrightarrow> PROP C) \<equiv> (b\<sharp>*x \<Longrightarrow> b\<sharp>*y \<Longrightarrow> PROP C)"
+  by (rule, simp_all add: fresh_star_prod)+
+
+
+lemma pt_fresh_star_bij_ineq:
+  fixes  pi :: "'x prm"
+  and     x :: "'a"
+  and     a :: "'y set"
+  and     b :: "'y list"
+  assumes pta: "pt TYPE('a) TYPE('x)"
+  and     ptb: "pt TYPE('y) TYPE('x)"
+  and     at:  "at TYPE('x)"
+  and     cp:  "cp TYPE('a) TYPE('x) TYPE('y)"
+  shows "(pi\<bullet>a)\<sharp>*(pi\<bullet>x) = a\<sharp>*x"
+  and   "(pi\<bullet>b)\<sharp>*(pi\<bullet>x) = b\<sharp>*x"
+apply(unfold fresh_star_def)
+apply(auto)
+apply(drule_tac x="pi\<bullet>xa" in bspec)
+apply(erule pt_set_bij2[OF ptb, OF at])
+apply(simp add: fresh_star_def pt_fresh_bij_ineq[OF pta, OF ptb, OF at, OF cp])
+apply(drule_tac x="(rev pi)\<bullet>xa" in bspec)
+apply(simp add: pt_set_bij1[OF ptb, OF at])
+apply(simp add: pt_fresh_left_ineq[OF pta, OF ptb, OF at, OF cp])
+apply(drule_tac x="pi\<bullet>xa" in bspec)
+apply(simp add: pt_set_bij1[OF ptb, OF at])
+apply(simp add: pt_set_eqvt [OF ptb at] pt_rev_pi[OF pt_list_inst[OF ptb], OF at])
+apply(simp add: pt_fresh_bij_ineq[OF pta, OF ptb, OF at, OF cp])
+apply(drule_tac x="(rev pi)\<bullet>xa" in bspec)
+apply(simp add: pt_set_bij1[OF ptb, OF at] pt_set_eqvt [OF ptb at])
+apply(simp add: pt_fresh_left_ineq[OF pta, OF ptb, OF at, OF cp])
+done
+
+lemma pt_fresh_star_bij:
+  fixes  pi :: "'x prm"
+  and     x :: "'a"
+  and     a :: "'x set"
+  and     b :: "'x list"
+  assumes pt: "pt TYPE('a) TYPE('x)"
+  and     at: "at TYPE('x)"
+  shows "(pi\<bullet>a)\<sharp>*(pi\<bullet>x) = a\<sharp>*x"
+  and   "(pi\<bullet>b)\<sharp>*(pi\<bullet>x) = b\<sharp>*x"
+apply(rule pt_fresh_star_bij_ineq(1))
+apply(rule pt)
+apply(rule at_pt_inst)
+apply(rule at)+
+apply(rule cp_pt_inst)
+apply(rule pt)
+apply(rule at)
+apply(rule pt_fresh_star_bij_ineq(2))
+apply(rule pt)
+apply(rule at_pt_inst)
+apply(rule at)+
+apply(rule cp_pt_inst)
+apply(rule pt)
+apply(rule at)
+done
+
+lemma pt_fresh_star_eqvt:
+  fixes  pi :: "'x prm"
+  and     x :: "'a"
+  and     a :: "'x set"
+  and     b :: "'x list"
+  assumes pt: "pt TYPE('a) TYPE('x)"
+  and     at: "at TYPE('x)"
+  shows "pi\<bullet>(a\<sharp>*x) = (pi\<bullet>a)\<sharp>*(pi\<bullet>x)"
+  and   "pi\<bullet>(b\<sharp>*x) = (pi\<bullet>b)\<sharp>*(pi\<bullet>x)"
+  by (simp_all add: perm_bool pt_fresh_star_bij[OF pt, OF at])
+
+lemma pt_fresh_star_eqvt_ineq:
+  fixes pi::"'x prm"
+  and   a::"'y set"
+  and   b::"'y list"
+  and   x::"'a"
+  assumes pta: "pt TYPE('a) TYPE('x)"
+  and     ptb: "pt TYPE('y) TYPE('x)"
+  and     at:  "at TYPE('x)"
+  and     cp:  "cp TYPE('a) TYPE('x) TYPE('y)"
+  and     dj:  "disjoint TYPE('y) TYPE('x)"
+  shows "pi\<bullet>(a\<sharp>*x) = (pi\<bullet>a)\<sharp>*(pi\<bullet>x)"
+  and   "pi\<bullet>(b\<sharp>*x) = (pi\<bullet>b)\<sharp>*(pi\<bullet>x)"
+  by (simp_all add: pt_fresh_star_bij_ineq[OF pta, OF ptb, OF at, OF cp] dj_perm_forget[OF dj] perm_bool)
+
+lemma pt_freshs_freshs:
+  assumes pt: "pt TYPE('a) TYPE('x)"
+  and at: "at TYPE ('x)"
+  and pi: "set (pi::'x prm) \<subseteq> Xs \<times> Ys"
+  and Xs: "Xs \<sharp>* (x::'a)"
+  and Ys: "Ys \<sharp>* x"
+  shows "pi\<bullet>x = x"
+  using pi
+proof (induct pi)
+  case Nil
+  show ?case by (simp add: pt1 [OF pt])
+next
+  case (Cons p pi)
+  obtain a b where p: "p = (a, b)" by (cases p)
+  with Cons Xs Ys have "a \<sharp> x" "b \<sharp> x"
+    by (simp_all add: fresh_star_def)
+  with Cons p show ?case
+    by (simp add: pt_fresh_fresh [OF pt at]
+      pt2 [OF pt, of "[(a, b)]" pi, simplified])
+qed
+
+lemma pt_fresh_star_pi: 
+  fixes x::"'a"
+  and   pi::"'x prm"
+  assumes pt: "pt TYPE('a) TYPE('x)"
+  and     at: "at TYPE('x)"
+  and     a: "((supp x)::'x set)\<sharp>* pi"
+  shows "pi\<bullet>x = x"
+using a
+apply(induct pi)
+apply(auto simp add: fresh_star_def fresh_list_cons fresh_prod pt1[OF pt])
+apply(subgoal_tac "((a,b)#pi)\<bullet>x = ([(a,b)]@pi)\<bullet>x")
+apply(simp only: pt2[OF pt])
+apply(rule pt_fresh_fresh[OF pt at])
+apply(simp add: fresh_def at_supp[OF at])
+apply(blast)
+apply(simp add: fresh_def at_supp[OF at])
+apply(blast)
+apply(simp add: pt2[OF pt])
+done
+
 section {* Infrastructure lemmas for strong rule inductions *}
 (*==========================================================*)
 
-
 text {* 
   For every set of atoms, there is another set of atoms
   avoiding a finitely supported c and there is a permutation
-  which make 'translates' between both sets.
+  which 'translates' between both sets.
 *}
 lemma at_set_avoiding_aux:
   fixes Xs::"'a set"
@@ -3365,7 +3408,6 @@
 
 syntax ABS :: "type \<Rightarrow> type \<Rightarrow> type" ("\<guillemotleft>_\<guillemotright>_" [1000,1000] 1000)
 
-
 section {* lemmas for deciding permutation equations *}
 (*===================================================*)
 
@@ -3526,8 +3568,8 @@
   shows "pi\<bullet>(x div y) = (pi\<bullet>x) div (pi\<bullet>y)" 
 by (simp add:perm_int_def) 
 
-(*******************************************************************)
-(* Setup of the theorem attributes eqvt, eqvt_force, fresh and bij *)
+(*******************************************************)
+(* Setup of the theorem attributes eqvt and eqvt_force *)
 use "nominal_thmdecls.ML"
 setup "NominalThmDecls.setup"
 

--- a/src/HOL/Nominal/nominal_atoms.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Nominal/nominal_atoms.ML	Fri May 15 15:56:28 2009 +0200
@@ -732,18 +732,18 @@
 
         in
          thy26
-         |> discrete_pt_inst "nat"  @{thm "perm_nat_def"}
-         |> discrete_fs_inst "nat"  @{thm "perm_nat_def"}
-         |> discrete_cp_inst "nat"  @{thm "perm_nat_def"}
-         |> discrete_pt_inst "bool" @{thm "perm_bool"}
-         |> discrete_fs_inst "bool" @{thm "perm_bool"}
-         |> discrete_cp_inst "bool" @{thm "perm_bool"}
-         |> discrete_pt_inst @{type_name "Int.int"} @{thm "perm_int_def"}
-         |> discrete_fs_inst @{type_name "Int.int"} @{thm "perm_int_def"}
-         |> discrete_cp_inst @{type_name "Int.int"} @{thm "perm_int_def"}
-         |> discrete_pt_inst "List.char" @{thm "perm_char_def"}
-         |> discrete_fs_inst "List.char" @{thm "perm_char_def"}
-         |> discrete_cp_inst "List.char" @{thm "perm_char_def"}
+         |> discrete_pt_inst @{type_name nat}  @{thm "perm_nat_def"}
+         |> discrete_fs_inst @{type_name nat}  @{thm "perm_nat_def"}
+         |> discrete_cp_inst @{type_name nat}  @{thm "perm_nat_def"}
+         |> discrete_pt_inst @{type_name bool} @{thm "perm_bool"}
+         |> discrete_fs_inst @{type_name bool} @{thm "perm_bool"}
+         |> discrete_cp_inst @{type_name bool} @{thm "perm_bool"}
+         |> discrete_pt_inst @{type_name int} @{thm "perm_int_def"}
+         |> discrete_fs_inst @{type_name int} @{thm "perm_int_def"}
+         |> discrete_cp_inst @{type_name int} @{thm "perm_int_def"}
+         |> discrete_pt_inst @{type_name char} @{thm "perm_char_def"}
+         |> discrete_fs_inst @{type_name char} @{thm "perm_char_def"}
+         |> discrete_cp_inst @{type_name char} @{thm "perm_char_def"}
         end;
 
 

--- a/src/HOL/Nominal/nominal_thmdecls.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Nominal/nominal_thmdecls.ML	Fri May 15 15:56:28 2009 +0200
@@ -1,12 +1,12 @@
 (* Authors: Julien Narboux and Christian Urban
 
    This file introduces the infrastructure for the lemma
-   declaration "eqvts" "bijs" and "freshs".
+   collection "eqvts".
 
-   By attaching [eqvt] [bij] or [fresh] to a lemma, the lemma gets stored
-   in a data-slot in the context. Possible modifiers
-   are [attribute add] and [attribute del] for adding and deleting,
-   respectively the lemma from the data-slot.
+   By attaching [eqvt] or [eqvt_force] to a lemma, it will get 
+   stored in a data-slot in the context. Possible modifiers
+   are [... add] and [... del] for adding and deleting, 
+   respectively, the lemma from the data-slot.
 *)
 
 signature NOMINAL_THMDECLS =
@@ -17,9 +17,6 @@
   val eqvt_force_del: attribute
   val setup: theory -> theory
   val get_eqvt_thms: Proof.context -> thm list
-  val get_fresh_thms: Proof.context -> thm list
-  val get_bij_thms: Proof.context -> thm list
-
 
   val NOMINAL_EQVT_DEBUG : bool ref
 end;
@@ -29,13 +26,11 @@
 
 structure Data = GenericDataFun
 (
-  type T = {eqvts:thm list, freshs:thm list, bijs:thm list};
-  val empty = ({eqvts=[], freshs=[], bijs=[]}:T);
-  val extend = I;
-  fun merge _ (r1:T,r2:T) = {eqvts  = Thm.merge_thms (#eqvts r1, #eqvts r2),
-                             freshs = Thm.merge_thms (#freshs r1, #freshs r2),
-                             bijs   = Thm.merge_thms (#bijs r1, #bijs r2)}
-);
+  type T = thm list
+  val empty = []:T
+  val extend = I
+  fun merge _ (r1:T, r2:T) = Thm.merge_thms (r1, r2)
+)
 
 (* Exception for when a theorem does not conform with form of an equivariance lemma. *)
 (* There are two forms: one is an implication (for relations) and the other is an    *)
@@ -46,72 +41,68 @@
 (* the implicational case it is also checked that the variables and permutation fit  *)
 (* together, i.e. are of the right "pt_class", so that a stronger version of the     *)
 (* equality-lemma can be derived. *)
-exception EQVT_FORM of string;
+exception EQVT_FORM of string
 
-val get_eqvt_thms = Context.Proof #> Data.get #> #eqvts;
-val get_fresh_thms = Context.Proof #> Data.get #> #freshs;
-val get_bij_thms = Context.Proof #> Data.get #> #bijs;
+val NOMINAL_EQVT_DEBUG = ref false
 
-(* FIXME: should be a function in a library *)
-fun mk_permT T = HOLogic.listT (HOLogic.mk_prodT (T, T));
-
-val NOMINAL_EQVT_DEBUG = ref false;
-
-fun tactic (msg,tac) =
-    if !NOMINAL_EQVT_DEBUG
-    then tac THEN print_tac ("after "^msg)
-    else tac
+fun tactic (msg, tac) =
+  if !NOMINAL_EQVT_DEBUG
+  then tac THEN' (K (print_tac ("after " ^ msg)))
+  else tac
 
-fun tactic_eqvt ctx orig_thm pi pi' =
-    let
-        val mypi = Thm.cterm_of ctx pi
-        val T = fastype_of pi'
-        val mypifree = Thm.cterm_of ctx (Const ("List.rev", T --> T) $ pi')
-        val perm_pi_simp = PureThy.get_thms ctx "perm_pi_simp"
-    in
-        EVERY [tactic ("iffI applied",rtac iffI 1),
-	       tactic ("remove pi with perm_boolE", (dtac @{thm perm_boolE} 1)),
-               tactic ("solve with orig_thm", (etac orig_thm 1)),
-               tactic ("applies orig_thm instantiated with rev pi",
-                          dtac (Drule.cterm_instantiate [(mypi,mypifree)] orig_thm) 1),
-	       tactic ("getting rid of the pi on the right",
-                          (rtac @{thm perm_boolI} 1)),
-               tactic ("getting rid of all remaining perms",
-                          full_simp_tac (HOL_basic_ss addsimps perm_pi_simp) 1)]
-    end;
+fun prove_eqvt_tac ctxt orig_thm pi pi' =
+let
+  val mypi = Thm.cterm_of ctxt pi
+  val T = fastype_of pi'
+  val mypifree = Thm.cterm_of ctxt (Const (@{const_name "rev"}, T --> T) $ pi')
+  val perm_pi_simp = PureThy.get_thms ctxt "perm_pi_simp"
+in
+  EVERY1 [tactic ("iffI applied", rtac @{thm iffI}),
+	  tactic ("remove pi with perm_boolE", dtac @{thm perm_boolE}),
+          tactic ("solve with orig_thm", etac orig_thm),
+          tactic ("applies orig_thm instantiated with rev pi",
+                     dtac (Drule.cterm_instantiate [(mypi,mypifree)] orig_thm)),
+	  tactic ("getting rid of the pi on the right", rtac @{thm perm_boolI}),
+          tactic ("getting rid of all remaining perms",
+                     full_simp_tac (HOL_basic_ss addsimps perm_pi_simp))]
+end;
 
 fun get_derived_thm ctxt hyp concl orig_thm pi typi =
   let
     val thy = ProofContext.theory_of ctxt;
     val pi' = Var (pi, typi);
-    val lhs = Const ("Nominal.perm", typi --> HOLogic.boolT --> HOLogic.boolT) $ pi' $ hyp;
+    val lhs = Const (@{const_name "perm"}, typi --> HOLogic.boolT --> HOLogic.boolT) $ pi' $ hyp;
     val ([goal_term, pi''], ctxt') = Variable.import_terms false
       [HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, concl)), pi'] ctxt
     val _ = Display.print_cterm (cterm_of thy goal_term)
   in
     Goal.prove ctxt' [] [] goal_term
-      (fn _ => tactic_eqvt thy orig_thm pi' pi'') |>
+      (fn _ => prove_eqvt_tac thy orig_thm pi' pi'') |>
     singleton (ProofContext.export ctxt' ctxt)
   end
 
-(* replaces every variable x in t with pi o x *)
-fun apply_pi trm (pi,typi) =
-  let
-    fun only_vars t =
-       (case t of
-          Var (n,ty) => (Const ("Nominal.perm",typi --> ty --> ty) $ (Var (pi,typi)) $ (Var (n,ty)))
-        | _ => t)
+(* replaces in t every variable, say x, with pi o x *)
+fun apply_pi trm (pi, typi) =
+let
+  fun replace n ty =
+  let 
+    val c  = Const (@{const_name "perm"}, typi --> ty --> ty) 
+    val v1 = Var (pi, typi)
+    val v2 = Var (n, ty)
   in
-     map_aterms only_vars trm
-  end;
+    c $ v1 $ v2 
+  end
+in
+  map_aterms (fn Var (n, ty) => replace n ty | t => t) trm
+end
 
 (* returns *the* pi which is in front of all variables, provided there *)
 (* exists such a pi; otherwise raises EQVT_FORM                        *)
 fun get_pi t thy =
   let fun get_pi_aux s =
         (case s of
-          (Const ("Nominal.perm",typrm) $
-             (Var (pi,typi as Type("List.list",[Type ("*",[Type (tyatm,[]),_])]))) $
+          (Const (@{const_name "perm"} ,typrm) $
+             (Var (pi,typi as Type(@{type_name "list"}, [Type ("*", [Type (tyatm,[]),_])]))) $
                (Var (n,ty))) =>
              let
                 (* FIXME: this should be an operation the library *)
@@ -130,7 +121,7 @@
     (* to ensure that all pi's must have been the same, i.e. distinct returns  *)
     (* a singleton-list  *)
     (case (distinct (op =) (get_pi_aux t)) of
-      [(pi,typi)] => (pi,typi)
+      [(pi,typi)] => (pi, typi)
     | _ => raise EQVT_FORM "All permutation should be the same")
   end;
 
@@ -155,8 +146,8 @@
              else raise EQVT_FORM "Type Implication"
           end
        (* case: eqvt-lemma is of the equational form *)
-      | (Const ("Trueprop", _) $ (Const ("op =", _) $
-            (Const ("Nominal.perm",typrm) $ Var (pi,typi) $ lhs) $ rhs)) =>
+      | (Const (@{const_name "Trueprop"}, _) $ (Const (@{const_name "op ="}, _) $
+            (Const (@{const_name "perm"},typrm) $ Var (pi,typi) $ lhs) $ rhs)) =>
            (if (apply_pi lhs (pi,typi)) = rhs
                then [orig_thm]
                else raise EQVT_FORM "Type Equality")
@@ -165,38 +156,24 @@
       fold (fn thm => Data.map (flag thm)) thms_to_be_added context
   end
   handle EQVT_FORM s =>
-      error (Display.string_of_thm orig_thm ^ " does not comply with the form of an equivariance lemma ("^s^").")
-
-(* in cases of bij- and freshness, we just add the lemmas to the *)
-(* data-slot *)
-
-fun eqvt_map f (r:Data.T)  = {eqvts = f (#eqvts r), freshs = #freshs r, bijs = #bijs r};
-fun fresh_map f (r:Data.T) = {eqvts = #eqvts r, freshs = f (#freshs r), bijs = #bijs r};
-fun bij_map f (r:Data.T)   = {eqvts = #eqvts r, freshs = #freshs r, bijs = f (#bijs r)};
-
-val eqvt_add = Thm.declaration_attribute (eqvt_add_del_aux (eqvt_map o Thm.add_thm));
-val eqvt_del = Thm.declaration_attribute (eqvt_add_del_aux (eqvt_map o Thm.del_thm));
-
-val eqvt_force_add  = Thm.declaration_attribute (Data.map o eqvt_map o Thm.add_thm);
-val eqvt_force_del  = Thm.declaration_attribute (Data.map o eqvt_map o Thm.del_thm);
-val bij_add   = Thm.declaration_attribute (Data.map o bij_map o Thm.add_thm);
-val bij_del   = Thm.declaration_attribute (Data.map o bij_map o Thm.del_thm);
-val fresh_add = Thm.declaration_attribute (Data.map o fresh_map o Thm.add_thm);
-val fresh_del = Thm.declaration_attribute (Data.map o fresh_map o Thm.del_thm);
+      error (Display.string_of_thm orig_thm ^ 
+               " does not comply with the form of an equivariance lemma (" ^ s ^").")
 
 
+val eqvt_add = Thm.declaration_attribute (eqvt_add_del_aux (Thm.add_thm));
+val eqvt_del = Thm.declaration_attribute (eqvt_add_del_aux (Thm.del_thm));
+
+val eqvt_force_add  = Thm.declaration_attribute (Data.map o Thm.add_thm);
+val eqvt_force_del  = Thm.declaration_attribute (Data.map o Thm.del_thm);
+
+val get_eqvt_thms = Context.Proof #> Data.get;
 
 val setup =
-  Attrib.setup @{binding eqvt} (Attrib.add_del eqvt_add eqvt_del)
-    "equivariance theorem declaration" #>
-  Attrib.setup @{binding eqvt_force} (Attrib.add_del eqvt_force_add eqvt_force_del)
-    "equivariance theorem declaration (without checking the form of the lemma)" #>
-  Attrib.setup @{binding fresh} (Attrib.add_del fresh_add fresh_del)
-    "freshness theorem declaration" #>
-  Attrib.setup @{binding "bij"} (Attrib.add_del bij_add bij_del)
-    "bijection theorem declaration" #>
-  PureThy.add_thms_dynamic (Binding.name "eqvts", #eqvts o Data.get) #>
-  PureThy.add_thms_dynamic (Binding.name "freshs", #freshs o Data.get) #>
-  PureThy.add_thms_dynamic (Binding.name "bijs", #bijs o Data.get);
+    Attrib.setup @{binding eqvt} (Attrib.add_del eqvt_add eqvt_del) 
+     "equivariance theorem declaration" 
+ #> Attrib.setup @{binding eqvt_force} (Attrib.add_del eqvt_force_add eqvt_force_del)
+     "equivariance theorem declaration (without checking the form of the lemma)" 
+ #> PureThy.add_thms_dynamic (Binding.name "eqvts", Data.get) 
+
 
 end;

--- a/src/HOL/NthRoot.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/NthRoot.thy	Fri May 15 15:56:28 2009 +0200
@@ -565,16 +565,6 @@
 lemma le_real_sqrt_sumsq [simp]: "x \<le> sqrt (x * x + y * y)"
 by (simp add: power2_eq_square [symmetric])
 
-lemma power2_sum:
-  fixes x y :: "'a::{number_ring,recpower}"
-  shows "(x + y)\<twosuperior> = x\<twosuperior> + y\<twosuperior> + 2 * x * y"
-by (simp add: ring_distribs power2_eq_square)
-
-lemma power2_diff:
-  fixes x y :: "'a::{number_ring,recpower}"
-  shows "(x - y)\<twosuperior> = x\<twosuperior> + y\<twosuperior> - 2 * x * y"
-by (simp add: ring_distribs power2_eq_square)
-
 lemma real_sqrt_sum_squares_triangle_ineq:
   "sqrt ((a + c)\<twosuperior> + (b + d)\<twosuperior>) \<le> sqrt (a\<twosuperior> + b\<twosuperior>) + sqrt (c\<twosuperior> + d\<twosuperior>)"
 apply (rule power2_le_imp_le, simp)

--- a/src/HOL/Option.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Option.thy	Fri May 15 15:56:28 2009 +0200
@@ -20,6 +20,9 @@
 only when applied to assumptions, in practice it seems better to give
 them the uniform iff attribute. *}
 
+lemma inj_Some [simp]: "inj_on Some A"
+by (rule inj_onI) simp
+
 lemma option_caseE:
   assumes c: "(case x of None => P | Some y => Q y)"
   obtains
@@ -27,14 +30,15 @@
   | (Some) y where "x = Some y" and "Q y"
   using c by (cases x) simp_all
 
-lemma insert_None_conv_UNIV: "insert None (range Some) = UNIV"
-  by (rule set_ext, case_tac x) auto
+lemma UNIV_option_conv: "UNIV = insert None (range Some)"
+by(auto intro: classical)
+
+lemma finite_option_UNIV[simp]:
+  "finite (UNIV :: 'a option set) = finite (UNIV :: 'a set)"
+by(auto simp add: UNIV_option_conv elim: finite_imageD intro: inj_Some)
 
 instance option :: (finite) finite proof
-qed (simp add: insert_None_conv_UNIV [symmetric])
-
-lemma inj_Some [simp]: "inj_on Some A"
-  by (rule inj_onI) simp
+qed (simp add: UNIV_option_conv)
 
 
 subsubsection {* Operations *}
@@ -59,10 +63,8 @@
 lemma set_empty_eq [simp]: "(set xo = {}) = (xo = None)"
   by (cases xo) auto
 
-definition
-  map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a option \<Rightarrow> 'b option"
-where
-  [code del]: "map = (%f y. case y of None => None | Some x => Some (f x))"
+definition map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a option \<Rightarrow> 'b option" where
+  "map = (%f y. case y of None => None | Some x => Some (f x))"
 
 lemma option_map_None [simp, code]: "map f None = None"
   by (simp add: map_def)
@@ -91,14 +93,21 @@
 
 subsubsection {* Code generator setup *}
 
-definition
-  is_none :: "'a option \<Rightarrow> bool" where
-  is_none_none [code post, symmetric, code inline]: "is_none x \<longleftrightarrow> x = None"
+definition is_none :: "'a option \<Rightarrow> bool" where
+  [code post]: "is_none x \<longleftrightarrow> x = None"
 
 lemma is_none_code [code]:
   shows "is_none None \<longleftrightarrow> True"
     and "is_none (Some x) \<longleftrightarrow> False"
-  unfolding is_none_none [symmetric] by simp_all
+  unfolding is_none_def by simp_all
+
+lemma is_none_none:
+  "is_none x \<longleftrightarrow> x = None"
+  by (simp add: is_none_def)
+
+lemma [code inline]:
+  "eq_class.eq x None \<longleftrightarrow> is_none x"
+  by (simp add: eq is_none_none)
 
 hide (open) const is_none
 

--- a/src/HOL/Orderings.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Orderings.thy	Fri May 15 15:56:28 2009 +0200
@@ -5,7 +5,7 @@
 header {* Abstract orderings *}
 
 theory Orderings
-imports Code_Setup
+imports HOL
 uses "~~/src/Provers/order.ML"
 begin
 

--- a/src/HOL/Parity.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Parity.thy	Fri May 15 15:56:28 2009 +0200
@@ -29,6 +29,18 @@
 end
 
 
+lemma even_zero_int[simp]: "even (0::int)" by presburger
+
+lemma odd_one_int[simp]: "odd (1::int)" by presburger
+
+lemma even_zero_nat[simp]: "even (0::nat)" by presburger
+
+lemma odd_zero_nat [simp]: "odd (1::nat)" by presburger
+
+declare even_def[of "number_of v", standard, simp]
+
+declare even_nat_def[of "number_of v", standard, simp]
+
 subsection {* Even and odd are mutually exclusive *}
 
 lemma int_pos_lt_two_imp_zero_or_one:
@@ -54,66 +66,47 @@
 lemma odd_times_odd: "odd (x::int) ==> odd y ==> odd (x * y)" 
   by (simp add: even_def zmod_zmult1_eq)
 
-lemma even_product[presburger]: "even((x::int) * y) = (even x | even y)"
+lemma even_product[simp,presburger]: "even((x::int) * y) = (even x | even y)"
   apply (auto simp add: even_times_anything anything_times_even)
   apply (rule ccontr)
   apply (auto simp add: odd_times_odd)
   done
 
 lemma even_plus_even: "even (x::int) ==> even y ==> even (x + y)"
-  by presburger
+by presburger
 
 lemma even_plus_odd: "even (x::int) ==> odd y ==> odd (x + y)"
-  by presburger
+by presburger
 
 lemma odd_plus_even: "odd (x::int) ==> even y ==> odd (x + y)"
-  by presburger
+by presburger
 
 lemma odd_plus_odd: "odd (x::int) ==> odd y ==> even (x + y)" by presburger
 
-lemma even_sum[presburger]: "even ((x::int) + y) = ((even x & even y) | (odd x & odd y))"
-  by presburger
+lemma even_sum[simp,presburger]:
+  "even ((x::int) + y) = ((even x & even y) | (odd x & odd y))"
+by presburger
 
-lemma even_neg[presburger, algebra]: "even (-(x::int)) = even x" by presburger
+lemma even_neg[simp,presburger,algebra]: "even (-(x::int)) = even x"
+by presburger
 
-lemma even_difference:
+lemma even_difference[simp]:
     "even ((x::int) - y) = ((even x & even y) | (odd x & odd y))" by presburger
 
-lemma even_pow_gt_zero:
-    "even (x::int) ==> 0 < n ==> even (x^n)"
-  by (induct n) (auto simp add: even_product)
-
-lemma odd_pow_iff[presburger, algebra]: 
-  "odd ((x::int) ^ n) \<longleftrightarrow> (n = 0 \<or> odd x)"
-  apply (induct n, simp_all)
-  apply presburger
-  apply (case_tac n, auto)
-  apply (simp_all add: even_product)
-  done
+lemma even_power[simp,presburger]: "even ((x::int)^n) = (even x & n \<noteq> 0)"
+by (induct n) auto
 
-lemma odd_pow: "odd x ==> odd((x::int)^n)" by (simp add: odd_pow_iff)
-
-lemma even_power[presburger]: "even ((x::int)^n) = (even x & 0 < n)"
-  apply (auto simp add: even_pow_gt_zero)
-  apply (erule contrapos_pp, erule odd_pow)
-  apply (erule contrapos_pp, simp add: even_def)
-  done
-
-lemma even_zero[presburger]: "even (0::int)" by presburger
-
-lemma odd_one[presburger]: "odd (1::int)" by presburger
-
-lemmas even_odd_simps [simp] = even_def[of "number_of v",standard] even_zero
-  odd_one even_product even_sum even_neg even_difference even_power
+lemma odd_pow: "odd x ==> odd((x::int)^n)" by simp
 
 
 subsection {* Equivalent definitions *}
 
 lemma two_times_even_div_two: "even (x::int) ==> 2 * (x div 2) = x" 
-  by presburger
+by presburger
 
-lemma two_times_odd_div_two_plus_one: "odd (x::int) ==>
-    2 * (x div 2) + 1 = x" by presburger
+lemma two_times_odd_div_two_plus_one:
+  "odd (x::int) ==> 2 * (x div 2) + 1 = x"
+by presburger
 
 lemma even_equiv_def: "even (x::int) = (EX y. x = 2 * y)" by presburger
 
@@ -122,45 +115,45 @@
 subsection {* even and odd for nats *}
 
 lemma pos_int_even_equiv_nat_even: "0 \<le> x ==> even x = even (nat x)"
-  by (simp add: even_nat_def)
-
-lemma even_nat_product[presburger, algebra]: "even((x::nat) * y) = (even x | even y)"
-  by (simp add: even_nat_def int_mult)
+by (simp add: even_nat_def)
 
-lemma even_nat_sum[presburger, algebra]: "even ((x::nat) + y) =
-    ((even x & even y) | (odd x & odd y))" by presburger
+lemma even_product_nat[simp,presburger,algebra]:
+  "even((x::nat) * y) = (even x | even y)"
+by (simp add: even_nat_def int_mult)
 
-lemma even_nat_difference[presburger, algebra]:
-    "even ((x::nat) - y) = (x < y | (even x & even y) | (odd x & odd y))"
+lemma even_sum_nat[simp,presburger,algebra]:
+  "even ((x::nat) + y) = ((even x & even y) | (odd x & odd y))"
 by presburger
 
-lemma even_nat_Suc[presburger, algebra]: "even (Suc x) = odd x" by presburger
-
-lemma even_nat_power[presburger, algebra]: "even ((x::nat)^y) = (even x & 0 < y)"
-  by (simp add: even_nat_def int_power)
+lemma even_difference_nat[simp,presburger,algebra]:
+  "even ((x::nat) - y) = (x < y | (even x & even y) | (odd x & odd y))"
+by presburger
 
-lemma even_nat_zero[presburger]: "even (0::nat)" by presburger
+lemma even_Suc[simp,presburger,algebra]: "even (Suc x) = odd x"
+by presburger
 
-lemmas even_odd_nat_simps [simp] = even_nat_def[of "number_of v",standard]
-  even_nat_zero even_nat_Suc even_nat_product even_nat_sum even_nat_power
+lemma even_power_nat[simp,presburger,algebra]:
+  "even ((x::nat)^y) = (even x & 0 < y)"
+by (simp add: even_nat_def int_power)
 
 
 subsection {* Equivalent definitions *}
 
-lemma nat_lt_two_imp_zero_or_one: "(x::nat) < Suc (Suc 0) ==>
-    x = 0 | x = Suc 0" by presburger
+lemma nat_lt_two_imp_zero_or_one:
+  "(x::nat) < Suc (Suc 0) ==> x = 0 | x = Suc 0"
+by presburger
 
 lemma even_nat_mod_two_eq_zero: "even (x::nat) ==> x mod (Suc (Suc 0)) = 0"
-  by presburger
+by presburger
 
 lemma odd_nat_mod_two_eq_one: "odd (x::nat) ==> x mod (Suc (Suc 0)) = Suc 0"
 by presburger
 
 lemma even_nat_equiv_def: "even (x::nat) = (x mod Suc (Suc 0) = 0)"
-  by presburger
+by presburger
 
 lemma odd_nat_equiv_def: "odd (x::nat) = (x mod Suc (Suc 0) = Suc 0)"
-  by presburger
+by presburger
 
 lemma even_nat_div_two_times_two: "even (x::nat) ==>
     Suc (Suc 0) * (x div Suc (Suc 0)) = x" by presburger
@@ -169,56 +162,56 @@
     Suc( Suc (Suc 0) * (x div Suc (Suc 0))) = x" by presburger
 
 lemma even_nat_equiv_def2: "even (x::nat) = (EX y. x = Suc (Suc 0) * y)"
-  by presburger
+by presburger
 
 lemma odd_nat_equiv_def2: "odd (x::nat) = (EX y. x = Suc(Suc (Suc 0) * y))"
-  by presburger
+by presburger
 
 
 subsection {* Parity and powers *}
 
 lemma  minus_one_even_odd_power:
-     "(even x --> (- 1::'a::{comm_ring_1,recpower})^x = 1) &
+     "(even x --> (- 1::'a::{comm_ring_1})^x = 1) &
       (odd x --> (- 1::'a)^x = - 1)"
   apply (induct x)
   apply (rule conjI)
   apply simp
-  apply (insert even_nat_zero, blast)
+  apply (insert even_zero_nat, blast)
   apply (simp add: power_Suc)
   done
 
 lemma minus_one_even_power [simp]:
-    "even x ==> (- 1::'a::{comm_ring_1,recpower})^x = 1"
+    "even x ==> (- 1::'a::{comm_ring_1})^x = 1"
   using minus_one_even_odd_power by blast
 
 lemma minus_one_odd_power [simp]:
-    "odd x ==> (- 1::'a::{comm_ring_1,recpower})^x = - 1"
+    "odd x ==> (- 1::'a::{comm_ring_1})^x = - 1"
   using minus_one_even_odd_power by blast
 
 lemma neg_one_even_odd_power:
-     "(even x --> (-1::'a::{number_ring,recpower})^x = 1) &
+     "(even x --> (-1::'a::{number_ring})^x = 1) &
       (odd x --> (-1::'a)^x = -1)"
   apply (induct x)
   apply (simp, simp add: power_Suc)
   done
 
 lemma neg_one_even_power [simp]:
-    "even x ==> (-1::'a::{number_ring,recpower})^x = 1"
+    "even x ==> (-1::'a::{number_ring})^x = 1"
   using neg_one_even_odd_power by blast
 
 lemma neg_one_odd_power [simp]:
-    "odd x ==> (-1::'a::{number_ring,recpower})^x = -1"
+    "odd x ==> (-1::'a::{number_ring})^x = -1"
   using neg_one_even_odd_power by blast
 
 lemma neg_power_if:
-     "(-x::'a::{comm_ring_1,recpower}) ^ n =
+     "(-x::'a::{comm_ring_1}) ^ n =
       (if even n then (x ^ n) else -(x ^ n))"
   apply (induct n)
   apply (simp_all split: split_if_asm add: power_Suc)
   done
 
 lemma zero_le_even_power: "even n ==>
-    0 <= (x::'a::{recpower,ordered_ring_strict}) ^ n"
+    0 <= (x::'a::{ordered_ring_strict,monoid_mult}) ^ n"
   apply (simp add: even_nat_equiv_def2)
   apply (erule exE)
   apply (erule ssubst)
@@ -227,12 +220,12 @@
   done
 
 lemma zero_le_odd_power: "odd n ==>
-    (0 <= (x::'a::{recpower,ordered_idom}) ^ n) = (0 <= x)"
+    (0 <= (x::'a::{ordered_idom}) ^ n) = (0 <= x)"
 apply (auto simp: odd_nat_equiv_def2 power_Suc power_add zero_le_mult_iff)
 apply (metis field_power_not_zero no_zero_divirors_neq0 order_antisym_conv zero_le_square)
 done
 
-lemma zero_le_power_eq[presburger]: "(0 <= (x::'a::{recpower,ordered_idom}) ^ n) =
+lemma zero_le_power_eq[presburger]: "(0 <= (x::'a::{ordered_idom}) ^ n) =
     (even n | (odd n & 0 <= x))"
   apply auto
   apply (subst zero_le_odd_power [symmetric])
@@ -240,19 +233,19 @@
   apply (erule zero_le_even_power)
   done
 
-lemma zero_less_power_eq[presburger]: "(0 < (x::'a::{recpower,ordered_idom}) ^ n) =
+lemma zero_less_power_eq[presburger]: "(0 < (x::'a::{ordered_idom}) ^ n) =
     (n = 0 | (even n & x ~= 0) | (odd n & 0 < x))"
 
   unfolding order_less_le zero_le_power_eq by auto
 
-lemma power_less_zero_eq[presburger]: "((x::'a::{recpower,ordered_idom}) ^ n < 0) =
+lemma power_less_zero_eq[presburger]: "((x::'a::{ordered_idom}) ^ n < 0) =
     (odd n & x < 0)"
   apply (subst linorder_not_le [symmetric])+
   apply (subst zero_le_power_eq)
   apply auto
   done
 
-lemma power_le_zero_eq[presburger]: "((x::'a::{recpower,ordered_idom}) ^ n <= 0) =
+lemma power_le_zero_eq[presburger]: "((x::'a::{ordered_idom}) ^ n <= 0) =
     (n ~= 0 & ((odd n & x <= 0) | (even n & x = 0)))"
   apply (subst linorder_not_less [symmetric])+
   apply (subst zero_less_power_eq)
@@ -260,7 +253,7 @@
   done
 
 lemma power_even_abs: "even n ==>
-    (abs (x::'a::{recpower,ordered_idom}))^n = x^n"
+    (abs (x::'a::{ordered_idom}))^n = x^n"
   apply (subst power_abs [symmetric])
   apply (simp add: zero_le_even_power)
   done
@@ -269,18 +262,18 @@
   by (induct n) auto
 
 lemma power_minus_even [simp]: "even n ==>
-    (- x)^n = (x^n::'a::{recpower,comm_ring_1})"
+    (- x)^n = (x^n::'a::{comm_ring_1})"
   apply (subst power_minus)
   apply simp
   done
 
 lemma power_minus_odd [simp]: "odd n ==>
-    (- x)^n = - (x^n::'a::{recpower,comm_ring_1})"
+    (- x)^n = - (x^n::'a::{comm_ring_1})"
   apply (subst power_minus)
   apply simp
   done
 
-lemma power_mono_even: fixes x y :: "'a :: {recpower, ordered_idom}"
+lemma power_mono_even: fixes x y :: "'a :: {ordered_idom}"
   assumes "even n" and "\<bar>x\<bar> \<le> \<bar>y\<bar>"
   shows "x^n \<le> y^n"
 proof -
@@ -292,7 +285,7 @@
 
 lemma odd_pos: "odd (n::nat) \<Longrightarrow> 0 < n" by presburger
 
-lemma power_mono_odd: fixes x y :: "'a :: {recpower, ordered_idom}"
+lemma power_mono_odd: fixes x y :: "'a :: {ordered_idom}"
   assumes "odd n" and "x \<le> y"
   shows "x^n \<le> y^n"
 proof (cases "y < 0")
@@ -406,11 +399,11 @@
 subsection {* An Equivalence for @{term [source] "0 \<le> a^n"} *}
 
 lemma even_power_le_0_imp_0:
-    "a ^ (2*k) \<le> (0::'a::{ordered_idom,recpower}) ==> a=0"
+    "a ^ (2*k) \<le> (0::'a::{ordered_idom}) ==> a=0"
   by (induct k) (auto simp add: zero_le_mult_iff mult_le_0_iff power_Suc)
 
 lemma zero_le_power_iff[presburger]:
-  "(0 \<le> a^n) = (0 \<le> (a::'a::{ordered_idom,recpower}) | even n)"
+  "(0 \<le> a^n) = (0 \<le> (a::'a::{ordered_idom}) | even n)"
 proof cases
   assume even: "even n"
   then obtain k where "n = 2*k"

--- a/src/HOL/Power.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Power.thy	Fri May 15 15:56:28 2009 +0200
@@ -1,95 +1,179 @@
 (*  Title:      HOL/Power.thy
-    ID:         $Id$
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1997  University of Cambridge
-
 *)
 
-header{*Exponentiation*}
+header {* Exponentiation *}
 
 theory Power
 imports Nat
 begin
 
-class power =
-  fixes power :: "'a \<Rightarrow> nat \<Rightarrow> 'a"            (infixr "^" 80)
+subsection {* Powers for Arbitrary Monoids *}
+
+class power = one + times
+begin
 
-subsection{*Powers for Arbitrary Monoids*}
+primrec power :: "'a \<Rightarrow> nat \<Rightarrow> 'a" (infixr "^" 80) where
+    power_0: "a ^ 0 = 1"
+  | power_Suc: "a ^ Suc n = a * a ^ n"
+
+notation (latex output)
+  power ("(_\<^bsup>_\<^esup>)" [1000] 1000)
 
-class recpower = monoid_mult + power +
-  assumes power_0 [simp]: "a ^ 0       = 1"
-  assumes power_Suc [simp]: "a ^ Suc n = a * (a ^ n)"
+notation (HTML output)
+  power ("(_\<^bsup>_\<^esup>)" [1000] 1000)
+
+end
+
+context monoid_mult
+begin
 
-lemma power_0_Suc [simp]: "(0::'a::{recpower,semiring_0}) ^ (Suc n) = 0"
+subclass power ..
+
+lemma power_one [simp]:
+  "1 ^ n = 1"
+  by (induct n) simp_all
+
+lemma power_one_right [simp]:
+  "a ^ 1 = a"
   by simp
 
-text{*It looks plausible as a simprule, but its effect can be strange.*}
-lemma power_0_left: "0^n = (if n=0 then 1 else (0::'a::{recpower,semiring_0}))"
-  by (induct n) simp_all
-
-lemma power_one [simp]: "1^n = (1::'a::recpower)"
-  by (induct n) simp_all
-
-lemma power_one_right [simp]: "(a::'a::recpower) ^ 1 = a"
-  unfolding One_nat_def by simp
-
-lemma power_commutes: "(a::'a::recpower) ^ n * a = a * a ^ n"
+lemma power_commutes:
+  "a ^ n * a = a * a ^ n"
   by (induct n) (simp_all add: mult_assoc)
 
-lemma power_Suc2: "(a::'a::recpower) ^ Suc n = a ^ n * a"
+lemma power_Suc2:
+  "a ^ Suc n = a ^ n * a"
   by (simp add: power_commutes)
 
-lemma power_add: "(a::'a::recpower) ^ (m+n) = (a^m) * (a^n)"
-  by (induct m) (simp_all add: mult_ac)
+lemma power_add:
+  "a ^ (m + n) = a ^ m * a ^ n"
+  by (induct m) (simp_all add: algebra_simps)
 
-lemma power_mult: "(a::'a::recpower) ^ (m*n) = (a^m) ^ n"
+lemma power_mult:
+  "a ^ (m * n) = (a ^ m) ^ n"
   by (induct n) (simp_all add: power_add)
 
-lemma power_mult_distrib: "((a::'a::{recpower,comm_monoid_mult}) * b) ^ n = (a^n) * (b^n)"
+end
+
+context comm_monoid_mult
+begin
+
+lemma power_mult_distrib:
+  "(a * b) ^ n = (a ^ n) * (b ^ n)"
   by (induct n) (simp_all add: mult_ac)
 
-lemma zero_less_power[simp]:
-     "0 < (a::'a::{ordered_semidom,recpower}) ==> 0 < a^n"
-by (induct n) (simp_all add: mult_pos_pos)
+end
+
+context semiring_1
+begin
+
+lemma of_nat_power:
+  "of_nat (m ^ n) = of_nat m ^ n"
+  by (induct n) (simp_all add: of_nat_mult)
+
+end
+
+context comm_semiring_1
+begin
+
+text {* The divides relation *}
+
+lemma le_imp_power_dvd:
+  assumes "m \<le> n" shows "a ^ m dvd a ^ n"
+proof
+  have "a ^ n = a ^ (m + (n - m))"
+    using `m \<le> n` by simp
+  also have "\<dots> = a ^ m * a ^ (n - m)"
+    by (rule power_add)
+  finally show "a ^ n = a ^ m * a ^ (n - m)" .
+qed
+
+lemma power_le_dvd:
+  "a ^ n dvd b \<Longrightarrow> m \<le> n \<Longrightarrow> a ^ m dvd b"
+  by (rule dvd_trans [OF le_imp_power_dvd])
+
+lemma dvd_power_same:
+  "x dvd y \<Longrightarrow> x ^ n dvd y ^ n"
+  by (induct n) (auto simp add: mult_dvd_mono)
+
+lemma dvd_power_le:
+  "x dvd y \<Longrightarrow> m \<ge> n \<Longrightarrow> x ^ n dvd y ^ m"
+  by (rule power_le_dvd [OF dvd_power_same])
 
-lemma zero_le_power[simp]:
-     "0 \<le> (a::'a::{ordered_semidom,recpower}) ==> 0 \<le> a^n"
-by (induct n) (simp_all add: mult_nonneg_nonneg)
+lemma dvd_power [simp]:
+  assumes "n > (0::nat) \<or> x = 1"
+  shows "x dvd (x ^ n)"
+using assms proof
+  assume "0 < n"
+  then have "x ^ n = x ^ Suc (n - 1)" by simp
+  then show "x dvd (x ^ n)" by simp
+next
+  assume "x = 1"
+  then show "x dvd (x ^ n)" by simp
+qed
+
+end
+
+context ring_1
+begin
+
+lemma power_minus:
+  "(- a) ^ n = (- 1) ^ n * a ^ n"
+proof (induct n)
+  case 0 show ?case by simp
+next
+  case (Suc n) then show ?case
+    by (simp del: power_Suc add: power_Suc2 mult_assoc)
+qed
+
+end
+
+context ordered_semidom
+begin
+
+lemma zero_less_power [simp]:
+  "0 < a \<Longrightarrow> 0 < a ^ n"
+  by (induct n) (simp_all add: mult_pos_pos)
+
+lemma zero_le_power [simp]:
+  "0 \<le> a \<Longrightarrow> 0 \<le> a ^ n"
+  by (induct n) (simp_all add: mult_nonneg_nonneg)
 
 lemma one_le_power[simp]:
-     "1 \<le> (a::'a::{ordered_semidom,recpower}) ==> 1 \<le> a^n"
-apply (induct "n")
-apply simp_all
-apply (rule order_trans [OF _ mult_mono [of 1 _ 1]])
-apply (simp_all add: order_trans [OF zero_le_one])
-done
-
-lemma gt1_imp_ge0: "1 < a ==> 0 \<le> (a::'a::ordered_semidom)"
-  by (simp add: order_trans [OF zero_le_one order_less_imp_le])
+  "1 \<le> a \<Longrightarrow> 1 \<le> a ^ n"
+  apply (induct n)
+  apply simp_all
+  apply (rule order_trans [OF _ mult_mono [of 1 _ 1]])
+  apply (simp_all add: order_trans [OF zero_le_one])
+  done
 
 lemma power_gt1_lemma:
-  assumes gt1: "1 < (a::'a::{ordered_semidom,recpower})"
-  shows "1 < a * a^n"
+  assumes gt1: "1 < a"
+  shows "1 < a * a ^ n"
 proof -
-  have "1*1 < a*1" using gt1 by simp
-  also have "\<dots> \<le> a * a^n" using gt1
-    by (simp only: mult_mono gt1_imp_ge0 one_le_power order_less_imp_le
+  from gt1 have "0 \<le> a"
+    by (fact order_trans [OF zero_le_one less_imp_le])
+  have "1 * 1 < a * 1" using gt1 by simp
+  also have "\<dots> \<le> a * a ^ n" using gt1
+    by (simp only: mult_mono `0 \<le> a` one_le_power order_less_imp_le
         zero_le_one order_refl)
   finally show ?thesis by simp
 qed
 
-lemma one_less_power[simp]:
-  "\<lbrakk>1 < (a::'a::{ordered_semidom,recpower}); 0 < n\<rbrakk> \<Longrightarrow> 1 < a ^ n"
-by (cases n, simp_all add: power_gt1_lemma)
+lemma power_gt1:
+  "1 < a \<Longrightarrow> 1 < a ^ Suc n"
+  by (simp add: power_gt1_lemma)
 
-lemma power_gt1:
-     "1 < (a::'a::{ordered_semidom,recpower}) ==> 1 < a ^ (Suc n)"
-by (simp add: power_gt1_lemma)
+lemma one_less_power [simp]:
+  "1 < a \<Longrightarrow> 0 < n \<Longrightarrow> 1 < a ^ n"
+  by (cases n) (simp_all add: power_gt1_lemma)
 
 lemma power_le_imp_le_exp:
-  assumes gt1: "(1::'a::{recpower,ordered_semidom}) < a"
-  shows "!!n. a^m \<le> a^n ==> m \<le> n"
-proof (induct m)
+  assumes gt1: "1 < a"
+  shows "a ^ m \<le> a ^ n \<Longrightarrow> m \<le> n"
+proof (induct m arbitrary: n)
   case 0
   show ?case by simp
 next
@@ -97,212 +181,128 @@
   show ?case
   proof (cases n)
     case 0
-    from prems have "a * a^m \<le> 1" by simp
+    with Suc.prems Suc.hyps have "a * a ^ m \<le> 1" by simp
     with gt1 show ?thesis
       by (force simp only: power_gt1_lemma
-          linorder_not_less [symmetric])
+          not_less [symmetric])
   next
     case (Suc n)
-    from prems show ?thesis
+    with Suc.prems Suc.hyps show ?thesis
       by (force dest: mult_left_le_imp_le
-          simp add: order_less_trans [OF zero_less_one gt1])
+          simp add: less_trans [OF zero_less_one gt1])
   qed
 qed
 
 text{*Surely we can strengthen this? It holds for @{text "0<a<1"} too.*}
 lemma power_inject_exp [simp]:
-     "1 < (a::'a::{ordered_semidom,recpower}) ==> (a^m = a^n) = (m=n)"
+  "1 < a \<Longrightarrow> a ^ m = a ^ n \<longleftrightarrow> m = n"
   by (force simp add: order_antisym power_le_imp_le_exp)
 
 text{*Can relax the first premise to @{term "0<a"} in the case of the
 natural numbers.*}
 lemma power_less_imp_less_exp:
-     "[| (1::'a::{recpower,ordered_semidom}) < a; a^m < a^n |] ==> m < n"
-by (simp add: order_less_le [of m n] order_less_le [of "a^m" "a^n"]
-              power_le_imp_le_exp)
-
+  "1 < a \<Longrightarrow> a ^ m < a ^ n \<Longrightarrow> m < n"
+  by (simp add: order_less_le [of m n] less_le [of "a^m" "a^n"]
+    power_le_imp_le_exp)
 
 lemma power_mono:
-     "[|a \<le> b; (0::'a::{recpower,ordered_semidom}) \<le> a|] ==> a^n \<le> b^n"
-apply (induct "n")
-apply simp_all
-apply (auto intro: mult_mono order_trans [of 0 a b])
-done
+  "a \<le> b \<Longrightarrow> 0 \<le> a \<Longrightarrow> a ^ n \<le> b ^ n"
+  by (induct n)
+    (auto intro: mult_mono order_trans [of 0 a b])
 
 lemma power_strict_mono [rule_format]:
-     "[|a < b; (0::'a::{recpower,ordered_semidom}) \<le> a|]
-      ==> 0 < n --> a^n < b^n"
-apply (induct "n")
-apply (auto simp add: mult_strict_mono order_le_less_trans [of 0 a b])
-done
-
-lemma power_eq_0_iff [simp]:
-  "(a^n = 0) \<longleftrightarrow>
-   (a = (0::'a::{mult_zero,zero_neq_one,no_zero_divisors,recpower}) & n\<noteq>0)"
-apply (induct "n")
-apply (auto simp add: no_zero_divisors)
-done
-
-
-lemma field_power_not_zero:
-  "a \<noteq> (0::'a::{ring_1_no_zero_divisors,recpower}) ==> a^n \<noteq> 0"
-by force
-
-lemma nonzero_power_inverse:
-  fixes a :: "'a::{division_ring,recpower}"
-  shows "a \<noteq> 0 ==> inverse (a ^ n) = (inverse a) ^ n"
-apply (induct "n")
-apply (auto simp add: nonzero_inverse_mult_distrib power_commutes)
-done (* TODO: reorient or rename to nonzero_inverse_power *)
-
-text{*Perhaps these should be simprules.*}
-lemma power_inverse:
-  fixes a :: "'a::{division_ring,division_by_zero,recpower}"
-  shows "inverse (a ^ n) = (inverse a) ^ n"
-apply (cases "a = 0")
-apply (simp add: power_0_left)
-apply (simp add: nonzero_power_inverse)
-done (* TODO: reorient or rename to inverse_power *)
-
-lemma power_one_over: "1 / (a::'a::{field,division_by_zero,recpower})^n = 
-    (1 / a)^n"
-apply (simp add: divide_inverse)
-apply (rule power_inverse)
-done
-
-lemma nonzero_power_divide:
-    "b \<noteq> 0 ==> (a/b) ^ n = ((a::'a::{field,recpower}) ^ n) / (b ^ n)"
-by (simp add: divide_inverse power_mult_distrib nonzero_power_inverse)
-
-lemma power_divide:
-    "(a/b) ^ n = ((a::'a::{field,division_by_zero,recpower}) ^ n / b ^ n)"
-apply (case_tac "b=0", simp add: power_0_left)
-apply (rule nonzero_power_divide)
-apply assumption
-done
-
-lemma power_abs: "abs(a ^ n) = abs(a::'a::{ordered_idom,recpower}) ^ n"
-apply (induct "n")
-apply (auto simp add: abs_mult)
-done
-
-lemma abs_power_minus [simp]:
-  fixes a:: "'a::{ordered_idom,recpower}" shows "abs((-a) ^ n) = abs(a ^ n)"
-  by (simp add: abs_minus_cancel power_abs) 
-
-lemma zero_less_power_abs_iff [simp,noatp]:
-     "(0 < (abs a)^n) = (a \<noteq> (0::'a::{ordered_idom,recpower}) | n=0)"
-proof (induct "n")
-  case 0
-    show ?case by simp
-next
-  case (Suc n)
-    show ?case by (auto simp add: prems zero_less_mult_iff)
-qed
-
-lemma zero_le_power_abs [simp]:
-     "(0::'a::{ordered_idom,recpower}) \<le> (abs a)^n"
-by (rule zero_le_power [OF abs_ge_zero])
-
-lemma power_minus: "(-a) ^ n = (- 1)^n * (a::'a::{ring_1,recpower}) ^ n"
-proof (induct n)
-  case 0 show ?case by simp
-next
-  case (Suc n) then show ?case
-    by (simp del: power_Suc add: power_Suc2 mult_assoc)
-qed
+  "a < b \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 < n \<longrightarrow> a ^ n < b ^ n"
+  by (induct n)
+   (auto simp add: mult_strict_mono le_less_trans [of 0 a b])
 
 text{*Lemma for @{text power_strict_decreasing}*}
 lemma power_Suc_less:
-     "[|(0::'a::{ordered_semidom,recpower}) < a; a < 1|]
-      ==> a * a^n < a^n"
-apply (induct n)
-apply (auto simp add: mult_strict_left_mono)
-done
+  "0 < a \<Longrightarrow> a < 1 \<Longrightarrow> a * a ^ n < a ^ n"
+  by (induct n)
+    (auto simp add: mult_strict_left_mono)
 
-lemma power_strict_decreasing:
-     "[|n < N; 0 < a; a < (1::'a::{ordered_semidom,recpower})|]
-      ==> a^N < a^n"
-apply (erule rev_mp)
-apply (induct "N")
-apply (auto simp add: power_Suc_less less_Suc_eq)
-apply (rename_tac m)
-apply (subgoal_tac "a * a^m < 1 * a^n", simp)
-apply (rule mult_strict_mono)
-apply (auto simp add: order_less_imp_le)
-done
+lemma power_strict_decreasing [rule_format]:
+  "n < N \<Longrightarrow> 0 < a \<Longrightarrow> a < 1 \<longrightarrow> a ^ N < a ^ n"
+proof (induct N)
+  case 0 then show ?case by simp
+next
+  case (Suc N) then show ?case 
+  apply (auto simp add: power_Suc_less less_Suc_eq)
+  apply (subgoal_tac "a * a^N < 1 * a^n")
+  apply simp
+  apply (rule mult_strict_mono) apply auto
+  done
+qed
 
 text{*Proof resembles that of @{text power_strict_decreasing}*}
-lemma power_decreasing:
-     "[|n \<le> N; 0 \<le> a; a \<le> (1::'a::{ordered_semidom,recpower})|]
-      ==> a^N \<le> a^n"
-apply (erule rev_mp)
-apply (induct "N")
-apply (auto simp add: le_Suc_eq)
-apply (rename_tac m)
-apply (subgoal_tac "a * a^m \<le> 1 * a^n", simp)
-apply (rule mult_mono)
-apply auto
-done
+lemma power_decreasing [rule_format]:
+  "n \<le> N \<Longrightarrow> 0 \<le> a \<Longrightarrow> a \<le> 1 \<longrightarrow> a ^ N \<le> a ^ n"
+proof (induct N)
+  case 0 then show ?case by simp
+next
+  case (Suc N) then show ?case 
+  apply (auto simp add: le_Suc_eq)
+  apply (subgoal_tac "a * a^N \<le> 1 * a^n", simp)
+  apply (rule mult_mono) apply auto
+  done
+qed
 
 lemma power_Suc_less_one:
-     "[| 0 < a; a < (1::'a::{ordered_semidom,recpower}) |] ==> a ^ Suc n < 1"
-apply (insert power_strict_decreasing [of 0 "Suc n" a], simp)
-done
+  "0 < a \<Longrightarrow> a < 1 \<Longrightarrow> a ^ Suc n < 1"
+  using power_strict_decreasing [of 0 "Suc n" a] by simp
 
 text{*Proof again resembles that of @{text power_strict_decreasing}*}
-lemma power_increasing:
-     "[|n \<le> N; (1::'a::{ordered_semidom,recpower}) \<le> a|] ==> a^n \<le> a^N"
-apply (erule rev_mp)
-apply (induct "N")
-apply (auto simp add: le_Suc_eq)
-apply (rename_tac m)
-apply (subgoal_tac "1 * a^n \<le> a * a^m", simp)
-apply (rule mult_mono)
-apply (auto simp add: order_trans [OF zero_le_one])
-done
+lemma power_increasing [rule_format]:
+  "n \<le> N \<Longrightarrow> 1 \<le> a \<Longrightarrow> a ^ n \<le> a ^ N"
+proof (induct N)
+  case 0 then show ?case by simp
+next
+  case (Suc N) then show ?case 
+  apply (auto simp add: le_Suc_eq)
+  apply (subgoal_tac "1 * a^n \<le> a * a^N", simp)
+  apply (rule mult_mono) apply (auto simp add: order_trans [OF zero_le_one])
+  done
+qed
 
 text{*Lemma for @{text power_strict_increasing}*}
 lemma power_less_power_Suc:
-     "(1::'a::{ordered_semidom,recpower}) < a ==> a^n < a * a^n"
-apply (induct n)
-apply (auto simp add: mult_strict_left_mono order_less_trans [OF zero_less_one])
-done
+  "1 < a \<Longrightarrow> a ^ n < a * a ^ n"
+  by (induct n) (auto simp add: mult_strict_left_mono less_trans [OF zero_less_one])
 
-lemma power_strict_increasing:
-     "[|n < N; (1::'a::{ordered_semidom,recpower}) < a|] ==> a^n < a^N"
-apply (erule rev_mp)
-apply (induct "N")
-apply (auto simp add: power_less_power_Suc less_Suc_eq)
-apply (rename_tac m)
-apply (subgoal_tac "1 * a^n < a * a^m", simp)
-apply (rule mult_strict_mono)
-apply (auto simp add: order_less_trans [OF zero_less_one] order_less_imp_le)
-done
+lemma power_strict_increasing [rule_format]:
+  "n < N \<Longrightarrow> 1 < a \<longrightarrow> a ^ n < a ^ N"
+proof (induct N)
+  case 0 then show ?case by simp
+next
+  case (Suc N) then show ?case 
+  apply (auto simp add: power_less_power_Suc less_Suc_eq)
+  apply (subgoal_tac "1 * a^n < a * a^N", simp)
+  apply (rule mult_strict_mono) apply (auto simp add: less_trans [OF zero_less_one] less_imp_le)
+  done
+qed
 
 lemma power_increasing_iff [simp]:
-  "1 < (b::'a::{ordered_semidom,recpower}) ==> (b ^ x \<le> b ^ y) = (x \<le> y)"
-by (blast intro: power_le_imp_le_exp power_increasing order_less_imp_le) 
+  "1 < b \<Longrightarrow> b ^ x \<le> b ^ y \<longleftrightarrow> x \<le> y"
+  by (blast intro: power_le_imp_le_exp power_increasing less_imp_le)
 
 lemma power_strict_increasing_iff [simp]:
-  "1 < (b::'a::{ordered_semidom,recpower}) ==> (b ^ x < b ^ y) = (x < y)"
+  "1 < b \<Longrightarrow> b ^ x < b ^ y \<longleftrightarrow> x < y"
 by (blast intro: power_less_imp_less_exp power_strict_increasing) 
 
 lemma power_le_imp_le_base:
-assumes le: "a ^ Suc n \<le> b ^ Suc n"
-    and ynonneg: "(0::'a::{ordered_semidom,recpower}) \<le> b"
-shows "a \<le> b"
+  assumes le: "a ^ Suc n \<le> b ^ Suc n"
+    and ynonneg: "0 \<le> b"
+  shows "a \<le> b"
 proof (rule ccontr)
   assume "~ a \<le> b"
   then have "b < a" by (simp only: linorder_not_le)
   then have "b ^ Suc n < a ^ Suc n"
     by (simp only: prems power_strict_mono)
-  from le and this show "False"
+  from le and this show False
     by (simp add: linorder_not_less [symmetric])
 qed
 
 lemma power_less_imp_less_base:
-  fixes a b :: "'a::{ordered_semidom,recpower}"
   assumes less: "a ^ n < b ^ n"
   assumes nonneg: "0 \<le> b"
   shows "a < b"
@@ -310,98 +310,140 @@
   assume "~ a < b"
   hence "b \<le> a" by (simp only: linorder_not_less)
   hence "b ^ n \<le> a ^ n" using nonneg by (rule power_mono)
-  thus "~ a ^ n < b ^ n" by (simp only: linorder_not_less)
+  thus "\<not> a ^ n < b ^ n" by (simp only: linorder_not_less)
 qed
 
 lemma power_inject_base:
-     "[| a ^ Suc n = b ^ Suc n; 0 \<le> a; 0 \<le> b |]
-      ==> a = (b::'a::{ordered_semidom,recpower})"
-by (blast intro: power_le_imp_le_base order_antisym order_eq_refl sym)
+  "a ^ Suc n = b ^ Suc n \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> a = b"
+by (blast intro: power_le_imp_le_base antisym eq_refl sym)
 
 lemma power_eq_imp_eq_base:
-  fixes a b :: "'a::{ordered_semidom,recpower}"
-  shows "\<lbrakk>a ^ n = b ^ n; 0 \<le> a; 0 \<le> b; 0 < n\<rbrakk> \<Longrightarrow> a = b"
-by (cases n, simp_all del: power_Suc, rule power_inject_base)
+  "a ^ n = b ^ n \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> 0 < n \<Longrightarrow> a = b"
+  by (cases n) (simp_all del: power_Suc, rule power_inject_base)
 
-text {* The divides relation *}
+end
+
+context ordered_idom
+begin
 
-lemma le_imp_power_dvd:
-  fixes a :: "'a::{comm_semiring_1,recpower}"
-  assumes "m \<le> n" shows "a^m dvd a^n"
-proof
-  have "a^n = a^(m + (n - m))"
-    using `m \<le> n` by simp
-  also have "\<dots> = a^m * a^(n - m)"
-    by (rule power_add)
-  finally show "a^n = a^m * a^(n - m)" .
+lemma power_abs:
+  "abs (a ^ n) = abs a ^ n"
+  by (induct n) (auto simp add: abs_mult)
+
+lemma abs_power_minus [simp]:
+  "abs ((-a) ^ n) = abs (a ^ n)"
+  by (simp add: abs_minus_cancel power_abs) 
+
+lemma zero_less_power_abs_iff [simp, noatp]:
+  "0 < abs a ^ n \<longleftrightarrow> a \<noteq> 0 \<or> n = 0"
+proof (induct n)
+  case 0 show ?case by simp
+next
+  case (Suc n) show ?case by (auto simp add: Suc zero_less_mult_iff)
 qed
 
-lemma power_le_dvd:
-  fixes a b :: "'a::{comm_semiring_1,recpower}"
-  shows "a^n dvd b \<Longrightarrow> m \<le> n \<Longrightarrow> a^m dvd b"
-  by (rule dvd_trans [OF le_imp_power_dvd])
+lemma zero_le_power_abs [simp]:
+  "0 \<le> abs a ^ n"
+  by (rule zero_le_power [OF abs_ge_zero])
+
+end
+
+context ring_1_no_zero_divisors
+begin
+
+lemma field_power_not_zero:
+  "a \<noteq> 0 \<Longrightarrow> a ^ n \<noteq> 0"
+  by (induct n) auto
+
+end
 
+context division_ring
+begin
 
-lemma dvd_power_same:
-  "(x::'a::{comm_semiring_1,recpower}) dvd y \<Longrightarrow> x^n dvd y^n"
-by (induct n) (auto simp add: mult_dvd_mono)
+text {* FIXME reorient or rename to @{text nonzero_inverse_power} *}
+lemma nonzero_power_inverse:
+  "a \<noteq> 0 \<Longrightarrow> inverse (a ^ n) = (inverse a) ^ n"
+  by (induct n)
+    (simp_all add: nonzero_inverse_mult_distrib power_commutes field_power_not_zero)
+
+end
+
+context field
+begin
+
+lemma nonzero_power_divide:
+  "b \<noteq> 0 \<Longrightarrow> (a / b) ^ n = a ^ n / b ^ n"
+  by (simp add: divide_inverse power_mult_distrib nonzero_power_inverse)
+
+end
 
-lemma dvd_power_le:
-  "(x::'a::{comm_semiring_1,recpower}) dvd y \<Longrightarrow> m >= n \<Longrightarrow> x^n dvd y^m"
-by(rule power_le_dvd[OF dvd_power_same])
+lemma power_0_Suc [simp]:
+  "(0::'a::{power, semiring_0}) ^ Suc n = 0"
+  by simp
+
+text{*It looks plausible as a simprule, but its effect can be strange.*}
+lemma power_0_left:
+  "0 ^ n = (if n = 0 then 1 else (0::'a::{power, semiring_0}))"
+  by (induct n) simp_all
+
+lemma power_eq_0_iff [simp]:
+  "a ^ n = 0 \<longleftrightarrow>
+     a = (0::'a::{mult_zero,zero_neq_one,no_zero_divisors,power}) \<and> n \<noteq> 0"
+  by (induct n)
+    (auto simp add: no_zero_divisors elim: contrapos_pp)
 
-lemma dvd_power [simp]:
-  "n > 0 | (x::'a::{comm_semiring_1,recpower}) = 1 \<Longrightarrow> x dvd x^n"
-apply (erule disjE)
- apply (subgoal_tac "x ^ n = x^(Suc (n - 1))")
-  apply (erule ssubst)
-  apply (subst power_Suc)
-  apply auto
+lemma power_diff:
+  fixes a :: "'a::field"
+  assumes nz: "a \<noteq> 0"
+  shows "n \<le> m \<Longrightarrow> a ^ (m - n) = a ^ m / a ^ n"
+  by (induct m n rule: diff_induct) (simp_all add: nz)
+
+text{*Perhaps these should be simprules.*}
+lemma power_inverse:
+  fixes a :: "'a::{division_ring,division_by_zero,power}"
+  shows "inverse (a ^ n) = (inverse a) ^ n"
+apply (cases "a = 0")
+apply (simp add: power_0_left)
+apply (simp add: nonzero_power_inverse)
+done (* TODO: reorient or rename to inverse_power *)
+
+lemma power_one_over:
+  "1 / (a::'a::{field,division_by_zero, power}) ^ n =  (1 / a) ^ n"
+  by (simp add: divide_inverse) (rule power_inverse)
+
+lemma power_divide:
+  "(a / b) ^ n = (a::'a::{field,division_by_zero}) ^ n / b ^ n"
+apply (cases "b = 0")
+apply (simp add: power_0_left)
+apply (rule nonzero_power_divide)
+apply assumption
 done
 
 
-subsection{*Exponentiation for the Natural Numbers*}
-
-instantiation nat :: recpower
-begin
-
-primrec power_nat where
-  "p ^ 0 = (1\<Colon>nat)"
-  | "p ^ (Suc n) = (p\<Colon>nat) * (p ^ n)"
+subsection {* Exponentiation for the Natural Numbers *}
 
-instance proof
-  fix z n :: nat
-  show "z^0 = 1" by simp
-  show "z^(Suc n) = z * (z^n)" by simp
-qed
-
-declare power_nat.simps [simp del]
-
-end
+lemma nat_one_le_power [simp]:
+  "Suc 0 \<le> i \<Longrightarrow> Suc 0 \<le> i ^ n"
+  by (rule one_le_power [of i n, unfolded One_nat_def])
 
-lemma of_nat_power:
-  "of_nat (m ^ n) = (of_nat m::'a::{semiring_1,recpower}) ^ n"
-by (induct n, simp_all add: of_nat_mult)
-
-lemma nat_one_le_power [simp]: "Suc 0 \<le> i ==> Suc 0 \<le> i^n"
-by (rule one_le_power [of i n, unfolded One_nat_def])
-
-lemma nat_zero_less_power_iff [simp]: "(x^n > 0) = (x > (0::nat) | n=0)"
-by (induct "n", auto)
+lemma nat_zero_less_power_iff [simp]:
+  "x ^ n > 0 \<longleftrightarrow> x > (0::nat) \<or> n = 0"
+  by (induct n) auto
 
 lemma nat_power_eq_Suc_0_iff [simp]: 
-  "((x::nat)^m = Suc 0) = (m = 0 | x = Suc 0)"
-by (induct_tac m, auto)
+  "x ^ m = Suc 0 \<longleftrightarrow> m = 0 \<or> x = Suc 0"
+  by (induct m) auto
 
-lemma power_Suc_0[simp]: "(Suc 0)^n = Suc 0"
-by simp
+lemma power_Suc_0 [simp]:
+  "Suc 0 ^ n = Suc 0"
+  by simp
 
 text{*Valid for the naturals, but what if @{text"0<i<1"}?
 Premises cannot be weakened: consider the case where @{term "i=0"},
 @{term "m=1"} and @{term "n=0"}.*}
 lemma nat_power_less_imp_less:
   assumes nonneg: "0 < (i\<Colon>nat)"
-  assumes less: "i^m < i^n"
+  assumes less: "i ^ m < i ^ n"
   shows "m < n"
 proof (cases "i = 1")
   case True with less power_one [where 'a = nat] show ?thesis by simp
@@ -410,10 +452,13 @@
   from power_strict_increasing_iff [OF this] less show ?thesis ..
 qed
 
-lemma power_diff:
-  assumes nz: "a ~= 0"
-  shows "n <= m ==> (a::'a::{recpower, field}) ^ (m-n) = (a^m) / (a^n)"
-  by (induct m n rule: diff_induct)
-    (simp_all add: nonzero_mult_divide_cancel_left nz)
+
+subsection {* Code generator tweak *}
+
+lemma power_power_power [code, code unfold, code inline del]:
+  "power = power.power (1::'a::{power}) (op *)"
+  unfolding power_def power.power_def ..
+
+declare power.power.simps [code]
 
 end

--- a/src/HOL/Predicate.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Predicate.thy	Fri May 15 15:56:28 2009 +0200
@@ -610,7 +610,7 @@
     (simp_all add: Seq_def single_less_eq_eval contained_less_eq)
 
 lemma eq_pred_code [code]:
-  fixes P Q :: "'a::eq pred"
+  fixes P Q :: "'a pred"
   shows "eq_class.eq P Q \<longleftrightarrow> P \<le> Q \<and> Q \<le> P"
   unfolding eq by auto
 
@@ -625,7 +625,71 @@
 inductive eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where "eq x x"
 
 lemma eq_is_eq: "eq x y \<equiv> (x = y)"
-by (rule eq_reflection) (auto intro: eq.intros elim: eq.cases)
+  by (rule eq_reflection) (auto intro: eq.intros elim: eq.cases)
+
+ML {*
+signature PREDICATE =
+sig
+  datatype 'a pred = Seq of (unit -> 'a seq)
+  and 'a seq = Empty | Insert of 'a * 'a pred | Join of 'a pred * 'a seq
+  val yield: 'a pred -> ('a * 'a pred) option
+  val yieldn: int -> 'a pred -> 'a list * 'a pred
+end;
+
+structure Predicate : PREDICATE =
+struct
+
+@{code_datatype pred = Seq};
+@{code_datatype seq = Empty | Insert | Join};
+
+fun yield (Seq f) = next (f ())
+and next @{code Empty} = NONE
+  | next (@{code Insert} (x, P)) = SOME (x, P)
+  | next (@{code Join} (P, xq)) = (case yield P
+     of NONE => next xq
+      | SOME (x, Q) => SOME (x, @{code Seq} (fn _ => @{code Join} (Q, xq))))
+
+fun anamorph f k x = (if k = 0 then ([], x)
+  else case f x
+   of NONE => ([], x)
+    | SOME (v, y) => let
+        val (vs, z) = anamorph f (k - 1) y
+      in (v :: vs, z) end)
+
+fun yieldn P = anamorph yield P;
+
+end;
+*}
+
+code_reserved Eval Predicate
+
+code_type pred and seq
+  (Eval "_/ Predicate.pred" and "_/ Predicate.seq")
+
+code_const Seq and Empty and Insert and Join
+  (Eval "Predicate.Seq" and "Predicate.Empty" and "Predicate.Insert/ (_,/ _)" and "Predicate.Join/ (_,/ _)")
+
+text {* dummy setup for @{text code_pred} and @{text values} keywords *}
+
+ML {*
+local
+
+structure P = OuterParse;
+
+val opt_modes = Scan.optional (P.$$$ "(" |-- P.!!! (Scan.repeat1 P.xname --| P.$$$ ")")) [];
+
+in
+
+val _ = OuterSyntax.local_theory_to_proof "code_pred" "sets up goal for cases rule from given introduction rules and compiles predicate"
+  OuterKeyword.thy_goal (P.term_group >> (K (Proof.theorem_i NONE (K I) [[]])));
+
+val _ = OuterSyntax.improper_command "values" "evaluate and print enumerations"
+  OuterKeyword.diag ((opt_modes -- P.term)
+    >> (fn (modes, t) => Toplevel.no_timing o Toplevel.keep
+        (K ())));
+
+end
+*}
 
 no_notation
   inf (infixl "\<sqinter>" 70) and
@@ -640,12 +704,4 @@
 hide (open) const Pred eval single bind if_pred not_pred
   Empty Insert Join Seq member pred_of_seq "apply" adjunct eq
 
-text {* dummy setup for code_pred keyword *}
-
-ML {*
-OuterSyntax.local_theory_to_proof "code_pred" "sets up goal for cases rule from given introduction rules and compiles predicate"
-  OuterKeyword.thy_goal (OuterParse.term_group >> (K (Proof.theorem_i NONE (K I) [[]])))
-*}
-
-
 end

--- a/src/HOL/Product_Type.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Product_Type.thy	Fri May 15 15:56:28 2009 +0200
@@ -84,6 +84,14 @@
 lemma unit_abs_eta_conv [simp,noatp]: "(%u::unit. f ()) = f"
   by (rule ext) simp
 
+instantiation unit :: default
+begin
+
+definition "default = ()"
+
+instance ..
+
+end
 
 text {* code generator setup *}
 

--- a/src/HOL/Rational.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Rational.thy	Fri May 15 15:56:28 2009 +0200
@@ -6,7 +6,6 @@
 
 theory Rational
 imports GCD Archimedean_Field
-uses ("Tools/rat_arith.ML")
 begin
 
 subsection {* Rational numbers as quotient *}
@@ -90,7 +89,7 @@
   and "\<And>a c. Fract 0 a = Fract 0 c"
   by (simp_all add: Fract_def)
 
-instantiation rat :: "{comm_ring_1, recpower}"
+instantiation rat :: comm_ring_1
 begin
 
 definition
@@ -156,11 +155,6 @@
   then show ?thesis by (simp add: mult_rat [symmetric])
 qed
 
-primrec power_rat
-where
-  "q ^ 0 = (1\<Colon>rat)"
-| "q ^ Suc n = (q\<Colon>rat) * (q ^ n)"
-
 instance proof
   fix q r s :: rat show "(q * r) * s = q * (r * s)" 
     by (cases q, cases r, cases s) (simp add: eq_rat)
@@ -190,18 +184,8 @@
     by (cases q, cases r, cases s) (simp add: eq_rat algebra_simps)
 next
   show "(0::rat) \<noteq> 1" by (simp add: Zero_rat_def One_rat_def eq_rat)
-next
-  fix q :: rat show "q * 1 = q"
-    by (cases q) (simp add: One_rat_def eq_rat)
-next
-  fix q :: rat
-  fix n :: nat
-  show "q ^ 0 = 1" by simp
-  show "q ^ (Suc n) = q * (q ^ n)" by simp
 qed
 
-declare power_rat.simps [simp del]
-
 end
 
 lemma of_nat_rat: "of_nat k = Fract (of_nat k) 1"
@@ -222,7 +206,8 @@
 definition
   rat_number_of_def [code del]: "number_of w = Fract w 1"
 
-instance by intro_classes (simp add: rat_number_of_def of_int_rat)
+instance proof
+qed (simp add: rat_number_of_def of_int_rat)
 
 end
 
@@ -596,10 +581,25 @@
   by (simp add: floor_unique)
 
 
-subsection {* Arithmetic setup *}
+subsection {* Linear arithmetic setup *}
 
-use "Tools/rat_arith.ML"
-declaration {* K rat_arith_setup *}
+declaration {*
+  K (Lin_Arith.add_inj_thms [@{thm of_nat_le_iff} RS iffD2, @{thm of_nat_eq_iff} RS iffD2]
+    (* not needed because x < (y::nat) can be rewritten as Suc x <= y: of_nat_less_iff RS iffD2 *)
+  #> Lin_Arith.add_inj_thms [@{thm of_int_le_iff} RS iffD2, @{thm of_int_eq_iff} RS iffD2]
+    (* not needed because x < (y::int) can be rewritten as x + 1 <= y: of_int_less_iff RS iffD2 *)
+  #> Lin_Arith.add_simps [@{thm neg_less_iff_less},
+      @{thm True_implies_equals},
+      read_instantiate @{context} [(("a", 0), "(number_of ?v)")] @{thm right_distrib},
+      @{thm divide_1}, @{thm divide_zero_left},
+      @{thm times_divide_eq_right}, @{thm times_divide_eq_left},
+      @{thm minus_divide_left} RS sym, @{thm minus_divide_right} RS sym,
+      @{thm of_int_minus}, @{thm of_int_diff},
+      @{thm of_int_of_nat_eq}]
+  #> Lin_Arith.add_simprocs Numeral_Simprocs.field_cancel_numeral_factors
+  #> Lin_Arith.add_inj_const (@{const_name of_nat}, @{typ "nat => rat"})
+  #> Lin_Arith.add_inj_const (@{const_name of_int}, @{typ "int => rat"}))
+*}
 
 
 subsection {* Embedding from Rationals to other Fields *}
@@ -667,7 +667,7 @@
 by (cases "b = 0") (simp_all add: nonzero_of_rat_divide)
 
 lemma of_rat_power:
-  "(of_rat (a ^ n)::'a::{field_char_0,recpower}) = of_rat a ^ n"
+  "(of_rat (a ^ n)::'a::field_char_0) = of_rat a ^ n"
 by (induct n) (simp_all add: of_rat_mult)
 
 lemma of_rat_eq_iff [simp]: "(of_rat a = of_rat b) = (a = b)"
@@ -827,7 +827,7 @@
 done
 
 lemma Rats_power [simp]:
-  fixes a :: "'a::{field_char_0,recpower}"
+  fixes a :: "'a::field_char_0"
   shows "a \<in> Rats \<Longrightarrow> a ^ n \<in> Rats"
 apply (auto simp add: Rats_def)
 apply (rule range_eqI)

--- a/src/HOL/RealDef.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/RealDef.thy	Fri May 15 15:56:28 2009 +0200
@@ -9,7 +9,6 @@
 
 theory RealDef
 imports PReal
-uses ("Tools/real_arith.ML")
 begin
 
 definition
@@ -960,10 +959,20 @@
         (if neg (number_of v :: int) then 0  
          else (number_of v :: real))"
 by (simp add: real_of_int_real_of_nat [symmetric] int_nat_number_of)
- 
 
-use "Tools/real_arith.ML"
-declaration {* K real_arith_setup *}
+declaration {*
+  K (Lin_Arith.add_inj_thms [@{thm real_of_nat_le_iff} RS iffD2, @{thm real_of_nat_inject} RS iffD2]
+    (* not needed because x < (y::nat) can be rewritten as Suc x <= y: real_of_nat_less_iff RS iffD2 *)
+  #> Lin_Arith.add_inj_thms [@{thm real_of_int_le_iff} RS iffD2, @{thm real_of_int_inject} RS iffD2]
+    (* not needed because x < (y::int) can be rewritten as x + 1 <= y: real_of_int_less_iff RS iffD2 *)
+  #> Lin_Arith.add_simps [@{thm real_of_nat_zero}, @{thm real_of_nat_Suc}, @{thm real_of_nat_add},
+      @{thm real_of_nat_mult}, @{thm real_of_int_zero}, @{thm real_of_one},
+      @{thm real_of_int_add}, @{thm real_of_int_minus}, @{thm real_of_int_diff},
+      @{thm real_of_int_mult}, @{thm real_of_int_of_nat_eq},
+      @{thm real_of_nat_number_of}, @{thm real_number_of}]
+  #> Lin_Arith.add_inj_const (@{const_name real}, HOLogic.natT --> HOLogic.realT)
+  #> Lin_Arith.add_inj_const (@{const_name real}, HOLogic.intT --> HOLogic.realT))
+*}
 
 
 subsection{* Simprules combining x+y and 0: ARE THEY NEEDED?*}

--- a/src/HOL/RealPow.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/RealPow.thy	Fri May 15 15:56:28 2009 +0200
@@ -12,25 +12,6 @@
 
 declare abs_mult_self [simp]
 
-instantiation real :: recpower
-begin
-
-primrec power_real where
-  "r ^ 0     = (1\<Colon>real)"
-| "r ^ Suc n = (r\<Colon>real) * r ^ n"
-
-instance proof
-  fix z :: real
-  fix n :: nat
-  show "z^0 = 1" by simp
-  show "z^(Suc n) = z * (z^n)" by simp
-qed
-
-declare power_real.simps [simp del]
-
-end
-
-
 lemma two_realpow_ge_one [simp]: "(1::real) \<le> 2 ^ n"
 by simp
 
@@ -47,7 +28,6 @@
 
 lemma realpow_minus_mult [rule_format]:
      "0 < n --> (x::real) ^ (n - 1) * x = x ^ n"
-unfolding One_nat_def
 apply (simp split add: nat_diff_split)
 done
 
@@ -101,75 +81,6 @@
 declare power_real_number_of [of _ "number_of w", standard, simp]
 
 
-subsection {* Properties of Squares *}
-
-lemma sum_squares_ge_zero:
-  fixes x y :: "'a::ordered_ring_strict"
-  shows "0 \<le> x * x + y * y"
-by (intro add_nonneg_nonneg zero_le_square)
-
-lemma not_sum_squares_lt_zero:
-  fixes x y :: "'a::ordered_ring_strict"
-  shows "\<not> x * x + y * y < 0"
-by (simp add: linorder_not_less sum_squares_ge_zero)
-
-lemma sum_nonneg_eq_zero_iff:
-  fixes x y :: "'a::pordered_ab_group_add"
-  assumes x: "0 \<le> x" and y: "0 \<le> y"
-  shows "(x + y = 0) = (x = 0 \<and> y = 0)"
-proof (auto)
-  from y have "x + 0 \<le> x + y" by (rule add_left_mono)
-  also assume "x + y = 0"
-  finally have "x \<le> 0" by simp
-  thus "x = 0" using x by (rule order_antisym)
-next
-  from x have "0 + y \<le> x + y" by (rule add_right_mono)
-  also assume "x + y = 0"
-  finally have "y \<le> 0" by simp
-  thus "y = 0" using y by (rule order_antisym)
-qed
-
-lemma sum_squares_eq_zero_iff:
-  fixes x y :: "'a::ordered_ring_strict"
-  shows "(x * x + y * y = 0) = (x = 0 \<and> y = 0)"
-by (simp add: sum_nonneg_eq_zero_iff)
-
-lemma sum_squares_le_zero_iff:
-  fixes x y :: "'a::ordered_ring_strict"
-  shows "(x * x + y * y \<le> 0) = (x = 0 \<and> y = 0)"
-by (simp add: order_le_less not_sum_squares_lt_zero sum_squares_eq_zero_iff)
-
-lemma sum_squares_gt_zero_iff:
-  fixes x y :: "'a::ordered_ring_strict"
-  shows "(0 < x * x + y * y) = (x \<noteq> 0 \<or> y \<noteq> 0)"
-by (simp add: order_less_le sum_squares_ge_zero sum_squares_eq_zero_iff)
-
-lemma sum_power2_ge_zero:
-  fixes x y :: "'a::{ordered_idom,recpower}"
-  shows "0 \<le> x\<twosuperior> + y\<twosuperior>"
-unfolding power2_eq_square by (rule sum_squares_ge_zero)
-
-lemma not_sum_power2_lt_zero:
-  fixes x y :: "'a::{ordered_idom,recpower}"
-  shows "\<not> x\<twosuperior> + y\<twosuperior> < 0"
-unfolding power2_eq_square by (rule not_sum_squares_lt_zero)
-
-lemma sum_power2_eq_zero_iff:
-  fixes x y :: "'a::{ordered_idom,recpower}"
-  shows "(x\<twosuperior> + y\<twosuperior> = 0) = (x = 0 \<and> y = 0)"
-unfolding power2_eq_square by (rule sum_squares_eq_zero_iff)
-
-lemma sum_power2_le_zero_iff:
-  fixes x y :: "'a::{ordered_idom,recpower}"
-  shows "(x\<twosuperior> + y\<twosuperior> \<le> 0) = (x = 0 \<and> y = 0)"
-unfolding power2_eq_square by (rule sum_squares_le_zero_iff)
-
-lemma sum_power2_gt_zero_iff:
-  fixes x y :: "'a::{ordered_idom,recpower}"
-  shows "(0 < x\<twosuperior> + y\<twosuperior>) = (x \<noteq> 0 \<or> y \<noteq> 0)"
-unfolding power2_eq_square by (rule sum_squares_gt_zero_iff)
-
-
 subsection{* Squares of Reals *}
 
 lemma real_two_squares_add_zero_iff [simp]:

--- a/src/HOL/RealVector.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/RealVector.thy	Fri May 15 15:56:28 2009 +0200
@@ -259,7 +259,7 @@
 by (simp add: divide_inverse)
 
 lemma of_real_power [simp]:
-  "of_real (x ^ n) = (of_real x :: 'a::{real_algebra_1,recpower}) ^ n"
+  "of_real (x ^ n) = (of_real x :: 'a::{real_algebra_1}) ^ n"
 by (induct n) simp_all
 
 lemma of_real_eq_iff [simp]: "(of_real x = of_real y) = (x = y)"
@@ -389,7 +389,7 @@
 done
 
 lemma Reals_power [simp]:
-  fixes a :: "'a::{real_algebra_1,recpower}"
+  fixes a :: "'a::{real_algebra_1}"
   shows "a \<in> Reals \<Longrightarrow> a ^ n \<in> Reals"
 apply (auto simp add: Reals_def)
 apply (rule range_eqI)
@@ -613,7 +613,7 @@
 by (simp add: divide_inverse norm_mult norm_inverse)
 
 lemma norm_power_ineq:
-  fixes x :: "'a::{real_normed_algebra_1,recpower}"
+  fixes x :: "'a::{real_normed_algebra_1}"
   shows "norm (x ^ n) \<le> norm x ^ n"
 proof (induct n)
   case 0 show "norm (x ^ 0) \<le> norm x ^ 0" by simp
@@ -628,7 +628,7 @@
 qed
 
 lemma norm_power:
-  fixes x :: "'a::{real_normed_div_algebra,recpower}"
+  fixes x :: "'a::{real_normed_div_algebra}"
   shows "norm (x ^ n) = norm x ^ n"
 by (induct n) (simp_all add: norm_mult)
 

--- a/src/HOL/Relation.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Relation.thy	Fri May 15 15:56:28 2009 +0200
@@ -6,7 +6,8 @@
 header {* Relations *}
 
 theory Relation
-imports Datatype Finite_Set
+imports Finite_Set Datatype
+  (*FIXME order is important, otherwise merge problem for canonical interpretation of class monoid_mult wrt. power!*)
 begin
 
 subsection {* Definitions *}

--- a/src/HOL/Relation_Power.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Relation_Power.thy	Fri May 15 15:56:28 2009 +0200
@@ -9,132 +9,124 @@
 imports Power Transitive_Closure Plain
 begin
 
-instance
-  "fun" :: (type, type) power ..
-      --{* only type @{typ "'a => 'a"} should be in class @{text power}!*}
+consts funpower :: "('a \<Rightarrow> 'b) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'b" (infixr "^^" 80)
 
 overloading
-  relpow \<equiv> "power \<Colon> ('a \<times> 'a) set \<Rightarrow> nat \<Rightarrow> ('a \<times> 'a) set"  (unchecked)
+  relpow \<equiv> "funpower \<Colon> ('a \<times> 'a) set \<Rightarrow> nat \<Rightarrow> ('a \<times> 'a) set"
 begin
 
-text {* @{text "R ^ n = R O ... O R"}, the n-fold composition of @{text R} *}
+text {* @{text "R ^^ n = R O ... O R"}, the n-fold composition of @{text R} *}
 
 primrec relpow where
-  "(R \<Colon> ('a \<times> 'a) set)  ^ 0 = Id"
-  | "(R \<Colon> ('a \<times> 'a) set) ^ Suc n = R O (R ^ n)"
+    "(R \<Colon> ('a \<times> 'a) set) ^^ 0 = Id"
+  | "(R \<Colon> ('a \<times> 'a) set) ^^ Suc n = R O (R ^^ n)"
 
 end
 
 overloading
-  funpow \<equiv> "power \<Colon>  ('a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a" (unchecked)
+  funpow \<equiv> "funpower \<Colon> ('a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a"
 begin
 
-text {* @{text "f ^ n = f o ... o f"}, the n-fold composition of @{text f} *}
+text {* @{text "f ^^ n = f o ... o f"}, the n-fold composition of @{text f} *}
 
 primrec funpow where
-  "(f \<Colon> 'a \<Rightarrow> 'a) ^ 0 = id"
-  | "(f \<Colon> 'a \<Rightarrow> 'a) ^ Suc n = f o (f ^ n)"
+    "(f \<Colon> 'a \<Rightarrow> 'a) ^^ 0 = id"
+  | "(f \<Colon> 'a \<Rightarrow> 'a) ^^ Suc n = f o (f ^^ n)"
 
 end
 
-text{*WARNING: due to the limits of Isabelle's type classes, exponentiation on
-functions and relations has too general a domain, namely @{typ "('a * 'b)set"}
-and @{typ "'a => 'b"}.  Explicit type constraints may therefore be necessary.
-For example, @{term "range(f^n) = A"} and @{term "Range(R^n) = B"} need
-constraints.*}
-
-text {*
-  Circumvent this problem for code generation:
-*}
-
-primrec
-  fun_pow :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a"
-where
-  "fun_pow 0 f = id"
+primrec fun_pow :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" where
+    "fun_pow 0 f = id"
   | "fun_pow (Suc n) f = f o fun_pow n f"
 
-lemma funpow_fun_pow [code unfold]: "f ^ n = fun_pow n f"
+lemma funpow_fun_pow [code unfold]:
+  "f ^^ n = fun_pow n f"
   unfolding funpow_def fun_pow_def ..
 
-lemma funpow_add: "f ^ (m+n) = f^m o f^n"
+lemma funpow_add:
+  "f ^^ (m + n) = f ^^ m o f ^^ n"
   by (induct m) simp_all
 
-lemma funpow_swap1: "f((f^n) x) = (f^n)(f x)"
+lemma funpow_swap1:
+  "f ((f ^^ n) x) = (f ^^ n) (f x)"
 proof -
-  have "f((f^n) x) = (f^(n+1)) x" unfolding One_nat_def by simp
-  also have "\<dots>  = (f^n o f^1) x" by (simp only: funpow_add)
-  also have "\<dots> = (f^n)(f x)" unfolding One_nat_def by simp
+  have "f ((f ^^ n) x) = (f ^^ (n+1)) x" unfolding One_nat_def by simp
+  also have "\<dots>  = (f ^^ n o f ^^ 1) x" by (simp only: funpow_add)
+  also have "\<dots> = (f ^^ n) (f x)" unfolding One_nat_def by simp
   finally show ?thesis .
 qed
 
 lemma rel_pow_1 [simp]:
-  fixes R :: "('a*'a)set"
-  shows "R^1 = R"
-  unfolding One_nat_def by simp
-
-lemma rel_pow_0_I: "(x,x) : R^0"
+  fixes R :: "('a * 'a) set"
+  shows "R ^^ 1 = R"
   by simp
 
-lemma rel_pow_Suc_I: "[| (x,y) : R^n; (y,z):R |] ==> (x,z):R^(Suc n)"
+lemma rel_pow_0_I: 
+  "(x, x) \<in> R ^^ 0"
+  by simp
+
+lemma rel_pow_Suc_I:
+  "(x, y) \<in>  R ^^ n \<Longrightarrow> (y, z) \<in> R \<Longrightarrow> (x, z) \<in> R ^^ Suc n"
   by auto
 
 lemma rel_pow_Suc_I2:
-    "(x, y) : R \<Longrightarrow> (y, z) : R^n \<Longrightarrow> (x,z) : R^(Suc n)"
-  apply (induct n arbitrary: z)
-   apply simp
-  apply fastsimp
-  done
+  "(x, y) \<in> R \<Longrightarrow> (y, z) \<in> R ^^ n \<Longrightarrow> (x, z) \<in> R ^^ Suc n"
+  by (induct n arbitrary: z) (simp, fastsimp)
 
-lemma rel_pow_0_E: "[| (x,y) : R^0; x=y ==> P |] ==> P"
+lemma rel_pow_0_E:
+  "(x, y) \<in> R ^^ 0 \<Longrightarrow> (x = y \<Longrightarrow> P) \<Longrightarrow> P"
   by simp
 
 lemma rel_pow_Suc_E:
-    "[| (x,z) : R^(Suc n);  !!y. [| (x,y) : R^n; (y,z) : R |] ==> P |] ==> P"
+  "(x, z) \<in> R ^^ Suc n \<Longrightarrow> (\<And>y. (x, y) \<in> R ^^ n \<Longrightarrow> (y, z) \<in> R \<Longrightarrow> P) \<Longrightarrow> P"
   by auto
 
 lemma rel_pow_E:
-    "[| (x,z) : R^n;  [| n=0; x = z |] ==> P;
-        !!y m. [| n = Suc m; (x,y) : R^m; (y,z) : R |] ==> P
-     |] ==> P"
+  "(x, z) \<in>  R ^^ n \<Longrightarrow>  (n = 0 \<Longrightarrow> x = z \<Longrightarrow> P)
+   \<Longrightarrow> (\<And>y m. n = Suc m \<Longrightarrow> (x, y) \<in>  R ^^ m \<Longrightarrow> (y, z) \<in> R \<Longrightarrow> P)
+   \<Longrightarrow> P"
   by (cases n) auto
 
 lemma rel_pow_Suc_D2:
-    "(x, z) : R^(Suc n) \<Longrightarrow> (\<exists>y. (x,y) : R & (y,z) : R^n)"
+  "(x, z) \<in> R ^^ Suc n \<Longrightarrow> (\<exists>y. (x, y) \<in> R \<and> (y, z) \<in> R ^^ n)"
   apply (induct n arbitrary: x z)
    apply (blast intro: rel_pow_0_I elim: rel_pow_0_E rel_pow_Suc_E)
   apply (blast intro: rel_pow_Suc_I elim: rel_pow_0_E rel_pow_Suc_E)
   done
 
 lemma rel_pow_Suc_D2':
-    "\<forall>x y z. (x,y) : R^n & (y,z) : R --> (\<exists>w. (x,w) : R & (w,z) : R^n)"
+  "\<forall>x y z. (x, y) \<in> R ^^ n \<and> (y, z) \<in> R \<longrightarrow> (\<exists>w. (x, w) \<in> R \<and> (w, z) \<in> R ^^ n)"
   by (induct n) (simp_all, blast)
 
 lemma rel_pow_E2:
-    "[| (x,z) : R^n;  [| n=0; x = z |] ==> P;
-        !!y m. [| n = Suc m; (x,y) : R; (y,z) : R^m |] ==> P
-     |] ==> P"
-  apply (case_tac n, simp)
+  "(x, z) \<in> R ^^ n \<Longrightarrow>  (n = 0 \<Longrightarrow> x = z \<Longrightarrow> P)
+     \<Longrightarrow> (\<And>y m. n = Suc m \<Longrightarrow> (x, y) \<in> R \<Longrightarrow> (y, z) \<in> R ^^ m \<Longrightarrow> P)
+   \<Longrightarrow> P"
+  apply (cases n, simp)
   apply (cut_tac n=nat and R=R in rel_pow_Suc_D2', simp, blast)
   done
 
-lemma rtrancl_imp_UN_rel_pow: "!!p. p:R^* ==> p : (UN n. R^n)"
-  apply (simp only: split_tupled_all)
+lemma rtrancl_imp_UN_rel_pow:
+  "p \<in> R^* \<Longrightarrow> p \<in> (\<Union>n. R ^^ n)"
+  apply (cases p) apply (simp only:)
   apply (erule rtrancl_induct)
    apply (blast intro: rel_pow_0_I rel_pow_Suc_I)+
   done
 
-lemma rel_pow_imp_rtrancl: "!!p. p:R^n ==> p:R^*"
-  apply (simp only: split_tupled_all)
-  apply (induct n)
+lemma rel_pow_imp_rtrancl:
+  "p \<in> R ^^ n \<Longrightarrow> p \<in> R^*"
+  apply (induct n arbitrary: p)
+  apply (simp_all only: split_tupled_all)
    apply (blast intro: rtrancl_refl elim: rel_pow_0_E)
   apply (blast elim: rel_pow_Suc_E intro: rtrancl_into_rtrancl)
   done
 
-lemma rtrancl_is_UN_rel_pow: "R^* = (UN n. R^n)"
+lemma rtrancl_is_UN_rel_pow:
+  "R^* = (UN n. R ^^ n)"
   by (blast intro: rtrancl_imp_UN_rel_pow rel_pow_imp_rtrancl)
 
 lemma trancl_power:
-  "x \<in> r^+ = (\<exists>n > 0. x \<in> r^n)"
+  "x \<in> r^+ = (\<exists>n > 0. x \<in> r ^^ n)"
   apply (cases x)
   apply simp
   apply (rule iffI)
@@ -151,30 +143,12 @@
   done
 
 lemma single_valued_rel_pow:
-    "!!r::('a * 'a)set. single_valued r ==> single_valued (r^n)"
+  fixes R :: "('a * 'a) set"
+  shows "single_valued R \<Longrightarrow> single_valued (R ^^ n)"
+  apply (induct n arbitrary: R)
+  apply simp_all
   apply (rule single_valuedI)
-  apply (induct n)
-   apply simp
   apply (fast dest: single_valuedD elim: rel_pow_Suc_E)
   done
 
-ML
-{*
-val funpow_add = thm "funpow_add";
-val rel_pow_1 = thm "rel_pow_1";
-val rel_pow_0_I = thm "rel_pow_0_I";
-val rel_pow_Suc_I = thm "rel_pow_Suc_I";
-val rel_pow_Suc_I2 = thm "rel_pow_Suc_I2";
-val rel_pow_0_E = thm "rel_pow_0_E";
-val rel_pow_Suc_E = thm "rel_pow_Suc_E";
-val rel_pow_E = thm "rel_pow_E";
-val rel_pow_Suc_D2 = thm "rel_pow_Suc_D2";
-val rel_pow_Suc_D2 = thm "rel_pow_Suc_D2";
-val rel_pow_E2 = thm "rel_pow_E2";
-val rtrancl_imp_UN_rel_pow = thm "rtrancl_imp_UN_rel_pow";
-val rel_pow_imp_rtrancl = thm "rel_pow_imp_rtrancl";
-val rtrancl_is_UN_rel_pow = thm "rtrancl_is_UN_rel_pow";
-val single_valued_rel_pow = thm "single_valued_rel_pow";
-*}
-
 end

--- a/src/HOL/Ring_and_Field.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Ring_and_Field.thy	Fri May 15 15:56:28 2009 +0200
@@ -2226,15 +2226,21 @@
 qed
 qed
 
-instance ordered_idom \<subseteq> pordered_ring_abs
-by default (auto simp add: abs_if not_less
-  equal_neg_zero neg_equal_zero mult_less_0_iff)
-
-lemma abs_mult: "abs (a * b) = abs a * abs (b::'a::ordered_idom)" 
-by (simp add: abs_eq_mult linorder_linear)
-
-lemma abs_mult_self: "abs a * abs a = a * (a::'a::ordered_idom)"
-by (simp add: abs_if) 
+context ordered_idom
+begin
+
+subclass pordered_ring_abs proof
+qed (auto simp add: abs_if not_less equal_neg_zero neg_equal_zero mult_less_0_iff)
+
+lemma abs_mult:
+  "abs (a * b) = abs a * abs b" 
+  by (rule abs_eq_mult) auto
+
+lemma abs_mult_self:
+  "abs a * abs a = a * a"
+  by (simp add: abs_if) 
+
+end
 
 lemma nonzero_abs_inverse:
      "a \<noteq> 0 ==> abs (inverse (a::'a::ordered_field)) = inverse (abs a)"

--- a/src/HOL/SEQ.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/SEQ.thy	Fri May 15 15:56:28 2009 +0200
@@ -487,7 +487,7 @@
 by (simp add: LIMSEQ_mult LIMSEQ_inverse divide_inverse)
 
 lemma LIMSEQ_pow:
-  fixes a :: "'a::{real_normed_algebra,recpower}"
+  fixes a :: "'a::{power, real_normed_algebra}"
   shows "X ----> a \<Longrightarrow> (\<lambda>n. (X n) ^ m) ----> a ^ m"
 by (induct m) (simp_all add: LIMSEQ_const LIMSEQ_mult)
 
@@ -1394,7 +1394,7 @@
 qed
 
 lemma LIMSEQ_power_zero:
-  fixes x :: "'a::{real_normed_algebra_1,recpower}"
+  fixes x :: "'a::{real_normed_algebra_1}"
   shows "norm x < 1 \<Longrightarrow> (\<lambda>n. x ^ n) ----> 0"
 apply (drule LIMSEQ_realpow_zero [OF norm_ge_zero])
 apply (simp only: LIMSEQ_Zseq_iff, erule Zseq_le)

--- a/src/HOL/Series.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Series.thy	Fri May 15 15:56:28 2009 +0200
@@ -331,7 +331,7 @@
 lemmas sumr_geometric = geometric_sum [where 'a = real]
 
 lemma geometric_sums:
-  fixes x :: "'a::{real_normed_field,recpower}"
+  fixes x :: "'a::{real_normed_field}"
   shows "norm x < 1 \<Longrightarrow> (\<lambda>n. x ^ n) sums (1 / (1 - x))"
 proof -
   assume less_1: "norm x < 1"
@@ -348,7 +348,7 @@
 qed
 
 lemma summable_geometric:
-  fixes x :: "'a::{real_normed_field,recpower}"
+  fixes x :: "'a::{real_normed_field}"
   shows "norm x < 1 \<Longrightarrow> summable (\<lambda>n. x ^ n)"
 by (rule geometric_sums [THEN sums_summable])
 
@@ -434,7 +434,7 @@
 text{*Summability of geometric series for real algebras*}
 
 lemma complete_algebra_summable_geometric:
-  fixes x :: "'a::{real_normed_algebra_1,banach,recpower}"
+  fixes x :: "'a::{real_normed_algebra_1,banach}"
   shows "norm x < 1 \<Longrightarrow> summable (\<lambda>n. x ^ n)"
 proof (rule summable_comparison_test)
   show "\<exists>N. \<forall>n\<ge>N. norm (x ^ n) \<le> norm x ^ n"

--- a/src/HOL/SetInterval.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/SetInterval.thy	Fri May 15 15:56:28 2009 +0200
@@ -397,6 +397,22 @@
  apply (rule_tac [2] finite_lessThan, auto)
 done
 
+text {* A set of natural numbers is finite iff it is bounded. *}
+lemma finite_nat_set_iff_bounded:
+  "finite(N::nat set) = (EX m. ALL n:N. n<m)" (is "?F = ?B")
+proof
+  assume f:?F  show ?B
+    using Max_ge[OF `?F`, simplified less_Suc_eq_le[symmetric]] by blast
+next
+  assume ?B show ?F using `?B` by(blast intro:bounded_nat_set_is_finite)
+qed
+
+lemma finite_nat_set_iff_bounded_le:
+  "finite(N::nat set) = (EX m. ALL n:N. n<=m)"
+apply(simp add:finite_nat_set_iff_bounded)
+apply(blast dest:less_imp_le_nat le_imp_less_Suc)
+done
+
 lemma finite_less_ub:
      "!!f::nat=>nat. (!!n. n \<le> f n) ==> finite {n. f n \<le> u}"
 by (rule_tac B="{..u}" in finite_subset, auto intro: order_trans)
@@ -855,7 +871,7 @@
 
 lemma geometric_sum:
   "x ~= 1 ==> (\<Sum>i=0..<n. x ^ i) =
-  (x ^ n - 1) / (x - 1::'a::{field, recpower})"
+  (x ^ n - 1) / (x - 1::'a::{field})"
 by (induct "n") (simp_all add:field_simps power_Suc)
 
 subsection {* The formula for arithmetic sums *}

--- a/src/HOL/SizeChange/Graphs.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/SizeChange/Graphs.thy	Fri May 15 15:56:28 2009 +0200
@@ -228,18 +228,8 @@
   qed
 qed
 
-instantiation graph :: (type, monoid_mult) "{semiring_1, idem_add, recpower, star}"
-begin
-
-primrec power_graph :: "('a\<Colon>type, 'b\<Colon>monoid_mult) graph \<Rightarrow> nat => ('a, 'b) graph"
-where
-  "(A \<Colon> ('a, 'b) graph) ^ 0 = 1"
-| "(A \<Colon> ('a, 'b) graph) ^ Suc n = A * (A ^ n)"
-
-definition
-  graph_star_def: "star (G \<Colon> ('a, 'b) graph) = (SUP n. G ^ n)" 
-
-instance proof
+instance graph :: (type, monoid_mult) "{semiring_1, idem_add}"
+proof
   fix a b c :: "('a, 'b) graph"
   
   show "1 * a = a" 
@@ -258,10 +248,16 @@
 
   show "a + a = a" unfolding graph_plus_def by simp
   
-  show "a ^ 0 = 1" "\<And>n. a ^ (Suc n) = a * a ^ n"
-    by simp_all
 qed
 
+instantiation graph :: (type, monoid_mult) star
+begin
+
+definition
+  graph_star_def: "star (G \<Colon> ('a, 'b) graph) = (SUP n. G ^ n)" 
+
+instance ..
+
 end
 
 lemma graph_leqI:
@@ -351,7 +347,7 @@
 
 lemma in_tcl: 
   "has_edge (tcl G) a x b = (\<exists>n>0. has_edge (G ^ n) a x b)"
-  apply (auto simp: tcl_is_SUP in_SUP simp del: power_graph.simps power_Suc)
+  apply (auto simp: tcl_is_SUP in_SUP simp del: power.simps power_Suc)
   apply (rule_tac x = "n - 1" in exI, auto)
   done
 

--- a/src/HOL/SizeChange/Interpretation.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/SizeChange/Interpretation.thy	Fri May 15 15:56:28 2009 +0200
@@ -35,7 +35,7 @@
 	and nia: "\<And>x. \<not>accp R x \<Longrightarrow> \<not>accp R (f x)"
 	by blast
   
-  let ?s = "\<lambda>i. (f ^ i) x"
+  let ?s = "\<lambda>i. (f ^^ i) x"
   
   {
 	fix i

--- a/src/HOL/SizeChange/Kleene_Algebras.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/SizeChange/Kleene_Algebras.thy	Fri May 15 15:56:28 2009 +0200
@@ -97,7 +97,7 @@
   and star4: "x * a \<le> x \<Longrightarrow> x * star a \<le> x"
 
 class kleene_by_complete_lattice = pre_kleene
-  + complete_lattice + recpower + star +
+  + complete_lattice + power + star +
   assumes star_cont: "a * star b * c = SUPR UNIV (\<lambda>n. a * b ^ n * c)"
 begin
 

--- a/src/HOL/SizeChange/Size_Change_Termination.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/SizeChange/Size_Change_Termination.thy	Fri May 15 15:56:28 2009 +0200
@@ -1,5 +1,4 @@
 (*  Title:      HOL/Library/Size_Change_Termination.thy
-    ID:         $Id$
     Author:     Alexander Krauss, TU Muenchen
 *)
 

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/String.thy	Fri May 15 15:56:28 2009 +0200
@@ -0,0 +1,150 @@
+(* Author: Tobias Nipkow, Florian Haftmann, TU Muenchen *)
+
+header {* Character and string types *}
+
+theory String
+imports List
+uses
+  "Tools/string_syntax.ML"
+  ("Tools/string_code.ML")
+begin
+
+subsection {* Characters *}
+
+datatype nibble =
+    Nibble0 | Nibble1 | Nibble2 | Nibble3 | Nibble4 | Nibble5 | Nibble6 | Nibble7
+  | Nibble8 | Nibble9 | NibbleA | NibbleB | NibbleC | NibbleD | NibbleE | NibbleF
+
+lemma UNIV_nibble:
+  "UNIV = {Nibble0, Nibble1, Nibble2, Nibble3, Nibble4, Nibble5, Nibble6, Nibble7,
+    Nibble8, Nibble9, NibbleA, NibbleB, NibbleC, NibbleD, NibbleE, NibbleF}" (is "_ = ?A")
+proof (rule UNIV_eq_I)
+  fix x show "x \<in> ?A" by (cases x) simp_all
+qed
+
+instance nibble :: finite
+  by default (simp add: UNIV_nibble)
+
+datatype char = Char nibble nibble
+  -- "Note: canonical order of character encoding coincides with standard term ordering"
+
+lemma UNIV_char:
+  "UNIV = image (split Char) (UNIV \<times> UNIV)"
+proof (rule UNIV_eq_I)
+  fix x show "x \<in> image (split Char) (UNIV \<times> UNIV)" by (cases x) auto
+qed
+
+instance char :: finite
+  by default (simp add: UNIV_char)
+
+lemma size_char [code, simp]:
+  "size (c::char) = 0" by (cases c) simp
+
+lemma char_size [code, simp]:
+  "char_size (c::char) = 0" by (cases c) simp
+
+primrec nibble_pair_of_char :: "char \<Rightarrow> nibble \<times> nibble" where
+  "nibble_pair_of_char (Char n m) = (n, m)"
+
+declare nibble_pair_of_char.simps [code del]
+
+setup {*
+let
+  val nibbles = map (Thm.cterm_of @{theory} o HOLogic.mk_nibble) (0 upto 15);
+  val thms = map_product
+   (fn n => fn m => Drule.instantiate' [] [SOME n, SOME m] @{thm nibble_pair_of_char.simps})
+      nibbles nibbles;
+in
+  PureThy.note_thmss Thm.lemmaK [((Binding.name "nibble_pair_of_char_simps", []), [(thms, [])])]
+  #-> (fn [(_, thms)] => fold_rev Code.add_eqn thms)
+end
+*}
+
+lemma char_case_nibble_pair [code, code inline]:
+  "char_case f = split f o nibble_pair_of_char"
+  by (simp add: expand_fun_eq split: char.split)
+
+lemma char_rec_nibble_pair [code, code inline]:
+  "char_rec f = split f o nibble_pair_of_char"
+  unfolding char_case_nibble_pair [symmetric]
+  by (simp add: expand_fun_eq split: char.split)
+
+syntax
+  "_Char" :: "xstr => char"    ("CHR _")
+
+
+subsection {* Strings *}
+
+types string = "char list"
+
+syntax
+  "_String" :: "xstr => string"    ("_")
+
+setup StringSyntax.setup
+
+
+subsection {* Strings as dedicated datatype *}
+
+datatype message_string = STR string
+
+lemmas [code del] =
+  message_string.recs message_string.cases
+
+lemma [code]: "size (s\<Colon>message_string) = 0"
+  by (cases s) simp_all
+
+lemma [code]: "message_string_size (s\<Colon>message_string) = 0"
+  by (cases s) simp_all
+
+
+subsection {* Code generator *}
+
+use "Tools/string_code.ML"
+
+code_type message_string
+  (SML "string")
+  (OCaml "string")
+  (Haskell "String")
+
+setup {*
+  fold String_Code.add_literal_message ["SML", "OCaml", "Haskell"]
+*}
+
+code_instance message_string :: eq
+  (Haskell -)
+
+code_const "eq_class.eq \<Colon> message_string \<Rightarrow> message_string \<Rightarrow> bool"
+  (SML "!((_ : string) = _)")
+  (OCaml "!((_ : string) = _)")
+  (Haskell infixl 4 "==")
+
+code_reserved SML string
+code_reserved OCaml string
+
+
+types_code
+  "char" ("string")
+attach (term_of) {*
+val term_of_char = HOLogic.mk_char o ord;
+*}
+attach (test) {*
+fun gen_char i =
+  let val j = random_range (ord "a") (Int.min (ord "a" + i, ord "z"))
+  in (chr j, fn () => HOLogic.mk_char j) end;
+*}
+
+setup {*
+let
+
+fun char_codegen thy defs dep thyname b t gr =
+  let
+    val i = HOLogic.dest_char t;
+    val (_, gr') = Codegen.invoke_tycodegen thy defs dep thyname false
+      (fastype_of t) gr;
+  in SOME (Codegen.str (ML_Syntax.print_string (chr i)), gr')
+  end handle TERM _ => NONE;
+
+in Codegen.add_codegen "char_codegen" char_codegen end
+*}
+
+end
\ No newline at end of file

--- a/src/HOL/Sum_Type.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Sum_Type.thy	Fri May 15 15:56:28 2009 +0200
@@ -157,6 +157,8 @@
 apply auto
 done
 
+lemma Plus_eq_empty_conv[simp]: "A <+> B = {} \<longleftrightarrow> A = {} \<and> B = {}"
+by(auto)
 
 subsection{*The @{term Part} Primitive*}
 

--- a/src/HOL/Tools/Qelim/cooper.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Tools/Qelim/cooper.ML	Fri May 15 15:56:28 2009 +0200
@@ -172,7 +172,7 @@
 
     (* Canonical linear form for terms, formulae etc.. *)
 fun provelin ctxt t = Goal.prove ctxt [] [] t 
-  (fn _ => EVERY [simp_tac lin_ss 1, TRY (linear_arith_tac ctxt 1)]);
+  (fn _ => EVERY [simp_tac lin_ss 1, TRY (Lin_Arith.tac ctxt 1)]);
 fun linear_cmul 0 tm = zero 
   | linear_cmul n tm = case tm of  
       Const (@{const_name HOL.plus}, _) $ a $ b => addC $ linear_cmul n a $ linear_cmul n b

--- a/src/HOL/Tools/Qelim/presburger.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Tools/Qelim/presburger.ML	Fri May 15 15:56:28 2009 +0200
@@ -131,7 +131,7 @@
      @{thm "div_0"}, @{thm "mod_0"}, @{thm "div_by_1"}, @{thm "mod_by_1"}, @{thm "div_1"}, 
      @{thm "mod_1"}, @{thm "Suc_plus1"}]
   @ @{thms add_ac}
- addsimprocs [cancel_div_mod_proc]
+ addsimprocs [cancel_div_mod_nat_proc, cancel_div_mod_int_proc]
  val splits_ss = comp_ss addsimps [@{thm "mod_div_equality'"}] addsplits 
      [@{thm "split_zdiv"}, @{thm "split_zmod"}, @{thm "split_div'"}, 
       @{thm "split_min"}, @{thm "split_max"}, @{thm "abs_split"}]

--- a/src/HOL/Tools/atp_manager.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Tools/atp_manager.ML	Fri May 15 15:56:28 2009 +0200
@@ -19,9 +19,11 @@
   val kill: unit -> unit
   val info: unit -> unit
   val messages: int option -> unit
-  type prover = int -> int -> Proof.context * (thm list * thm) -> bool * string
+  type prover = int -> (thm * (string * int)) list option -> string -> int ->
+    Proof.context * (thm list * thm) -> bool * string * string * string vector
   val add_prover: string -> prover -> theory -> theory
   val print_provers: theory -> unit
+  val get_prover: string -> theory -> prover option
   val sledgehammer: string list -> Proof.state -> unit
 end;
 
@@ -51,15 +53,17 @@
 fun set_timeout time = CRITICAL (fn () => timeout := time);
 
 val _ =
-  ProofGeneralPgip.add_preference "Proof"
+  ProofGeneralPgip.add_preference Preferences.category_proof
     (Preferences.string_pref atps
       "ATP: provers" "Default automatic provers (separated by whitespace)");
 
-val _ = ProofGeneralPgip.add_preference "Proof"
+val _ =
+  ProofGeneralPgip.add_preference Preferences.category_proof
     (Preferences.int_pref max_atps
       "ATP: maximum number" "How many provers may run in parallel");
 
-val _ = ProofGeneralPgip.add_preference "Proof"
+val _ =
+  ProofGeneralPgip.add_preference Preferences.category_proof
     (Preferences.int_pref timeout
       "ATP: timeout" "ATPs will be interrupted after this time (in seconds)");
 
@@ -284,7 +288,8 @@
 
 (* named provers *)
 
-type prover = int -> int -> Proof.context * (thm list * thm) -> bool * string;
+type prover = int -> (thm * (string * int)) list option -> string -> int ->
+  Proof.context * (thm list * thm) -> bool * string * string * string vector
 
 fun err_dup_prover name = error ("Duplicate prover: " ^ quote name);
 
@@ -305,13 +310,16 @@
 fun print_provers thy = Pretty.writeln
   (Pretty.strs ("external provers:" :: sort_strings (Symtab.keys (Provers.get thy))));
 
+fun get_prover name thy = case Symtab.lookup (Provers.get thy) name of
+  NONE => NONE
+| SOME (prover, _) => SOME prover;
 
 (* start prover thread *)
 
 fun start_prover name birthtime deadtime i proof_state =
-  (case Symtab.lookup (Provers.get (Proof.theory_of proof_state)) name of
+  (case get_prover name (Proof.theory_of proof_state) of
     NONE => warning ("Unknown external prover: " ^ quote name)
-  | SOME (prover, _) =>
+  | SOME prover =>
       let
         val (ctxt, (_, goal)) = Proof.get_goal proof_state
         val desc =
@@ -320,7 +328,10 @@
         val _ = SimpleThread.fork true (fn () =>
           let
             val _ = register birthtime deadtime (Thread.self (), desc)
-            val result = prover (get_timeout ()) i (Proof.get_goal proof_state)
+            val result =
+              let val (success, message, _, _) =
+                prover (get_timeout ()) NONE name i (Proof.get_goal proof_state)
+              in (success, message) end
               handle ResHolClause.TOO_TRIVIAL
                 => (true, "Empty clause: Try this command: " ^ Markup.markup Markup.sendback "apply metis")
               | ERROR msg

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/atp_minimal.ML	Fri May 15 15:56:28 2009 +0200
@@ -0,0 +1,201 @@
+(*  Title:      HOL/Tools/atp_minimal.ML
+    Author:     Philipp Meyer, TU Muenchen
+
+Minimalization of theorem list for metis by using an external automated theorem prover
+*)
+
+structure AtpMinimal =
+struct
+
+  (* output control *)
+  fun debug str = Output.debug (fn () => str)
+  fun debug_fn f = if !Output.debugging then f() else ()
+  fun answer str = Output.writeln str
+  fun println str = Output.priority str
+
+  fun order_unique name_list = OrdList.make (String.collate Char.compare) name_list
+  fun length_string namelist = Int.toString (length namelist)
+
+  fun print_names name_thms_pairs =
+    let
+      val names = (map fst name_thms_pairs)
+      val ordered = order_unique names
+    in
+      app (fn name => (debug ("  " ^ name))) ordered
+    end
+
+  (* minimalization algorithm *)
+  local
+    fun isplit (l,r) [] = (l,r)
+      | isplit (l,r) (h::[]) = (h::l, r)
+      | isplit (l,r) (h1::h2::t) = isplit (h1::l, h2::r) t
+  in
+    fun split lst = isplit ([],[]) lst
+  end
+
+  local
+    fun min p sup [] = raise Empty
+      | min p sup [s0] = [s0]
+      | min p sup s =
+        let
+          val (l0, r0) = split s
+        in
+          if p(sup @ l0)
+          then min p sup l0
+          else
+            if p(sup @ r0)
+            then min p sup r0
+            else
+              let
+                val l = min p (sup @ r0) l0
+                val r = min p (sup @ l) r0
+              in
+                l @ r
+              end
+        end
+  in
+    (* return a minimal subset v of s that satisfies p
+     @pre p(s) & ~p([]) & monotone(p)
+     @post v subset s & p(v) &
+           forall e in v. ~p(v \ e)
+     *)
+    fun minimal p s = min p [] s
+  end
+
+ (* failure check and producing answer*)
+  datatype 'a prove_result = Success of 'a | Failure | Timeout | Error
+
+  val string_of_result = fn
+    Success _ => "Success"
+  | Failure => "Failure"
+  | Timeout => "Timeout"
+  | Error => "Error"
+
+  val failure_strings =
+     [("SPASS beiseite: Ran out of time.", Timeout),
+     ("Timeout", Timeout),
+     ("time limit exceeded", Timeout),
+     ("# Cannot determine problem status within resource limit", Timeout),
+     ("Error", Error)]
+
+  fun produce_answer (success, message, result_string, thm_name_vec) =
+    if success then
+      (Success (Vector.foldr op:: [] thm_name_vec), result_string)
+    else
+      let
+        val failure = get_first (fn (s, t) => if String.isSubstring s result_string then SOME (t, result_string) else NONE) failure_strings
+      in
+        if is_some failure then
+          the failure
+        else
+          (Failure, result_string)
+      end
+
+  (* wrapper for calling external prover *)
+  fun sh_test_thms prover prover_name time_limit subgoalno state name_thms_pairs =
+    let
+      val _ = println ("Testing " ^ (length_string name_thms_pairs) ^ " theorems... ")
+      val name_thm_pairs = flat (map (fn (n, ths) => map_index (fn (i, th) => (n, th)) ths) name_thms_pairs)
+      val _ = debug_fn (fn () => print_names name_thm_pairs)
+      val axclauses = ResAxioms.cnf_rules_pairs (Proof.theory_of state) name_thm_pairs
+      val (result, proof) =
+        (produce_answer (prover time_limit (SOME axclauses) prover_name subgoalno (Proof.get_goal state)))
+      val _ = println (string_of_result result)
+      val _ = debug proof
+    in
+      (result, proof)
+    end
+
+  (* minimalization of thms *)
+  fun minimalize prover prover_name time_limit state name_thms_pairs =
+    let
+      val _ = println ("Minimize called with " ^ (length_string name_thms_pairs) ^ " theorems, prover: "
+                       ^ prover_name ^ ", time limit: " ^ (Int.toString time_limit) ^ " seconds")
+      val _ = debug_fn (fn () => app (fn (n, tl) => (debug n; app (fn t => debug ("  " ^ Display.string_of_thm t)) tl)) name_thms_pairs)
+      val test_thms_fun = sh_test_thms prover prover_name time_limit 1 state
+      fun test_thms thms = case test_thms_fun thms of (Success _, _) => true | _ => false
+    in
+      (* try proove first to check result and get used theorems *)
+      (case test_thms_fun name_thms_pairs of
+        (Success used, _) =>
+          let
+            val ordered_used = order_unique used
+            val to_use =
+              if length ordered_used < length name_thms_pairs then
+                filter (fn (name1, _) => List.exists (equal name1) ordered_used) name_thms_pairs
+              else
+                name_thms_pairs
+            val min_thms = (minimal test_thms to_use)
+            val min_names = order_unique (map fst min_thms)
+            val _ = println ("Minimal " ^ (length_string min_thms) ^ " theorems")
+            val _ = debug_fn (fn () => print_names min_thms)
+          in
+            answer ("Try this command: " ^ Markup.markup Markup.sendback ("apply (metis " ^ (space_implode " " min_names) ^ ")"))
+          end
+      | (Timeout, _) =>
+          answer ("Timeout: You may need to increase the time limit of " ^ (Int.toString time_limit) ^ " seconds. Call atp_minimize [time=...] ")
+      | (Error, msg) =>
+          answer ("Error in prover: " ^ msg)
+      | (Failure, _) =>
+          answer "Failure: No proof with the theorems supplied")
+      handle ResHolClause.TOO_TRIVIAL =>
+          answer ("Trivial: Try this command: " ^ Markup.markup Markup.sendback "apply metis")
+      | ERROR msg =>
+          answer ("Error: " ^ msg)
+    end
+
+  (* isar command and parsing input *)
+
+  local structure K = OuterKeyword and P = OuterParse and T = OuterLex in
+
+  fun get_thms context =
+    map (fn (name, interval) =>
+      let
+        val thmref = Facts.Named ((name, Position.none), interval)
+        val ths = ProofContext.get_fact context thmref
+        val name' = Facts.string_of_ref thmref
+      in
+        (name', ths)
+      end)
+
+  val default_prover = "remote_vampire"
+  val default_time_limit = 5
+
+  fun get_time_limit_arg time_string =
+    (case Int.fromString time_string of
+      SOME t => t
+    | NONE => error ("Invalid time limit: " ^ quote time_string))
+
+  val get_options =
+    let
+      val def = (default_prover, default_time_limit)
+    in
+      foldl (fn ((name, a), (p, t)) => (case name of
+        "time" => (p, (get_time_limit_arg a))
+      | "atp" => (a, t)
+      | n => error ("Invalid argument: " ^ n))) def
+    end
+
+  fun sh_min_command args thm_names state =
+    let
+      val (prover_name, time_limit) = get_options args
+      val prover =
+        case AtpManager.get_prover prover_name (Proof.theory_of state) of
+          SOME prover => prover
+        | NONE => error ("Unknown prover: " ^ quote prover_name)
+      val name_thms_pairs = get_thms (Proof.context_of state) thm_names
+    in
+      minimalize prover prover_name time_limit state name_thms_pairs
+    end
+
+  val parse_args = Scan.optional (Args.bracks (P.list (P.xname --| P.$$$ "=" -- P.xname) )) []
+  val parse_thm_names = Scan.repeat (P.xname -- Scan.option Attrib.thm_sel)
+
+  val _ =
+    OuterSyntax.command "atp_minimize" "minimize theorem list with external prover" K.diag
+      (parse_args -- parse_thm_names >> (fn (args, thm_names) =>
+        Toplevel.no_timing o Toplevel.unknown_proof o Toplevel.keep ((sh_min_command args thm_names) o Toplevel.proof_of)))
+
+  end
+end
+

--- a/src/HOL/Tools/atp_wrapper.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Tools/atp_wrapper.ML	Fri May 15 15:56:28 2009 +0200
@@ -1,5 +1,4 @@
 (*  Title:      HOL/Tools/atp_wrapper.ML
-    ID:         $Id$
     Author:     Fabian Immler, TU Muenchen
 
 Wrapper functions for external ATPs.
@@ -10,10 +9,10 @@
   val destdir: string ref
   val problem_name: string ref
   val external_prover:
-    (thm * (string * int)) list ->
+    (unit -> (thm * (string * int)) list) ->
     (Path.T -> thm -> int -> (thm * (string * int)) list -> theory -> string vector) ->
     Path.T * string -> (string -> string option) ->
-    (string * string vector * Proof.context * thm * int -> string) ->
+    (string -> string * string vector * Proof.context * thm * int -> string) ->
     AtpManager.prover
   val tptp_prover_opts_full: int -> bool -> bool -> Path.T * string -> AtpManager.prover
   val tptp_prover_opts: int -> bool -> Path.T * string -> AtpManager.prover
@@ -47,7 +46,8 @@
 
 (* basic template *)
 
-fun external_prover axiom_clauses write_problem_file (cmd, args) find_failure produce_answer timeout subgoalno goal =
+fun external_prover relevance_filter write_problem_file (cmd, args) find_failure produce_answer
+  timeout axiom_clauses name subgoalno goal =
   let
     (* path to unique problem file *)
     val destdir' = ! destdir
@@ -66,7 +66,8 @@
     val chain_ths = map (Thm.put_name_hint ResReconstruct.chained_hint) chain_ths
     val probfile = prob_pathname subgoalno
     val fname = File.platform_path probfile
-    val thm_names = write_problem_file probfile th subgoalno axiom_clauses thy
+    val the_ax_clauses = case axiom_clauses of NONE => relevance_filter () | SOME axcls => axcls
+    val thm_names = write_problem_file probfile th subgoalno the_ax_clauses thy
     val cmdline =
       if File.exists cmd then "exec " ^ File.shell_path cmd ^ " " ^ args
       else error ("Bad executable: " ^ Path.implode cmd)
@@ -81,7 +82,7 @@
     val message =
       if is_some failure then "External prover failed."
       else if rc <> 0 then "External prover failed: " ^ proof
-      else "Try this command: " ^ produce_answer (proof, thm_names, ctxt, th, subgoalno)
+      else "Try this command: " ^ produce_answer name (proof, thm_names, ctxt, th, subgoalno)
 
     val _ =
       if is_some failure
@@ -91,7 +92,7 @@
       if rc <> 0
       then Output.debug (fn () => "Sledgehammer exited with return code " ^ string_of_int rc ^ ":\n" ^ proof)
       else ()
-  in (success, message) end;
+  in (success, message, proof, thm_names) end;
 
 
 
@@ -99,14 +100,14 @@
 
 (* generic TPTP-based provers *)
 
-fun tptp_prover_opts_full max_new theory_const full command timeout n goal =
+fun tptp_prover_opts_full max_new theory_const full command timeout ax_clauses name n goal =
   external_prover
-    (ResAtp.get_relevant max_new theory_const goal n)
+    (fn () => ResAtp.get_relevant max_new theory_const goal n)
     (ResAtp.write_problem_file false)
     command
     ResReconstruct.find_failure
     (if full then ResReconstruct.structured_proof else ResReconstruct.lemma_list_tstp)
-    timeout n goal;
+    timeout ax_clauses name n goal;
 
 (*arbitrary ATP with TPTP input/output and problemfile as last argument*)
 fun tptp_prover_opts max_new theory_const =
@@ -163,14 +164,14 @@
 
 (* SPASS *)
 
-fun spass_opts max_new theory_const timeout n goal = external_prover
-  (ResAtp.get_relevant max_new theory_const goal n)
+fun spass_opts max_new theory_const timeout ax_clauses name n goal = external_prover
+  (fn () => ResAtp.get_relevant max_new theory_const goal n)
   (ResAtp.write_problem_file true)
   (Path.explode "$SPASS_HOME/SPASS",
     "-Auto -SOS=1 -PGiven=0 -PProblem=0 -Splits=0 -FullRed=0 -DocProof -TimeLimit=" ^ string_of_int timeout)
   ResReconstruct.find_failure
   ResReconstruct.lemma_list_dfg
-  timeout n goal;
+  timeout ax_clauses name n goal;
 
 val spass = spass_opts 40 true;
 
@@ -179,7 +180,7 @@
 
 fun remote_prover_opts max_new theory_const args timeout =
   tptp_prover_opts max_new theory_const
-  (Path.explode "$ISABELLE_HOME/contrib/SystemOnTPTP/remote", args ^ " -t " ^ string_of_int timeout)
+  (Path.explode "$ISABELLE_HOME/lib/scripts/SystemOnTPTP", args ^ " -t " ^ string_of_int timeout)
   timeout;
 
 val remote_prover = remote_prover_opts 60 false;

--- a/src/HOL/Tools/datatype_codegen.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Tools/datatype_codegen.ML	Fri May 15 15:56:28 2009 +0200
@@ -6,7 +6,7 @@
 
 signature DATATYPE_CODEGEN =
 sig
-  val mk_eq: theory -> string -> thm list
+  val mk_eq_eqns: theory -> string -> (thm * bool) list
   val mk_case_cert: theory -> string -> thm
   val setup: theory -> theory
 end;
@@ -309,18 +309,6 @@
 
 (** generic code generator **)
 
-(* specification *)
-
-fun add_datatype_spec vs dtco cos thy =
-  let
-    val cs = map (fn (c, tys) => (c, tys ---> Type (dtco, map TFree vs))) cos;
-  in
-    thy
-    |> try (Code.add_datatype cs)
-    |> the_default thy
-  end;
-
-
 (* case certificates *)
 
 fun mk_case_cert thy tyco =
@@ -354,88 +342,40 @@
     |> Thm.varifyT
   end;
 
-fun add_datatype_cases dtco thy =
-  let
-    val {case_rewrites, ...} = DatatypePackage.the_datatype thy dtco;
-    val cert = mk_case_cert thy dtco;
-    fun add_case_liberal thy = thy
-      |> try (Code.add_case cert)
-      |> the_default thy;
-  in
-    thy
-    |> add_case_liberal
-    |> fold_rev Code.add_default_eqn case_rewrites
-  end;
-
 
 (* equality *)
 
-local
-
-val not_sym = @{thm HOL.not_sym};
-val not_false_true = iffD2 OF [nth @{thms HOL.simp_thms} 7, TrueI];
-val refl = @{thm refl};
-val eqTrueI = @{thm eqTrueI};
-
-fun mk_distinct cos =
-  let
-    fun sym_product [] = []
-      | sym_product (x::xs) = map (pair x) xs @ sym_product xs;
-    fun mk_co_args (co, tys) ctxt =
-      let
-        val names = Name.invents ctxt "a" (length tys);
-        val ctxt' = fold Name.declare names ctxt;
-        val vs = map2 (curry Free) names tys;
-      in (vs, ctxt') end;
-    fun mk_dist ((co1, tys1), (co2, tys2)) =
-      let
-        val ((xs1, xs2), _) = Name.context
-          |> mk_co_args (co1, tys1)
-          ||>> mk_co_args (co2, tys2);
-        val prem = HOLogic.mk_eq
-          (list_comb (co1, xs1), list_comb (co2, xs2));
-        val t = HOLogic.mk_not prem;
-      in HOLogic.mk_Trueprop t end;
-  in map mk_dist (sym_product cos) end;
-
-in
-
-fun mk_eq thy dtco =
+fun mk_eq_eqns thy dtco =
   let
-    val (vs, cs) = DatatypePackage.the_datatype_spec thy dtco;
-    fun mk_triv_inject co =
-      let
-        val ct' = Thm.cterm_of thy
-          (Const (co, Type (dtco, map (fn (v, sort) => TVar ((v, 0), sort)) vs)))
-        val cty' = Thm.ctyp_of_term ct';
-        val SOME (ct, cty) = fold_aterms (fn Var (v, ty) =>
-          (K o SOME) (Thm.cterm_of thy (Var (v, Thm.typ_of cty')), Thm.ctyp_of thy ty) | _ => I)
-          (Thm.prop_of refl) NONE;
-      in eqTrueI OF [Thm.instantiate ([(cty, cty')], [(ct, ct')]) refl] end;
-    val inject1 = map_filter (fn (co, []) => SOME (mk_triv_inject co) | _ => NONE) cs
-    val inject2 = (#inject o DatatypePackage.the_datatype thy) dtco;
-    val ctxt = ProofContext.init thy;
-    val simpset = Simplifier.context ctxt
-      (Simplifier.empty_ss addsimprocs [DatatypePackage.distinct_simproc]);
-    val cos = map (fn (co, tys) =>
-        (Const (co, tys ---> Type (dtco, map TFree vs)), tys)) cs;
-    val tac = ALLGOALS (simp_tac simpset)
-      THEN ALLGOALS (ProofContext.fact_tac [not_false_true, TrueI]);
-    val distinct =
-      mk_distinct cos
-      |> map (fn t => Goal.prove_global thy [] [] t (K tac))
-      |> (fn thms => thms @ map (fn thm => not_sym OF [thm]) thms)
-  in inject1 @ inject2 @ distinct end;
+    val (vs, cos) = DatatypePackage.the_datatype_spec thy dtco;
+    val { descr, index, inject = inject_thms, ... } = DatatypePackage.the_datatype thy dtco;
+    val ty = Type (dtco, map TFree vs);
+    fun mk_eq (t1, t2) = Const (@{const_name eq_class.eq}, ty --> ty --> HOLogic.boolT)
+      $ t1 $ t2;
+    fun true_eq t12 = HOLogic.mk_eq (mk_eq t12, HOLogic.true_const);
+    fun false_eq t12 = HOLogic.mk_eq (mk_eq t12, HOLogic.false_const);
+    val triv_injects = map_filter
+     (fn (c, []) => SOME (HOLogic.mk_Trueprop (true_eq (Const (c, ty), Const (c, ty))))
+       | _ => NONE) cos;
+    fun prep_inject (trueprop $ (equiv $ (_ $ t1 $ t2) $ rhs)) =
+      trueprop $ (equiv $ mk_eq (t1, t2) $ rhs);
+    val injects = map prep_inject (nth (DatatypeProp.make_injs [descr] vs) index);
+    fun prep_distinct (trueprop $ (not $ (_ $ t1 $ t2))) =
+      [trueprop $ false_eq (t1, t2), trueprop $ false_eq (t2, t1)];
+    val distincts = maps prep_distinct (snd (nth (DatatypeProp.make_distincts [descr] vs) index));
+    val refl = HOLogic.mk_Trueprop (true_eq (Free ("x", ty), Free ("x", ty)));
+    val simpset = Simplifier.context (ProofContext.init thy) (HOL_basic_ss
+      addsimps (map Simpdata.mk_eq (@{thm eq} :: @{thm eq_True} :: inject_thms))
+      addsimprocs [DatatypePackage.distinct_simproc]);
+    fun prove prop = Goal.prove_global thy [] [] prop (K (ALLGOALS (simp_tac simpset)))
+      |> Simpdata.mk_eq;
+  in map (rpair true o prove) (triv_injects @ injects @ distincts) @ [(prove refl, false)] end;
 
-end;
-
-fun add_datatypes_equality vs dtcos thy =
+fun add_equality vs dtcos thy =
   let
-    val vs' = (map o apsnd)
-      (curry (Sorts.inter_sort (Sign.classes_of thy)) [HOLogic.class_eq]) vs;
     fun add_def dtco lthy =
       let
-        val ty = Type (dtco, map TFree vs');
+        val ty = Type (dtco, map TFree vs);
         fun mk_side const_name = Const (const_name, ty --> ty --> HOLogic.boolT)
           $ Free ("x", ty) $ Free ("y", ty);
         val def = HOLogic.mk_Trueprop (HOLogic.mk_eq
@@ -448,52 +388,60 @@
       in (thm', lthy') end;
     fun tac thms = Class.intro_classes_tac []
       THEN ALLGOALS (ProofContext.fact_tac thms);
-    fun mk_eq' thy dtco = mk_eq thy dtco
-      |> map (Code_Unit.constrain_thm thy [HOLogic.class_eq])
-      |> map Simpdata.mk_eq
-      |> map (MetaSimplifier.rewrite_rule [Thm.transfer thy @{thm equals_eq}])
-      |> map (AxClass.unoverload thy);
     fun add_eq_thms dtco thy =
       let
-        val ty = Type (dtco, map TFree vs');
+        val const = AxClass.param_of_inst thy (@{const_name eq_class.eq}, dtco);
         val thy_ref = Theory.check_thy thy;
-        val const = AxClass.param_of_inst thy (@{const_name eq_class.eq}, dtco);
-        val eq_refl = @{thm HOL.eq_refl}
-          |> Thm.instantiate
-              ([pairself (Thm.ctyp_of thy) (TVar (("'a", 0), @{sort eq}), Logic.varifyT ty)], [])
-          |> Simpdata.mk_eq
-          |> AxClass.unoverload thy;
-        fun mk_thms () = (eq_refl, false)
-          :: rev (map (rpair true) (mk_eq' (Theory.deref thy_ref) dtco));
+        fun mk_thms () = rev ((mk_eq_eqns (Theory.deref thy_ref) dtco));
       in
         Code.add_eqnl (const, Lazy.lazy mk_thms) thy
       end;
   in
     thy
-    |> TheoryTarget.instantiation (dtcos, vs', [HOLogic.class_eq])
+    |> TheoryTarget.instantiation (dtcos, vs, [HOLogic.class_eq])
     |> fold_map add_def dtcos
-    |-> (fn thms => Class.prove_instantiation_instance (K (tac thms))
-    #> LocalTheory.exit_global
-    #> fold Code.del_eqn thms
-    #> fold add_eq_thms dtcos)
+    |-> (fn def_thms => Class.prove_instantiation_exit_result (map o Morphism.thm)
+         (fn _ => fn def_thms => tac def_thms) def_thms)
+    |-> (fn def_thms => fold Code.del_eqn def_thms)
+    |> fold add_eq_thms dtcos
+  end;
+
+
+(* liberal addition of code data for datatypes *)
+
+fun mk_constr_consts thy vs dtco cos =
+  let
+    val cs = map (fn (c, tys) => (c, tys ---> Type (dtco, map TFree vs))) cos;
+    val cs' = map (fn c_ty as (_, ty) => (AxClass.unoverload_const thy c_ty, ty)) cs;
+  in if is_some (try (Code.constrset_of_consts thy) cs')
+    then SOME cs
+    else NONE
   end;
 
+fun add_all_code dtcos thy =
+  let
+    val (vs :: _, coss) = (split_list o map (DatatypePackage.the_datatype_spec thy)) dtcos;
+    val any_css = map2 (mk_constr_consts thy vs) dtcos coss;
+    val css = if exists is_none any_css then []
+      else map_filter I any_css;
+    val case_rewrites = maps (#case_rewrites o DatatypePackage.the_datatype thy) dtcos;
+    val certs = map (mk_case_cert thy) dtcos;
+  in
+    if null css then thy
+    else thy
+      |> fold Code.add_datatype css
+      |> fold_rev Code.add_default_eqn case_rewrites
+      |> fold Code.add_case certs
+      |> add_equality vs dtcos
+   end;
+
+
 
 (** theory setup **)
 
-fun add_datatype_code dtcos thy =
-  let
-    val (vs :: _, coss) = (split_list o map (DatatypePackage.the_datatype_spec thy)) dtcos;
-  in
-    thy
-    |> fold2 (add_datatype_spec vs) dtcos coss
-    |> fold add_datatype_cases dtcos
-    |> add_datatypes_equality vs dtcos
-  end;
-
 val setup = 
   add_codegen "datatype" datatype_codegen
   #> add_tycodegen "datatype" datatype_tycodegen
-  #> DatatypePackage.interpretation add_datatype_code
+  #> DatatypePackage.interpretation add_all_code
 
 end;

--- a/src/HOL/Tools/hologic.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Tools/hologic.ML	Fri May 15 15:56:28 2009 +0200
@@ -116,6 +116,12 @@
   val stringT: typ
   val mk_string: string -> term
   val dest_string: term -> string
+  val message_stringT: typ
+  val mk_message_string: string -> term
+  val dest_message_string: term -> string
+  val mk_typerep: typ -> term
+  val mk_term_of: typ -> term -> term
+  val reflect_term: term -> term
 end;
 
 structure HOLogic: HOLOGIC =
@@ -510,44 +516,6 @@
 val realT = Type ("RealDef.real", []);
 
 
-(* nibble *)
-
-val nibbleT = Type ("List.nibble", []);
-
-fun mk_nibble n =
-  let val s =
-    if 0 <= n andalso n <= 9 then chr (n + ord "0")
-    else if 10 <= n andalso n <= 15 then chr (n + ord "A" - 10)
-    else raise TERM ("mk_nibble", [])
-  in Const ("List.nibble.Nibble" ^ s, nibbleT) end;
-
-fun dest_nibble t =
-  let fun err () = raise TERM ("dest_nibble", [t]) in
-    (case try (unprefix "List.nibble.Nibble" o fst o Term.dest_Const) t of
-      NONE => err ()
-    | SOME c =>
-        if size c <> 1 then err ()
-        else if "0" <= c andalso c <= "9" then ord c - ord "0"
-        else if "A" <= c andalso c <= "F" then ord c - ord "A" + 10
-        else err ())
-  end;
-
-
-(* char *)
-
-val charT = Type ("List.char", []);
-
-fun mk_char n =
-  if 0 <= n andalso n <= 255 then
-    Const ("List.char.Char", nibbleT --> nibbleT --> charT) $
-      mk_nibble (n div 16) $ mk_nibble (n mod 16)
-  else raise TERM ("mk_char", []);
-
-fun dest_char (Const ("List.char.Char", _) $ t $ u) =
-      dest_nibble t * 16 + dest_nibble u
-  | dest_char t = raise TERM ("dest_char", [t]);
-
-
 (* list *)
 
 fun listT T = Type ("List.list", [T]);
@@ -570,11 +538,82 @@
   | dest_list t = raise TERM ("dest_list", [t]);
 
 
+(* nibble *)
+
+val nibbleT = Type ("String.nibble", []);
+
+fun mk_nibble n =
+  let val s =
+    if 0 <= n andalso n <= 9 then chr (n + ord "0")
+    else if 10 <= n andalso n <= 15 then chr (n + ord "A" - 10)
+    else raise TERM ("mk_nibble", [])
+  in Const ("String.nibble.Nibble" ^ s, nibbleT) end;
+
+fun dest_nibble t =
+  let fun err () = raise TERM ("dest_nibble", [t]) in
+    (case try (unprefix "String.nibble.Nibble" o fst o Term.dest_Const) t of
+      NONE => err ()
+    | SOME c =>
+        if size c <> 1 then err ()
+        else if "0" <= c andalso c <= "9" then ord c - ord "0"
+        else if "A" <= c andalso c <= "F" then ord c - ord "A" + 10
+        else err ())
+  end;
+
+
+(* char *)
+
+val charT = Type ("String.char", []);
+
+fun mk_char n =
+  if 0 <= n andalso n <= 255 then
+    Const ("String.char.Char", nibbleT --> nibbleT --> charT) $
+      mk_nibble (n div 16) $ mk_nibble (n mod 16)
+  else raise TERM ("mk_char", []);
+
+fun dest_char (Const ("String.char.Char", _) $ t $ u) =
+      dest_nibble t * 16 + dest_nibble u
+  | dest_char t = raise TERM ("dest_char", [t]);
+
+
 (* string *)
 
-val stringT = Type ("List.string", []);
+val stringT = Type ("String.string", []);
 
 val mk_string = mk_list charT o map (mk_char o ord) o explode;
 val dest_string = implode o map (chr o dest_char) o dest_list;
 
+
+(* message_string *)
+
+val message_stringT = Type ("String.message_string", []);
+
+fun mk_message_string s = Const ("String.message_string.STR", stringT --> message_stringT)
+      $ mk_string s;
+fun dest_message_string (Const ("String.message_string.STR", _) $ t) =
+      dest_string t
+  | dest_message_string t = raise TERM ("dest_message_string", [t]);
+
+
+(* typerep and term *)
+
+val typerepT = Type ("Typerep.typerep", []);
+
+fun mk_typerep T = Const ("Typerep.typerep_class.typerep",
+  Term.itselfT T --> typerepT) $ Logic.mk_type T;
+
+val termT = Type ("Code_Eval.term", []);
+
+fun mk_term_of T t = Const ("Code_Eval.term_of_class.term_of", T --> termT) $ t;
+
+fun reflect_term (Const (c, T)) =
+      Const ("Code_Eval.Const", message_stringT --> typerepT --> termT)
+        $ mk_message_string c $ mk_typerep T
+  | reflect_term (t1 $ t2) =
+      Const ("Code_Eval.App", termT --> termT --> termT)
+        $ reflect_term t1 $ reflect_term t2
+  | reflect_term (t as Free _) = t
+  | reflect_term (t as Bound _) = t
+  | reflect_term (Abs (v, _, t)) = Abs (v, termT, reflect_term t);
+
 end;

--- a/src/HOL/Tools/int_arith.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Tools/int_arith.ML	Fri May 15 15:56:28 2009 +0200
@@ -1,442 +1,15 @@
-(* Authors: Larry Paulson and Tobias Nipkow
-
-Simprocs and decision procedure for numerals and linear arithmetic.
-*)
-
-structure Int_Numeral_Simprocs =
-struct
-
-(*reorientation simprules using ==, for the following simproc*)
-val meta_zero_reorient = @{thm zero_reorient} RS eq_reflection
-val meta_one_reorient = @{thm one_reorient} RS eq_reflection
-val meta_number_of_reorient = @{thm number_of_reorient} RS eq_reflection
-
-(*reorientation simplification procedure: reorients (polymorphic) 
-  0 = x, 1 = x, nnn = x provided x isn't 0, 1 or a Int.*)
-fun reorient_proc sg _ (_ $ t $ u) =
-  case u of
-      Const(@{const_name HOL.zero}, _) => NONE
-    | Const(@{const_name HOL.one}, _) => NONE
-    | Const(@{const_name Int.number_of}, _) $ _ => NONE
-    | _ => SOME (case t of
-        Const(@{const_name HOL.zero}, _) => meta_zero_reorient
-      | Const(@{const_name HOL.one}, _) => meta_one_reorient
-      | Const(@{const_name Int.number_of}, _) $ _ => meta_number_of_reorient)
-
-val reorient_simproc = 
-  Arith_Data.prep_simproc ("reorient_simproc", ["0=x", "1=x", "number_of w = x"], reorient_proc);
-
-
-(** Utilities **)
-
-fun mk_number T n = HOLogic.number_of_const T $ HOLogic.mk_numeral n;
-
-fun find_first_numeral past (t::terms) =
-        ((snd (HOLogic.dest_number t), rev past @ terms)
-         handle TERM _ => find_first_numeral (t::past) terms)
-  | find_first_numeral past [] = raise TERM("find_first_numeral", []);
-
-val mk_plus = HOLogic.mk_binop @{const_name HOL.plus};
-
-fun mk_minus t = 
-  let val T = Term.fastype_of t
-  in Const (@{const_name HOL.uminus}, T --> T) $ t end;
-
-(*Thus mk_sum[t] yields t+0; longer sums don't have a trailing zero*)
-fun mk_sum T []        = mk_number T 0
-  | mk_sum T [t,u]     = mk_plus (t, u)
-  | mk_sum T (t :: ts) = mk_plus (t, mk_sum T ts);
-
-(*this version ALWAYS includes a trailing zero*)
-fun long_mk_sum T []        = mk_number T 0
-  | long_mk_sum T (t :: ts) = mk_plus (t, mk_sum T ts);
-
-val dest_plus = HOLogic.dest_bin @{const_name HOL.plus} Term.dummyT;
-
-(*decompose additions AND subtractions as a sum*)
-fun dest_summing (pos, Const (@{const_name HOL.plus}, _) $ t $ u, ts) =
-        dest_summing (pos, t, dest_summing (pos, u, ts))
-  | dest_summing (pos, Const (@{const_name HOL.minus}, _) $ t $ u, ts) =
-        dest_summing (pos, t, dest_summing (not pos, u, ts))
-  | dest_summing (pos, t, ts) =
-        if pos then t::ts else mk_minus t :: ts;
-
-fun dest_sum t = dest_summing (true, t, []);
-
-val mk_diff = HOLogic.mk_binop @{const_name HOL.minus};
-val dest_diff = HOLogic.dest_bin @{const_name HOL.minus} Term.dummyT;
-
-val mk_times = HOLogic.mk_binop @{const_name HOL.times};
-
-fun one_of T = Const(@{const_name HOL.one},T);
-
-(* build product with trailing 1 rather than Numeral 1 in order to avoid the
-   unnecessary restriction to type class number_ring
-   which is not required for cancellation of common factors in divisions.
-*)
-fun mk_prod T = 
-  let val one = one_of T
-  fun mk [] = one
-    | mk [t] = t
-    | mk (t :: ts) = if t = one then mk ts else mk_times (t, mk ts)
-  in mk end;
-
-(*This version ALWAYS includes a trailing one*)
-fun long_mk_prod T []        = one_of T
-  | long_mk_prod T (t :: ts) = mk_times (t, mk_prod T ts);
-
-val dest_times = HOLogic.dest_bin @{const_name HOL.times} Term.dummyT;
-
-fun dest_prod t =
-      let val (t,u) = dest_times t
-      in dest_prod t @ dest_prod u end
-      handle TERM _ => [t];
-
-(*DON'T do the obvious simplifications; that would create special cases*)
-fun mk_coeff (k, t) = mk_times (mk_number (Term.fastype_of t) k, t);
-
-(*Express t as a product of (possibly) a numeral with other sorted terms*)
-fun dest_coeff sign (Const (@{const_name HOL.uminus}, _) $ t) = dest_coeff (~sign) t
-  | dest_coeff sign t =
-    let val ts = sort TermOrd.term_ord (dest_prod t)
-        val (n, ts') = find_first_numeral [] ts
-                          handle TERM _ => (1, ts)
-    in (sign*n, mk_prod (Term.fastype_of t) ts') end;
-
-(*Find first coefficient-term THAT MATCHES u*)
-fun find_first_coeff past u [] = raise TERM("find_first_coeff", [])
-  | find_first_coeff past u (t::terms) =
-        let val (n,u') = dest_coeff 1 t
-        in if u aconv u' then (n, rev past @ terms)
-                         else find_first_coeff (t::past) u terms
-        end
-        handle TERM _ => find_first_coeff (t::past) u terms;
-
-(*Fractions as pairs of ints. Can't use Rat.rat because the representation
-  needs to preserve negative values in the denominator.*)
-fun mk_frac (p, q) = if q = 0 then raise Div else (p, q);
-
-(*Don't reduce fractions; sums must be proved by rule add_frac_eq.
-  Fractions are reduced later by the cancel_numeral_factor simproc.*)
-fun add_frac ((p1, q1), (p2, q2)) = (p1 * q2 + p2 * q1, q1 * q2);
-
-val mk_divide = HOLogic.mk_binop @{const_name HOL.divide};
-
-(*Build term (p / q) * t*)
-fun mk_fcoeff ((p, q), t) =
-  let val T = Term.fastype_of t
-  in mk_times (mk_divide (mk_number T p, mk_number T q), t) end;
-
-(*Express t as a product of a fraction with other sorted terms*)
-fun dest_fcoeff sign (Const (@{const_name HOL.uminus}, _) $ t) = dest_fcoeff (~sign) t
-  | dest_fcoeff sign (Const (@{const_name HOL.divide}, _) $ t $ u) =
-    let val (p, t') = dest_coeff sign t
-        val (q, u') = dest_coeff 1 u
-    in (mk_frac (p, q), mk_divide (t', u')) end
-  | dest_fcoeff sign t =
-    let val (p, t') = dest_coeff sign t
-        val T = Term.fastype_of t
-    in (mk_frac (p, 1), mk_divide (t', one_of T)) end;
-
-
-(** New term ordering so that AC-rewriting brings numerals to the front **)
-
-(*Order integers by absolute value and then by sign. The standard integer
-  ordering is not well-founded.*)
-fun num_ord (i,j) =
-  (case int_ord (abs i, abs j) of
-    EQUAL => int_ord (Int.sign i, Int.sign j) 
-  | ord => ord);
-
-(*This resembles TermOrd.term_ord, but it puts binary numerals before other
-  non-atomic terms.*)
-local open Term 
-in 
-fun numterm_ord (Abs (_, T, t), Abs(_, U, u)) =
-      (case numterm_ord (t, u) of EQUAL => TermOrd.typ_ord (T, U) | ord => ord)
-  | numterm_ord
-     (Const(@{const_name Int.number_of}, _) $ v, Const(@{const_name Int.number_of}, _) $ w) =
-     num_ord (HOLogic.dest_numeral v, HOLogic.dest_numeral w)
-  | numterm_ord (Const(@{const_name Int.number_of}, _) $ _, _) = LESS
-  | numterm_ord (_, Const(@{const_name Int.number_of}, _) $ _) = GREATER
-  | numterm_ord (t, u) =
-      (case int_ord (size_of_term t, size_of_term u) of
-        EQUAL =>
-          let val (f, ts) = strip_comb t and (g, us) = strip_comb u in
-            (case TermOrd.hd_ord (f, g) of EQUAL => numterms_ord (ts, us) | ord => ord)
-          end
-      | ord => ord)
-and numterms_ord (ts, us) = list_ord numterm_ord (ts, us)
-end;
-
-fun numtermless tu = (numterm_ord tu = LESS);
-
-val num_ss = HOL_ss settermless numtermless;
-
-(*Maps 0 to Numeral0 and 1 to Numeral1 so that arithmetic isn't complicated by the abstract 0 and 1.*)
-val numeral_syms = [@{thm numeral_0_eq_0} RS sym, @{thm numeral_1_eq_1} RS sym];
-
-(*Simplify Numeral0+n, n+Numeral0, Numeral1*n, n*Numeral1, 1*x, x*1, x/1 *)
-val add_0s =  @{thms add_0s};
-val mult_1s = @{thms mult_1s mult_1_left mult_1_right divide_1};
-
-(*Simplify inverse Numeral1, a/Numeral1*)
-val inverse_1s = [@{thm inverse_numeral_1}];
-val divide_1s = [@{thm divide_numeral_1}];
-
-(*To perform binary arithmetic.  The "left" rewriting handles patterns
-  created by the Int_Numeral_Simprocs, such as 3 * (5 * x). *)
-val simps = [@{thm numeral_0_eq_0} RS sym, @{thm numeral_1_eq_1} RS sym,
-                 @{thm add_number_of_left}, @{thm mult_number_of_left}] @
-                @{thms arith_simps} @ @{thms rel_simps};
-
-(*Binary arithmetic BUT NOT ADDITION since it may collapse adjacent terms
-  during re-arrangement*)
-val non_add_simps =
-  subtract Thm.eq_thm [@{thm add_number_of_left}, @{thm number_of_add} RS sym] simps;
-
-(*To evaluate binary negations of coefficients*)
-val minus_simps = [@{thm numeral_m1_eq_minus_1} RS sym, @{thm number_of_minus} RS sym] @
-                   @{thms minus_bin_simps} @ @{thms pred_bin_simps};
-
-(*To let us treat subtraction as addition*)
-val diff_simps = [@{thm diff_minus}, @{thm minus_add_distrib}, @{thm minus_minus}];
-
-(*To let us treat division as multiplication*)
-val divide_simps = [@{thm divide_inverse}, @{thm inverse_mult_distrib}, @{thm inverse_inverse_eq}];
-
-(*push the unary minus down: - x * y = x * - y *)
-val minus_mult_eq_1_to_2 =
-    [@{thm mult_minus_left}, @{thm minus_mult_right}] MRS trans |> standard;
-
-(*to extract again any uncancelled minuses*)
-val minus_from_mult_simps =
-    [@{thm minus_minus}, @{thm mult_minus_left}, @{thm mult_minus_right}];
+(* Author: Tobias Nipkow
 
-(*combine unary minus with numeric literals, however nested within a product*)
-val mult_minus_simps =
-    [@{thm mult_assoc}, @{thm minus_mult_left}, minus_mult_eq_1_to_2];
-
-val norm_ss1 = num_ss addsimps numeral_syms @ add_0s @ mult_1s @
-  diff_simps @ minus_simps @ @{thms add_ac}
-val norm_ss2 = num_ss addsimps non_add_simps @ mult_minus_simps
-val norm_ss3 = num_ss addsimps minus_from_mult_simps @ @{thms add_ac} @ @{thms mult_ac}
-
-structure CancelNumeralsCommon =
-  struct
-  val mk_sum            = mk_sum
-  val dest_sum          = dest_sum
-  val mk_coeff          = mk_coeff
-  val dest_coeff        = dest_coeff 1
-  val find_first_coeff  = find_first_coeff []
-  val trans_tac         = K Arith_Data.trans_tac
-
-  fun norm_tac ss =
-    ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1))
-    THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2))
-    THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss3))
-
-  val numeral_simp_ss = HOL_ss addsimps add_0s @ simps
-  fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss))
-  val simplify_meta_eq = Arith_Data.simplify_meta_eq (add_0s @ mult_1s)
-  end;
-
-
-structure EqCancelNumerals = CancelNumeralsFun
- (open CancelNumeralsCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_eq
-  val dest_bal = HOLogic.dest_bin "op =" Term.dummyT
-  val bal_add1 = @{thm eq_add_iff1} RS trans
-  val bal_add2 = @{thm eq_add_iff2} RS trans
-);
-
-structure LessCancelNumerals = CancelNumeralsFun
- (open CancelNumeralsCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less}
-  val dest_bal = HOLogic.dest_bin @{const_name HOL.less} Term.dummyT
-  val bal_add1 = @{thm less_add_iff1} RS trans
-  val bal_add2 = @{thm less_add_iff2} RS trans
-);
-
-structure LeCancelNumerals = CancelNumeralsFun
- (open CancelNumeralsCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less_eq}
-  val dest_bal = HOLogic.dest_bin @{const_name HOL.less_eq} Term.dummyT
-  val bal_add1 = @{thm le_add_iff1} RS trans
-  val bal_add2 = @{thm le_add_iff2} RS trans
-);
-
-val cancel_numerals =
-  map Arith_Data.prep_simproc
-   [("inteq_cancel_numerals",
-     ["(l::'a::number_ring) + m = n",
-      "(l::'a::number_ring) = m + n",
-      "(l::'a::number_ring) - m = n",
-      "(l::'a::number_ring) = m - n",
-      "(l::'a::number_ring) * m = n",
-      "(l::'a::number_ring) = m * n"],
-     K EqCancelNumerals.proc),
-    ("intless_cancel_numerals",
-     ["(l::'a::{ordered_idom,number_ring}) + m < n",
-      "(l::'a::{ordered_idom,number_ring}) < m + n",
-      "(l::'a::{ordered_idom,number_ring}) - m < n",
-      "(l::'a::{ordered_idom,number_ring}) < m - n",
-      "(l::'a::{ordered_idom,number_ring}) * m < n",
-      "(l::'a::{ordered_idom,number_ring}) < m * n"],
-     K LessCancelNumerals.proc),
-    ("intle_cancel_numerals",
-     ["(l::'a::{ordered_idom,number_ring}) + m <= n",
-      "(l::'a::{ordered_idom,number_ring}) <= m + n",
-      "(l::'a::{ordered_idom,number_ring}) - m <= n",
-      "(l::'a::{ordered_idom,number_ring}) <= m - n",
-      "(l::'a::{ordered_idom,number_ring}) * m <= n",
-      "(l::'a::{ordered_idom,number_ring}) <= m * n"],
-     K LeCancelNumerals.proc)];
-
-
-structure CombineNumeralsData =
-  struct
-  type coeff            = int
-  val iszero            = (fn x => x = 0)
-  val add               = op +
-  val mk_sum            = long_mk_sum    (*to work for e.g. 2*x + 3*x *)
-  val dest_sum          = dest_sum
-  val mk_coeff          = mk_coeff
-  val dest_coeff        = dest_coeff 1
-  val left_distrib      = @{thm combine_common_factor} RS trans
-  val prove_conv        = Arith_Data.prove_conv_nohyps
-  val trans_tac         = K Arith_Data.trans_tac
-
-  fun norm_tac ss =
-    ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1))
-    THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2))
-    THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss3))
-
-  val numeral_simp_ss = HOL_ss addsimps add_0s @ simps
-  fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss))
-  val simplify_meta_eq = Arith_Data.simplify_meta_eq (add_0s @ mult_1s)
-  end;
-
-structure CombineNumerals = CombineNumeralsFun(CombineNumeralsData);
-
-(*Version for fields, where coefficients can be fractions*)
-structure FieldCombineNumeralsData =
-  struct
-  type coeff            = int * int
-  val iszero            = (fn (p, q) => p = 0)
-  val add               = add_frac
-  val mk_sum            = long_mk_sum
-  val dest_sum          = dest_sum
-  val mk_coeff          = mk_fcoeff
-  val dest_coeff        = dest_fcoeff 1
-  val left_distrib      = @{thm combine_common_factor} RS trans
-  val prove_conv        = Arith_Data.prove_conv_nohyps
-  val trans_tac         = K Arith_Data.trans_tac
-
-  val norm_ss1a = norm_ss1 addsimps inverse_1s @ divide_simps
-  fun norm_tac ss =
-    ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1a))
-    THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2))
-    THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss3))
-
-  val numeral_simp_ss = HOL_ss addsimps add_0s @ simps @ [@{thm add_frac_eq}]
-  fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss))
-  val simplify_meta_eq = Arith_Data.simplify_meta_eq (add_0s @ mult_1s @ divide_1s)
-  end;
-
-structure FieldCombineNumerals = CombineNumeralsFun(FieldCombineNumeralsData);
-
-val combine_numerals =
-  Arith_Data.prep_simproc
-    ("int_combine_numerals", 
-     ["(i::'a::number_ring) + j", "(i::'a::number_ring) - j"], 
-     K CombineNumerals.proc);
-
-val field_combine_numerals =
-  Arith_Data.prep_simproc
-    ("field_combine_numerals", 
-     ["(i::'a::{number_ring,field,division_by_zero}) + j",
-      "(i::'a::{number_ring,field,division_by_zero}) - j"], 
-     K FieldCombineNumerals.proc);
-
-(** Constant folding for multiplication in semirings **)
-
-(*We do not need folding for addition: combine_numerals does the same thing*)
-
-structure Semiring_Times_Assoc_Data : ASSOC_FOLD_DATA =
-struct
-  val assoc_ss = HOL_ss addsimps @{thms mult_ac}
-  val eq_reflection = eq_reflection
-  fun is_numeral (Const(@{const_name Int.number_of}, _) $ _) = true
-    | is_numeral _ = false;
-end;
-
-structure Semiring_Times_Assoc = Assoc_Fold (Semiring_Times_Assoc_Data);
-
-val assoc_fold_simproc =
-  Arith_Data.prep_simproc
-   ("semiring_assoc_fold", ["(a::'a::comm_semiring_1_cancel) * b"],
-    K Semiring_Times_Assoc.proc);
-
-end;
-
-Addsimprocs [Int_Numeral_Simprocs.reorient_simproc];
-Addsimprocs Int_Numeral_Simprocs.cancel_numerals;
-Addsimprocs [Int_Numeral_Simprocs.combine_numerals];
-Addsimprocs [Int_Numeral_Simprocs.field_combine_numerals];
-Addsimprocs [Int_Numeral_Simprocs.assoc_fold_simproc];
-
-(*examples:
-print_depth 22;
-set timing;
-set trace_simp;
-fun test s = (Goal s, by (Simp_tac 1));
-
-test "l + 2 + 2 + 2 + (l + 2) + (oo + 2) = (uu::int)";
-
-test "2*u = (u::int)";
-test "(i + j + 12 + (k::int)) - 15 = y";
-test "(i + j + 12 + (k::int)) - 5 = y";
-
-test "y - b < (b::int)";
-test "y - (3*b + c) < (b::int) - 2*c";
-
-test "(2*x - (u*v) + y) - v*3*u = (w::int)";
-test "(2*x*u*v + (u*v)*4 + y) - v*u*4 = (w::int)";
-test "(2*x*u*v + (u*v)*4 + y) - v*u = (w::int)";
-test "u*v - (x*u*v + (u*v)*4 + y) = (w::int)";
-
-test "(i + j + 12 + (k::int)) = u + 15 + y";
-test "(i + j*2 + 12 + (k::int)) = j + 5 + y";
-
-test "2*y + 3*z + 6*w + 2*y + 3*z + 2*u = 2*y' + 3*z' + 6*w' + 2*y' + 3*z' + u + (vv::int)";
-
-test "a + -(b+c) + b = (d::int)";
-test "a + -(b+c) - b = (d::int)";
-
-(*negative numerals*)
-test "(i + j + -2 + (k::int)) - (u + 5 + y) = zz";
-test "(i + j + -3 + (k::int)) < u + 5 + y";
-test "(i + j + 3 + (k::int)) < u + -6 + y";
-test "(i + j + -12 + (k::int)) - 15 = y";
-test "(i + j + 12 + (k::int)) - -15 = y";
-test "(i + j + -12 + (k::int)) - -15 = y";
-*)
-
-(*** decision procedure for linear arithmetic ***)
-
-(*---------------------------------------------------------------------------*)
-(* Linear arithmetic                                                         *)
-(*---------------------------------------------------------------------------*)
-
-(*
 Instantiation of the generic linear arithmetic package for int.
 *)
 
-structure Int_Arith =
+signature INT_ARITH =
+sig
+  val setup: Context.generic -> Context.generic
+  val global_setup: theory -> theory
+end
+
+structure Int_Arith : INT_ARITH =
 struct
 
 (* Update parameters of arithmetic prover *)
@@ -476,17 +49,15 @@
   make_simproc {lhss = lhss1, name = "one_to_of_int_one_simproc",
   proc = proc1, identifier = []};
 
-val allowed_consts =
-  [@{const_name "op ="}, @{const_name "HOL.times"}, @{const_name "HOL.uminus"},
-   @{const_name "HOL.minus"}, @{const_name "HOL.plus"},
-   @{const_name "HOL.zero"}, @{const_name "HOL.one"}, @{const_name "HOL.less"},
-   @{const_name "HOL.less_eq"}];
-
-fun check t = case t of
-   Const(s,t) => if s = @{const_name "HOL.one"} then not (t = @{typ int})
-                else s mem_string allowed_consts
- | a$b => check a andalso check b
- | _ => false;
+fun check (Const (@{const_name "HOL.one"}, @{typ int})) = false
+  | check (Const (@{const_name "HOL.one"}, _)) = true
+  | check (Const (s, _)) = member (op =) [@{const_name "op ="},
+      @{const_name "HOL.times"}, @{const_name "HOL.uminus"},
+      @{const_name "HOL.minus"}, @{const_name "HOL.plus"},
+      @{const_name "HOL.zero"},
+      @{const_name "HOL.less"}, @{const_name "HOL.less_eq"}] s
+  | check (a $ b) = check a andalso check b
+  | check _ = false;
 
 val conv =
   Simplifier.rewrite
@@ -507,36 +78,24 @@
   make_simproc {lhss = lhss' , name = "zero_one_idom_simproc",
   proc = sproc, identifier = []}
 
-val add_rules =
-    simp_thms @ @{thms arith_simps} @ @{thms rel_simps} @ @{thms arith_special} @
-    @{thms int_arith_rules}
+val fast_int_arith_simproc =
+  Simplifier.simproc @{theory} "fast_int_arith"
+     ["(m::'a::{ordered_idom,number_ring}) < n",
+      "(m::'a::{ordered_idom,number_ring}) <= n",
+      "(m::'a::{ordered_idom,number_ring}) = n"] (K Lin_Arith.simproc);
 
-val nat_inj_thms = [@{thm zle_int} RS iffD2, @{thm int_int_eq} RS iffD2]
-
-val int_numeral_base_simprocs = Int_Numeral_Simprocs.assoc_fold_simproc :: zero_one_idom_simproc
-  :: Int_Numeral_Simprocs.combine_numerals
-  :: Int_Numeral_Simprocs.cancel_numerals;
+val global_setup = Simplifier.map_simpset
+  (fn simpset => simpset addsimprocs [fast_int_arith_simproc]);
 
 val setup =
-  Lin_Arith.map_data (fn {add_mono_thms, mult_mono_thms, inj_thms, lessD, neqE, simpset} =>
-   {add_mono_thms = add_mono_thms,
-    mult_mono_thms = @{thm mult_strict_left_mono} :: @{thm mult_left_mono} :: mult_mono_thms,
-    inj_thms = nat_inj_thms @ inj_thms,
-    lessD = lessD @ [@{thm zless_imp_add1_zle}],
-    neqE = neqE,
-    simpset = simpset addsimps add_rules
-                      addsimprocs int_numeral_base_simprocs
-                      addcongs [if_weak_cong]}) #>
-  arith_inj_const (@{const_name of_nat}, HOLogic.natT --> HOLogic.intT) #>
-  arith_discrete @{type_name Int.int}
-
-val fast_int_arith_simproc =
-  Simplifier.simproc (the_context ())
-  "fast_int_arith" 
-     ["(m::'a::{ordered_idom,number_ring}) < n",
-      "(m::'a::{ordered_idom,number_ring}) <= n",
-      "(m::'a::{ordered_idom,number_ring}) = n"] (K Lin_Arith.lin_arith_simproc);
+  Lin_Arith.add_inj_thms [@{thm zle_int} RS iffD2, @{thm int_int_eq} RS iffD2]
+  #> Lin_Arith.add_lessD @{thm zless_imp_add1_zle}
+  #> Lin_Arith.add_simps (@{thms simp_thms} @ @{thms arith_simps} @ @{thms rel_simps}
+      @ @{thms arith_special} @ @{thms int_arith_rules})
+  #> Lin_Arith.add_simprocs (Numeral_Simprocs.assoc_fold_simproc :: zero_one_idom_simproc
+      :: Numeral_Simprocs.combine_numerals
+      :: Numeral_Simprocs.cancel_numerals)
+  #> Lin_Arith.add_inj_const (@{const_name of_nat}, HOLogic.natT --> HOLogic.intT)
+  #> Lin_Arith.add_discrete_type @{type_name Int.int}
 
 end;
-
-Addsimprocs [Int_Arith.fast_int_arith_simproc];

--- a/src/HOL/Tools/int_factor_simprocs.ML	Fri May 15 15:29:34 2009 +0200
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,390 +0,0 @@
-(*  Title:      HOL/int_factor_simprocs.ML
-    ID:         $Id$
-    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
-    Copyright   2000  University of Cambridge
-
-Factor cancellation simprocs for the integers (and for fields).
-
-This file can't be combined with int_arith1 because it requires IntDiv.thy.
-*)
-
-
-(*To quote from Provers/Arith/cancel_numeral_factor.ML:
-
-Cancels common coefficients in balanced expressions:
-
-     u*#m ~~ u'*#m'  ==  #n*u ~~ #n'*u'
-
-where ~~ is an appropriate balancing operation (e.g. =, <=, <, div, /)
-and d = gcd(m,m') and n=m/d and n'=m'/d.
-*)
-
-val rel_number_of = [@{thm eq_number_of_eq}, @{thm less_number_of}, @{thm le_number_of}];
-
-local
-  open Int_Numeral_Simprocs
-in
-
-structure CancelNumeralFactorCommon =
-  struct
-  val mk_coeff          = mk_coeff
-  val dest_coeff        = dest_coeff 1
-  val trans_tac         = K Arith_Data.trans_tac
-
-  val norm_ss1 = HOL_ss addsimps minus_from_mult_simps @ mult_1s
-  val norm_ss2 = HOL_ss addsimps simps @ mult_minus_simps
-  val norm_ss3 = HOL_ss addsimps @{thms mult_ac}
-  fun norm_tac ss =
-    ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1))
-    THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2))
-    THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss3))
-
-  val numeral_simp_ss = HOL_ss addsimps rel_number_of @ simps
-  fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss))
-  val simplify_meta_eq = Arith_Data.simplify_meta_eq
-    [@{thm add_0}, @{thm add_0_right}, @{thm mult_zero_left},
-      @{thm mult_zero_right}, @{thm mult_Bit1}, @{thm mult_1_right}];
-  end
-
-(*Version for integer division*)
-structure IntDivCancelNumeralFactor = CancelNumeralFactorFun
- (open CancelNumeralFactorCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_binop @{const_name Divides.div}
-  val dest_bal = HOLogic.dest_bin @{const_name Divides.div} HOLogic.intT
-  val cancel = @{thm zdiv_zmult_zmult1} RS trans
-  val neg_exchanges = false
-)
-
-(*Version for fields*)
-structure DivideCancelNumeralFactor = CancelNumeralFactorFun
- (open CancelNumeralFactorCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_binop @{const_name HOL.divide}
-  val dest_bal = HOLogic.dest_bin @{const_name HOL.divide} Term.dummyT
-  val cancel = @{thm mult_divide_mult_cancel_left} RS trans
-  val neg_exchanges = false
-)
-
-structure EqCancelNumeralFactor = CancelNumeralFactorFun
- (open CancelNumeralFactorCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_eq
-  val dest_bal = HOLogic.dest_bin "op =" Term.dummyT
-  val cancel = @{thm mult_cancel_left} RS trans
-  val neg_exchanges = false
-)
-
-structure LessCancelNumeralFactor = CancelNumeralFactorFun
- (open CancelNumeralFactorCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less}
-  val dest_bal = HOLogic.dest_bin @{const_name HOL.less} Term.dummyT
-  val cancel = @{thm mult_less_cancel_left} RS trans
-  val neg_exchanges = true
-)
-
-structure LeCancelNumeralFactor = CancelNumeralFactorFun
- (open CancelNumeralFactorCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less_eq}
-  val dest_bal = HOLogic.dest_bin @{const_name HOL.less_eq} Term.dummyT
-  val cancel = @{thm mult_le_cancel_left} RS trans
-  val neg_exchanges = true
-)
-
-val cancel_numeral_factors =
-  map Arith_Data.prep_simproc
-   [("ring_eq_cancel_numeral_factor",
-     ["(l::'a::{idom,number_ring}) * m = n",
-      "(l::'a::{idom,number_ring}) = m * n"],
-     K EqCancelNumeralFactor.proc),
-    ("ring_less_cancel_numeral_factor",
-     ["(l::'a::{ordered_idom,number_ring}) * m < n",
-      "(l::'a::{ordered_idom,number_ring}) < m * n"],
-     K LessCancelNumeralFactor.proc),
-    ("ring_le_cancel_numeral_factor",
-     ["(l::'a::{ordered_idom,number_ring}) * m <= n",
-      "(l::'a::{ordered_idom,number_ring}) <= m * n"],
-     K LeCancelNumeralFactor.proc),
-    ("int_div_cancel_numeral_factors",
-     ["((l::int) * m) div n", "(l::int) div (m * n)"],
-     K IntDivCancelNumeralFactor.proc),
-    ("divide_cancel_numeral_factor",
-     ["((l::'a::{division_by_zero,field,number_ring}) * m) / n",
-      "(l::'a::{division_by_zero,field,number_ring}) / (m * n)",
-      "((number_of v)::'a::{division_by_zero,field,number_ring}) / (number_of w)"],
-     K DivideCancelNumeralFactor.proc)];
-
-(* referenced by rat_arith.ML *)
-val field_cancel_numeral_factors =
-  map Arith_Data.prep_simproc
-   [("field_eq_cancel_numeral_factor",
-     ["(l::'a::{field,number_ring}) * m = n",
-      "(l::'a::{field,number_ring}) = m * n"],
-     K EqCancelNumeralFactor.proc),
-    ("field_cancel_numeral_factor",
-     ["((l::'a::{division_by_zero,field,number_ring}) * m) / n",
-      "(l::'a::{division_by_zero,field,number_ring}) / (m * n)",
-      "((number_of v)::'a::{division_by_zero,field,number_ring}) / (number_of w)"],
-     K DivideCancelNumeralFactor.proc)]
-
-end;
-
-Addsimprocs cancel_numeral_factors;
-
-(*examples:
-print_depth 22;
-set timing;
-set trace_simp;
-fun test s = (Goal s; by (Simp_tac 1));
-
-test "9*x = 12 * (y::int)";
-test "(9*x) div (12 * (y::int)) = z";
-test "9*x < 12 * (y::int)";
-test "9*x <= 12 * (y::int)";
-
-test "-99*x = 132 * (y::int)";
-test "(-99*x) div (132 * (y::int)) = z";
-test "-99*x < 132 * (y::int)";
-test "-99*x <= 132 * (y::int)";
-
-test "999*x = -396 * (y::int)";
-test "(999*x) div (-396 * (y::int)) = z";
-test "999*x < -396 * (y::int)";
-test "999*x <= -396 * (y::int)";
-
-test "-99*x = -81 * (y::int)";
-test "(-99*x) div (-81 * (y::int)) = z";
-test "-99*x <= -81 * (y::int)";
-test "-99*x < -81 * (y::int)";
-
-test "-2 * x = -1 * (y::int)";
-test "-2 * x = -(y::int)";
-test "(-2 * x) div (-1 * (y::int)) = z";
-test "-2 * x < -(y::int)";
-test "-2 * x <= -1 * (y::int)";
-test "-x < -23 * (y::int)";
-test "-x <= -23 * (y::int)";
-*)
-
-(*And the same examples for fields such as rat or real:
-test "0 <= (y::rat) * -2";
-test "9*x = 12 * (y::rat)";
-test "(9*x) / (12 * (y::rat)) = z";
-test "9*x < 12 * (y::rat)";
-test "9*x <= 12 * (y::rat)";
-
-test "-99*x = 132 * (y::rat)";
-test "(-99*x) / (132 * (y::rat)) = z";
-test "-99*x < 132 * (y::rat)";
-test "-99*x <= 132 * (y::rat)";
-
-test "999*x = -396 * (y::rat)";
-test "(999*x) / (-396 * (y::rat)) = z";
-test "999*x < -396 * (y::rat)";
-test "999*x <= -396 * (y::rat)";
-
-test  "(- ((2::rat) * x) <= 2 * y)";
-test "-99*x = -81 * (y::rat)";
-test "(-99*x) / (-81 * (y::rat)) = z";
-test "-99*x <= -81 * (y::rat)";
-test "-99*x < -81 * (y::rat)";
-
-test "-2 * x = -1 * (y::rat)";
-test "-2 * x = -(y::rat)";
-test "(-2 * x) / (-1 * (y::rat)) = z";
-test "-2 * x < -(y::rat)";
-test "-2 * x <= -1 * (y::rat)";
-test "-x < -23 * (y::rat)";
-test "-x <= -23 * (y::rat)";
-*)
-
-
-(** Declarations for ExtractCommonTerm **)
-
-local
-  open Int_Numeral_Simprocs
-in
-
-(*Find first term that matches u*)
-fun find_first_t past u []         = raise TERM ("find_first_t", [])
-  | find_first_t past u (t::terms) =
-        if u aconv t then (rev past @ terms)
-        else find_first_t (t::past) u terms
-        handle TERM _ => find_first_t (t::past) u terms;
-
-(** Final simplification for the CancelFactor simprocs **)
-val simplify_one = Arith_Data.simplify_meta_eq  
-  [@{thm mult_1_left}, @{thm mult_1_right}, @{thm div_by_1}, @{thm numeral_1_eq_1}];
-
-fun cancel_simplify_meta_eq ss cancel_th th =
-    simplify_one ss (([th, cancel_th]) MRS trans);
-
-local
-  val Tp_Eq = Thm.reflexive(Thm.cterm_of (@{theory HOL}) HOLogic.Trueprop)
-  fun Eq_True_elim Eq = 
-    Thm.equal_elim (Thm.combination Tp_Eq (Thm.symmetric Eq)) @{thm TrueI}
-in
-fun sign_conv pos_th neg_th ss t =
-  let val T = fastype_of t;
-      val zero = Const(@{const_name HOL.zero}, T);
-      val less = Const(@{const_name HOL.less}, [T,T] ---> HOLogic.boolT);
-      val pos = less $ zero $ t and neg = less $ t $ zero
-      fun prove p =
-        Option.map Eq_True_elim (Lin_Arith.lin_arith_simproc ss p)
-        handle THM _ => NONE
-    in case prove pos of
-         SOME th => SOME(th RS pos_th)
-       | NONE => (case prove neg of
-                    SOME th => SOME(th RS neg_th)
-                  | NONE => NONE)
-    end;
-end
-
-structure CancelFactorCommon =
-  struct
-  val mk_sum            = long_mk_prod
-  val dest_sum          = dest_prod
-  val mk_coeff          = mk_coeff
-  val dest_coeff        = dest_coeff
-  val find_first        = find_first_t []
-  val trans_tac         = K Arith_Data.trans_tac
-  val norm_ss = HOL_ss addsimps mult_1s @ @{thms mult_ac}
-  fun norm_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss))
-  val simplify_meta_eq  = cancel_simplify_meta_eq 
-  end;
-
-(*mult_cancel_left requires a ring with no zero divisors.*)
-structure EqCancelFactor = ExtractCommonTermFun
- (open CancelFactorCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_eq
-  val dest_bal = HOLogic.dest_bin "op =" Term.dummyT
-  val simp_conv = K (K (SOME @{thm mult_cancel_left}))
-);
-
-(*for ordered rings*)
-structure LeCancelFactor = ExtractCommonTermFun
- (open CancelFactorCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less_eq}
-  val dest_bal = HOLogic.dest_bin @{const_name HOL.less_eq} Term.dummyT
-  val simp_conv = sign_conv
-    @{thm mult_le_cancel_left_pos} @{thm mult_le_cancel_left_neg}
-);
-
-(*for ordered rings*)
-structure LessCancelFactor = ExtractCommonTermFun
- (open CancelFactorCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less}
-  val dest_bal = HOLogic.dest_bin @{const_name HOL.less} Term.dummyT
-  val simp_conv = sign_conv
-    @{thm mult_less_cancel_left_pos} @{thm mult_less_cancel_left_neg}
-);
-
-(*zdiv_zmult_zmult1_if is for integer division (div).*)
-structure IntDivCancelFactor = ExtractCommonTermFun
- (open CancelFactorCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_binop @{const_name Divides.div}
-  val dest_bal = HOLogic.dest_bin @{const_name Divides.div} HOLogic.intT
-  val simp_conv = K (K (SOME @{thm zdiv_zmult_zmult1_if}))
-);
-
-structure IntModCancelFactor = ExtractCommonTermFun
- (open CancelFactorCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_binop @{const_name Divides.mod}
-  val dest_bal = HOLogic.dest_bin @{const_name Divides.mod} HOLogic.intT
-  val simp_conv = K (K (SOME @{thm zmod_zmult_zmult1}))
-);
-
-structure IntDvdCancelFactor = ExtractCommonTermFun
- (open CancelFactorCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_binrel @{const_name Ring_and_Field.dvd}
-  val dest_bal = HOLogic.dest_bin @{const_name Ring_and_Field.dvd} Term.dummyT
-  val simp_conv = K (K (SOME @{thm dvd_mult_cancel_left}))
-);
-
-(*Version for all fields, including unordered ones (type complex).*)
-structure DivideCancelFactor = ExtractCommonTermFun
- (open CancelFactorCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_binop @{const_name HOL.divide}
-  val dest_bal = HOLogic.dest_bin @{const_name HOL.divide} Term.dummyT
-  val simp_conv = K (K (SOME @{thm mult_divide_mult_cancel_left_if}))
-);
-
-val cancel_factors =
-  map Arith_Data.prep_simproc
-   [("ring_eq_cancel_factor",
-     ["(l::'a::{idom}) * m = n",
-      "(l::'a::{idom}) = m * n"],
-     K EqCancelFactor.proc),
-    ("ordered_ring_le_cancel_factor",
-     ["(l::'a::ordered_ring) * m <= n",
-      "(l::'a::ordered_ring) <= m * n"],
-     K LeCancelFactor.proc),
-    ("ordered_ring_less_cancel_factor",
-     ["(l::'a::ordered_ring) * m < n",
-      "(l::'a::ordered_ring) < m * n"],
-     K LessCancelFactor.proc),
-    ("int_div_cancel_factor",
-     ["((l::int) * m) div n", "(l::int) div (m * n)"],
-     K IntDivCancelFactor.proc),
-    ("int_mod_cancel_factor",
-     ["((l::int) * m) mod n", "(l::int) mod (m * n)"],
-     K IntModCancelFactor.proc),
-    ("dvd_cancel_factor",
-     ["((l::'a::idom) * m) dvd n", "(l::'a::idom) dvd (m * n)"],
-     K IntDvdCancelFactor.proc),
-    ("divide_cancel_factor",
-     ["((l::'a::{division_by_zero,field}) * m) / n",
-      "(l::'a::{division_by_zero,field}) / (m * n)"],
-     K DivideCancelFactor.proc)];
-
-end;
-
-Addsimprocs cancel_factors;
-
-
-(*examples:
-print_depth 22;
-set timing;
-set trace_simp;
-fun test s = (Goal s; by (Asm_simp_tac 1));
-
-test "x*k = k*(y::int)";
-test "k = k*(y::int)";
-test "a*(b*c) = (b::int)";
-test "a*(b*c) = d*(b::int)*(x*a)";
-
-test "(x*k) div (k*(y::int)) = (uu::int)";
-test "(k) div (k*(y::int)) = (uu::int)";
-test "(a*(b*c)) div ((b::int)) = (uu::int)";
-test "(a*(b*c)) div (d*(b::int)*(x*a)) = (uu::int)";
-*)
-
-(*And the same examples for fields such as rat or real:
-print_depth 22;
-set timing;
-set trace_simp;
-fun test s = (Goal s; by (Asm_simp_tac 1));
-
-test "x*k = k*(y::rat)";
-test "k = k*(y::rat)";
-test "a*(b*c) = (b::rat)";
-test "a*(b*c) = d*(b::rat)*(x*a)";
-
-
-test "(x*k) / (k*(y::rat)) = (uu::rat)";
-test "(k) / (k*(y::rat)) = (uu::rat)";
-test "(a*(b*c)) / ((b::rat)) = (uu::rat)";
-test "(a*(b*c)) / (d*(b::rat)*(x*a)) = (uu::rat)";
-
-(*FIXME: what do we do about this?*)
-test "a*(b*c)/(y*z) = d*(b::rat)*(x*a)/z";
-*)

--- a/src/HOL/Tools/lin_arith.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Tools/lin_arith.ML	Fri May 15 15:56:28 2009 +0200
@@ -4,33 +4,24 @@
 HOL setup for linear arithmetic (see Provers/Arith/fast_lin_arith.ML).
 *)
 
-signature BASIC_LIN_ARITH =
-sig
-  val arith_split_add: attribute
-  val arith_discrete: string -> Context.generic -> Context.generic
-  val arith_inj_const: string * typ -> Context.generic -> Context.generic
-  val fast_arith_split_limit: int Config.T
-  val fast_arith_neq_limit: int Config.T
-  val lin_arith_pre_tac: Proof.context -> int -> tactic
-  val fast_arith_tac: Proof.context -> int -> tactic
-  val fast_ex_arith_tac: Proof.context -> bool -> int -> tactic
-  val trace_arith: bool ref
-  val lin_arith_simproc: simpset -> term -> thm option
-  val fast_nat_arith_simproc: simproc
-  val linear_arith_tac: Proof.context -> int -> tactic
-end;
-
 signature LIN_ARITH =
 sig
-  include BASIC_LIN_ARITH
-  val map_data:
-    ({add_mono_thms: thm list, mult_mono_thms: thm list, inj_thms: thm list,
-      lessD: thm list, neqE: thm list, simpset: Simplifier.simpset} ->
-     {add_mono_thms: thm list, mult_mono_thms: thm list, inj_thms: thm list,
-      lessD: thm list, neqE: thm list, simpset: Simplifier.simpset}) ->
-    Context.generic -> Context.generic
+  val pre_tac: Proof.context -> int -> tactic
+  val simple_tac: Proof.context -> int -> tactic
+  val tac: Proof.context -> int -> tactic
+  val simproc: simpset -> term -> thm option
+  val add_inj_thms: thm list -> Context.generic -> Context.generic
+  val add_lessD: thm -> Context.generic -> Context.generic
+  val add_simps: thm list -> Context.generic -> Context.generic
+  val add_simprocs: simproc list -> Context.generic -> Context.generic
+  val add_inj_const: string * typ -> Context.generic -> Context.generic
+  val add_discrete_type: string -> Context.generic -> Context.generic
+  val setup: Context.generic -> Context.generic
+  val global_setup: theory -> theory
+  val split_limit: int Config.T
+  val neq_limit: int Config.T
   val warning_count: int ref
-  val setup: Context.generic -> Context.generic
+  val trace: bool ref
 end;
 
 structure Lin_Arith: LIN_ARITH =
@@ -47,37 +38,38 @@
 val sym = sym;
 val not_lessD = @{thm linorder_not_less} RS iffD1;
 val not_leD = @{thm linorder_not_le} RS iffD1;
-val le0 = thm "le0";
 
-fun mk_Eq thm = (thm RS Eq_FalseI) handle THM _ => (thm RS Eq_TrueI);
+fun mk_Eq thm = thm RS Eq_FalseI handle THM _ => thm RS Eq_TrueI;
 
 val mk_Trueprop = HOLogic.mk_Trueprop;
 
 fun atomize thm = case Thm.prop_of thm of
-    Const("Trueprop",_) $ (Const("op &",_) $ _ $ _) =>
-    atomize(thm RS conjunct1) @ atomize(thm RS conjunct2)
+    Const ("Trueprop", _) $ (Const (@{const_name "op &"}, _) $ _ $ _) =>
+    atomize (thm RS conjunct1) @ atomize (thm RS conjunct2)
   | _ => [thm];
 
-fun neg_prop ((TP as Const("Trueprop",_)) $ (Const("Not",_) $ t)) = TP $ t
-  | neg_prop ((TP as Const("Trueprop",_)) $ t) = TP $ (HOLogic.Not $t)
+fun neg_prop ((TP as Const("Trueprop", _)) $ (Const (@{const_name "Not"}, _) $ t)) = TP $ t
+  | neg_prop ((TP as Const("Trueprop", _)) $ t) = TP $ (HOLogic.Not $t)
   | neg_prop t = raise TERM ("neg_prop", [t]);
 
 fun is_False thm =
   let val _ $ t = Thm.prop_of thm
-  in t = Const("False",HOLogic.boolT) end;
+  in t = HOLogic.false_const end;
 
 fun is_nat t = (fastype_of1 t = HOLogic.natT);
 
-fun mk_nat_thm sg t =
-  let val ct = cterm_of sg t  and cn = cterm_of sg (Var(("n",0),HOLogic.natT))
-  in instantiate ([],[(cn,ct)]) le0 end;
+fun mk_nat_thm thy t =
+  let
+    val cn = cterm_of thy (Var (("n", 0), HOLogic.natT))
+    and ct = cterm_of thy t
+  in instantiate ([], [(cn, ct)]) @{thm le0} end;
 
 end;
 
 
 (* arith context data *)
 
-structure ArithContextData = GenericDataFun
+structure Lin_Arith_Data = GenericDataFun
 (
   type T = {splits: thm list,
             inj_consts: (string * typ) list,
@@ -92,30 +84,28 @@
     discrete = Library.merge (op =) (discrete1, discrete2)};
 );
 
-val get_arith_data = ArithContextData.get o Context.Proof;
+val get_arith_data = Lin_Arith_Data.get o Context.Proof;
 
-val arith_split_add = Thm.declaration_attribute (fn thm =>
-  ArithContextData.map (fn {splits, inj_consts, discrete} =>
-    {splits = update Thm.eq_thm_prop thm splits,
-     inj_consts = inj_consts, discrete = discrete}));
+fun add_split thm = Lin_Arith_Data.map (fn {splits, inj_consts, discrete} =>
+  {splits = update Thm.eq_thm_prop thm splits,
+   inj_consts = inj_consts, discrete = discrete});
 
-fun arith_discrete d = ArithContextData.map (fn {splits, inj_consts, discrete} =>
+fun add_discrete_type d = Lin_Arith_Data.map (fn {splits, inj_consts, discrete} =>
   {splits = splits, inj_consts = inj_consts,
    discrete = update (op =) d discrete});
 
-fun arith_inj_const c = ArithContextData.map (fn {splits, inj_consts, discrete} =>
+fun add_inj_const c = Lin_Arith_Data.map (fn {splits, inj_consts, discrete} =>
   {splits = splits, inj_consts = update (op =) c inj_consts,
    discrete = discrete});
 
-val (fast_arith_split_limit, setup1) = Attrib.config_int "fast_arith_split_limit" 9;
-val (fast_arith_neq_limit, setup2) = Attrib.config_int "fast_arith_neq_limit" 9;
-val setup_options = setup1 #> setup2;
+val (split_limit, setup_split_limit) = Attrib.config_int "linarith_split_limit" 9;
+val (neq_limit, setup_neq_limit) = Attrib.config_int "linarith_neq_limit" 9;
 
 
-structure LA_Data_Ref =
+structure LA_Data =
 struct
 
-val fast_arith_neq_limit = fast_arith_neq_limit;
+val fast_arith_neq_limit = neq_limit;
 
 
 (* Decomposition of terms *)
@@ -243,15 +233,12 @@
 end handle Rat.DIVZERO => NONE;
 
 fun of_lin_arith_sort thy U =
-  Sign.of_sort thy (U, ["Ring_and_Field.ordered_idom"]);
+  Sign.of_sort thy (U, @{sort Ring_and_Field.ordered_idom});
 
-fun allows_lin_arith sg (discrete : string list) (U as Type (D, [])) : bool * bool =
-  if of_lin_arith_sort sg U then
-    (true, D mem discrete)
-  else (* special cases *)
-    if D mem discrete then  (true, true)  else  (false, false)
-  | allows_lin_arith sg discrete U =
-  (of_lin_arith_sort sg U, false);
+fun allows_lin_arith thy (discrete : string list) (U as Type (D, [])) : bool * bool =
+      if of_lin_arith_sort thy U then (true, member (op =) discrete D)
+      else if member (op =) discrete D then (true, true) else (false, false)
+  | allows_lin_arith sg discrete U = (of_lin_arith_sort sg U, false);
 
 fun decomp_typecheck (thy, discrete, inj_consts) (T : typ, xxx) : decomp option =
   case T of
@@ -287,7 +274,7 @@
   | domain_is_nat (_ $ (Const ("Not", _) $ (Const (_, T) $ _ $ _))) = nT T
   | domain_is_nat _                                                 = false;
 
-fun number_of (n, T) = HOLogic.mk_number T n;
+val mk_number = HOLogic.mk_number;
 
 (*---------------------------------------------------------------------------*)
 (* the following code performs splitting of certain constants (e.g. min,     *)
@@ -358,10 +345,10 @@
   val split_thms = filter is_split_thm (#splits (get_arith_data ctxt))
   val cmap       = Splitter.cmap_of_split_thms split_thms
   val splits     = Splitter.split_posns cmap thy Ts (REPEAT_DETERM_etac_rev_mp terms)
-  val split_limit = Config.get ctxt fast_arith_split_limit
+  val split_limit = Config.get ctxt split_limit
 in
   if length splits > split_limit then
-   (tracing ("fast_arith_split_limit exceeded (current value is " ^
+   (tracing ("linarith_split_limit exceeded (current value is " ^
       string_of_int split_limit ^ ")"); NONE)
   else (
   case splits of [] =>
@@ -696,7 +683,7 @@
 (* disjunctions and existential quantifiers from the premises, possibly (in  *)
 (* the case of disjunctions) resulting in several new subgoals, each of the  *)
 (* general form  [| Q1; ...; Qm |] ==> False.  Fails if more than            *)
-(* !fast_arith_split_limit splits are possible.                              *)
+(* !split_limit splits are possible.                              *)
 
 local
   val nnf_simpset =
@@ -717,7 +704,7 @@
         val concl = HOLogic.dest_Trueprop (Logic.strip_assums_concl subgoal)
         val cmap = Splitter.cmap_of_split_thms split_thms
         val splits = Splitter.split_posns cmap thy Ts concl
-        val split_limit = Config.get ctxt fast_arith_split_limit
+        val split_limit = Config.get ctxt split_limit
       in
         if length splits > split_limit then no_tac
         else split_tac split_thms i
@@ -756,30 +743,46 @@
   )
 end;
 
-end;  (* LA_Data_Ref *)
+end;  (* LA_Data *)
 
 
-val lin_arith_pre_tac = LA_Data_Ref.pre_tac;
+val pre_tac = LA_Data.pre_tac;
 
-structure Fast_Arith = Fast_Lin_Arith(structure LA_Logic = LA_Logic and LA_Data = LA_Data_Ref);
+structure Fast_Arith = Fast_Lin_Arith(structure LA_Logic = LA_Logic and LA_Data = LA_Data);
 
 val map_data = Fast_Arith.map_data;
 
-fun fast_arith_tac ctxt = Fast_Arith.lin_arith_tac ctxt false;
-val fast_ex_arith_tac = Fast_Arith.lin_arith_tac;
-val trace_arith = Fast_Arith.trace;
+fun map_inj_thms f {add_mono_thms, mult_mono_thms, inj_thms, lessD, neqE, simpset} =
+  {add_mono_thms = add_mono_thms, mult_mono_thms = mult_mono_thms, inj_thms = f inj_thms,
+    lessD = lessD, neqE = neqE, simpset = simpset};
+
+fun map_lessD f {add_mono_thms, mult_mono_thms, inj_thms, lessD, neqE, simpset} =
+  {add_mono_thms = add_mono_thms, mult_mono_thms = mult_mono_thms, inj_thms = inj_thms,
+    lessD = f lessD, neqE = neqE, simpset = simpset};
+
+fun map_simpset f {add_mono_thms, mult_mono_thms, inj_thms, lessD, neqE, simpset} =
+  {add_mono_thms = add_mono_thms, mult_mono_thms = mult_mono_thms, inj_thms = inj_thms,
+    lessD = lessD, neqE = neqE, simpset = f simpset};
+
+fun add_inj_thms thms = Fast_Arith.map_data (map_inj_thms (append thms));
+fun add_lessD thm = Fast_Arith.map_data (map_lessD (fn thms => thms @ [thm]));
+fun add_simps thms = Fast_Arith.map_data (map_simpset (fn simpset => simpset addsimps thms));
+fun add_simprocs procs = Fast_Arith.map_data (map_simpset (fn simpset => simpset addsimprocs procs));
+
+fun simple_tac ctxt = Fast_Arith.lin_arith_tac ctxt false;
+val lin_arith_tac = Fast_Arith.lin_arith_tac;
+val trace = Fast_Arith.trace;
 val warning_count = Fast_Arith.warning_count;
 
 (* reduce contradictory <= to False.
    Most of the work is done by the cancel tactics. *)
 
 val init_arith_data =
- map_data (fn {add_mono_thms, mult_mono_thms, inj_thms, lessD, ...} =>
-   {add_mono_thms = add_mono_thms @
-    @{thms add_mono_thms_ordered_semiring} @ @{thms add_mono_thms_ordered_field},
-    mult_mono_thms = mult_mono_thms,
+  Fast_Arith.map_data (fn {add_mono_thms, mult_mono_thms, inj_thms, lessD, ...} =>
+   {add_mono_thms = @{thms add_mono_thms_ordered_semiring} @ @{thms add_mono_thms_ordered_field} @ add_mono_thms,
+    mult_mono_thms = @{thm mult_strict_left_mono} :: @{thm mult_left_mono} :: mult_mono_thms,
     inj_thms = inj_thms,
-    lessD = lessD @ [thm "Suc_leI"],
+    lessD = lessD @ [@{thm "Suc_leI"}],
     neqE = [@{thm linorder_neqE_nat}, @{thm linorder_neqE_ordered_idom}],
     simpset = HOL_basic_ss
       addsimps
@@ -791,23 +794,14 @@
         @{thm "not_one_less_zero"}]
       addsimprocs [ab_group_add_cancel.sum_conv, ab_group_add_cancel.rel_conv]
        (*abel_cancel helps it work in abstract algebraic domains*)
-      addsimprocs Nat_Arith.nat_cancel_sums_add}) #>
-  arith_discrete "nat";
+      addsimprocs Nat_Arith.nat_cancel_sums_add
+      addcongs [if_weak_cong]}) #>
+  add_discrete_type @{type_name nat};
 
 fun add_arith_facts ss =
   add_prems (Arith_Data.get_arith_facts (MetaSimplifier.the_context ss)) ss;
 
-val lin_arith_simproc = add_arith_facts #> Fast_Arith.lin_arith_simproc;
-
-val fast_nat_arith_simproc =
-  Simplifier.simproc (the_context ()) "fast_nat_arith"
-    ["(m::nat) < n","(m::nat) <= n", "(m::nat) = n"] (K lin_arith_simproc);
-
-(* Because of fast_nat_arith_simproc, the arithmetic solver is really only
-useful to detect inconsistencies among the premises for subgoals which are
-*not* themselves (in)equalities, because the latter activate
-fast_nat_arith_simproc anyway. However, it seems cheaper to activate the
-solver all the time rather than add the additional check. *)
+val simproc = add_arith_facts #> Fast_Arith.lin_arith_simproc;
 
 
 (* generic refutation procedure *)
@@ -857,7 +851,7 @@
 
 local
 
-fun raw_arith_tac ctxt ex =
+fun raw_tac ctxt ex =
   (* FIXME: K true should be replaced by a sensible test (perhaps "isSome o
      decomp sg"? -- but note that the test is applied to terms already before
      they are split/normalized) to speed things up in case there are lots of
@@ -866,21 +860,21 @@
      (l <= min m n + k) = (l <= m+k & l <= n+k)
   *)
   refute_tac (K true)
-    (* Splitting is also done inside fast_arith_tac, but not completely --   *)
+    (* Splitting is also done inside simple_tac, but not completely --   *)
     (* split_tac may use split theorems that have not been implemented in    *)
-    (* fast_arith_tac (cf. pre_decomp and split_once_items above), and       *)
-    (* fast_arith_split_limit may trigger.                                   *)
-    (* Therefore splitting outside of fast_arith_tac may allow us to prove   *)
-    (* some goals that fast_arith_tac alone would fail on.                   *)
+    (* simple_tac (cf. pre_decomp and split_once_items above), and       *)
+    (* split_limit may trigger.                                   *)
+    (* Therefore splitting outside of simple_tac may allow us to prove   *)
+    (* some goals that simple_tac alone would fail on.                   *)
     (REPEAT_DETERM o split_tac (#splits (get_arith_data ctxt)))
-    (fast_ex_arith_tac ctxt ex);
+    (lin_arith_tac ctxt ex);
 
 in
 
-fun gen_linear_arith_tac ex ctxt = FIRST' [fast_arith_tac ctxt,
-  ObjectLogic.full_atomize_tac THEN' (REPEAT_DETERM o rtac impI) THEN' raw_arith_tac ctxt ex];
+fun gen_tac ex ctxt = FIRST' [simple_tac ctxt,
+  ObjectLogic.full_atomize_tac THEN' (REPEAT_DETERM o rtac impI) THEN' raw_tac ctxt ex];
 
-val linear_arith_tac = gen_linear_arith_tac true;
+val tac = gen_tac true;
 
 end;
 
@@ -889,21 +883,25 @@
 
 val setup =
   init_arith_data #>
-  Simplifier.map_ss (fn ss => ss addsimprocs [fast_nat_arith_simproc]
+  Simplifier.map_ss (fn ss => ss addsimprocs [Simplifier.simproc (@{theory}) "fast_nat_arith"
+    ["(m::nat) < n","(m::nat) <= n", "(m::nat) = n"] (K simproc)]
+    (* Because of fast_nat_arith_simproc, the arithmetic solver is really only
+    useful to detect inconsistencies among the premises for subgoals which are
+    *not* themselves (in)equalities, because the latter activate
+    fast_nat_arith_simproc anyway. However, it seems cheaper to activate the
+    solver all the time rather than add the additional check. *)
     addSolver (mk_solver' "lin_arith"
-      (add_arith_facts #> Fast_Arith.cut_lin_arith_tac))) #>
-  Context.mapping
-   (setup_options #>
-    Arith_Data.add_tactic "linear arithmetic" gen_linear_arith_tac #>
-    Method.setup @{binding linarith}
-      (Args.bang_facts >> (fn prems => fn ctxt =>
-        METHOD (fn facts =>
-          HEADGOAL (Method.insert_tac (prems @ Arith_Data.get_arith_facts ctxt @ facts)
-            THEN' linear_arith_tac ctxt)))) "linear arithmetic" #>
-    Attrib.setup @{binding arith_split} (Scan.succeed arith_split_add)
-      "declaration of split rules for arithmetic procedure") I;
+      (add_arith_facts #> Fast_Arith.cut_lin_arith_tac)))
+
+val global_setup =
+  setup_split_limit #> setup_neq_limit #>
+  Attrib.setup @{binding arith_split} (Scan.succeed (Thm.declaration_attribute add_split))
+    "declaration of split rules for arithmetic procedure" #>
+  Method.setup @{binding linarith}
+    (Args.bang_facts >> (fn prems => fn ctxt =>
+      METHOD (fn facts =>
+        HEADGOAL (Method.insert_tac (prems @ Arith_Data.get_arith_facts ctxt @ facts)
+          THEN' tac ctxt)))) "linear arithmetic" #>
+  Arith_Data.add_tactic "linear arithmetic" gen_tac;
 
 end;
-
-structure Basic_Lin_Arith: BASIC_LIN_ARITH = Lin_Arith;
-open Basic_Lin_Arith;

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/list_code.ML	Fri May 15 15:56:28 2009 +0200
@@ -0,0 +1,52 @@
+(* Author: Florian Haftmann, TU Muenchen
+
+Code generation for list literals.
+*)
+
+signature LIST_CODE =
+sig
+  val implode_list: string -> string -> Code_Thingol.iterm -> Code_Thingol.iterm list option
+  val default_list: int * string
+    -> (Code_Printer.fixity -> Code_Thingol.iterm -> Pretty.T)
+    -> Code_Printer.fixity -> Code_Thingol.iterm -> Code_Thingol.iterm -> Pretty.T
+  val add_literal_list: string -> theory -> theory
+end;
+
+structure List_Code : LIST_CODE =
+struct
+
+open Basic_Code_Thingol;
+
+fun implode_list nil' cons' t =
+  let
+    fun dest_cons (IConst (c, _) `$ t1 `$ t2) =
+          if c = cons'
+          then SOME (t1, t2)
+          else NONE
+      | dest_cons _ = NONE;
+    val (ts, t') = Code_Thingol.unfoldr dest_cons t;
+  in case t'
+   of IConst (c, _) => if c = nil' then SOME ts else NONE
+    | _ => NONE
+  end;
+
+fun default_list (target_fxy, target_cons) pr fxy t1 t2 =
+  Code_Printer.brackify_infix (target_fxy, Code_Printer.R) fxy [
+    pr (Code_Printer.INFX (target_fxy, Code_Printer.X)) t1,
+    Code_Printer.str target_cons,
+    pr (Code_Printer.INFX (target_fxy, Code_Printer.R)) t2
+  ];
+
+fun add_literal_list target =
+  let
+    fun pretty literals [nil', cons'] pr thm vars fxy [(t1, _), (t2, _)] =
+      case Option.map (cons t1) (implode_list nil' cons' t2)
+       of SOME ts =>
+            Code_Printer.literal_list literals (map (pr vars Code_Printer.NOBR) ts)
+        | NONE =>
+            default_list (Code_Printer.infix_cons literals) (pr vars) fxy t1 t2;
+  in Code_Target.add_syntax_const target
+    @{const_name Cons} (SOME (2, ([@{const_name Nil}, @{const_name Cons}], pretty)))
+  end
+
+end;

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/nat_numeral_simprocs.ML	Fri May 15 15:56:28 2009 +0200
@@ -0,0 +1,538 @@
+(* Author: Lawrence C Paulson, Cambridge University Computer Laboratory
+
+Simprocs for nat numerals.
+*)
+
+signature NAT_NUMERAL_SIMPROCS =
+sig
+  val combine_numerals: simproc
+  val cancel_numerals: simproc list
+  val cancel_factors: simproc list
+  val cancel_numeral_factors: simproc list
+end;
+
+structure Nat_Numeral_Simprocs =
+struct
+
+(*Maps n to #n for n = 0, 1, 2*)
+val numeral_syms = [@{thm nat_numeral_0_eq_0} RS sym, @{thm nat_numeral_1_eq_1} RS sym, @{thm numeral_2_eq_2} RS sym];
+val numeral_sym_ss = HOL_ss addsimps numeral_syms;
+
+fun rename_numerals th =
+    simplify numeral_sym_ss (Thm.transfer (the_context ()) th);
+
+(*Utilities*)
+
+fun mk_number n = HOLogic.number_of_const HOLogic.natT $ HOLogic.mk_numeral n;
+fun dest_number t = Int.max (0, snd (HOLogic.dest_number t));
+
+fun find_first_numeral past (t::terms) =
+        ((dest_number t, t, rev past @ terms)
+         handle TERM _ => find_first_numeral (t::past) terms)
+  | find_first_numeral past [] = raise TERM("find_first_numeral", []);
+
+val zero = mk_number 0;
+val mk_plus = HOLogic.mk_binop @{const_name HOL.plus};
+
+(*Thus mk_sum[t] yields t+0; longer sums don't have a trailing zero*)
+fun mk_sum []        = zero
+  | mk_sum [t,u]     = mk_plus (t, u)
+  | mk_sum (t :: ts) = mk_plus (t, mk_sum ts);
+
+(*this version ALWAYS includes a trailing zero*)
+fun long_mk_sum []        = HOLogic.zero
+  | long_mk_sum (t :: ts) = mk_plus (t, mk_sum ts);
+
+val dest_plus = HOLogic.dest_bin @{const_name HOL.plus} HOLogic.natT;
+
+
+(** Other simproc items **)
+
+val bin_simps =
+     [@{thm nat_numeral_0_eq_0} RS sym, @{thm nat_numeral_1_eq_1} RS sym,
+      @{thm add_nat_number_of}, @{thm nat_number_of_add_left}, 
+      @{thm diff_nat_number_of}, @{thm le_number_of_eq_not_less},
+      @{thm mult_nat_number_of}, @{thm nat_number_of_mult_left}, 
+      @{thm less_nat_number_of}, 
+      @{thm Let_number_of}, @{thm nat_number_of}] @
+     @{thms arith_simps} @ @{thms rel_simps} @ @{thms neg_simps};
+
+
+(*** CancelNumerals simprocs ***)
+
+val one = mk_number 1;
+val mk_times = HOLogic.mk_binop @{const_name HOL.times};
+
+fun mk_prod [] = one
+  | mk_prod [t] = t
+  | mk_prod (t :: ts) = if t = one then mk_prod ts
+                        else mk_times (t, mk_prod ts);
+
+val dest_times = HOLogic.dest_bin @{const_name HOL.times} HOLogic.natT;
+
+fun dest_prod t =
+      let val (t,u) = dest_times t
+      in  dest_prod t @ dest_prod u  end
+      handle TERM _ => [t];
+
+(*DON'T do the obvious simplifications; that would create special cases*)
+fun mk_coeff (k,t) = mk_times (mk_number k, t);
+
+(*Express t as a product of (possibly) a numeral with other factors, sorted*)
+fun dest_coeff t =
+    let val ts = sort TermOrd.term_ord (dest_prod t)
+        val (n, _, ts') = find_first_numeral [] ts
+                          handle TERM _ => (1, one, ts)
+    in (n, mk_prod ts') end;
+
+(*Find first coefficient-term THAT MATCHES u*)
+fun find_first_coeff past u [] = raise TERM("find_first_coeff", [])
+  | find_first_coeff past u (t::terms) =
+        let val (n,u') = dest_coeff t
+        in  if u aconv u' then (n, rev past @ terms)
+                          else find_first_coeff (t::past) u terms
+        end
+        handle TERM _ => find_first_coeff (t::past) u terms;
+
+
+(*Split up a sum into the list of its constituent terms, on the way removing any
+  Sucs and counting them.*)
+fun dest_Suc_sum (Const ("Suc", _) $ t, (k,ts)) = dest_Suc_sum (t, (k+1,ts))
+  | dest_Suc_sum (t, (k,ts)) = 
+      let val (t1,t2) = dest_plus t
+      in  dest_Suc_sum (t1, dest_Suc_sum (t2, (k,ts)))  end
+      handle TERM _ => (k, t::ts);
+
+(*Code for testing whether numerals are already used in the goal*)
+fun is_numeral (Const(@{const_name Int.number_of}, _) $ w) = true
+  | is_numeral _ = false;
+
+fun prod_has_numeral t = exists is_numeral (dest_prod t);
+
+(*The Sucs found in the term are converted to a binary numeral. If relaxed is false,
+  an exception is raised unless the original expression contains at least one
+  numeral in a coefficient position.  This prevents nat_combine_numerals from 
+  introducing numerals to goals.*)
+fun dest_Sucs_sum relaxed t = 
+  let val (k,ts) = dest_Suc_sum (t,(0,[]))
+  in
+     if relaxed orelse exists prod_has_numeral ts then 
+       if k=0 then ts
+       else mk_number k :: ts
+     else raise TERM("Nat_Numeral_Simprocs.dest_Sucs_sum", [t])
+  end;
+
+
+(*Simplify 1*n and n*1 to n*)
+val add_0s  = map rename_numerals [@{thm add_0}, @{thm add_0_right}];
+val mult_1s = map rename_numerals [@{thm nat_mult_1}, @{thm nat_mult_1_right}];
+
+(*Final simplification: cancel + and *; replace Numeral0 by 0 and Numeral1 by 1*)
+
+(*And these help the simproc return False when appropriate, which helps
+  the arith prover.*)
+val contra_rules = [@{thm add_Suc}, @{thm add_Suc_right}, @{thm Zero_not_Suc},
+  @{thm Suc_not_Zero}, @{thm le_0_eq}];
+
+val simplify_meta_eq =
+    Arith_Data.simplify_meta_eq
+        ([@{thm nat_numeral_0_eq_0}, @{thm numeral_1_eq_Suc_0}, @{thm add_0}, @{thm add_0_right},
+          @{thm mult_0}, @{thm mult_0_right}, @{thm mult_1}, @{thm mult_1_right}] @ contra_rules);
+
+
+(*** Applying CancelNumeralsFun ***)
+
+structure CancelNumeralsCommon =
+  struct
+  val mk_sum            = (fn T:typ => mk_sum)
+  val dest_sum          = dest_Sucs_sum true
+  val mk_coeff          = mk_coeff
+  val dest_coeff        = dest_coeff
+  val find_first_coeff  = find_first_coeff []
+  val trans_tac         = K Arith_Data.trans_tac
+
+  val norm_ss1 = Numeral_Simprocs.num_ss addsimps numeral_syms @ add_0s @ mult_1s @
+    [@{thm Suc_eq_add_numeral_1_left}] @ @{thms add_ac}
+  val norm_ss2 = Numeral_Simprocs.num_ss addsimps bin_simps @ @{thms add_ac} @ @{thms mult_ac}
+  fun norm_tac ss = 
+    ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1))
+    THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2))
+
+  val numeral_simp_ss = HOL_ss addsimps add_0s @ bin_simps;
+  fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss));
+  val simplify_meta_eq  = simplify_meta_eq
+  end;
+
+
+structure EqCancelNumerals = CancelNumeralsFun
+ (open CancelNumeralsCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_eq
+  val dest_bal = HOLogic.dest_bin "op =" HOLogic.natT
+  val bal_add1 = @{thm nat_eq_add_iff1} RS trans
+  val bal_add2 = @{thm nat_eq_add_iff2} RS trans
+);
+
+structure LessCancelNumerals = CancelNumeralsFun
+ (open CancelNumeralsCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less}
+  val dest_bal = HOLogic.dest_bin @{const_name HOL.less} HOLogic.natT
+  val bal_add1 = @{thm nat_less_add_iff1} RS trans
+  val bal_add2 = @{thm nat_less_add_iff2} RS trans
+);
+
+structure LeCancelNumerals = CancelNumeralsFun
+ (open CancelNumeralsCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less_eq}
+  val dest_bal = HOLogic.dest_bin @{const_name HOL.less_eq} HOLogic.natT
+  val bal_add1 = @{thm nat_le_add_iff1} RS trans
+  val bal_add2 = @{thm nat_le_add_iff2} RS trans
+);
+
+structure DiffCancelNumerals = CancelNumeralsFun
+ (open CancelNumeralsCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_binop @{const_name HOL.minus}
+  val dest_bal = HOLogic.dest_bin @{const_name HOL.minus} HOLogic.natT
+  val bal_add1 = @{thm nat_diff_add_eq1} RS trans
+  val bal_add2 = @{thm nat_diff_add_eq2} RS trans
+);
+
+
+val cancel_numerals =
+  map Arith_Data.prep_simproc
+   [("nateq_cancel_numerals",
+     ["(l::nat) + m = n", "(l::nat) = m + n",
+      "(l::nat) * m = n", "(l::nat) = m * n",
+      "Suc m = n", "m = Suc n"],
+     K EqCancelNumerals.proc),
+    ("natless_cancel_numerals",
+     ["(l::nat) + m < n", "(l::nat) < m + n",
+      "(l::nat) * m < n", "(l::nat) < m * n",
+      "Suc m < n", "m < Suc n"],
+     K LessCancelNumerals.proc),
+    ("natle_cancel_numerals",
+     ["(l::nat) + m <= n", "(l::nat) <= m + n",
+      "(l::nat) * m <= n", "(l::nat) <= m * n",
+      "Suc m <= n", "m <= Suc n"],
+     K LeCancelNumerals.proc),
+    ("natdiff_cancel_numerals",
+     ["((l::nat) + m) - n", "(l::nat) - (m + n)",
+      "(l::nat) * m - n", "(l::nat) - m * n",
+      "Suc m - n", "m - Suc n"],
+     K DiffCancelNumerals.proc)];
+
+
+(*** Applying CombineNumeralsFun ***)
+
+structure CombineNumeralsData =
+  struct
+  type coeff            = int
+  val iszero            = (fn x => x = 0)
+  val add               = op +
+  val mk_sum            = (fn T:typ => long_mk_sum)  (*to work for 2*x + 3*x *)
+  val dest_sum          = dest_Sucs_sum false
+  val mk_coeff          = mk_coeff
+  val dest_coeff        = dest_coeff
+  val left_distrib      = @{thm left_add_mult_distrib} RS trans
+  val prove_conv        = Arith_Data.prove_conv_nohyps
+  val trans_tac         = K Arith_Data.trans_tac
+
+  val norm_ss1 = Numeral_Simprocs.num_ss addsimps numeral_syms @ add_0s @ mult_1s @ [@{thm Suc_eq_add_numeral_1}] @ @{thms add_ac}
+  val norm_ss2 = Numeral_Simprocs.num_ss addsimps bin_simps @ @{thms add_ac} @ @{thms mult_ac}
+  fun norm_tac ss =
+    ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1))
+    THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2))
+
+  val numeral_simp_ss = HOL_ss addsimps add_0s @ bin_simps;
+  fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss))
+  val simplify_meta_eq  = simplify_meta_eq
+  end;
+
+structure CombineNumerals = CombineNumeralsFun(CombineNumeralsData);
+
+val combine_numerals =
+  Arith_Data.prep_simproc ("nat_combine_numerals", ["(i::nat) + j", "Suc (i + j)"], K CombineNumerals.proc);
+
+
+(*** Applying CancelNumeralFactorFun ***)
+
+structure CancelNumeralFactorCommon =
+  struct
+  val mk_coeff          = mk_coeff
+  val dest_coeff        = dest_coeff
+  val trans_tac         = K Arith_Data.trans_tac
+
+  val norm_ss1 = Numeral_Simprocs.num_ss addsimps
+    numeral_syms @ add_0s @ mult_1s @ [@{thm Suc_eq_add_numeral_1_left}] @ @{thms add_ac}
+  val norm_ss2 = Numeral_Simprocs.num_ss addsimps bin_simps @ @{thms add_ac} @ @{thms mult_ac}
+  fun norm_tac ss =
+    ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1))
+    THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2))
+
+  val numeral_simp_ss = HOL_ss addsimps bin_simps
+  fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss))
+  val simplify_meta_eq  = simplify_meta_eq
+  end
+
+structure DivCancelNumeralFactor = CancelNumeralFactorFun
+ (open CancelNumeralFactorCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_binop @{const_name Divides.div}
+  val dest_bal = HOLogic.dest_bin @{const_name Divides.div} HOLogic.natT
+  val cancel = @{thm nat_mult_div_cancel1} RS trans
+  val neg_exchanges = false
+)
+
+structure DvdCancelNumeralFactor = CancelNumeralFactorFun
+ (open CancelNumeralFactorCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_binrel @{const_name Ring_and_Field.dvd}
+  val dest_bal = HOLogic.dest_bin @{const_name Ring_and_Field.dvd} HOLogic.natT
+  val cancel = @{thm nat_mult_dvd_cancel1} RS trans
+  val neg_exchanges = false
+)
+
+structure EqCancelNumeralFactor = CancelNumeralFactorFun
+ (open CancelNumeralFactorCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_eq
+  val dest_bal = HOLogic.dest_bin "op =" HOLogic.natT
+  val cancel = @{thm nat_mult_eq_cancel1} RS trans
+  val neg_exchanges = false
+)
+
+structure LessCancelNumeralFactor = CancelNumeralFactorFun
+ (open CancelNumeralFactorCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less}
+  val dest_bal = HOLogic.dest_bin @{const_name HOL.less} HOLogic.natT
+  val cancel = @{thm nat_mult_less_cancel1} RS trans
+  val neg_exchanges = true
+)
+
+structure LeCancelNumeralFactor = CancelNumeralFactorFun
+ (open CancelNumeralFactorCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less_eq}
+  val dest_bal = HOLogic.dest_bin @{const_name HOL.less_eq} HOLogic.natT
+  val cancel = @{thm nat_mult_le_cancel1} RS trans
+  val neg_exchanges = true
+)
+
+val cancel_numeral_factors =
+  map Arith_Data.prep_simproc
+   [("nateq_cancel_numeral_factors",
+     ["(l::nat) * m = n", "(l::nat) = m * n"],
+     K EqCancelNumeralFactor.proc),
+    ("natless_cancel_numeral_factors",
+     ["(l::nat) * m < n", "(l::nat) < m * n"],
+     K LessCancelNumeralFactor.proc),
+    ("natle_cancel_numeral_factors",
+     ["(l::nat) * m <= n", "(l::nat) <= m * n"],
+     K LeCancelNumeralFactor.proc),
+    ("natdiv_cancel_numeral_factors",
+     ["((l::nat) * m) div n", "(l::nat) div (m * n)"],
+     K DivCancelNumeralFactor.proc),
+    ("natdvd_cancel_numeral_factors",
+     ["((l::nat) * m) dvd n", "(l::nat) dvd (m * n)"],
+     K DvdCancelNumeralFactor.proc)];
+
+
+
+(*** Applying ExtractCommonTermFun ***)
+
+(*this version ALWAYS includes a trailing one*)
+fun long_mk_prod []        = one
+  | long_mk_prod (t :: ts) = mk_times (t, mk_prod ts);
+
+(*Find first term that matches u*)
+fun find_first_t past u []         = raise TERM("find_first_t", [])
+  | find_first_t past u (t::terms) =
+        if u aconv t then (rev past @ terms)
+        else find_first_t (t::past) u terms
+        handle TERM _ => find_first_t (t::past) u terms;
+
+(** Final simplification for the CancelFactor simprocs **)
+val simplify_one = Arith_Data.simplify_meta_eq  
+  [@{thm mult_1_left}, @{thm mult_1_right}, @{thm div_1}, @{thm numeral_1_eq_Suc_0}];
+
+fun cancel_simplify_meta_eq ss cancel_th th =
+    simplify_one ss (([th, cancel_th]) MRS trans);
+
+structure CancelFactorCommon =
+  struct
+  val mk_sum            = (fn T:typ => long_mk_prod)
+  val dest_sum          = dest_prod
+  val mk_coeff          = mk_coeff
+  val dest_coeff        = dest_coeff
+  val find_first        = find_first_t []
+  val trans_tac         = K Arith_Data.trans_tac
+  val norm_ss = HOL_ss addsimps mult_1s @ @{thms mult_ac}
+  fun norm_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss))
+  val simplify_meta_eq  = cancel_simplify_meta_eq
+  end;
+
+structure EqCancelFactor = ExtractCommonTermFun
+ (open CancelFactorCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_eq
+  val dest_bal = HOLogic.dest_bin "op =" HOLogic.natT
+  val simp_conv = K(K (SOME @{thm nat_mult_eq_cancel_disj}))
+);
+
+structure LessCancelFactor = ExtractCommonTermFun
+ (open CancelFactorCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less}
+  val dest_bal = HOLogic.dest_bin @{const_name HOL.less} HOLogic.natT
+  val simp_conv = K(K (SOME @{thm nat_mult_less_cancel_disj}))
+);
+
+structure LeCancelFactor = ExtractCommonTermFun
+ (open CancelFactorCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less_eq}
+  val dest_bal = HOLogic.dest_bin @{const_name HOL.less_eq} HOLogic.natT
+  val simp_conv = K(K (SOME @{thm nat_mult_le_cancel_disj}))
+);
+
+structure DivideCancelFactor = ExtractCommonTermFun
+ (open CancelFactorCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_binop @{const_name Divides.div}
+  val dest_bal = HOLogic.dest_bin @{const_name Divides.div} HOLogic.natT
+  val simp_conv = K(K (SOME @{thm nat_mult_div_cancel_disj}))
+);
+
+structure DvdCancelFactor = ExtractCommonTermFun
+ (open CancelFactorCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_binrel @{const_name Ring_and_Field.dvd}
+  val dest_bal = HOLogic.dest_bin @{const_name Ring_and_Field.dvd} HOLogic.natT
+  val simp_conv = K(K (SOME @{thm nat_mult_dvd_cancel_disj}))
+);
+
+val cancel_factor =
+  map Arith_Data.prep_simproc
+   [("nat_eq_cancel_factor",
+     ["(l::nat) * m = n", "(l::nat) = m * n"],
+     K EqCancelFactor.proc),
+    ("nat_less_cancel_factor",
+     ["(l::nat) * m < n", "(l::nat) < m * n"],
+     K LessCancelFactor.proc),
+    ("nat_le_cancel_factor",
+     ["(l::nat) * m <= n", "(l::nat) <= m * n"],
+     K LeCancelFactor.proc),
+    ("nat_divide_cancel_factor",
+     ["((l::nat) * m) div n", "(l::nat) div (m * n)"],
+     K DivideCancelFactor.proc),
+    ("nat_dvd_cancel_factor",
+     ["((l::nat) * m) dvd n", "(l::nat) dvd (m * n)"],
+     K DvdCancelFactor.proc)];
+
+end;
+
+
+Addsimprocs Nat_Numeral_Simprocs.cancel_numerals;
+Addsimprocs [Nat_Numeral_Simprocs.combine_numerals];
+Addsimprocs Nat_Numeral_Simprocs.cancel_numeral_factors;
+Addsimprocs Nat_Numeral_Simprocs.cancel_factor;
+
+
+(*examples:
+print_depth 22;
+set timing;
+set trace_simp;
+fun test s = (Goal s; by (Simp_tac 1));
+
+(*cancel_numerals*)
+test "l +( 2) + (2) + 2 + (l + 2) + (oo  + 2) = (uu::nat)";
+test "(2*length xs < 2*length xs + j)";
+test "(2*length xs < length xs * 2 + j)";
+test "2*u = (u::nat)";
+test "2*u = Suc (u)";
+test "(i + j + 12 + (k::nat)) - 15 = y";
+test "(i + j + 12 + (k::nat)) - 5 = y";
+test "Suc u - 2 = y";
+test "Suc (Suc (Suc u)) - 2 = y";
+test "(i + j + 2 + (k::nat)) - 1 = y";
+test "(i + j + 1 + (k::nat)) - 2 = y";
+
+test "(2*x + (u*v) + y) - v*3*u = (w::nat)";
+test "(2*x*u*v + 5 + (u*v)*4 + y) - v*u*4 = (w::nat)";
+test "(2*x*u*v + (u*v)*4 + y) - v*u = (w::nat)";
+test "Suc (Suc (2*x*u*v + u*4 + y)) - u = w";
+test "Suc ((u*v)*4) - v*3*u = w";
+test "Suc (Suc ((u*v)*3)) - v*3*u = w";
+
+test "(i + j + 12 + (k::nat)) = u + 15 + y";
+test "(i + j + 32 + (k::nat)) - (u + 15 + y) = zz";
+test "(i + j + 12 + (k::nat)) = u + 5 + y";
+(*Suc*)
+test "(i + j + 12 + k) = Suc (u + y)";
+test "Suc (Suc (Suc (Suc (Suc (u + y))))) <= ((i + j) + 41 + k)";
+test "(i + j + 5 + k) < Suc (Suc (Suc (Suc (Suc (u + y)))))";
+test "Suc (Suc (Suc (Suc (Suc (u + y))))) - 5 = v";
+test "(i + j + 5 + k) = Suc (Suc (Suc (Suc (Suc (Suc (Suc (u + y)))))))";
+test "2*y + 3*z + 2*u = Suc (u)";
+test "2*y + 3*z + 6*w + 2*y + 3*z + 2*u = Suc (u)";
+test "2*y + 3*z + 6*w + 2*y + 3*z + 2*u = 2*y' + 3*z' + 6*w' + 2*y' + 3*z' + u + (vv::nat)";
+test "6 + 2*y + 3*z + 4*u = Suc (vv + 2*u + z)";
+test "(2*n*m) < (3*(m*n)) + (u::nat)";
+
+test "(Suc (Suc (Suc (Suc (Suc (Suc (case length (f c) of 0 => 0 | Suc k => k)))))) <= Suc 0)";
+ 
+test "Suc (Suc (Suc (Suc (Suc (Suc (length l1 + length l2)))))) <= length l1";
+
+test "( (Suc (Suc (Suc (Suc (Suc (length (compT P E A ST mxr e) + length l3)))))) <= length (compT P E A ST mxr e))";
+
+test "( (Suc (Suc (Suc (Suc (Suc (length (compT P E A ST mxr e) + length (compT P E (A Un \<A> e) ST mxr c))))))) <= length (compT P E A ST mxr e))";
+
+
+(*negative numerals: FAIL*)
+test "(i + j + -23 + (k::nat)) < u + 15 + y";
+test "(i + j + 3 + (k::nat)) < u + -15 + y";
+test "(i + j + -12 + (k::nat)) - 15 = y";
+test "(i + j + 12 + (k::nat)) - -15 = y";
+test "(i + j + -12 + (k::nat)) - -15 = y";
+
+(*combine_numerals*)
+test "k + 3*k = (u::nat)";
+test "Suc (i + 3) = u";
+test "Suc (i + j + 3 + k) = u";
+test "k + j + 3*k + j = (u::nat)";
+test "Suc (j*i + i + k + 5 + 3*k + i*j*4) = (u::nat)";
+test "(2*n*m) + (3*(m*n)) = (u::nat)";
+(*negative numerals: FAIL*)
+test "Suc (i + j + -3 + k) = u";
+
+(*cancel_numeral_factors*)
+test "9*x = 12 * (y::nat)";
+test "(9*x) div (12 * (y::nat)) = z";
+test "9*x < 12 * (y::nat)";
+test "9*x <= 12 * (y::nat)";
+
+(*cancel_factor*)
+test "x*k = k*(y::nat)";
+test "k = k*(y::nat)";
+test "a*(b*c) = (b::nat)";
+test "a*(b*c) = d*(b::nat)*(x*a)";
+
+test "x*k < k*(y::nat)";
+test "k < k*(y::nat)";
+test "a*(b*c) < (b::nat)";
+test "a*(b*c) < d*(b::nat)*(x*a)";
+
+test "x*k <= k*(y::nat)";
+test "k <= k*(y::nat)";
+test "a*(b*c) <= (b::nat)";
+test "a*(b*c) <= d*(b::nat)*(x*a)";
+
+test "(x*k) div (k*(y::nat)) = (uu::nat)";
+test "(k) div (k*(y::nat)) = (uu::nat)";
+test "(a*(b*c)) div ((b::nat)) = (uu::nat)";
+test "(a*(b*c)) div (d*(b::nat)*(x*a)) = (uu::nat)";
+*)

--- a/src/HOL/Tools/nat_simprocs.ML	Fri May 15 15:29:34 2009 +0200
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,574 +0,0 @@
-(*  Title:      HOL/Tools/nat_simprocs.ML
-    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
-
-Simprocs for nat numerals.
-*)
-
-structure Nat_Numeral_Simprocs =
-struct
-
-(*Maps n to #n for n = 0, 1, 2*)
-val numeral_syms = [@{thm nat_numeral_0_eq_0} RS sym, @{thm nat_numeral_1_eq_1} RS sym, @{thm numeral_2_eq_2} RS sym];
-val numeral_sym_ss = HOL_ss addsimps numeral_syms;
-
-fun rename_numerals th =
-    simplify numeral_sym_ss (Thm.transfer (the_context ()) th);
-
-(*Utilities*)
-
-fun mk_number n = HOLogic.number_of_const HOLogic.natT $ HOLogic.mk_numeral n;
-fun dest_number t = Int.max (0, snd (HOLogic.dest_number t));
-
-fun find_first_numeral past (t::terms) =
-        ((dest_number t, t, rev past @ terms)
-         handle TERM _ => find_first_numeral (t::past) terms)
-  | find_first_numeral past [] = raise TERM("find_first_numeral", []);
-
-val zero = mk_number 0;
-val mk_plus = HOLogic.mk_binop @{const_name HOL.plus};
-
-(*Thus mk_sum[t] yields t+0; longer sums don't have a trailing zero*)
-fun mk_sum []        = zero
-  | mk_sum [t,u]     = mk_plus (t, u)
-  | mk_sum (t :: ts) = mk_plus (t, mk_sum ts);
-
-(*this version ALWAYS includes a trailing zero*)
-fun long_mk_sum []        = HOLogic.zero
-  | long_mk_sum (t :: ts) = mk_plus (t, mk_sum ts);
-
-val dest_plus = HOLogic.dest_bin @{const_name HOL.plus} HOLogic.natT;
-
-
-(** Other simproc items **)
-
-val bin_simps =
-     [@{thm nat_numeral_0_eq_0} RS sym, @{thm nat_numeral_1_eq_1} RS sym,
-      @{thm add_nat_number_of}, @{thm nat_number_of_add_left}, 
-      @{thm diff_nat_number_of}, @{thm le_number_of_eq_not_less},
-      @{thm mult_nat_number_of}, @{thm nat_number_of_mult_left}, 
-      @{thm less_nat_number_of}, 
-      @{thm Let_number_of}, @{thm nat_number_of}] @
-     @{thms arith_simps} @ @{thms rel_simps} @ @{thms neg_simps};
-
-
-(*** CancelNumerals simprocs ***)
-
-val one = mk_number 1;
-val mk_times = HOLogic.mk_binop @{const_name HOL.times};
-
-fun mk_prod [] = one
-  | mk_prod [t] = t
-  | mk_prod (t :: ts) = if t = one then mk_prod ts
-                        else mk_times (t, mk_prod ts);
-
-val dest_times = HOLogic.dest_bin @{const_name HOL.times} HOLogic.natT;
-
-fun dest_prod t =
-      let val (t,u) = dest_times t
-      in  dest_prod t @ dest_prod u  end
-      handle TERM _ => [t];
-
-(*DON'T do the obvious simplifications; that would create special cases*)
-fun mk_coeff (k,t) = mk_times (mk_number k, t);
-
-(*Express t as a product of (possibly) a numeral with other factors, sorted*)
-fun dest_coeff t =
-    let val ts = sort TermOrd.term_ord (dest_prod t)
-        val (n, _, ts') = find_first_numeral [] ts
-                          handle TERM _ => (1, one, ts)
-    in (n, mk_prod ts') end;
-
-(*Find first coefficient-term THAT MATCHES u*)
-fun find_first_coeff past u [] = raise TERM("find_first_coeff", [])
-  | find_first_coeff past u (t::terms) =
-        let val (n,u') = dest_coeff t
-        in  if u aconv u' then (n, rev past @ terms)
-                          else find_first_coeff (t::past) u terms
-        end
-        handle TERM _ => find_first_coeff (t::past) u terms;
-
-
-(*Split up a sum into the list of its constituent terms, on the way removing any
-  Sucs and counting them.*)
-fun dest_Suc_sum (Const ("Suc", _) $ t, (k,ts)) = dest_Suc_sum (t, (k+1,ts))
-  | dest_Suc_sum (t, (k,ts)) = 
-      let val (t1,t2) = dest_plus t
-      in  dest_Suc_sum (t1, dest_Suc_sum (t2, (k,ts)))  end
-      handle TERM _ => (k, t::ts);
-
-(*Code for testing whether numerals are already used in the goal*)
-fun is_numeral (Const(@{const_name Int.number_of}, _) $ w) = true
-  | is_numeral _ = false;
-
-fun prod_has_numeral t = exists is_numeral (dest_prod t);
-
-(*The Sucs found in the term are converted to a binary numeral. If relaxed is false,
-  an exception is raised unless the original expression contains at least one
-  numeral in a coefficient position.  This prevents nat_combine_numerals from 
-  introducing numerals to goals.*)
-fun dest_Sucs_sum relaxed t = 
-  let val (k,ts) = dest_Suc_sum (t,(0,[]))
-  in
-     if relaxed orelse exists prod_has_numeral ts then 
-       if k=0 then ts
-       else mk_number k :: ts
-     else raise TERM("Nat_Numeral_Simprocs.dest_Sucs_sum", [t])
-  end;
-
-
-(*Simplify 1*n and n*1 to n*)
-val add_0s  = map rename_numerals [@{thm add_0}, @{thm add_0_right}];
-val mult_1s = map rename_numerals [@{thm nat_mult_1}, @{thm nat_mult_1_right}];
-
-(*Final simplification: cancel + and *; replace Numeral0 by 0 and Numeral1 by 1*)
-
-(*And these help the simproc return False when appropriate, which helps
-  the arith prover.*)
-val contra_rules = [@{thm add_Suc}, @{thm add_Suc_right}, @{thm Zero_not_Suc},
-  @{thm Suc_not_Zero}, @{thm le_0_eq}];
-
-val simplify_meta_eq =
-    Arith_Data.simplify_meta_eq
-        ([@{thm nat_numeral_0_eq_0}, @{thm numeral_1_eq_Suc_0}, @{thm add_0}, @{thm add_0_right},
-          @{thm mult_0}, @{thm mult_0_right}, @{thm mult_1}, @{thm mult_1_right}] @ contra_rules);
-
-
-(*** Applying CancelNumeralsFun ***)
-
-structure CancelNumeralsCommon =
-  struct
-  val mk_sum            = (fn T:typ => mk_sum)
-  val dest_sum          = dest_Sucs_sum true
-  val mk_coeff          = mk_coeff
-  val dest_coeff        = dest_coeff
-  val find_first_coeff  = find_first_coeff []
-  val trans_tac         = K Arith_Data.trans_tac
-
-  val norm_ss1 = Int_Numeral_Simprocs.num_ss addsimps numeral_syms @ add_0s @ mult_1s @
-    [@{thm Suc_eq_add_numeral_1_left}] @ @{thms add_ac}
-  val norm_ss2 = Int_Numeral_Simprocs.num_ss addsimps bin_simps @ @{thms add_ac} @ @{thms mult_ac}
-  fun norm_tac ss = 
-    ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1))
-    THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2))
-
-  val numeral_simp_ss = HOL_ss addsimps add_0s @ bin_simps;
-  fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss));
-  val simplify_meta_eq  = simplify_meta_eq
-  end;
-
-
-structure EqCancelNumerals = CancelNumeralsFun
- (open CancelNumeralsCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_eq
-  val dest_bal = HOLogic.dest_bin "op =" HOLogic.natT
-  val bal_add1 = @{thm nat_eq_add_iff1} RS trans
-  val bal_add2 = @{thm nat_eq_add_iff2} RS trans
-);
-
-structure LessCancelNumerals = CancelNumeralsFun
- (open CancelNumeralsCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less}
-  val dest_bal = HOLogic.dest_bin @{const_name HOL.less} HOLogic.natT
-  val bal_add1 = @{thm nat_less_add_iff1} RS trans
-  val bal_add2 = @{thm nat_less_add_iff2} RS trans
-);
-
-structure LeCancelNumerals = CancelNumeralsFun
- (open CancelNumeralsCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less_eq}
-  val dest_bal = HOLogic.dest_bin @{const_name HOL.less_eq} HOLogic.natT
-  val bal_add1 = @{thm nat_le_add_iff1} RS trans
-  val bal_add2 = @{thm nat_le_add_iff2} RS trans
-);
-
-structure DiffCancelNumerals = CancelNumeralsFun
- (open CancelNumeralsCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_binop @{const_name HOL.minus}
-  val dest_bal = HOLogic.dest_bin @{const_name HOL.minus} HOLogic.natT
-  val bal_add1 = @{thm nat_diff_add_eq1} RS trans
-  val bal_add2 = @{thm nat_diff_add_eq2} RS trans
-);
-
-
-val cancel_numerals =
-  map Arith_Data.prep_simproc
-   [("nateq_cancel_numerals",
-     ["(l::nat) + m = n", "(l::nat) = m + n",
-      "(l::nat) * m = n", "(l::nat) = m * n",
-      "Suc m = n", "m = Suc n"],
-     K EqCancelNumerals.proc),
-    ("natless_cancel_numerals",
-     ["(l::nat) + m < n", "(l::nat) < m + n",
-      "(l::nat) * m < n", "(l::nat) < m * n",
-      "Suc m < n", "m < Suc n"],
-     K LessCancelNumerals.proc),
-    ("natle_cancel_numerals",
-     ["(l::nat) + m <= n", "(l::nat) <= m + n",
-      "(l::nat) * m <= n", "(l::nat) <= m * n",
-      "Suc m <= n", "m <= Suc n"],
-     K LeCancelNumerals.proc),
-    ("natdiff_cancel_numerals",
-     ["((l::nat) + m) - n", "(l::nat) - (m + n)",
-      "(l::nat) * m - n", "(l::nat) - m * n",
-      "Suc m - n", "m - Suc n"],
-     K DiffCancelNumerals.proc)];
-
-
-(*** Applying CombineNumeralsFun ***)
-
-structure CombineNumeralsData =
-  struct
-  type coeff            = int
-  val iszero            = (fn x => x = 0)
-  val add               = op +
-  val mk_sum            = (fn T:typ => long_mk_sum)  (*to work for 2*x + 3*x *)
-  val dest_sum          = dest_Sucs_sum false
-  val mk_coeff          = mk_coeff
-  val dest_coeff        = dest_coeff
-  val left_distrib      = @{thm left_add_mult_distrib} RS trans
-  val prove_conv        = Arith_Data.prove_conv_nohyps
-  val trans_tac         = K Arith_Data.trans_tac
-
-  val norm_ss1 = Int_Numeral_Simprocs.num_ss addsimps numeral_syms @ add_0s @ mult_1s @ [@{thm Suc_eq_add_numeral_1}] @ @{thms add_ac}
-  val norm_ss2 = Int_Numeral_Simprocs.num_ss addsimps bin_simps @ @{thms add_ac} @ @{thms mult_ac}
-  fun norm_tac ss =
-    ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1))
-    THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2))
-
-  val numeral_simp_ss = HOL_ss addsimps add_0s @ bin_simps;
-  fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss))
-  val simplify_meta_eq  = simplify_meta_eq
-  end;
-
-structure CombineNumerals = CombineNumeralsFun(CombineNumeralsData);
-
-val combine_numerals =
-  Arith_Data.prep_simproc ("nat_combine_numerals", ["(i::nat) + j", "Suc (i + j)"], K CombineNumerals.proc);
-
-
-(*** Applying CancelNumeralFactorFun ***)
-
-structure CancelNumeralFactorCommon =
-  struct
-  val mk_coeff          = mk_coeff
-  val dest_coeff        = dest_coeff
-  val trans_tac         = K Arith_Data.trans_tac
-
-  val norm_ss1 = Int_Numeral_Simprocs.num_ss addsimps
-    numeral_syms @ add_0s @ mult_1s @ [@{thm Suc_eq_add_numeral_1_left}] @ @{thms add_ac}
-  val norm_ss2 = Int_Numeral_Simprocs.num_ss addsimps bin_simps @ @{thms add_ac} @ @{thms mult_ac}
-  fun norm_tac ss =
-    ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1))
-    THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2))
-
-  val numeral_simp_ss = HOL_ss addsimps bin_simps
-  fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss))
-  val simplify_meta_eq  = simplify_meta_eq
-  end
-
-structure DivCancelNumeralFactor = CancelNumeralFactorFun
- (open CancelNumeralFactorCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_binop @{const_name Divides.div}
-  val dest_bal = HOLogic.dest_bin @{const_name Divides.div} HOLogic.natT
-  val cancel = @{thm nat_mult_div_cancel1} RS trans
-  val neg_exchanges = false
-)
-
-structure DvdCancelNumeralFactor = CancelNumeralFactorFun
- (open CancelNumeralFactorCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_binrel @{const_name Ring_and_Field.dvd}
-  val dest_bal = HOLogic.dest_bin @{const_name Ring_and_Field.dvd} HOLogic.natT
-  val cancel = @{thm nat_mult_dvd_cancel1} RS trans
-  val neg_exchanges = false
-)
-
-structure EqCancelNumeralFactor = CancelNumeralFactorFun
- (open CancelNumeralFactorCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_eq
-  val dest_bal = HOLogic.dest_bin "op =" HOLogic.natT
-  val cancel = @{thm nat_mult_eq_cancel1} RS trans
-  val neg_exchanges = false
-)
-
-structure LessCancelNumeralFactor = CancelNumeralFactorFun
- (open CancelNumeralFactorCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less}
-  val dest_bal = HOLogic.dest_bin @{const_name HOL.less} HOLogic.natT
-  val cancel = @{thm nat_mult_less_cancel1} RS trans
-  val neg_exchanges = true
-)
-
-structure LeCancelNumeralFactor = CancelNumeralFactorFun
- (open CancelNumeralFactorCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less_eq}
-  val dest_bal = HOLogic.dest_bin @{const_name HOL.less_eq} HOLogic.natT
-  val cancel = @{thm nat_mult_le_cancel1} RS trans
-  val neg_exchanges = true
-)
-
-val cancel_numeral_factors =
-  map Arith_Data.prep_simproc
-   [("nateq_cancel_numeral_factors",
-     ["(l::nat) * m = n", "(l::nat) = m * n"],
-     K EqCancelNumeralFactor.proc),
-    ("natless_cancel_numeral_factors",
-     ["(l::nat) * m < n", "(l::nat) < m * n"],
-     K LessCancelNumeralFactor.proc),
-    ("natle_cancel_numeral_factors",
-     ["(l::nat) * m <= n", "(l::nat) <= m * n"],
-     K LeCancelNumeralFactor.proc),
-    ("natdiv_cancel_numeral_factors",
-     ["((l::nat) * m) div n", "(l::nat) div (m * n)"],
-     K DivCancelNumeralFactor.proc),
-    ("natdvd_cancel_numeral_factors",
-     ["((l::nat) * m) dvd n", "(l::nat) dvd (m * n)"],
-     K DvdCancelNumeralFactor.proc)];
-
-
-
-(*** Applying ExtractCommonTermFun ***)
-
-(*this version ALWAYS includes a trailing one*)
-fun long_mk_prod []        = one
-  | long_mk_prod (t :: ts) = mk_times (t, mk_prod ts);
-
-(*Find first term that matches u*)
-fun find_first_t past u []         = raise TERM("find_first_t", [])
-  | find_first_t past u (t::terms) =
-        if u aconv t then (rev past @ terms)
-        else find_first_t (t::past) u terms
-        handle TERM _ => find_first_t (t::past) u terms;
-
-(** Final simplification for the CancelFactor simprocs **)
-val simplify_one = Arith_Data.simplify_meta_eq  
-  [@{thm mult_1_left}, @{thm mult_1_right}, @{thm div_1}, @{thm numeral_1_eq_Suc_0}];
-
-fun cancel_simplify_meta_eq ss cancel_th th =
-    simplify_one ss (([th, cancel_th]) MRS trans);
-
-structure CancelFactorCommon =
-  struct
-  val mk_sum            = (fn T:typ => long_mk_prod)
-  val dest_sum          = dest_prod
-  val mk_coeff          = mk_coeff
-  val dest_coeff        = dest_coeff
-  val find_first        = find_first_t []
-  val trans_tac         = K Arith_Data.trans_tac
-  val norm_ss = HOL_ss addsimps mult_1s @ @{thms mult_ac}
-  fun norm_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss))
-  val simplify_meta_eq  = cancel_simplify_meta_eq
-  end;
-
-structure EqCancelFactor = ExtractCommonTermFun
- (open CancelFactorCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_eq
-  val dest_bal = HOLogic.dest_bin "op =" HOLogic.natT
-  val simp_conv = K(K (SOME @{thm nat_mult_eq_cancel_disj}))
-);
-
-structure LessCancelFactor = ExtractCommonTermFun
- (open CancelFactorCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less}
-  val dest_bal = HOLogic.dest_bin @{const_name HOL.less} HOLogic.natT
-  val simp_conv = K(K (SOME @{thm nat_mult_less_cancel_disj}))
-);
-
-structure LeCancelFactor = ExtractCommonTermFun
- (open CancelFactorCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less_eq}
-  val dest_bal = HOLogic.dest_bin @{const_name HOL.less_eq} HOLogic.natT
-  val simp_conv = K(K (SOME @{thm nat_mult_le_cancel_disj}))
-);
-
-structure DivideCancelFactor = ExtractCommonTermFun
- (open CancelFactorCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_binop @{const_name Divides.div}
-  val dest_bal = HOLogic.dest_bin @{const_name Divides.div} HOLogic.natT
-  val simp_conv = K(K (SOME @{thm nat_mult_div_cancel_disj}))
-);
-
-structure DvdCancelFactor = ExtractCommonTermFun
- (open CancelFactorCommon
-  val prove_conv = Arith_Data.prove_conv
-  val mk_bal   = HOLogic.mk_binrel @{const_name Ring_and_Field.dvd}
-  val dest_bal = HOLogic.dest_bin @{const_name Ring_and_Field.dvd} HOLogic.natT
-  val simp_conv = K(K (SOME @{thm nat_mult_dvd_cancel_disj}))
-);
-
-val cancel_factor =
-  map Arith_Data.prep_simproc
-   [("nat_eq_cancel_factor",
-     ["(l::nat) * m = n", "(l::nat) = m * n"],
-     K EqCancelFactor.proc),
-    ("nat_less_cancel_factor",
-     ["(l::nat) * m < n", "(l::nat) < m * n"],
-     K LessCancelFactor.proc),
-    ("nat_le_cancel_factor",
-     ["(l::nat) * m <= n", "(l::nat) <= m * n"],
-     K LeCancelFactor.proc),
-    ("nat_divide_cancel_factor",
-     ["((l::nat) * m) div n", "(l::nat) div (m * n)"],
-     K DivideCancelFactor.proc),
-    ("nat_dvd_cancel_factor",
-     ["((l::nat) * m) dvd n", "(l::nat) dvd (m * n)"],
-     K DvdCancelFactor.proc)];
-
-end;
-
-
-Addsimprocs Nat_Numeral_Simprocs.cancel_numerals;
-Addsimprocs [Nat_Numeral_Simprocs.combine_numerals];
-Addsimprocs Nat_Numeral_Simprocs.cancel_numeral_factors;
-Addsimprocs Nat_Numeral_Simprocs.cancel_factor;
-
-
-(*examples:
-print_depth 22;
-set timing;
-set trace_simp;
-fun test s = (Goal s; by (Simp_tac 1));
-
-(*cancel_numerals*)
-test "l +( 2) + (2) + 2 + (l + 2) + (oo  + 2) = (uu::nat)";
-test "(2*length xs < 2*length xs + j)";
-test "(2*length xs < length xs * 2 + j)";
-test "2*u = (u::nat)";
-test "2*u = Suc (u)";
-test "(i + j + 12 + (k::nat)) - 15 = y";
-test "(i + j + 12 + (k::nat)) - 5 = y";
-test "Suc u - 2 = y";
-test "Suc (Suc (Suc u)) - 2 = y";
-test "(i + j + 2 + (k::nat)) - 1 = y";
-test "(i + j + 1 + (k::nat)) - 2 = y";
-
-test "(2*x + (u*v) + y) - v*3*u = (w::nat)";
-test "(2*x*u*v + 5 + (u*v)*4 + y) - v*u*4 = (w::nat)";
-test "(2*x*u*v + (u*v)*4 + y) - v*u = (w::nat)";
-test "Suc (Suc (2*x*u*v + u*4 + y)) - u = w";
-test "Suc ((u*v)*4) - v*3*u = w";
-test "Suc (Suc ((u*v)*3)) - v*3*u = w";
-
-test "(i + j + 12 + (k::nat)) = u + 15 + y";
-test "(i + j + 32 + (k::nat)) - (u + 15 + y) = zz";
-test "(i + j + 12 + (k::nat)) = u + 5 + y";
-(*Suc*)
-test "(i + j + 12 + k) = Suc (u + y)";
-test "Suc (Suc (Suc (Suc (Suc (u + y))))) <= ((i + j) + 41 + k)";
-test "(i + j + 5 + k) < Suc (Suc (Suc (Suc (Suc (u + y)))))";
-test "Suc (Suc (Suc (Suc (Suc (u + y))))) - 5 = v";
-test "(i + j + 5 + k) = Suc (Suc (Suc (Suc (Suc (Suc (Suc (u + y)))))))";
-test "2*y + 3*z + 2*u = Suc (u)";
-test "2*y + 3*z + 6*w + 2*y + 3*z + 2*u = Suc (u)";
-test "2*y + 3*z + 6*w + 2*y + 3*z + 2*u = 2*y' + 3*z' + 6*w' + 2*y' + 3*z' + u + (vv::nat)";
-test "6 + 2*y + 3*z + 4*u = Suc (vv + 2*u + z)";
-test "(2*n*m) < (3*(m*n)) + (u::nat)";
-
-test "(Suc (Suc (Suc (Suc (Suc (Suc (case length (f c) of 0 => 0 | Suc k => k)))))) <= Suc 0)";
- 
-test "Suc (Suc (Suc (Suc (Suc (Suc (length l1 + length l2)))))) <= length l1";
-
-test "( (Suc (Suc (Suc (Suc (Suc (length (compT P E A ST mxr e) + length l3)))))) <= length (compT P E A ST mxr e))";
-
-test "( (Suc (Suc (Suc (Suc (Suc (length (compT P E A ST mxr e) + length (compT P E (A Un \<A> e) ST mxr c))))))) <= length (compT P E A ST mxr e))";
-
-
-(*negative numerals: FAIL*)
-test "(i + j + -23 + (k::nat)) < u + 15 + y";
-test "(i + j + 3 + (k::nat)) < u + -15 + y";
-test "(i + j + -12 + (k::nat)) - 15 = y";
-test "(i + j + 12 + (k::nat)) - -15 = y";
-test "(i + j + -12 + (k::nat)) - -15 = y";
-
-(*combine_numerals*)
-test "k + 3*k = (u::nat)";
-test "Suc (i + 3) = u";
-test "Suc (i + j + 3 + k) = u";
-test "k + j + 3*k + j = (u::nat)";
-test "Suc (j*i + i + k + 5 + 3*k + i*j*4) = (u::nat)";
-test "(2*n*m) + (3*(m*n)) = (u::nat)";
-(*negative numerals: FAIL*)
-test "Suc (i + j + -3 + k) = u";
-
-(*cancel_numeral_factors*)
-test "9*x = 12 * (y::nat)";
-test "(9*x) div (12 * (y::nat)) = z";
-test "9*x < 12 * (y::nat)";
-test "9*x <= 12 * (y::nat)";
-
-(*cancel_factor*)
-test "x*k = k*(y::nat)";
-test "k = k*(y::nat)";
-test "a*(b*c) = (b::nat)";
-test "a*(b*c) = d*(b::nat)*(x*a)";
-
-test "x*k < k*(y::nat)";
-test "k < k*(y::nat)";
-test "a*(b*c) < (b::nat)";
-test "a*(b*c) < d*(b::nat)*(x*a)";
-
-test "x*k <= k*(y::nat)";
-test "k <= k*(y::nat)";
-test "a*(b*c) <= (b::nat)";
-test "a*(b*c) <= d*(b::nat)*(x*a)";
-
-test "(x*k) div (k*(y::nat)) = (uu::nat)";
-test "(k) div (k*(y::nat)) = (uu::nat)";
-test "(a*(b*c)) div ((b::nat)) = (uu::nat)";
-test "(a*(b*c)) div (d*(b::nat)*(x*a)) = (uu::nat)";
-*)
-
-
-(*** Prepare linear arithmetic for nat numerals ***)
-
-local
-
-(* reduce contradictory <= to False *)
-val add_rules = @{thms ring_distribs} @
-  [@{thm Let_number_of}, @{thm Let_0}, @{thm Let_1}, @{thm nat_0}, @{thm nat_1},
-   @{thm add_nat_number_of}, @{thm diff_nat_number_of}, @{thm mult_nat_number_of},
-   @{thm eq_nat_number_of}, @{thm less_nat_number_of}, @{thm le_number_of_eq_not_less},
-   @{thm le_Suc_number_of}, @{thm le_number_of_Suc},
-   @{thm less_Suc_number_of}, @{thm less_number_of_Suc},
-   @{thm Suc_eq_number_of}, @{thm eq_number_of_Suc},
-   @{thm mult_Suc}, @{thm mult_Suc_right},
-   @{thm add_Suc}, @{thm add_Suc_right},
-   @{thm eq_number_of_0}, @{thm eq_0_number_of}, @{thm less_0_number_of},
-   @{thm of_int_number_of_eq}, @{thm of_nat_number_of_eq}, @{thm nat_number_of}, @{thm if_True}, @{thm if_False}];
-
-(* Products are multiplied out during proof (re)construction via
-ring_distribs. Ideally they should remain atomic. But that is
-currently not possible because 1 is replaced by Suc 0, and then some
-simprocs start to mess around with products like (n+1)*m. The rule
-1 == Suc 0 is necessary for early parts of HOL where numerals and
-simprocs are not yet available. But then it is difficult to remove
-that rule later on, because it may find its way back in when theories
-(and thus lin-arith simpsets) are merged. Otherwise one could turn the
-rule around (Suc n = n+1) and see if that helps products being left
-alone. *)
-
-val simprocs = Nat_Numeral_Simprocs.combine_numerals
-  :: Nat_Numeral_Simprocs.cancel_numerals;
-
-in
-
-val nat_simprocs_setup =
-  Lin_Arith.map_data (fn {add_mono_thms, mult_mono_thms, inj_thms, lessD, neqE, simpset} =>
-   {add_mono_thms = add_mono_thms, mult_mono_thms = mult_mono_thms,
-    inj_thms = inj_thms, lessD = lessD, neqE = neqE,
-    simpset = simpset addsimps add_rules
-                      addsimprocs simprocs});
-
-end;

--- a/src/HOL/Tools/numeral.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Tools/numeral.ML	Fri May 15 15:56:28 2009 +0200
@@ -1,5 +1,4 @@
 (*  Title:      HOL/Tools/numeral.ML
-    ID:         $Id$
     Author:     Makarius
 
 Logical operations on numerals (see also HOL/hologic.ML).
@@ -59,13 +58,8 @@
 
 fun add_code number_of negative unbounded target thy =
   let
-    val pr_numeral = (Code_Printer.literal_numeral o Code_Target.the_literals thy) target;
-    fun dest_numeral naming thm =
+    fun dest_numeral pls' min' bit0' bit1' thm =
       let
-        val SOME pls' = Code_Thingol.lookup_const naming @{const_name Int.Pls};
-        val SOME min' = Code_Thingol.lookup_const naming @{const_name Int.Min};
-        val SOME bit0' = Code_Thingol.lookup_const naming @{const_name Int.Bit0};
-        val SOME bit1' = Code_Thingol.lookup_const naming @{const_name Int.Bit1};
         fun dest_bit (IConst (c, _)) = if c = bit0' then 0
               else if c = bit1' then 1
               else Code_Printer.nerror thm "Illegal numeral expression: illegal bit"
@@ -79,11 +73,12 @@
               in case n of SOME n => SOME (2 * n + b) | NONE => NONE end
           | dest_num _ = Code_Printer.nerror thm "Illegal numeral expression: illegal term";
       in dest_num end;
-    fun pretty _ naming thm _ _ [(t, _)] =
-      (Code_Printer.str o pr_numeral unbounded o the_default 0 o dest_numeral naming thm) t;
+    fun pretty literals [pls', min', bit0', bit1'] _ thm _ _ [(t, _)] =
+      (Code_Printer.str o Code_Printer.literal_numeral literals unbounded
+        o the_default 0 o dest_numeral pls' min' bit0' bit1' thm) t;
   in
-    thy
-    |> Code_Target.add_syntax_const target number_of (SOME (1, pretty))
+    thy |>  Code_Target.add_syntax_const target number_of
+      (SOME (1, ([@{const_name Int.Pls}, @{const_name Int.Min}, @{const_name Int.Bit0}, @{const_name Int.Bit1}], pretty)))
   end;
 
 end; (*local*)

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/numeral_simprocs.ML	Fri May 15 15:56:28 2009 +0200
@@ -0,0 +1,786 @@
+(* Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
+   Copyright   2000  University of Cambridge
+
+Simprocs for the integer numerals.
+*)
+
+(*To quote from Provers/Arith/cancel_numeral_factor.ML:
+
+Cancels common coefficients in balanced expressions:
+
+     u*#m ~~ u'*#m'  ==  #n*u ~~ #n'*u'
+
+where ~~ is an appropriate balancing operation (e.g. =, <=, <, div, /)
+and d = gcd(m,m') and n=m/d and n'=m'/d.
+*)
+
+signature NUMERAL_SIMPROCS =
+sig
+  val mk_sum: typ -> term list -> term
+  val dest_sum: term -> term list
+
+  val assoc_fold_simproc: simproc
+  val combine_numerals: simproc
+  val cancel_numerals: simproc list
+  val cancel_factors: simproc list
+  val cancel_numeral_factors: simproc list
+  val field_combine_numerals: simproc
+  val field_cancel_numeral_factors: simproc list
+  val num_ss: simpset
+end;
+
+structure Numeral_Simprocs : NUMERAL_SIMPROCS =
+struct
+
+fun mk_number T n = HOLogic.number_of_const T $ HOLogic.mk_numeral n;
+
+fun find_first_numeral past (t::terms) =
+        ((snd (HOLogic.dest_number t), rev past @ terms)
+         handle TERM _ => find_first_numeral (t::past) terms)
+  | find_first_numeral past [] = raise TERM("find_first_numeral", []);
+
+val mk_plus = HOLogic.mk_binop @{const_name HOL.plus};
+
+fun mk_minus t = 
+  let val T = Term.fastype_of t
+  in Const (@{const_name HOL.uminus}, T --> T) $ t end;
+
+(*Thus mk_sum[t] yields t+0; longer sums don't have a trailing zero*)
+fun mk_sum T []        = mk_number T 0
+  | mk_sum T [t,u]     = mk_plus (t, u)
+  | mk_sum T (t :: ts) = mk_plus (t, mk_sum T ts);
+
+(*this version ALWAYS includes a trailing zero*)
+fun long_mk_sum T []        = mk_number T 0
+  | long_mk_sum T (t :: ts) = mk_plus (t, mk_sum T ts);
+
+val dest_plus = HOLogic.dest_bin @{const_name HOL.plus} Term.dummyT;
+
+(*decompose additions AND subtractions as a sum*)
+fun dest_summing (pos, Const (@{const_name HOL.plus}, _) $ t $ u, ts) =
+        dest_summing (pos, t, dest_summing (pos, u, ts))
+  | dest_summing (pos, Const (@{const_name HOL.minus}, _) $ t $ u, ts) =
+        dest_summing (pos, t, dest_summing (not pos, u, ts))
+  | dest_summing (pos, t, ts) =
+        if pos then t::ts else mk_minus t :: ts;
+
+fun dest_sum t = dest_summing (true, t, []);
+
+val mk_diff = HOLogic.mk_binop @{const_name HOL.minus};
+val dest_diff = HOLogic.dest_bin @{const_name HOL.minus} Term.dummyT;
+
+val mk_times = HOLogic.mk_binop @{const_name HOL.times};
+
+fun one_of T = Const(@{const_name HOL.one},T);
+
+(* build product with trailing 1 rather than Numeral 1 in order to avoid the
+   unnecessary restriction to type class number_ring
+   which is not required for cancellation of common factors in divisions.
+*)
+fun mk_prod T = 
+  let val one = one_of T
+  fun mk [] = one
+    | mk [t] = t
+    | mk (t :: ts) = if t = one then mk ts else mk_times (t, mk ts)
+  in mk end;
+
+(*This version ALWAYS includes a trailing one*)
+fun long_mk_prod T []        = one_of T
+  | long_mk_prod T (t :: ts) = mk_times (t, mk_prod T ts);
+
+val dest_times = HOLogic.dest_bin @{const_name HOL.times} Term.dummyT;
+
+fun dest_prod t =
+      let val (t,u) = dest_times t
+      in dest_prod t @ dest_prod u end
+      handle TERM _ => [t];
+
+(*DON'T do the obvious simplifications; that would create special cases*)
+fun mk_coeff (k, t) = mk_times (mk_number (Term.fastype_of t) k, t);
+
+(*Express t as a product of (possibly) a numeral with other sorted terms*)
+fun dest_coeff sign (Const (@{const_name HOL.uminus}, _) $ t) = dest_coeff (~sign) t
+  | dest_coeff sign t =
+    let val ts = sort TermOrd.term_ord (dest_prod t)
+        val (n, ts') = find_first_numeral [] ts
+                          handle TERM _ => (1, ts)
+    in (sign*n, mk_prod (Term.fastype_of t) ts') end;
+
+(*Find first coefficient-term THAT MATCHES u*)
+fun find_first_coeff past u [] = raise TERM("find_first_coeff", [])
+  | find_first_coeff past u (t::terms) =
+        let val (n,u') = dest_coeff 1 t
+        in if u aconv u' then (n, rev past @ terms)
+                         else find_first_coeff (t::past) u terms
+        end
+        handle TERM _ => find_first_coeff (t::past) u terms;
+
+(*Fractions as pairs of ints. Can't use Rat.rat because the representation
+  needs to preserve negative values in the denominator.*)
+fun mk_frac (p, q) = if q = 0 then raise Div else (p, q);
+
+(*Don't reduce fractions; sums must be proved by rule add_frac_eq.
+  Fractions are reduced later by the cancel_numeral_factor simproc.*)
+fun add_frac ((p1, q1), (p2, q2)) = (p1 * q2 + p2 * q1, q1 * q2);
+
+val mk_divide = HOLogic.mk_binop @{const_name HOL.divide};
+
+(*Build term (p / q) * t*)
+fun mk_fcoeff ((p, q), t) =
+  let val T = Term.fastype_of t
+  in mk_times (mk_divide (mk_number T p, mk_number T q), t) end;
+
+(*Express t as a product of a fraction with other sorted terms*)
+fun dest_fcoeff sign (Const (@{const_name HOL.uminus}, _) $ t) = dest_fcoeff (~sign) t
+  | dest_fcoeff sign (Const (@{const_name HOL.divide}, _) $ t $ u) =
+    let val (p, t') = dest_coeff sign t
+        val (q, u') = dest_coeff 1 u
+    in (mk_frac (p, q), mk_divide (t', u')) end
+  | dest_fcoeff sign t =
+    let val (p, t') = dest_coeff sign t
+        val T = Term.fastype_of t
+    in (mk_frac (p, 1), mk_divide (t', one_of T)) end;
+
+
+(** New term ordering so that AC-rewriting brings numerals to the front **)
+
+(*Order integers by absolute value and then by sign. The standard integer
+  ordering is not well-founded.*)
+fun num_ord (i,j) =
+  (case int_ord (abs i, abs j) of
+    EQUAL => int_ord (Int.sign i, Int.sign j) 
+  | ord => ord);
+
+(*This resembles TermOrd.term_ord, but it puts binary numerals before other
+  non-atomic terms.*)
+local open Term 
+in 
+fun numterm_ord (Abs (_, T, t), Abs(_, U, u)) =
+      (case numterm_ord (t, u) of EQUAL => TermOrd.typ_ord (T, U) | ord => ord)
+  | numterm_ord
+     (Const(@{const_name Int.number_of}, _) $ v, Const(@{const_name Int.number_of}, _) $ w) =
+     num_ord (HOLogic.dest_numeral v, HOLogic.dest_numeral w)
+  | numterm_ord (Const(@{const_name Int.number_of}, _) $ _, _) = LESS
+  | numterm_ord (_, Const(@{const_name Int.number_of}, _) $ _) = GREATER
+  | numterm_ord (t, u) =
+      (case int_ord (size_of_term t, size_of_term u) of
+        EQUAL =>
+          let val (f, ts) = strip_comb t and (g, us) = strip_comb u in
+            (case TermOrd.hd_ord (f, g) of EQUAL => numterms_ord (ts, us) | ord => ord)
+          end
+      | ord => ord)
+and numterms_ord (ts, us) = list_ord numterm_ord (ts, us)
+end;
+
+fun numtermless tu = (numterm_ord tu = LESS);
+
+val num_ss = HOL_ss settermless numtermless;
+
+(*Maps 0 to Numeral0 and 1 to Numeral1 so that arithmetic isn't complicated by the abstract 0 and 1.*)
+val numeral_syms = [@{thm numeral_0_eq_0} RS sym, @{thm numeral_1_eq_1} RS sym];
+
+(*Simplify Numeral0+n, n+Numeral0, Numeral1*n, n*Numeral1, 1*x, x*1, x/1 *)
+val add_0s =  @{thms add_0s};
+val mult_1s = @{thms mult_1s mult_1_left mult_1_right divide_1};
+
+(*Simplify inverse Numeral1, a/Numeral1*)
+val inverse_1s = [@{thm inverse_numeral_1}];
+val divide_1s = [@{thm divide_numeral_1}];
+
+(*To perform binary arithmetic.  The "left" rewriting handles patterns
+  created by the Numeral_Simprocs, such as 3 * (5 * x). *)
+val simps = [@{thm numeral_0_eq_0} RS sym, @{thm numeral_1_eq_1} RS sym,
+                 @{thm add_number_of_left}, @{thm mult_number_of_left}] @
+                @{thms arith_simps} @ @{thms rel_simps};
+
+(*Binary arithmetic BUT NOT ADDITION since it may collapse adjacent terms
+  during re-arrangement*)
+val non_add_simps =
+  subtract Thm.eq_thm [@{thm add_number_of_left}, @{thm number_of_add} RS sym] simps;
+
+(*To evaluate binary negations of coefficients*)
+val minus_simps = [@{thm numeral_m1_eq_minus_1} RS sym, @{thm number_of_minus} RS sym] @
+                   @{thms minus_bin_simps} @ @{thms pred_bin_simps};
+
+(*To let us treat subtraction as addition*)
+val diff_simps = [@{thm diff_minus}, @{thm minus_add_distrib}, @{thm minus_minus}];
+
+(*To let us treat division as multiplication*)
+val divide_simps = [@{thm divide_inverse}, @{thm inverse_mult_distrib}, @{thm inverse_inverse_eq}];
+
+(*push the unary minus down: - x * y = x * - y *)
+val minus_mult_eq_1_to_2 =
+    [@{thm mult_minus_left}, @{thm minus_mult_right}] MRS trans |> standard;
+
+(*to extract again any uncancelled minuses*)
+val minus_from_mult_simps =
+    [@{thm minus_minus}, @{thm mult_minus_left}, @{thm mult_minus_right}];
+
+(*combine unary minus with numeric literals, however nested within a product*)
+val mult_minus_simps =
+    [@{thm mult_assoc}, @{thm minus_mult_left}, minus_mult_eq_1_to_2];
+
+val norm_ss1 = num_ss addsimps numeral_syms @ add_0s @ mult_1s @
+  diff_simps @ minus_simps @ @{thms add_ac}
+val norm_ss2 = num_ss addsimps non_add_simps @ mult_minus_simps
+val norm_ss3 = num_ss addsimps minus_from_mult_simps @ @{thms add_ac} @ @{thms mult_ac}
+
+structure CancelNumeralsCommon =
+  struct
+  val mk_sum            = mk_sum
+  val dest_sum          = dest_sum
+  val mk_coeff          = mk_coeff
+  val dest_coeff        = dest_coeff 1
+  val find_first_coeff  = find_first_coeff []
+  val trans_tac         = K Arith_Data.trans_tac
+
+  fun norm_tac ss =
+    ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1))
+    THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2))
+    THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss3))
+
+  val numeral_simp_ss = HOL_ss addsimps add_0s @ simps
+  fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss))
+  val simplify_meta_eq = Arith_Data.simplify_meta_eq (add_0s @ mult_1s)
+  end;
+
+
+structure EqCancelNumerals = CancelNumeralsFun
+ (open CancelNumeralsCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_eq
+  val dest_bal = HOLogic.dest_bin "op =" Term.dummyT
+  val bal_add1 = @{thm eq_add_iff1} RS trans
+  val bal_add2 = @{thm eq_add_iff2} RS trans
+);
+
+structure LessCancelNumerals = CancelNumeralsFun
+ (open CancelNumeralsCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less}
+  val dest_bal = HOLogic.dest_bin @{const_name HOL.less} Term.dummyT
+  val bal_add1 = @{thm less_add_iff1} RS trans
+  val bal_add2 = @{thm less_add_iff2} RS trans
+);
+
+structure LeCancelNumerals = CancelNumeralsFun
+ (open CancelNumeralsCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less_eq}
+  val dest_bal = HOLogic.dest_bin @{const_name HOL.less_eq} Term.dummyT
+  val bal_add1 = @{thm le_add_iff1} RS trans
+  val bal_add2 = @{thm le_add_iff2} RS trans
+);
+
+val cancel_numerals =
+  map Arith_Data.prep_simproc
+   [("inteq_cancel_numerals",
+     ["(l::'a::number_ring) + m = n",
+      "(l::'a::number_ring) = m + n",
+      "(l::'a::number_ring) - m = n",
+      "(l::'a::number_ring) = m - n",
+      "(l::'a::number_ring) * m = n",
+      "(l::'a::number_ring) = m * n"],
+     K EqCancelNumerals.proc),
+    ("intless_cancel_numerals",
+     ["(l::'a::{ordered_idom,number_ring}) + m < n",
+      "(l::'a::{ordered_idom,number_ring}) < m + n",
+      "(l::'a::{ordered_idom,number_ring}) - m < n",
+      "(l::'a::{ordered_idom,number_ring}) < m - n",
+      "(l::'a::{ordered_idom,number_ring}) * m < n",
+      "(l::'a::{ordered_idom,number_ring}) < m * n"],
+     K LessCancelNumerals.proc),
+    ("intle_cancel_numerals",
+     ["(l::'a::{ordered_idom,number_ring}) + m <= n",
+      "(l::'a::{ordered_idom,number_ring}) <= m + n",
+      "(l::'a::{ordered_idom,number_ring}) - m <= n",
+      "(l::'a::{ordered_idom,number_ring}) <= m - n",
+      "(l::'a::{ordered_idom,number_ring}) * m <= n",
+      "(l::'a::{ordered_idom,number_ring}) <= m * n"],
+     K LeCancelNumerals.proc)];
+
+structure CombineNumeralsData =
+  struct
+  type coeff            = int
+  val iszero            = (fn x => x = 0)
+  val add               = op +
+  val mk_sum            = long_mk_sum    (*to work for e.g. 2*x + 3*x *)
+  val dest_sum          = dest_sum
+  val mk_coeff          = mk_coeff
+  val dest_coeff        = dest_coeff 1
+  val left_distrib      = @{thm combine_common_factor} RS trans
+  val prove_conv        = Arith_Data.prove_conv_nohyps
+  val trans_tac         = K Arith_Data.trans_tac
+
+  fun norm_tac ss =
+    ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1))
+    THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2))
+    THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss3))
+
+  val numeral_simp_ss = HOL_ss addsimps add_0s @ simps
+  fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss))
+  val simplify_meta_eq = Arith_Data.simplify_meta_eq (add_0s @ mult_1s)
+  end;
+
+structure CombineNumerals = CombineNumeralsFun(CombineNumeralsData);
+
+(*Version for fields, where coefficients can be fractions*)
+structure FieldCombineNumeralsData =
+  struct
+  type coeff            = int * int
+  val iszero            = (fn (p, q) => p = 0)
+  val add               = add_frac
+  val mk_sum            = long_mk_sum
+  val dest_sum          = dest_sum
+  val mk_coeff          = mk_fcoeff
+  val dest_coeff        = dest_fcoeff 1
+  val left_distrib      = @{thm combine_common_factor} RS trans
+  val prove_conv        = Arith_Data.prove_conv_nohyps
+  val trans_tac         = K Arith_Data.trans_tac
+
+  val norm_ss1a = norm_ss1 addsimps inverse_1s @ divide_simps
+  fun norm_tac ss =
+    ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1a))
+    THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2))
+    THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss3))
+
+  val numeral_simp_ss = HOL_ss addsimps add_0s @ simps @ [@{thm add_frac_eq}]
+  fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss))
+  val simplify_meta_eq = Arith_Data.simplify_meta_eq (add_0s @ mult_1s @ divide_1s)
+  end;
+
+structure FieldCombineNumerals = CombineNumeralsFun(FieldCombineNumeralsData);
+
+val combine_numerals =
+  Arith_Data.prep_simproc
+    ("int_combine_numerals", 
+     ["(i::'a::number_ring) + j", "(i::'a::number_ring) - j"], 
+     K CombineNumerals.proc);
+
+val field_combine_numerals =
+  Arith_Data.prep_simproc
+    ("field_combine_numerals", 
+     ["(i::'a::{number_ring,field,division_by_zero}) + j",
+      "(i::'a::{number_ring,field,division_by_zero}) - j"], 
+     K FieldCombineNumerals.proc);
+
+(** Constant folding for multiplication in semirings **)
+
+(*We do not need folding for addition: combine_numerals does the same thing*)
+
+structure Semiring_Times_Assoc_Data : ASSOC_FOLD_DATA =
+struct
+  val assoc_ss = HOL_ss addsimps @{thms mult_ac}
+  val eq_reflection = eq_reflection
+  fun is_numeral (Const(@{const_name Int.number_of}, _) $ _) = true
+    | is_numeral _ = false;
+end;
+
+structure Semiring_Times_Assoc = Assoc_Fold (Semiring_Times_Assoc_Data);
+
+val assoc_fold_simproc =
+  Arith_Data.prep_simproc
+   ("semiring_assoc_fold", ["(a::'a::comm_semiring_1_cancel) * b"],
+    K Semiring_Times_Assoc.proc);
+
+structure CancelNumeralFactorCommon =
+  struct
+  val mk_coeff          = mk_coeff
+  val dest_coeff        = dest_coeff 1
+  val trans_tac         = K Arith_Data.trans_tac
+
+  val norm_ss1 = HOL_ss addsimps minus_from_mult_simps @ mult_1s
+  val norm_ss2 = HOL_ss addsimps simps @ mult_minus_simps
+  val norm_ss3 = HOL_ss addsimps @{thms mult_ac}
+  fun norm_tac ss =
+    ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1))
+    THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2))
+    THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss3))
+
+  val numeral_simp_ss = HOL_ss addsimps
+    [@{thm eq_number_of_eq}, @{thm less_number_of}, @{thm le_number_of}] @ simps
+  fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss))
+  val simplify_meta_eq = Arith_Data.simplify_meta_eq
+    [@{thm add_0}, @{thm add_0_right}, @{thm mult_zero_left},
+      @{thm mult_zero_right}, @{thm mult_Bit1}, @{thm mult_1_right}];
+  end
+
+(*Version for semiring_div*)
+structure DivCancelNumeralFactor = CancelNumeralFactorFun
+ (open CancelNumeralFactorCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_binop @{const_name Divides.div}
+  val dest_bal = HOLogic.dest_bin @{const_name Divides.div} Term.dummyT
+  val cancel = @{thm div_mult_mult1} RS trans
+  val neg_exchanges = false
+)
+
+(*Version for fields*)
+structure DivideCancelNumeralFactor = CancelNumeralFactorFun
+ (open CancelNumeralFactorCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_binop @{const_name HOL.divide}
+  val dest_bal = HOLogic.dest_bin @{const_name HOL.divide} Term.dummyT
+  val cancel = @{thm mult_divide_mult_cancel_left} RS trans
+  val neg_exchanges = false
+)
+
+structure EqCancelNumeralFactor = CancelNumeralFactorFun
+ (open CancelNumeralFactorCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_eq
+  val dest_bal = HOLogic.dest_bin "op =" Term.dummyT
+  val cancel = @{thm mult_cancel_left} RS trans
+  val neg_exchanges = false
+)
+
+structure LessCancelNumeralFactor = CancelNumeralFactorFun
+ (open CancelNumeralFactorCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less}
+  val dest_bal = HOLogic.dest_bin @{const_name HOL.less} Term.dummyT
+  val cancel = @{thm mult_less_cancel_left} RS trans
+  val neg_exchanges = true
+)
+
+structure LeCancelNumeralFactor = CancelNumeralFactorFun
+ (open CancelNumeralFactorCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less_eq}
+  val dest_bal = HOLogic.dest_bin @{const_name HOL.less_eq} Term.dummyT
+  val cancel = @{thm mult_le_cancel_left} RS trans
+  val neg_exchanges = true
+)
+
+val cancel_numeral_factors =
+  map Arith_Data.prep_simproc
+   [("ring_eq_cancel_numeral_factor",
+     ["(l::'a::{idom,number_ring}) * m = n",
+      "(l::'a::{idom,number_ring}) = m * n"],
+     K EqCancelNumeralFactor.proc),
+    ("ring_less_cancel_numeral_factor",
+     ["(l::'a::{ordered_idom,number_ring}) * m < n",
+      "(l::'a::{ordered_idom,number_ring}) < m * n"],
+     K LessCancelNumeralFactor.proc),
+    ("ring_le_cancel_numeral_factor",
+     ["(l::'a::{ordered_idom,number_ring}) * m <= n",
+      "(l::'a::{ordered_idom,number_ring}) <= m * n"],
+     K LeCancelNumeralFactor.proc),
+    ("int_div_cancel_numeral_factors",
+     ["((l::'a::{semiring_div,number_ring}) * m) div n",
+      "(l::'a::{semiring_div,number_ring}) div (m * n)"],
+     K DivCancelNumeralFactor.proc),
+    ("divide_cancel_numeral_factor",
+     ["((l::'a::{division_by_zero,field,number_ring}) * m) / n",
+      "(l::'a::{division_by_zero,field,number_ring}) / (m * n)",
+      "((number_of v)::'a::{division_by_zero,field,number_ring}) / (number_of w)"],
+     K DivideCancelNumeralFactor.proc)];
+
+val field_cancel_numeral_factors =
+  map Arith_Data.prep_simproc
+   [("field_eq_cancel_numeral_factor",
+     ["(l::'a::{field,number_ring}) * m = n",
+      "(l::'a::{field,number_ring}) = m * n"],
+     K EqCancelNumeralFactor.proc),
+    ("field_cancel_numeral_factor",
+     ["((l::'a::{division_by_zero,field,number_ring}) * m) / n",
+      "(l::'a::{division_by_zero,field,number_ring}) / (m * n)",
+      "((number_of v)::'a::{division_by_zero,field,number_ring}) / (number_of w)"],
+     K DivideCancelNumeralFactor.proc)]
+
+
+(** Declarations for ExtractCommonTerm **)
+
+(*Find first term that matches u*)
+fun find_first_t past u []         = raise TERM ("find_first_t", [])
+  | find_first_t past u (t::terms) =
+        if u aconv t then (rev past @ terms)
+        else find_first_t (t::past) u terms
+        handle TERM _ => find_first_t (t::past) u terms;
+
+(** Final simplification for the CancelFactor simprocs **)
+val simplify_one = Arith_Data.simplify_meta_eq  
+  [@{thm mult_1_left}, @{thm mult_1_right}, @{thm div_by_1}, @{thm numeral_1_eq_1}];
+
+fun cancel_simplify_meta_eq ss cancel_th th =
+    simplify_one ss (([th, cancel_th]) MRS trans);
+
+local
+  val Tp_Eq = Thm.reflexive (Thm.cterm_of @{theory HOL} HOLogic.Trueprop)
+  fun Eq_True_elim Eq = 
+    Thm.equal_elim (Thm.combination Tp_Eq (Thm.symmetric Eq)) @{thm TrueI}
+in
+fun sign_conv pos_th neg_th ss t =
+  let val T = fastype_of t;
+      val zero = Const(@{const_name HOL.zero}, T);
+      val less = Const(@{const_name HOL.less}, [T,T] ---> HOLogic.boolT);
+      val pos = less $ zero $ t and neg = less $ t $ zero
+      fun prove p =
+        Option.map Eq_True_elim (Lin_Arith.simproc ss p)
+        handle THM _ => NONE
+    in case prove pos of
+         SOME th => SOME(th RS pos_th)
+       | NONE => (case prove neg of
+                    SOME th => SOME(th RS neg_th)
+                  | NONE => NONE)
+    end;
+end
+
+structure CancelFactorCommon =
+  struct
+  val mk_sum            = long_mk_prod
+  val dest_sum          = dest_prod
+  val mk_coeff          = mk_coeff
+  val dest_coeff        = dest_coeff
+  val find_first        = find_first_t []
+  val trans_tac         = K Arith_Data.trans_tac
+  val norm_ss = HOL_ss addsimps mult_1s @ @{thms mult_ac}
+  fun norm_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss))
+  val simplify_meta_eq  = cancel_simplify_meta_eq 
+  end;
+
+(*mult_cancel_left requires a ring with no zero divisors.*)
+structure EqCancelFactor = ExtractCommonTermFun
+ (open CancelFactorCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_eq
+  val dest_bal = HOLogic.dest_bin "op =" Term.dummyT
+  val simp_conv = K (K (SOME @{thm mult_cancel_left}))
+);
+
+(*for ordered rings*)
+structure LeCancelFactor = ExtractCommonTermFun
+ (open CancelFactorCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less_eq}
+  val dest_bal = HOLogic.dest_bin @{const_name HOL.less_eq} Term.dummyT
+  val simp_conv = sign_conv
+    @{thm mult_le_cancel_left_pos} @{thm mult_le_cancel_left_neg}
+);
+
+(*for ordered rings*)
+structure LessCancelFactor = ExtractCommonTermFun
+ (open CancelFactorCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less}
+  val dest_bal = HOLogic.dest_bin @{const_name HOL.less} Term.dummyT
+  val simp_conv = sign_conv
+    @{thm mult_less_cancel_left_pos} @{thm mult_less_cancel_left_neg}
+);
+
+(*for semirings with division*)
+structure DivCancelFactor = ExtractCommonTermFun
+ (open CancelFactorCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_binop @{const_name Divides.div}
+  val dest_bal = HOLogic.dest_bin @{const_name Divides.div} Term.dummyT
+  val simp_conv = K (K (SOME @{thm div_mult_mult1_if}))
+);
+
+structure ModCancelFactor = ExtractCommonTermFun
+ (open CancelFactorCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_binop @{const_name Divides.mod}
+  val dest_bal = HOLogic.dest_bin @{const_name Divides.mod} Term.dummyT
+  val simp_conv = K (K (SOME @{thm mod_mult_mult1}))
+);
+
+(*for idoms*)
+structure DvdCancelFactor = ExtractCommonTermFun
+ (open CancelFactorCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_binrel @{const_name Ring_and_Field.dvd}
+  val dest_bal = HOLogic.dest_bin @{const_name Ring_and_Field.dvd} Term.dummyT
+  val simp_conv = K (K (SOME @{thm dvd_mult_cancel_left}))
+);
+
+(*Version for all fields, including unordered ones (type complex).*)
+structure DivideCancelFactor = ExtractCommonTermFun
+ (open CancelFactorCommon
+  val prove_conv = Arith_Data.prove_conv
+  val mk_bal   = HOLogic.mk_binop @{const_name HOL.divide}
+  val dest_bal = HOLogic.dest_bin @{const_name HOL.divide} Term.dummyT
+  val simp_conv = K (K (SOME @{thm mult_divide_mult_cancel_left_if}))
+);
+
+val cancel_factors =
+  map Arith_Data.prep_simproc
+   [("ring_eq_cancel_factor",
+     ["(l::'a::idom) * m = n",
+      "(l::'a::idom) = m * n"],
+     K EqCancelFactor.proc),
+    ("ordered_ring_le_cancel_factor",
+     ["(l::'a::ordered_ring) * m <= n",
+      "(l::'a::ordered_ring) <= m * n"],
+     K LeCancelFactor.proc),
+    ("ordered_ring_less_cancel_factor",
+     ["(l::'a::ordered_ring) * m < n",
+      "(l::'a::ordered_ring) < m * n"],
+     K LessCancelFactor.proc),
+    ("int_div_cancel_factor",
+     ["((l::'a::semiring_div) * m) div n", "(l::'a::semiring_div) div (m * n)"],
+     K DivCancelFactor.proc),
+    ("int_mod_cancel_factor",
+     ["((l::'a::semiring_div) * m) mod n", "(l::'a::semiring_div) mod (m * n)"],
+     K ModCancelFactor.proc),
+    ("dvd_cancel_factor",
+     ["((l::'a::idom) * m) dvd n", "(l::'a::idom) dvd (m * n)"],
+     K DvdCancelFactor.proc),
+    ("divide_cancel_factor",
+     ["((l::'a::{division_by_zero,field}) * m) / n",
+      "(l::'a::{division_by_zero,field}) / (m * n)"],
+     K DivideCancelFactor.proc)];
+
+end;
+
+Addsimprocs Numeral_Simprocs.cancel_numerals;
+Addsimprocs [Numeral_Simprocs.combine_numerals];
+Addsimprocs [Numeral_Simprocs.field_combine_numerals];
+Addsimprocs [Numeral_Simprocs.assoc_fold_simproc];
+
+(*examples:
+print_depth 22;
+set timing;
+set trace_simp;
+fun test s = (Goal s, by (Simp_tac 1));
+
+test "l + 2 + 2 + 2 + (l + 2) + (oo + 2) = (uu::int)";
+
+test "2*u = (u::int)";
+test "(i + j + 12 + (k::int)) - 15 = y";
+test "(i + j + 12 + (k::int)) - 5 = y";
+
+test "y - b < (b::int)";
+test "y - (3*b + c) < (b::int) - 2*c";
+
+test "(2*x - (u*v) + y) - v*3*u = (w::int)";
+test "(2*x*u*v + (u*v)*4 + y) - v*u*4 = (w::int)";
+test "(2*x*u*v + (u*v)*4 + y) - v*u = (w::int)";
+test "u*v - (x*u*v + (u*v)*4 + y) = (w::int)";
+
+test "(i + j + 12 + (k::int)) = u + 15 + y";
+test "(i + j*2 + 12 + (k::int)) = j + 5 + y";
+
+test "2*y + 3*z + 6*w + 2*y + 3*z + 2*u = 2*y' + 3*z' + 6*w' + 2*y' + 3*z' + u + (vv::int)";
+
+test "a + -(b+c) + b = (d::int)";
+test "a + -(b+c) - b = (d::int)";
+
+(*negative numerals*)
+test "(i + j + -2 + (k::int)) - (u + 5 + y) = zz";
+test "(i + j + -3 + (k::int)) < u + 5 + y";
+test "(i + j + 3 + (k::int)) < u + -6 + y";
+test "(i + j + -12 + (k::int)) - 15 = y";
+test "(i + j + 12 + (k::int)) - -15 = y";
+test "(i + j + -12 + (k::int)) - -15 = y";
+*)
+
+Addsimprocs Numeral_Simprocs.cancel_numeral_factors;
+
+(*examples:
+print_depth 22;
+set timing;
+set trace_simp;
+fun test s = (Goal s; by (Simp_tac 1));
+
+test "9*x = 12 * (y::int)";
+test "(9*x) div (12 * (y::int)) = z";
+test "9*x < 12 * (y::int)";
+test "9*x <= 12 * (y::int)";
+
+test "-99*x = 132 * (y::int)";
+test "(-99*x) div (132 * (y::int)) = z";
+test "-99*x < 132 * (y::int)";
+test "-99*x <= 132 * (y::int)";
+
+test "999*x = -396 * (y::int)";
+test "(999*x) div (-396 * (y::int)) = z";
+test "999*x < -396 * (y::int)";
+test "999*x <= -396 * (y::int)";
+
+test "-99*x = -81 * (y::int)";
+test "(-99*x) div (-81 * (y::int)) = z";
+test "-99*x <= -81 * (y::int)";
+test "-99*x < -81 * (y::int)";
+
+test "-2 * x = -1 * (y::int)";
+test "-2 * x = -(y::int)";
+test "(-2 * x) div (-1 * (y::int)) = z";
+test "-2 * x < -(y::int)";
+test "-2 * x <= -1 * (y::int)";
+test "-x < -23 * (y::int)";
+test "-x <= -23 * (y::int)";
+*)
+
+(*And the same examples for fields such as rat or real:
+test "0 <= (y::rat) * -2";
+test "9*x = 12 * (y::rat)";
+test "(9*x) / (12 * (y::rat)) = z";
+test "9*x < 12 * (y::rat)";
+test "9*x <= 12 * (y::rat)";
+
+test "-99*x = 132 * (y::rat)";
+test "(-99*x) / (132 * (y::rat)) = z";
+test "-99*x < 132 * (y::rat)";
+test "-99*x <= 132 * (y::rat)";
+
+test "999*x = -396 * (y::rat)";
+test "(999*x) / (-396 * (y::rat)) = z";
+test "999*x < -396 * (y::rat)";
+test "999*x <= -396 * (y::rat)";
+
+test  "(- ((2::rat) * x) <= 2 * y)";
+test "-99*x = -81 * (y::rat)";
+test "(-99*x) / (-81 * (y::rat)) = z";
+test "-99*x <= -81 * (y::rat)";
+test "-99*x < -81 * (y::rat)";
+
+test "-2 * x = -1 * (y::rat)";
+test "-2 * x = -(y::rat)";
+test "(-2 * x) / (-1 * (y::rat)) = z";
+test "-2 * x < -(y::rat)";
+test "-2 * x <= -1 * (y::rat)";
+test "-x < -23 * (y::rat)";
+test "-x <= -23 * (y::rat)";
+*)
+
+Addsimprocs Numeral_Simprocs.cancel_factors;
+
+
+(*examples:
+print_depth 22;
+set timing;
+set trace_simp;
+fun test s = (Goal s; by (Asm_simp_tac 1));
+
+test "x*k = k*(y::int)";
+test "k = k*(y::int)";
+test "a*(b*c) = (b::int)";
+test "a*(b*c) = d*(b::int)*(x*a)";
+
+test "(x*k) div (k*(y::int)) = (uu::int)";
+test "(k) div (k*(y::int)) = (uu::int)";
+test "(a*(b*c)) div ((b::int)) = (uu::int)";
+test "(a*(b*c)) div (d*(b::int)*(x*a)) = (uu::int)";
+*)
+
+(*And the same examples for fields such as rat or real:
+print_depth 22;
+set timing;
+set trace_simp;
+fun test s = (Goal s; by (Asm_simp_tac 1));
+
+test "x*k = k*(y::rat)";
+test "k = k*(y::rat)";
+test "a*(b*c) = (b::rat)";
+test "a*(b*c) = d*(b::rat)*(x*a)";
+
+
+test "(x*k) / (k*(y::rat)) = (uu::rat)";
+test "(k) / (k*(y::rat)) = (uu::rat)";
+test "(a*(b*c)) / ((b::rat)) = (uu::rat)";
+test "(a*(b*c)) / (d*(b::rat)*(x*a)) = (uu::rat)";
+
+(*FIXME: what do we do about this?*)
+test "a*(b*c)/(y*z) = d*(b::rat)*(x*a)/z";
+*)

--- a/src/HOL/Tools/rat_arith.ML	Fri May 15 15:29:34 2009 +0200
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,49 +0,0 @@
-(*  Title:      HOL/Real/rat_arith.ML
-    ID:         $Id$
-    Author:     Lawrence C Paulson
-    Copyright   2004 University of Cambridge
-
-Simprocs for common factor cancellation & Rational coefficient handling
-
-Instantiation of the generic linear arithmetic package for type rat.
-*)
-
-local
-
-val simprocs = field_cancel_numeral_factors
-
-val simps =
- [@{thm order_less_irrefl}, @{thm neg_less_iff_less}, @{thm True_implies_equals},
-  read_instantiate @{context} [(("a", 0), "(number_of ?v)")] @{thm right_distrib},
-  @{thm divide_1}, @{thm divide_zero_left},
-  @{thm times_divide_eq_right}, @{thm times_divide_eq_left},
-  @{thm minus_divide_left} RS sym, @{thm minus_divide_right} RS sym,
-  @{thm of_int_0}, @{thm of_int_1}, @{thm of_int_add},
-  @{thm of_int_minus}, @{thm of_int_diff},
-  @{thm of_int_mult}, @{thm of_int_of_nat_eq}]
-
-val nat_inj_thms = [@{thm of_nat_le_iff} RS iffD2,
-                    @{thm of_nat_eq_iff} RS iffD2]
-(* not needed because x < (y::nat) can be rewritten as Suc x <= y:
-                    of_nat_less_iff RS iffD2 *)
-
-val int_inj_thms = [@{thm of_int_le_iff} RS iffD2,
-                    @{thm of_int_eq_iff} RS iffD2]
-(* not needed because x < (y::int) can be rewritten as x + 1 <= y:
-                    of_int_less_iff RS iffD2 *)
-
-in
-
-val rat_arith_setup =
-  Lin_Arith.map_data (fn {add_mono_thms, mult_mono_thms, inj_thms, lessD, neqE, simpset} =>
-   {add_mono_thms = add_mono_thms,
-    mult_mono_thms = mult_mono_thms,
-    inj_thms = int_inj_thms @ nat_inj_thms @ inj_thms,
-    lessD = lessD,  (*Can't change lessD: the rats are dense!*)
-    neqE =  neqE,
-    simpset = simpset addsimps simps
-                      addsimprocs simprocs}) #>
-  arith_inj_const (@{const_name of_nat}, @{typ "nat => rat"}) #>
-  arith_inj_const (@{const_name of_int}, @{typ "int => rat"})
-
-end;

--- a/src/HOL/Tools/real_arith.ML	Fri May 15 15:29:34 2009 +0200
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,42 +0,0 @@
-(*  Title:      HOL/Real/real_arith.ML
-    ID:         $Id$
-    Author:     Tobias Nipkow, TU Muenchen
-    Copyright   1999 TU Muenchen
-
-Simprocs for common factor cancellation & Rational coefficient handling
-
-Instantiation of the generic linear arithmetic package for type real.
-*)
-
-local
-
-val simps = [@{thm real_of_nat_zero}, @{thm real_of_nat_Suc}, @{thm real_of_nat_add},
-             @{thm real_of_nat_mult}, @{thm real_of_int_zero}, @{thm real_of_one},
-             @{thm real_of_int_add}, @{thm real_of_int_minus}, @{thm real_of_int_diff},
-             @{thm real_of_int_mult}, @{thm real_of_int_of_nat_eq},
-             @{thm real_of_nat_number_of}, @{thm real_number_of}]
-
-val nat_inj_thms = [@{thm real_of_nat_le_iff} RS iffD2,
-                    @{thm real_of_nat_inject} RS iffD2]
-(* not needed because x < (y::nat) can be rewritten as Suc x <= y:
-                    real_of_nat_less_iff RS iffD2 *)
-
-val int_inj_thms = [@{thm real_of_int_le_iff} RS iffD2,
-                    @{thm real_of_int_inject} RS iffD2]
-(* not needed because x < (y::int) can be rewritten as x + 1 <= y:
-                    real_of_int_less_iff RS iffD2 *)
-
-in
-
-val real_arith_setup =
-  Lin_Arith.map_data (fn {add_mono_thms, mult_mono_thms, inj_thms, lessD, neqE, simpset} =>
-   {add_mono_thms = add_mono_thms,
-    mult_mono_thms = mult_mono_thms,
-    inj_thms = int_inj_thms @ nat_inj_thms @ inj_thms,
-    lessD = lessD,  (*Can't change lessD: the reals are dense!*)
-    neqE = neqE,
-    simpset = simpset addsimps simps}) #>
-  arith_inj_const (@{const_name real}, HOLogic.natT --> HOLogic.realT) #>
-  arith_inj_const (@{const_name real}, HOLogic.intT --> HOLogic.realT)
-
-end;

--- a/src/HOL/Tools/recfun_codegen.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Tools/recfun_codegen.ML	Fri May 15 15:56:28 2009 +0200
@@ -25,13 +25,13 @@
 
 fun add_thm NONE thm thy = Code.add_eqn thm thy
   | add_thm (SOME module_name) thm thy =
-      case Code_Unit.warning_thm (Code_Unit.mk_eqn thy) thm
-       of SOME (thm', _) => let val c = Code_Unit.const_eqn thm'
-            in thy
-              |> ModuleData.map (Symtab.update (c, module_name))
-              |> Code.add_eqn thm'
-            end
-        | NONE => Code.add_eqn thm thy;
+      let
+        val (thm', _) = Code.mk_eqn thy (K false) (thm, true)
+      in
+        thy
+        |> ModuleData.map (Symtab.update (Code.const_eqn thy thm', module_name))
+        |> Code.add_eqn thm'
+      end;
 
 fun meta_eq_to_obj_eq thy thm =
   let
@@ -44,22 +44,21 @@
 fun expand_eta thy [] = []
   | expand_eta thy (thms as thm :: _) =
       let
-        val (_, ty) = Code_Unit.const_typ_eqn thm;
+        val (_, ty) = Code.const_typ_eqn thm;
       in if null (Term.add_tvarsT ty []) orelse (null o fst o strip_type) ty
         then thms
-        else map (Code_Unit.expand_eta thy 1) thms
+        else map (Code.expand_eta thy 1) thms
       end;
 
 fun retrieve_equations thy (c, T) = if c = @{const_name "op ="} then NONE else
   let
     val c' = AxClass.unoverload_const thy (c, T);
     val opt_name = Symtab.lookup (ModuleData.get thy) c';
-    val thms = Code.these_raw_eqns thy c'
+    val thms = Code.these_eqns thy c'
       |> map_filter (fn (thm, linear) => if linear then SOME thm else NONE)
       |> expand_eta thy
-      |> map (AxClass.overload thy)
       |> map_filter (meta_eq_to_obj_eq thy)
-      |> Code_Unit.norm_varnames thy Code_Name.purify_tvar Code_Name.purify_var
+      |> Code.norm_varnames thy
       |> map (rpair opt_name)
   in if null thms then NONE else SOME thms end;
 

--- a/src/HOL/Tools/record_package.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Tools/record_package.ML	Fri May 15 15:56:28 2009 +0200
@@ -1464,7 +1464,7 @@
     val tname = Binding.name (Long_Name.base_name name);
   in
     thy
-    |> TypecopyPackage.add_typecopy (Binding.suffix_name ext_typeN tname, alphas) repT NONE
+    |> TypecopyPackage.typecopy (Binding.suffix_name ext_typeN tname, alphas) repT NONE
     |-> (fn (name, _) => `(fn thy => get_thms thy name))
   end;
 

--- a/src/HOL/Tools/res_reconstruct.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Tools/res_reconstruct.ML	Fri May 15 15:56:28 2009 +0200
@@ -16,10 +16,10 @@
   val setup: Context.theory -> Context.theory
   (* extracting lemma list*)
   val find_failure: string -> string option
-  val lemma_list_dfg: string * string vector * Proof.context * Thm.thm * int -> string
-  val lemma_list_tstp: string * string vector * Proof.context * Thm.thm * int -> string
+  val lemma_list_dfg: string -> string * string vector * Proof.context * Thm.thm * int -> string
+  val lemma_list_tstp: string -> string * string vector * Proof.context * Thm.thm * int -> string
   (* structured proofs *)
-  val structured_proof: string * string vector * Proof.context * Thm.thm * int -> string
+  val structured_proof: string -> string * string vector * Proof.context * Thm.thm * int -> string
 end;
 
 structure ResReconstruct : RES_RECONSTRUCT =
@@ -103,7 +103,7 @@
 
 (*If string s has the prefix s1, return the result of deleting it.*)
 fun strip_prefix s1 s =
-  if String.isPrefix s1 s 
+  if String.isPrefix s1 s
   then SOME (ResClause.undo_ascii_of (String.extract (s, size s1, NONE)))
   else NONE;
 
@@ -278,10 +278,10 @@
   in  #1 (fold_map (decode_tstp vt0) tuples ctxt) end;
 
 (** Finding a matching assumption. The literals may be permuted, and variable names
-    may disagree. We have to try all combinations of literals (quadratic!) and 
+    may disagree. We have to try all combinations of literals (quadratic!) and
     match up the variable names consistently. **)
 
-fun strip_alls_aux n (Const("all",_)$Abs(a,T,t))  =  
+fun strip_alls_aux n (Const("all",_)$Abs(a,T,t))  =
       strip_alls_aux (n+1) (subst_bound (Var ((a,n), T), t))
   | strip_alls_aux _ t  =  t;
 
@@ -292,20 +292,20 @@
 (*Ignore types: they are not to be trusted...*)
 fun match_literal (t1$u1) (t2$u2) env =
       match_literal t1 t2 (match_literal u1 u2 env)
-  | match_literal (Abs (_,_,t1)) (Abs (_,_,t2)) env = 
+  | match_literal (Abs (_,_,t1)) (Abs (_,_,t2)) env =
       match_literal t1 t2 env
-  | match_literal (Bound i1) (Bound i2) env = 
+  | match_literal (Bound i1) (Bound i2) env =
       if i1=i2 then env else raise MATCH_LITERAL
-  | match_literal (Const(a1,_)) (Const(a2,_)) env = 
+  | match_literal (Const(a1,_)) (Const(a2,_)) env =
       if a1=a2 then env else raise MATCH_LITERAL
-  | match_literal (Free(a1,_)) (Free(a2,_)) env = 
+  | match_literal (Free(a1,_)) (Free(a2,_)) env =
       if a1=a2 then env else raise MATCH_LITERAL
   | match_literal (Var(ix1,_)) (Var(ix2,_)) env = insert (op =) (ix1,ix2) env
   | match_literal _ _ env = raise MATCH_LITERAL;
 
 (*Checking that all variable associations are unique. The list env contains no
   repetitions, but does it contain say (x,y) and (y,y)? *)
-fun good env = 
+fun good env =
   let val (xs,ys) = ListPair.unzip env
   in  not (has_duplicates (op=) xs orelse has_duplicates (op=) ys)  end;
 
@@ -316,15 +316,15 @@
       let fun match1 us [] = false
             | match1 us (t::ts) =
                 let val env' = match_literal lit t env
-                in  (good env' andalso matches_aux env' lits (us@ts)) orelse 
-                    match1 (t::us) ts  
+                in  (good env' andalso matches_aux env' lits (us@ts)) orelse
+                    match1 (t::us) ts
                 end
                 handle MATCH_LITERAL => match1 (t::us) ts
-      in  match1 [] ts  end; 
+      in  match1 [] ts  end;
 
 (*Is this length test useful?*)
-fun matches (lits1,lits2) = 
-  length lits1 = length lits2  andalso  
+fun matches (lits1,lits2) =
+  length lits1 = length lits2  andalso
   matches_aux [] (map Envir.eta_contract lits1) (map Envir.eta_contract lits2);
 
 fun permuted_clause t =
@@ -408,7 +408,7 @@
       if eq_types t orelse not (null (Term.add_tvars t [])) orelse
          exists_subterm bad_free t orelse
          (not (null lines) andalso   (*final line can't be deleted for these reasons*)
-          (length deps < 2 orelse nlines mod (Config.get ctxt modulus) <> 0))   
+          (length deps < 2 orelse nlines mod (Config.get ctxt modulus) <> 0))
       then (nlines+1, map (replace_deps (lno, deps)) lines) (*Delete line*)
       else (nlines+1, (lno, t, deps) :: lines);
 
@@ -467,7 +467,7 @@
   val failure_strings_remote = ["Remote-script could not extract proof"];
   fun find_failure proof =
     let val failures =
-      map_filter (fn s => if String.isSubstring s proof then SOME s else NONE) 
+      map_filter (fn s => if String.isSubstring s proof then SOME s else NONE)
          (failure_strings_E @ failure_strings_vampire @ failure_strings_SPASS @ failure_strings_remote)
     in if null failures then NONE else SOME (hd failures) end;
     
@@ -481,7 +481,7 @@
   "Formulae used in the proof"];
   fun get_proof_extract proof =
     let
-    (*splits to_split by the first possible of a list of splitters*)                        
+    (*splits to_split by the first possible of a list of splitters*)
     fun first_field_any [] to_split = NONE
       | first_field_any (splitter::splitters) to_split =
       let
@@ -493,10 +493,10 @@
     val (proofextract:string, c:string) = valOf (first_field_any end_proof_strings b)
     in proofextract end;
   
-  (* === EXTRACTING LEMMAS === *)    
+  (* === EXTRACTING LEMMAS === *)
   (* lines have the form "cnf(108, axiom, ...",
   the number (108) has to be extracted)*)
-  fun get_step_nums_tstp proofextract = 
+  fun get_step_nums_tstp proofextract =
     let val toks = String.tokens (not o Char.isAlphaNum)
     fun inputno ("cnf"::ntok::"axiom"::_) = Int.fromString ntok
       | inputno _ = NONE
@@ -513,47 +513,56 @@
     val lines = split_lines proofextract
     in  List.mapPartial (inputno o toks) lines  end
     
-  (*extracting lemmas from tstp-output between the lines from above*)                         
-  fun extract_lemmas get_step_nums (proof, thm_names, _, _, _) = 
+  (*extracting lemmas from tstp-output between the lines from above*)
+  fun extract_lemmas get_step_nums (proof, thm_names, _, _, _) =
     let
     (* get the names of axioms from their numbers*)
     fun get_axiom_names thm_names step_nums =
       let
       fun is_axiom n = n <= Vector.length thm_names
       fun getname i = Vector.sub(thm_names, i-1)
-      in 
+      in
         sort_distinct string_ord (filter (fn x => x <> "??.unknown") (map getname (filter is_axiom step_nums)))
       end
     val proofextract = get_proof_extract proof
-    in 
+    in
       get_axiom_names thm_names (get_step_nums proofextract)
     end;
     
-    (* metis-command *)
-    fun metis_line [] = "apply metis"
-      | metis_line xs = "apply (metis " ^ space_implode " " xs ^ ")"
-    
-    (*Used to label theorems chained into the sledgehammer call*)
-    val chained_hint = "CHAINED";
-    fun sendback_metis_nochained lemmas = 
-      let val nochained = filter_out (fn y => y = chained_hint)
-      in (Markup.markup Markup.sendback o metis_line) (nochained lemmas) end
-    fun lemma_list_tstp result = sendback_metis_nochained (extract_lemmas get_step_nums_tstp result);
-    fun lemma_list_dfg result = sendback_metis_nochained (extract_lemmas get_step_nums_dfg result);
-           
-    (* === Extracting structured Isar-proof === *)
-    fun structured_proof (result as (proof, thm_names, ctxt, goal, subgoalno)) = 
-      let
-      (*Could use split_lines, but it can return blank lines...*)
-      val lines = String.tokens (equal #"\n");
-      val nospaces = String.translate (fn c => if Char.isSpace c then "" else str c)
-      val proofextract = get_proof_extract proof
-      val cnfs = filter (String.isPrefix "cnf(") (map nospaces (lines proofextract))
-      val one_line_proof = lemma_list_tstp result
-      val structured = if chained_hint mem_string (String.tokens (fn c => c = #" ") one_line_proof) then ""
-                  else decode_tstp_file cnfs ctxt goal subgoalno thm_names
-      in
-      one_line_proof ^ "\n\n" ^ (Markup.markup Markup.sendback) structured
-    end
+  (* metis-command *)
+  fun metis_line [] = "apply metis"
+    | metis_line xs = "apply (metis " ^ space_implode " " xs ^ ")"
+
+  (* atp_minimize [atp=<prover>] <lemmas> *)
+  fun minimize_line _ [] = ""
+    | minimize_line name lemmas = "For minimizing the number of lemmas try this command:\n" ^
+          (Markup.markup Markup.sendback) ("atp_minimize [atp=" ^ name ^ "] " ^ space_implode " " lemmas)
 
- end;
+  (*Used to label theorems chained into the sledgehammer call*)
+  val chained_hint = "CHAINED";
+  fun sendback_metis_nochained lemmas =
+    let val nochained = filter_out (fn y => y = chained_hint)
+    in (Markup.markup Markup.sendback o metis_line) (nochained lemmas) end
+  fun lemma_list_tstp name result =
+    let val lemmas = extract_lemmas get_step_nums_tstp result
+    in sendback_metis_nochained lemmas ^ "\n" ^ minimize_line name lemmas end;
+  fun lemma_list_dfg name result =
+    let val lemmas = extract_lemmas get_step_nums_dfg result
+    in sendback_metis_nochained lemmas ^ "\n" ^ minimize_line name lemmas end;
+
+  (* === Extracting structured Isar-proof === *)
+  fun structured_proof name (result as (proof, thm_names, ctxt, goal, subgoalno)) =
+    let
+    (*Could use split_lines, but it can return blank lines...*)
+    val lines = String.tokens (equal #"\n");
+    val nospaces = String.translate (fn c => if Char.isSpace c then "" else str c)
+    val proofextract = get_proof_extract proof
+    val cnfs = filter (String.isPrefix "cnf(") (map nospaces (lines proofextract))
+    val one_line_proof = lemma_list_tstp name result
+    val structured = if chained_hint mem_string (String.tokens (fn c => c = #" ") one_line_proof) then ""
+                else decode_tstp_file cnfs ctxt goal subgoalno thm_names
+    in
+    one_line_proof ^ "\n\n" ^ (Markup.markup Markup.sendback) structured
+  end
+
+end;

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Tools/string_code.ML	Fri May 15 15:56:28 2009 +0200
@@ -0,0 +1,88 @@
+(* Author: Florian Haftmann, TU Muenchen
+
+Code generation for character and string literals.
+*)
+
+signature STRING_CODE =
+sig
+  val add_literal_list_string: string -> theory -> theory
+  val add_literal_char: string -> theory -> theory
+  val add_literal_message: string -> theory -> theory
+end;
+
+structure String_Code : STRING_CODE =
+struct
+
+open Basic_Code_Thingol;
+
+fun decode_char nibbles' tt =
+  let
+    fun idx c = find_index (curry (op =) c) nibbles';
+    fun decode ~1 _ = NONE
+      | decode _ ~1 = NONE
+      | decode n m = SOME (chr (n * 16 + m));
+  in case tt
+   of (IConst (c1, _), IConst (c2, _)) => decode (idx c1) (idx c2)
+    | _ => NONE
+  end;
+   
+fun implode_string char' nibbles' mk_char mk_string ts =
+  let
+    fun implode_char (IConst (c, _) `$ t1 `$ t2) =
+          if c = char' then decode_char nibbles' (t1, t2) else NONE
+      | implode_char _ = NONE;
+    val ts' = map_filter implode_char ts;
+  in if length ts = length ts'
+    then (SOME o Code_Printer.str o mk_string o implode) ts'
+    else NONE
+  end;
+
+val cs_nibbles = [@{const_name Nibble0}, @{const_name Nibble1},
+  @{const_name Nibble2}, @{const_name Nibble3},
+  @{const_name Nibble4}, @{const_name Nibble5},
+  @{const_name Nibble6}, @{const_name Nibble7},
+  @{const_name Nibble8}, @{const_name Nibble9},
+  @{const_name NibbleA}, @{const_name NibbleB},
+  @{const_name NibbleC}, @{const_name NibbleD},
+  @{const_name NibbleE}, @{const_name NibbleF}];
+val cs_summa = [@{const_name Nil}, @{const_name Cons}, @{const_name Char}] @ cs_nibbles;
+
+fun add_literal_list_string target =
+  let
+    fun pretty literals (nil' :: cons' :: char' :: nibbles') pr thm vars fxy [(t1, _), (t2, _)] =
+      case Option.map (cons t1) (List_Code.implode_list nil' cons' t2)
+       of SOME ts => (case implode_string char' nibbles'
+          (Code_Printer.literal_char literals) (Code_Printer.literal_string literals) ts
+             of SOME p => p
+              | NONE =>
+                  Code_Printer.literal_list literals (map (pr vars Code_Printer.NOBR) ts))
+        | NONE =>
+            List_Code.default_list (Code_Printer.infix_cons literals) (pr vars) fxy t1 t2;
+  in Code_Target.add_syntax_const target
+    @{const_name Cons} (SOME (2, (cs_summa, pretty)))
+  end;
+
+fun add_literal_char target =
+  let
+    fun pretty literals nibbles' _ thm _ _ [(t1, _), (t2, _)] =
+      case decode_char nibbles' (t1, t2)
+       of SOME c => (Code_Printer.str o Code_Printer.literal_char literals) c
+        | NONE => Code_Printer.nerror thm "Illegal character expression";
+  in Code_Target.add_syntax_const target
+    @{const_name Char} (SOME (2, (cs_nibbles, pretty)))
+  end;
+
+fun add_literal_message target =
+  let
+    fun pretty literals (nil' :: cons' :: char' :: nibbles') _ thm _ _ [(t, _)] =
+      case List_Code.implode_list nil' cons' t
+       of SOME ts => (case implode_string char' nibbles'
+          (Code_Printer.literal_char literals) (Code_Printer.literal_string literals) ts
+             of SOME p => p
+              | NONE => Code_Printer.nerror thm "Illegal message expression")
+        | NONE => Code_Printer.nerror thm "Illegal message expression";
+  in Code_Target.add_syntax_const target 
+    @{const_name STR} (SOME (1, (cs_summa, pretty)))
+  end;
+
+end;

--- a/src/HOL/Tools/string_syntax.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Tools/string_syntax.ML	Fri May 15 15:56:28 2009 +0200
@@ -15,12 +15,14 @@
 
 (* nibble *)
 
+val nib_prefix = "String.nibble.";
+
 val mk_nib =
-  Syntax.Constant o unprefix "List.nibble." o
+  Syntax.Constant o unprefix nib_prefix o
   fst o Term.dest_Const o HOLogic.mk_nibble;
 
 fun dest_nib (Syntax.Constant c) =
-  HOLogic.dest_nibble (Const ("List.nibble." ^ c, dummyT))
+  HOLogic.dest_nibble (Const (nib_prefix ^ c, dummyT))
     handle TERM _ => raise Match;
 
 

--- a/src/HOL/Tools/typecopy_package.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Tools/typecopy_package.ML	Fri May 15 15:56:28 2009 +0200
@@ -14,12 +14,12 @@
     proj: string * typ,
     proj_def: thm
   }
-  val add_typecopy: binding * string list -> typ -> (binding * binding) option
+  val typecopy: binding * string list -> typ -> (binding * binding) option
     -> theory -> (string * info) * theory
   val get_typecopies: theory -> string list
   val get_info: theory -> string -> info option
   val interpretation: (string -> theory -> theory) -> theory -> theory
-  val add_typecopy_default_code: string -> theory -> theory
+  val add_default_code: string -> theory -> theory
   val print_typecopies: theory -> unit
   val setup: theory -> theory
 end;
@@ -71,7 +71,10 @@
 structure TypecopyInterpretation = InterpretationFun(type T = string val eq = op =);
 val interpretation = TypecopyInterpretation.interpretation;
 
-fun add_typecopy (raw_tyco, raw_vs) raw_ty constr_proj thy =
+
+(* declaring typecopies *)
+
+fun typecopy (raw_tyco, raw_vs) raw_ty constr_proj thy =
   let
     val ty = Sign.certify_typ thy raw_ty;
     val vs =
@@ -108,28 +111,26 @@
   end;
 
 
-(* code generator setup *)
+(* default code setup *)
 
-fun add_typecopy_default_code tyco thy =
+fun add_default_code tyco thy =
   let
     val SOME { constr = constr_name, proj = (proj, _), proj_def = proj_eq, vs = raw_vs,
-      typ = raw_ty_rep, ... } =  get_info thy tyco;
-    val inst_meet = Sorts.meet_sort_typ (Sign.classes_of thy)
-      (Logic.varifyT raw_ty_rep, [HOLogic.class_eq]) handle Sorts.CLASS_ERROR _ => I;
-    val ty_inst = Logic.unvarifyT o inst_meet o Logic.varifyT;
-    val vs = (map dest_TFree o snd o dest_Type o ty_inst)
-      (Type (tyco, map TFree raw_vs));
-    val ty_rep = ty_inst raw_ty_rep;
+      typ = ty_rep, ... } =  get_info thy tyco;
     val SOME { Rep_inject = proj_inject, ... } = TypedefPackage.get_info thy tyco;
-    val ty_constr = Logic.unvarifyT (Sign.the_const_type thy constr_name);
-    val constr = (constr_name, ty_constr)
+    val constr = (constr_name, Logic.unvarifyT (Sign.the_const_type thy constr_name));
+    val vs = (map dest_TFree o snd o dest_Type) (Type (tyco, map TFree raw_vs));
     val ty = Type (tyco, map TFree vs);
-    fun mk_eq ty t_x t_y = Const (@{const_name eq_class.eq}, ty --> ty --> HOLogic.boolT)
+    val proj = Const (proj, ty --> ty_rep);
+    val (t_x, t_y) = (Free ("x", ty), Free ("y", ty));
+    val eq_lhs = Const (@{const_name eq_class.eq}, ty --> ty --> HOLogic.boolT)
       $ t_x $ t_y;
-    fun mk_proj t = Const (proj, ty --> ty_rep) $ t;
-    val (t_x, t_y) = (Free ("x", ty), Free ("y", ty));
-    val def_eq = (HOLogic.mk_Trueprop o HOLogic.mk_eq)
-      (mk_eq ty t_x t_y, HOLogic.mk_eq (mk_proj t_x, mk_proj t_y));
+    val eq_rhs = HOLogic.mk_eq (proj $ t_x, proj $ t_y);
+    val eq = (HOLogic.mk_Trueprop o HOLogic.mk_eq) (eq_lhs, eq_rhs);
+    fun tac eq_thm = Class.intro_classes_tac []
+      THEN (Simplifier.rewrite_goals_tac
+        (map Simpdata.mk_eq [eq_thm, @{thm eq}, proj_inject]))
+          THEN ALLGOALS (rtac @{thm refl});
     fun mk_eq_refl thy = @{thm HOL.eq_refl}
       |> Thm.instantiate
          ([pairself (Thm.ctyp_of thy) (TVar (("'a", 0), @{sort eq}), Logic.varifyT ty)], [])
@@ -139,22 +140,18 @@
     |> Code.add_datatype [constr]
     |> Code.add_eqn proj_eq
     |> TheoryTarget.instantiation ([tyco], vs, [HOLogic.class_eq])
-    |> `(fn lthy => Syntax.check_term lthy def_eq)
-    |-> (fn def_eq => Specification.definition
-         (NONE, (Attrib.empty_binding, def_eq)))
-    |-> (fn (_, (_, def_thm)) =>
+    |> `(fn lthy => Syntax.check_term lthy eq)
+    |-> (fn eq => Specification.definition
+         (NONE, (Attrib.empty_binding, eq)))
+    |-> (fn (_, (_, eq_thm)) =>
        Class.prove_instantiation_exit_result Morphism.thm
-         (fn _ => fn def_thm => Class.intro_classes_tac []
-            THEN (Simplifier.rewrite_goals_tac
-              (map Simpdata.mk_eq [def_thm, @{thm eq}, proj_inject]))
-                THEN ALLGOALS (rtac @{thm refl})) def_thm)
-    |-> (fn def_thm => Code.add_eqn def_thm)
-    |> `(fn thy => mk_eq_refl thy)
-    |-> (fn refl_thm => Code.add_nonlinear_eqn refl_thm)
+         (fn _ => fn eq_thm => tac eq_thm) eq_thm)
+    |-> (fn eq_thm => Code.add_eqn eq_thm)
+    |> (fn thy => Code.add_nbe_eqn (mk_eq_refl thy) thy)
   end;
 
 val setup =
   TypecopyInterpretation.init
-  #> interpretation add_typecopy_default_code
+  #> interpretation add_default_code
 
 end;

--- a/src/HOL/Transcendental.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Transcendental.thy	Fri May 15 15:56:28 2009 +0200
@@ -14,7 +14,7 @@
 subsection {* Properties of Power Series *}
 
 lemma lemma_realpow_diff:
-  fixes y :: "'a::recpower"
+  fixes y :: "'a::monoid_mult"
   shows "p \<le> n \<Longrightarrow> y ^ (Suc n - p) = (y ^ (n - p)) * y"
 proof -
   assume "p \<le> n"
@@ -23,14 +23,14 @@
 qed
 
 lemma lemma_realpow_diff_sumr:
-  fixes y :: "'a::{recpower,comm_semiring_0}" shows
+  fixes y :: "'a::{comm_semiring_0,monoid_mult}" shows
      "(\<Sum>p=0..<Suc n. (x ^ p) * y ^ (Suc n - p)) =  
       y * (\<Sum>p=0..<Suc n. (x ^ p) * y ^ (n - p))"
 by (simp add: setsum_right_distrib lemma_realpow_diff mult_ac
          del: setsum_op_ivl_Suc cong: strong_setsum_cong)
 
 lemma lemma_realpow_diff_sumr2:
-  fixes y :: "'a::{recpower,comm_ring}" shows
+  fixes y :: "'a::{comm_ring,monoid_mult}" shows
      "x ^ (Suc n) - y ^ (Suc n) =  
       (x - y) * (\<Sum>p=0..<Suc n. (x ^ p) * y ^ (n - p))"
 apply (induct n, simp)
@@ -56,7 +56,7 @@
 x}, then it sums absolutely for @{term z} with @{term "\<bar>z\<bar> < \<bar>x\<bar>"}.*}
 
 lemma powser_insidea:
-  fixes x z :: "'a::{real_normed_field,banach,recpower}"
+  fixes x z :: "'a::{real_normed_field,banach}"
   assumes 1: "summable (\<lambda>n. f n * x ^ n)"
   assumes 2: "norm z < norm x"
   shows "summable (\<lambda>n. norm (f n * z ^ n))"
@@ -108,7 +108,7 @@
 qed
 
 lemma powser_inside:
-  fixes f :: "nat \<Rightarrow> 'a::{real_normed_field,banach,recpower}" shows
+  fixes f :: "nat \<Rightarrow> 'a::{real_normed_field,banach}" shows
      "[| summable (%n. f(n) * (x ^ n)); norm z < norm x |]  
       ==> summable (%n. f(n) * (z ^ n))"
 by (rule powser_insidea [THEN summable_norm_cancel])
@@ -173,7 +173,7 @@
     have "(\<lambda> n. if even n then f (n div 2) else 0) sums y"
       unfolding sums_def setsum_shift_lb_Suc0_0_upt[where f="?s", OF `?s 0 = 0`, symmetric]
                 image_Suc_atLeastLessThan[symmetric] setsum_reindex[OF inj_Suc, unfolded comp_def]
-                even_nat_Suc Suc_m1 if_eq .
+                even_Suc Suc_m1 if_eq .
   } from sums_add[OF g_sums this]
   show ?thesis unfolding if_sum .
 qed
@@ -347,7 +347,7 @@
 done
 
 lemma lemma_termdiff1:
-  fixes z :: "'a :: {recpower,comm_ring}" shows
+  fixes z :: "'a :: {monoid_mult,comm_ring}" shows
   "(\<Sum>p=0..<m. (((z + h) ^ (m - p)) * (z ^ p)) - (z ^ m)) =  
    (\<Sum>p=0..<m. (z ^ p) * (((z + h) ^ (m - p)) - (z ^ (m - p))))"
 by(auto simp add: algebra_simps power_add [symmetric] cong: strong_setsum_cong)
@@ -357,7 +357,7 @@
 by (simp add: setsum_subtractf)
 
 lemma lemma_termdiff2:
-  fixes h :: "'a :: {recpower,field}"
+  fixes h :: "'a :: {field}"
   assumes h: "h \<noteq> 0" shows
   "((z + h) ^ n - z ^ n) / h - of_nat n * z ^ (n - Suc 0) =
    h * (\<Sum>p=0..< n - Suc 0. \<Sum>q=0..< n - Suc 0 - p.
@@ -393,7 +393,7 @@
 done
 
 lemma lemma_termdiff3:
-  fixes h z :: "'a::{real_normed_field,recpower}"
+  fixes h z :: "'a::{real_normed_field}"
   assumes 1: "h \<noteq> 0"
   assumes 2: "norm z \<le> K"
   assumes 3: "norm (z + h) \<le> K"
@@ -433,7 +433,7 @@
 qed
 
 lemma lemma_termdiff4:
-  fixes f :: "'a::{real_normed_field,recpower} \<Rightarrow>
+  fixes f :: "'a::{real_normed_field} \<Rightarrow>
               'b::real_normed_vector"
   assumes k: "0 < (k::real)"
   assumes le: "\<And>h. \<lbrakk>h \<noteq> 0; norm h < k\<rbrakk> \<Longrightarrow> norm (f h) \<le> K * norm h"
@@ -478,7 +478,7 @@
 qed
 
 lemma lemma_termdiff5:
-  fixes g :: "'a::{recpower,real_normed_field} \<Rightarrow>
+  fixes g :: "'a::{real_normed_field} \<Rightarrow>
               nat \<Rightarrow> 'b::banach"
   assumes k: "0 < (k::real)"
   assumes f: "summable f"
@@ -507,7 +507,7 @@
 text{* FIXME: Long proofs*}
 
 lemma termdiffs_aux:
-  fixes x :: "'a::{recpower,real_normed_field,banach}"
+  fixes x :: "'a::{real_normed_field,banach}"
   assumes 1: "summable (\<lambda>n. diffs (diffs c) n * K ^ n)"
   assumes 2: "norm x < norm K"
   shows "(\<lambda>h. \<Sum>n. c n * (((x + h) ^ n - x ^ n) / h
@@ -572,7 +572,7 @@
 qed
 
 lemma termdiffs:
-  fixes K x :: "'a::{recpower,real_normed_field,banach}"
+  fixes K x :: "'a::{real_normed_field,banach}"
   assumes 1: "summable (\<lambda>n. c n * K ^ n)"
   assumes 2: "summable (\<lambda>n. (diffs c) n * K ^ n)"
   assumes 3: "summable (\<lambda>n. (diffs (diffs c)) n * K ^ n)"
@@ -822,11 +822,11 @@
 subsection {* Exponential Function *}
 
 definition
-  exp :: "'a \<Rightarrow> 'a::{recpower,real_normed_field,banach}" where
+  exp :: "'a \<Rightarrow> 'a::{real_normed_field,banach}" where
   "exp x = (\<Sum>n. x ^ n /\<^sub>R real (fact n))"
 
 lemma summable_exp_generic:
-  fixes x :: "'a::{real_normed_algebra_1,recpower,banach}"
+  fixes x :: "'a::{real_normed_algebra_1,banach}"
   defines S_def: "S \<equiv> \<lambda>n. x ^ n /\<^sub>R real (fact n)"
   shows "summable S"
 proof -
@@ -856,7 +856,7 @@
 qed
 
 lemma summable_norm_exp:
-  fixes x :: "'a::{real_normed_algebra_1,recpower,banach}"
+  fixes x :: "'a::{real_normed_algebra_1,banach}"
   shows "summable (\<lambda>n. norm (x ^ n /\<^sub>R real (fact n)))"
 proof (rule summable_norm_comparison_test [OF exI, rule_format])
   show "summable (\<lambda>n. norm x ^ n /\<^sub>R real (fact n))"
@@ -901,7 +901,7 @@
 subsubsection {* Properties of the Exponential Function *}
 
 lemma powser_zero:
-  fixes f :: "nat \<Rightarrow> 'a::{real_normed_algebra_1,recpower}"
+  fixes f :: "nat \<Rightarrow> 'a::{real_normed_algebra_1}"
   shows "(\<Sum>n. f n * 0 ^ n) = f 0"
 proof -
   have "(\<Sum>n = 0..<1. f n * 0 ^ n) = (\<Sum>n. f n * 0 ^ n)"
@@ -918,7 +918,7 @@
          del: setsum_cl_ivl_Suc)
 
 lemma exp_series_add:
-  fixes x y :: "'a::{real_field,recpower}"
+  fixes x y :: "'a::{real_field}"
   defines S_def: "S \<equiv> \<lambda>x n. x ^ n /\<^sub>R real (fact n)"
   shows "S (x + y) n = (\<Sum>i=0..n. S x i * S y (n - i))"
 proof (induct n)

--- a/src/HOL/Transitive_Closure.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Transitive_Closure.thy	Fri May 15 15:56:28 2009 +0200
@@ -630,6 +630,140 @@
 
 declare trancl_into_rtrancl [elim]
 
+subsection {* The power operation on relations *}
+
+text {* @{text "R ^^ n = R O ... O R"}, the n-fold composition of @{text R} *}
+
+overloading
+  relpow == "compow :: nat \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set"
+begin
+
+primrec relpow :: "nat \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set" where
+    "relpow 0 R = Id"
+  | "relpow (Suc n) R = R O (R ^^ n)"
+
+end
+
+lemma rel_pow_1 [simp]:
+  fixes R :: "('a \<times> 'a) set"
+  shows "R ^^ 1 = R"
+  by simp
+
+lemma rel_pow_0_I: 
+  "(x, x) \<in> R ^^ 0"
+  by simp
+
+lemma rel_pow_Suc_I:
+  "(x, y) \<in>  R ^^ n \<Longrightarrow> (y, z) \<in> R \<Longrightarrow> (x, z) \<in> R ^^ Suc n"
+  by auto
+
+lemma rel_pow_Suc_I2:
+  "(x, y) \<in> R \<Longrightarrow> (y, z) \<in> R ^^ n \<Longrightarrow> (x, z) \<in> R ^^ Suc n"
+  by (induct n arbitrary: z) (simp, fastsimp)
+
+lemma rel_pow_0_E:
+  "(x, y) \<in> R ^^ 0 \<Longrightarrow> (x = y \<Longrightarrow> P) \<Longrightarrow> P"
+  by simp
+
+lemma rel_pow_Suc_E:
+  "(x, z) \<in> R ^^ Suc n \<Longrightarrow> (\<And>y. (x, y) \<in> R ^^ n \<Longrightarrow> (y, z) \<in> R \<Longrightarrow> P) \<Longrightarrow> P"
+  by auto
+
+lemma rel_pow_E:
+  "(x, z) \<in>  R ^^ n \<Longrightarrow>  (n = 0 \<Longrightarrow> x = z \<Longrightarrow> P)
+   \<Longrightarrow> (\<And>y m. n = Suc m \<Longrightarrow> (x, y) \<in>  R ^^ m \<Longrightarrow> (y, z) \<in> R \<Longrightarrow> P)
+   \<Longrightarrow> P"
+  by (cases n) auto
+
+lemma rel_pow_Suc_D2:
+  "(x, z) \<in> R ^^ Suc n \<Longrightarrow> (\<exists>y. (x, y) \<in> R \<and> (y, z) \<in> R ^^ n)"
+  apply (induct n arbitrary: x z)
+   apply (blast intro: rel_pow_0_I elim: rel_pow_0_E rel_pow_Suc_E)
+  apply (blast intro: rel_pow_Suc_I elim: rel_pow_0_E rel_pow_Suc_E)
+  done
+
+lemma rel_pow_Suc_E2:
+  "(x, z) \<in> R ^^ Suc n \<Longrightarrow> (\<And>y. (x, y) \<in> R \<Longrightarrow> (y, z) \<in> R ^^ n \<Longrightarrow> P) \<Longrightarrow> P"
+  by (blast dest: rel_pow_Suc_D2)
+
+lemma rel_pow_Suc_D2':
+  "\<forall>x y z. (x, y) \<in> R ^^ n \<and> (y, z) \<in> R \<longrightarrow> (\<exists>w. (x, w) \<in> R \<and> (w, z) \<in> R ^^ n)"
+  by (induct n) (simp_all, blast)
+
+lemma rel_pow_E2:
+  "(x, z) \<in> R ^^ n \<Longrightarrow>  (n = 0 \<Longrightarrow> x = z \<Longrightarrow> P)
+     \<Longrightarrow> (\<And>y m. n = Suc m \<Longrightarrow> (x, y) \<in> R \<Longrightarrow> (y, z) \<in> R ^^ m \<Longrightarrow> P)
+   \<Longrightarrow> P"
+  apply (cases n, simp)
+  apply (cut_tac n=nat and R=R in rel_pow_Suc_D2', simp, blast)
+  done
+
+lemma rtrancl_imp_UN_rel_pow:
+  assumes "p \<in> R^*"
+  shows "p \<in> (\<Union>n. R ^^ n)"
+proof (cases p)
+  case (Pair x y)
+  with assms have "(x, y) \<in> R^*" by simp
+  then have "(x, y) \<in> (\<Union>n. R ^^ n)" proof induct
+    case base show ?case by (blast intro: rel_pow_0_I)
+  next
+    case step then show ?case by (blast intro: rel_pow_Suc_I)
+  qed
+  with Pair show ?thesis by simp
+qed
+
+lemma rel_pow_imp_rtrancl:
+  assumes "p \<in> R ^^ n"
+  shows "p \<in> R^*"
+proof (cases p)
+  case (Pair x y)
+  with assms have "(x, y) \<in> R ^^ n" by simp
+  then have "(x, y) \<in> R^*" proof (induct n arbitrary: x y)
+    case 0 then show ?case by simp
+  next
+    case Suc then show ?case
+      by (blast elim: rel_pow_Suc_E intro: rtrancl_into_rtrancl)
+  qed
+  with Pair show ?thesis by simp
+qed
+
+lemma rtrancl_is_UN_rel_pow:
+  "R^* = (\<Union>n. R ^^ n)"
+  by (blast intro: rtrancl_imp_UN_rel_pow rel_pow_imp_rtrancl)
+
+lemma rtrancl_power:
+  "p \<in> R^* \<longleftrightarrow> (\<exists>n. p \<in> R ^^ n)"
+  by (simp add: rtrancl_is_UN_rel_pow)
+
+lemma trancl_power:
+  "p \<in> R^+ \<longleftrightarrow> (\<exists>n > 0. p \<in> R ^^ n)"
+  apply (cases p)
+  apply simp
+  apply (rule iffI)
+   apply (drule tranclD2)
+   apply (clarsimp simp: rtrancl_is_UN_rel_pow)
+   apply (rule_tac x="Suc n" in exI)
+   apply (clarsimp simp: rel_comp_def)
+   apply fastsimp
+  apply clarsimp
+  apply (case_tac n, simp)
+  apply clarsimp
+  apply (drule rel_pow_imp_rtrancl)
+  apply (drule rtrancl_into_trancl1) apply auto
+  done
+
+lemma rtrancl_imp_rel_pow:
+  "p \<in> R^* \<Longrightarrow> \<exists>n. p \<in> R ^^ n"
+  by (auto dest: rtrancl_imp_UN_rel_pow)
+
+lemma single_valued_rel_pow:
+  fixes R :: "('a * 'a) set"
+  shows "single_valued R \<Longrightarrow> single_valued (R ^^ n)"
+  apply (induct n arbitrary: R)
+  apply simp_all
+  apply (rule single_valuedI)
+  apply (fast dest: single_valuedD elim: rel_pow_Suc_E)
+  done
 
 subsection {* Setup of transitivity reasoner *}
 

--- a/src/HOL/Typerep.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Typerep.thy	Fri May 15 15:56:28 2009 +0200
@@ -1,17 +1,15 @@
-(*  Title:      HOL/Typerep.thy
-    Author:     Florian Haftmann, TU Muenchen
-*)
+(* Author: Florian Haftmann, TU Muenchen *)
 
 header {* Reflecting Pure types into HOL *}
 
 theory Typerep
-imports Plain List Code_Message
+imports Plain String
 begin
 
 datatype typerep = Typerep message_string "typerep list"
 
 class typerep =
-  fixes typerep :: "'a\<Colon>{} itself \<Rightarrow> typerep"
+  fixes typerep :: "'a itself \<Rightarrow> typerep"
 begin
 
 definition typerep_of :: "'a \<Rightarrow> typerep" where
@@ -37,28 +35,18 @@
 end
 *}
 
-ML {*
-structure Typerep =
-struct
+setup {*
+let
 
-fun mk f (Type (tyco, tys)) =
-      @{term Typerep} $ Message_String.mk tyco
-        $ HOLogic.mk_list @{typ typerep} (map (mk f) tys)
-  | mk f (TFree v) =
-      f v;
-
-fun typerep ty =
-  Const (@{const_name typerep}, Term.itselfT ty --> @{typ typerep})
-    $ Logic.mk_type ty;
-
-fun add_def tyco thy =
+fun add_typerep tyco thy =
   let
     val sorts = replicate (Sign.arity_number thy tyco) @{sort typerep};
     val vs = Name.names Name.context "'a" sorts;
     val ty = Type (tyco, map TFree vs);
     val lhs = Const (@{const_name typerep}, Term.itselfT ty --> @{typ typerep})
       $ Free ("T", Term.itselfT ty);
-    val rhs = mk (typerep o TFree) ty;
+    val rhs = @{term Typerep} $ HOLogic.mk_message_string tyco
+      $ HOLogic.mk_list @{typ typerep} (map (HOLogic.mk_typerep o TFree) vs);
     val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs));
   in
     thy
@@ -66,24 +54,20 @@
     |> `(fn lthy => Syntax.check_term lthy eq)
     |-> (fn eq => Specification.definition (NONE, (Attrib.empty_binding, eq)))
     |> snd
-    |> Class.prove_instantiation_instance (K (Class.intro_classes_tac []))
-    |> LocalTheory.exit_global
+    |> Class.prove_instantiation_exit (K (Class.intro_classes_tac []))
   end;
 
-fun perhaps_add_def tyco thy =
-  let
-    val inst = can (Sorts.mg_domain (Sign.classes_of thy) tyco) @{sort typerep}
-  in if inst then thy else add_def tyco thy end;
+fun ensure_typerep tyco thy = if not (can (Sorts.mg_domain (Sign.classes_of thy) tyco) @{sort typerep})
+  andalso can (Sorts.mg_domain (Sign.classes_of thy) tyco) @{sort type}
+  then add_typerep tyco thy else thy;
+
+in
 
-end;
-*}
+add_typerep @{type_name fun}
+#> TypedefPackage.interpretation ensure_typerep
+#> Code.type_interpretation (ensure_typerep o fst)
 
-setup {*
-  Typerep.add_def @{type_name prop}
-  #> Typerep.add_def @{type_name fun}
-  #> Typerep.add_def @{type_name itself}
-  #> Typerep.add_def @{type_name bool}
-  #> TypedefPackage.interpretation Typerep.perhaps_add_def
+end
 *}
 
 lemma [code]:
@@ -92,12 +76,12 @@
   by (auto simp add: equals_eq [symmetric] list_all2_eq [symmetric])
 
 code_type typerep
-  (SML "Term.typ")
+  (Eval "Term.typ")
 
 code_const Typerep
-  (SML "Term.Type/ (_, _)")
+  (Eval "Term.Type/ (_, _)")
 
-code_reserved SML Term
+code_reserved Eval Term
 
 hide (open) const typerep Typerep
 

--- a/src/HOL/UNITY/Comp.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/UNITY/Comp.thy	Fri May 15 15:56:28 2009 +0200
@@ -15,14 +15,22 @@
 
 header{*Composition: Basic Primitives*}
 
-theory Comp imports Union begin
+theory Comp
+imports Union
+begin
 
-instance program :: (type) ord ..
+instantiation program :: (type) ord
+begin
 
-defs
-  component_def:          "F \<le> H == \<exists>G. F\<squnion>G = H"
-  strict_component_def:   "(F < (H::'a program)) == (F \<le> H & F \<noteq> H)"
+definition
+  component_def: "F \<le> H <-> (\<exists>G. F\<squnion>G = H)"
 
+definition
+  strict_component_def: "F < (H::'a program) <-> (F \<le> H & F \<noteq> H)"
+
+instance ..
+
+end
 
 constdefs
   component_of :: "'a program =>'a program=> bool"
@@ -114,7 +122,7 @@
 by (auto simp add: stable_def component_constrains)
 
 (*Used in Guar.thy to show that programs are partially ordered*)
-lemmas program_less_le = strict_component_def [THEN meta_eq_to_obj_eq]
+lemmas program_less_le = strict_component_def
 
 
 subsection{*The preserves property*}
@@ -229,8 +237,7 @@
 apply (blast intro: Join_assoc [symmetric])
 done
 
-lemmas strict_component_of_eq =
-    strict_component_of_def [THEN meta_eq_to_obj_eq, standard]
+lemmas strict_component_of_eq = strict_component_of_def
 
 (** localize **)
 lemma localize_Init_eq [simp]: "Init (localize v F) = Init F"

--- a/src/HOL/UNITY/Transformers.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/UNITY/Transformers.thy	Fri May 15 15:56:28 2009 +0200
@@ -338,10 +338,10 @@
 
 constdefs
   wens_single_finite :: "[('a*'a) set, 'a set, nat] => 'a set"  
-    "wens_single_finite act B k == \<Union>i \<in> atMost k. ((wp act)^i) B"
+    "wens_single_finite act B k == \<Union>i \<in> atMost k. (wp act ^^ i) B"
 
   wens_single :: "[('a*'a) set, 'a set] => 'a set"  
-    "wens_single act B == \<Union>i. ((wp act)^i) B"
+    "wens_single act B == \<Union>i. (wp act ^^ i) B"
 
 lemma wens_single_Un_eq:
       "single_valued act

--- a/src/HOL/Wellfounded.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Wellfounded.thy	Fri May 15 15:56:28 2009 +0200
@@ -7,7 +7,7 @@
 header {*Well-founded Recursion*}
 
 theory Wellfounded
-imports Finite_Set Transitive_Closure Nat
+imports Finite_Set Transitive_Closure
 uses ("Tools/function_package/size.ML")
 begin
 

--- a/src/HOL/Word/BinBoolList.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Word/BinBoolList.thy	Fri May 15 15:56:28 2009 +0200
@@ -38,7 +38,7 @@
     if y then rbl_add ws x else ws)"
 
 lemma butlast_power:
-  "(butlast ^ n) bl = take (length bl - n) bl"
+  "(butlast ^^ n) bl = take (length bl - n) bl"
   by (induct n) (auto simp: butlast_take)
 
 lemma bin_to_bl_aux_Pls_minus_simp [simp]:
@@ -370,14 +370,14 @@
   done
 
 lemma nth_rest_power_bin [rule_format] :
-  "ALL n. bin_nth ((bin_rest ^ k) w) n = bin_nth w (n + k)"
+  "ALL n. bin_nth ((bin_rest ^^ k) w) n = bin_nth w (n + k)"
   apply (induct k, clarsimp)
   apply clarsimp
   apply (simp only: bin_nth.Suc [symmetric] add_Suc)
   done
 
 lemma take_rest_power_bin:
-  "m <= n ==> take m (bin_to_bl n w) = bin_to_bl m ((bin_rest ^ (n - m)) w)" 
+  "m <= n ==> take m (bin_to_bl n w) = bin_to_bl m ((bin_rest ^^ (n - m)) w)" 
   apply (rule nth_equalityI)
    apply simp
   apply (clarsimp simp add: nth_bin_to_bl nth_rest_power_bin)

--- a/src/HOL/Word/BinGeneral.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Word/BinGeneral.thy	Fri May 15 15:56:28 2009 +0200
@@ -439,7 +439,7 @@
   apply clarsimp
   apply (simp add: bin_last_mod bin_rest_div Bit_def 
               cong: number_of_False_cong)
-  apply (clarsimp simp: zmod_zmult_zmult1 [symmetric] 
+  apply (clarsimp simp: mod_mult_mult1 [symmetric] 
          zmod_zdiv_equality [THEN diff_eq_eq [THEN iffD2 [THEN sym]]])
   apply (rule trans [symmetric, OF _ emep1])
      apply auto
@@ -822,8 +822,8 @@
   by (induct n) auto
 
 lemma bin_rest_power_trunc [rule_format] :
-  "(bin_rest ^ k) (bintrunc n bin) = 
-    bintrunc (n - k) ((bin_rest ^ k) bin)"
+  "(bin_rest ^^ k) (bintrunc n bin) = 
+    bintrunc (n - k) ((bin_rest ^^ k) bin)"
   by (induct k) (auto simp: bin_rest_trunc)
 
 lemma bin_rest_trunc_i:
@@ -857,7 +857,7 @@
   by (rule ext) auto
 
 lemma rco_lem:
-  "f o g o f = g o f ==> f o (g o f) ^ n = g ^ n o f"
+  "f o g o f = g o f ==> f o (g o f) ^^ n = g ^^ n o f"
   apply (rule ext)
   apply (induct_tac n)
    apply (simp_all (no_asm))
@@ -867,7 +867,7 @@
   apply simp
   done
 
-lemma rco_alt: "(f o g) ^ n o f = f o (g o f) ^ n"
+lemma rco_alt: "(f o g) ^^ n o f = f o (g o f) ^^ n"
   apply (rule ext)
   apply (induct n)
    apply (simp_all add: o_def)
@@ -891,8 +891,9 @@
 
 subsection {* Miscellaneous lemmas *}
 
-lemmas funpow_minus_simp = 
-  trans [OF gen_minus [where f = "power f"] funpow_Suc, standard]
+lemma funpow_minus_simp:
+  "0 < n \<Longrightarrow> f ^^ n = f \<circ> f ^^ (n - 1)"
+  by (cases n) simp_all
 
 lemmas funpow_pred_simp [simp] =
   funpow_minus_simp [of "number_of bin", simplified nobm1, standard]

--- a/src/HOL/Word/BinOperations.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Word/BinOperations.thy	Fri May 15 15:56:28 2009 +0200
@@ -641,7 +641,7 @@
   apply (simp add: bin_rest_div zdiv_zmult2_eq)
   apply (case_tac b rule: bin_exhaust)
   apply simp
-  apply (simp add: Bit_def zmod_zmult_zmult1 p1mod22k
+  apply (simp add: Bit_def mod_mult_mult1 p1mod22k
               split: bit.split 
               cong: number_of_False_cong)
   done 

--- a/src/HOL/Word/Num_Lemmas.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Word/Num_Lemmas.thy	Fri May 15 15:56:28 2009 +0200
@@ -45,10 +45,6 @@
   apply (simp add: number_of_eq nat_diff_distrib [symmetric])
   done
 
-lemma of_int_power:
-  "of_int (a ^ n) = (of_int a ^ n :: 'a :: {recpower, comm_ring_1})" 
-  by (induct n) (auto simp add: power_Suc)
-
 lemma zless2: "0 < (2 :: int)" by arith
 
 lemmas zless2p [simp] = zless2 [THEN zero_less_power]
@@ -66,7 +62,7 @@
   apply (safe dest!: even_equiv_def [THEN iffD1])
   apply (subst pos_zmod_mult_2)
    apply arith
-  apply (simp add: zmod_zmult_zmult1)
+  apply (simp add: mod_mult_mult1)
  done
 
 lemmas eme1p = emep1 [simplified add_commute]

--- a/src/HOL/Word/TdThs.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Word/TdThs.thy	Fri May 15 15:56:28 2009 +0200
@@ -110,7 +110,7 @@
   done
 
 lemma fn_comm_power:
-  "fa o tr = tr o fr ==> fa ^ n o tr = tr o fr ^ n" 
+  "fa o tr = tr o fr ==> fa ^^ n o tr = tr o fr ^^ n" 
   apply (rule ext) 
   apply (induct n)
    apply (auto dest: fun_cong)

--- a/src/HOL/Word/WordArith.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Word/WordArith.thy	Fri May 15 15:56:28 2009 +0200
@@ -701,7 +701,8 @@
   apply (erule (2) udvd_decr0)
   done
 
-ML{*Delsimprocs cancel_factors*}
+ML {* Delsimprocs Numeral_Simprocs.cancel_factors *}
+
 lemma udvd_incr2_K: 
   "p < a + s ==> a <= a + s ==> K udvd s ==> K udvd p - a ==> a <= p ==> 
     0 < K ==> p <= p + K & p + K <= a + s"
@@ -717,7 +718,8 @@
    apply arith
   apply simp
   done
-ML{*Delsimprocs cancel_factors*}
+
+ML {* Addsimprocs Numeral_Simprocs.cancel_factors *}
 
 (* links with rbl operations *)
 lemma word_succ_rbl:
@@ -794,9 +796,6 @@
 
 instance word :: (len0) order ..
 
-instance word :: (len) recpower
-  by (intro_classes) simp_all
-
 (* note that iszero_def is only for class comm_semiring_1_cancel,
    which requires word length >= 1, ie 'a :: len word *) 
 lemma zero_bintrunc:

--- a/src/HOL/Word/WordBitwise.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Word/WordBitwise.thy	Fri May 15 15:56:28 2009 +0200
@@ -443,8 +443,10 @@
 
 lemmas test_bit_2p = refl [THEN test_bit_2p', unfolded word_size]
 
-lemmas nth_w2p = test_bit_2p [unfolded of_int_number_of_eq
-  word_of_int [symmetric] Int.of_int_power]
+lemma nth_w2p:
+  "((2\<Colon>'a\<Colon>len word) ^ n) !! m \<longleftrightarrow> m = n \<and> m < len_of TYPE('a\<Colon>len)"
+  unfolding test_bit_2p [symmetric] word_of_int [symmetric]
+  by (simp add:  of_int_power)
 
 lemma uint_2p: 
   "(0::'a::len word) < 2 ^ n ==> uint (2 ^ n::'a::len word) = 2 ^ n"

--- a/src/HOL/Word/WordDefinition.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Word/WordDefinition.thy	Fri May 15 15:56:28 2009 +0200
@@ -99,7 +99,7 @@
 
 subsection  "Arithmetic operations"
 
-instantiation word :: (len0) "{number, uminus, minus, plus, one, zero, times, Divides.div, power, ord, bit}"
+instantiation word :: (len0) "{number, uminus, minus, plus, one, zero, times, Divides.div, ord, bit}"
 begin
 
 definition
@@ -126,10 +126,6 @@
 definition
   word_mod_def: "a mod b = word_of_int (uint a mod uint b)"
 
-primrec power_word where
-  "(a\<Colon>'a word) ^ 0 = 1"
-  | "(a\<Colon>'a word) ^ Suc n = a * a ^ n"
-
 definition
   word_number_of_def: "number_of w = word_of_int w"
 
@@ -157,7 +153,7 @@
 
 instance ..
 
-end 
+end
 
 definition
   word_succ :: "'a :: len0 word => 'a word"
@@ -207,10 +203,10 @@
   "shiftr1 w = word_of_int (bin_rest (uint w))"
 
 definition
-  shiftl_def: "w << n = (shiftl1 ^ n) w"
+  shiftl_def: "w << n = (shiftl1 ^^ n) w"
 
 definition
-  shiftr_def: "w >> n = (shiftr1 ^ n) w"
+  shiftr_def: "w >> n = (shiftr1 ^^ n) w"
 
 instance ..
 
@@ -245,7 +241,7 @@
   "bshiftr1 b w == of_bl (b # butlast (to_bl w))"
 
   sshiftr :: "'a :: len word => nat => 'a word" (infixl ">>>" 55)
-  "w >>> n == (sshiftr1 ^ n) w"
+  "w >>> n == (sshiftr1 ^^ n) w"
 
   mask :: "nat => 'a::len word"
   "mask n == (1 << n) - 1"
@@ -268,7 +264,7 @@
     case ys of [] => [] | x # xs => last ys # butlast ys"
 
   rotater :: "nat => 'a list => 'a list"
-  "rotater n == rotater1 ^ n"
+  "rotater n == rotater1 ^^ n"
 
   word_rotr :: "nat => 'a :: len0 word => 'a :: len0 word"
   "word_rotr n w == of_bl (rotater n (to_bl w))"
@@ -303,7 +299,7 @@
 constdefs
   -- "Largest representable machine integer."
   max_word :: "'a::len word"
-  "max_word \<equiv> word_of_int (2^len_of TYPE('a) - 1)"
+  "max_word \<equiv> word_of_int (2 ^ len_of TYPE('a) - 1)"
 
 consts 
   of_bool :: "bool \<Rightarrow> 'a::len word"

--- a/src/HOL/Word/WordShift.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/Word/WordShift.thy	Fri May 15 15:56:28 2009 +0200
@@ -361,14 +361,14 @@
 
 lemma shiftr_no': 
   "w = number_of bin ==> 
-  (w::'a::len0 word) >> n = number_of ((bin_rest ^ n) (bintrunc (size w) bin))"
+  (w::'a::len0 word) >> n = number_of ((bin_rest ^^ n) (bintrunc (size w) bin))"
   apply clarsimp
   apply (rule word_eqI)
   apply (auto simp: nth_shiftr nth_rest_power_bin nth_bintr word_size)
   done
 
 lemma sshiftr_no': 
-  "w = number_of bin ==> w >>> n = number_of ((bin_rest ^ n) 
+  "w = number_of bin ==> w >>> n = number_of ((bin_rest ^^ n) 
     (sbintrunc (size w - 1) bin))"
   apply clarsimp
   apply (rule word_eqI)

--- a/src/HOL/base.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/base.ML	Fri May 15 15:56:28 2009 +0200
@@ -1,2 +1,2 @@
 (*side-entry for HOL-Base*)
-use_thy "Code_Setup";
+use_thy "HOL";

--- a/src/HOL/ex/Arith_Examples.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/ex/Arith_Examples.thy	Fri May 15 15:56:28 2009 +0200
@@ -4,30 +4,32 @@
 
 header {* Arithmetic *}
 
-theory Arith_Examples imports Main begin
+theory Arith_Examples
+imports Main
+begin
 
 text {*
   The @{text arith} method is used frequently throughout the Isabelle
   distribution.  This file merely contains some additional tests and special
   corner cases.  Some rather technical remarks:
 
-  @{ML fast_arith_tac} is a very basic version of the tactic.  It performs no
+  @{ML Lin_Arith.simple_tac} is a very basic version of the tactic.  It performs no
   meta-to-object-logic conversion, and only some splitting of operators.
-  @{ML linear_arith_tac} performs meta-to-object-logic conversion, full
+  @{ML Lin_Arith.tac} performs meta-to-object-logic conversion, full
   splitting of operators, and NNF normalization of the goal.  The @{text arith}
   method combines them both, and tries other methods (e.g.~@{text presburger})
   as well.  This is the one that you should use in your proofs!
 
   An @{text arith}-based simproc is available as well (see @{ML
-  Lin_Arith.lin_arith_simproc}), which---for performance
-  reasons---however does even less splitting than @{ML fast_arith_tac}
+  Lin_Arith.simproc}), which---for performance
+  reasons---however does even less splitting than @{ML Lin_Arith.simple_tac}
   at the moment (namely inequalities only).  (On the other hand, it
-  does take apart conjunctions, which @{ML fast_arith_tac} currently
+  does take apart conjunctions, which @{ML Lin_Arith.simple_tac} currently
   does not do.)
 *}
 
 (*
-ML {* set trace_arith; *}
+ML {* set Lin_Arith.trace; *}
 *)
 
 subsection {* Splitting of Operators: @{term max}, @{term min}, @{term abs},
@@ -35,165 +37,165 @@
            @{term Divides.div} *}
 
 lemma "(i::nat) <= max i j"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "(i::int) <= max i j"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "min i j <= (i::nat)"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "min i j <= (i::int)"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "min (i::nat) j <= max i j"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "min (i::int) j <= max i j"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "min (i::nat) j + max i j = i + j"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "min (i::int) j + max i j = i + j"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "(i::nat) < j ==> min i j < max i j"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "(i::int) < j ==> min i j < max i j"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "(0::int) <= abs i"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "(i::int) <= abs i"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "abs (abs (i::int)) = abs i"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 text {* Also testing subgoals with bound variables. *}
 
 lemma "!!x. (x::nat) <= y ==> x - y = 0"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "!!x. (x::nat) - y = 0 ==> x <= y"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "!!x. ((x::nat) <= y) = (x - y = 0)"
-  by (tactic {* linear_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "[| (x::nat) < y; d < 1 |] ==> x - y = d"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "[| (x::nat) < y; d < 1 |] ==> x - y - x = d - x"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "(x::int) < y ==> x - y < 0"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "nat (i + j) <= nat i + nat j"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "i < j ==> nat (i - j) = 0"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "(i::nat) mod 0 = i"
   (* FIXME: need to replace 0 by its numeral representation *)
   apply (subst nat_numeral_0_eq_0 [symmetric])
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "(i::nat) mod 1 = 0"
   (* FIXME: need to replace 1 by its numeral representation *)
   apply (subst nat_numeral_1_eq_1 [symmetric])
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "(i::nat) mod 42 <= 41"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "(i::int) mod 0 = i"
   (* FIXME: need to replace 0 by its numeral representation *)
   apply (subst numeral_0_eq_0 [symmetric])
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "(i::int) mod 1 = 0"
   (* FIXME: need to replace 1 by its numeral representation *)
   apply (subst numeral_1_eq_1 [symmetric])
   (* FIXME: arith does not know about iszero *)
-  apply (tactic {* lin_arith_pre_tac @{context} 1 *})
+  apply (tactic {* Lin_Arith.pre_tac @{context} 1 *})
 oops
 
 lemma "(i::int) mod 42 <= 41"
   (* FIXME: arith does not know about iszero *)
-  apply (tactic {* lin_arith_pre_tac @{context} 1 *})
+  apply (tactic {* Lin_Arith.pre_tac @{context} 1 *})
 oops
 
 lemma "-(i::int) * 1 = 0 ==> i = 0"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "[| (0::int) < abs i; abs i * 1 < abs i * j |] ==> 1 < abs i * j"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 
 subsection {* Meta-Logic *}
 
 lemma "x < Suc y == x <= y"
-  by (tactic {* linear_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "((x::nat) == z ==> x ~= y) ==> x ~= y | z ~= y"
-  by (tactic {* linear_arith_tac @{context} 1 *})
+  by linarith
 
 
 subsection {* Various Other Examples *}
 
 lemma "(x < Suc y) = (x <= y)"
-  by (tactic {* linear_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "[| (x::nat) < y; y < z |] ==> x < z"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "(x::nat) < y & y < z ==> x < z"
-  by (tactic {* linear_arith_tac @{context} 1 *})
+  by linarith
 
 text {* This example involves no arithmetic at all, but is solved by
   preprocessing (i.e. NNF normalization) alone. *}
 
 lemma "(P::bool) = Q ==> Q = P"
-  by (tactic {* linear_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "[| P = (x = 0); (~P) = (y = 0) |] ==> min (x::nat) y = 0"
-  by (tactic {* linear_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "[| P = (x = 0); (~P) = (y = 0) |] ==> max (x::nat) y = x + y"
-  by (tactic {* linear_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "[| (x::nat) ~= y; a + 2 = b; a < y; y < b; a < x; x < b |] ==> False"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "[| (x::nat) > y; y > z; z > x |] ==> False"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "(x::nat) - 5 > y ==> y < x"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "(x::nat) ~= 0 ==> 0 < x"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "[| (x::nat) ~= y; x <= y |] ==> x < y"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "[| (x::nat) < y; P (x - y) |] ==> P 0"
-  by (tactic {* linear_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "(x - y) - (x::nat) = (x - x) - y"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "[| (a::nat) < b; c < d |] ==> (a - b) = (c - d)"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "((a::nat) - (b - (c - (d - e)))) = (a - (b - (c - (d - e))))"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "(n < m & m < n') | (n < m & m = n') | (n < n' & n' < m) |
   (n = n' & n' < m) | (n = m & m < n') |
@@ -206,43 +208,43 @@
 (*        preprocessing negates the goal and tries to compute its negation *)
 (*        normal form, which creates lots of separate cases for this       *)
 (*        disjunction of conjunctions                                      *)
-(* by (tactic {* linear_arith_tac 1 *}) *)
+(* by (tactic {* Lin_Arith.tac 1 *}) *)
 oops
 
 lemma "2 * (x::nat) ~= 1"
 (* FIXME: this is beyond the scope of the decision procedure at the moment, *)
 (*        because its negation is satisfiable in the rationals?             *)
-(* by (tactic {* fast_arith_tac 1 *}) *)
+(* by (tactic {* Lin_Arith.simple_tac 1 *}) *)
 oops
 
 text {* Constants. *}
 
 lemma "(0::nat) < 1"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "(0::int) < 1"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "(47::nat) + 11 < 08 * 15"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 lemma "(47::int) + 11 < 08 * 15"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 text {* Splitting of inequalities of different type. *}
 
 lemma "[| (a::nat) ~= b; (i::int) ~= j; a < 2; b < 2 |] ==>
   a + b <= nat (max (abs i) (abs j))"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 text {* Again, but different order. *}
 
 lemma "[| (i::int) ~= j; (a::nat) ~= b; a < 2; b < 2 |] ==>
   a + b <= nat (max (abs i) (abs j))"
-  by (tactic {* fast_arith_tac @{context} 1 *})
+  by linarith
 
 (*
-ML {* reset trace_arith; *}
+ML {* reset Lin_Arith.trace; *}
 *)
 
 end

--- a/src/HOL/ex/BinEx.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/ex/BinEx.thy	Fri May 15 15:56:28 2009 +0200
@@ -712,38 +712,38 @@
 by arith
 
 lemma "!!a::real. a \<le> b ==> c \<le> d ==> x + y < z ==> a + c \<le> b + d"
-by (tactic "fast_arith_tac @{context} 1")
+by linarith
 
 lemma "!!a::real. a < b ==> c < d ==> a - d \<le> b + (-c)"
-by (tactic "fast_arith_tac @{context} 1")
+by linarith
 
 lemma "!!a::real. a \<le> b ==> b + b \<le> c ==> a + a \<le> c"
-by (tactic "fast_arith_tac @{context} 1")
+by linarith
 
 lemma "!!a::real. a + b \<le> i + j ==> a \<le> b ==> i \<le> j ==> a + a \<le> j + j"
-by (tactic "fast_arith_tac @{context} 1")
+by linarith
 
 lemma "!!a::real. a + b < i + j ==> a < b ==> i < j ==> a + a < j + j"
-by (tactic "fast_arith_tac @{context} 1")
+by linarith
 
 lemma "!!a::real. a + b + c \<le> i + j + k \<and> a \<le> b \<and> b \<le> c \<and> i \<le> j \<and> j \<le> k --> a + a + a \<le> k + k + k"
 by arith
 
 lemma "!!a::real. a + b + c + d \<le> i + j + k + l ==> a \<le> b ==> b \<le> c
     ==> c \<le> d ==> i \<le> j ==> j \<le> k ==> k \<le> l ==> a \<le> l"
-by (tactic "fast_arith_tac @{context} 1")
+by linarith
 
 lemma "!!a::real. a + b + c + d \<le> i + j + k + l ==> a \<le> b ==> b \<le> c
     ==> c \<le> d ==> i \<le> j ==> j \<le> k ==> k \<le> l ==> a + a + a + a \<le> l + l + l + l"
-by (tactic "fast_arith_tac @{context} 1")
+by linarith
 
 lemma "!!a::real. a + b + c + d \<le> i + j + k + l ==> a \<le> b ==> b \<le> c
     ==> c \<le> d ==> i \<le> j ==> j \<le> k ==> k \<le> l ==> a + a + a + a + a \<le> l + l + l + l + i"
-by (tactic "fast_arith_tac @{context} 1")
+by linarith
 
 lemma "!!a::real. a + b + c + d \<le> i + j + k + l ==> a \<le> b ==> b \<le> c
     ==> c \<le> d ==> i \<le> j ==> j \<le> k ==> k \<le> l ==> a + a + a + a + a + a \<le> l + l + l + l + i + l"
-by (tactic "fast_arith_tac @{context} 1")
+by linarith
 
 
 subsection{*Complex Arithmetic*}

--- a/src/HOL/ex/Commutative_Ring_Complete.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/ex/Commutative_Ring_Complete.thy	Fri May 15 15:56:28 2009 +0200
@@ -1,5 +1,4 @@
-(*  ID:         $Id$
-    Author:     Bernhard Haeupler
+(*  Author:     Bernhard Haeupler
 
 This theory is about of the relative completeness of method comm-ring
 method.  As long as the reified atomic polynomials of type 'a pol are
@@ -14,7 +13,7 @@
 
 text {* Formalization of normal form *}
 fun
-  isnorm :: "('a::{comm_ring,recpower}) pol \<Rightarrow> bool"
+  isnorm :: "('a::{comm_ring}) pol \<Rightarrow> bool"
 where
     "isnorm (Pc c) \<longleftrightarrow> True"
   | "isnorm (Pinj i (Pc c)) \<longleftrightarrow> False"

--- a/src/HOL/ex/Formal_Power_Series_Examples.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/ex/Formal_Power_Series_Examples.thy	Fri May 15 15:56:28 2009 +0200
@@ -11,7 +11,7 @@
 
 section{* The generalized binomial theorem *}
 lemma gbinomial_theorem: 
-  "((a::'a::{ring_char_0, field, division_by_zero, recpower})+b) ^ n = (\<Sum>k=0..n. of_nat (n choose k) * a^k * b^(n-k))"
+  "((a::'a::{ring_char_0, field, division_by_zero})+b) ^ n = (\<Sum>k=0..n. of_nat (n choose k) * a^k * b^(n-k))"
 proof-
   from E_add_mult[of a b] 
   have "(E (a + b)) $ n = (E a * E b)$n" by simp
@@ -38,7 +38,7 @@
   by (simp add: fps_binomial_def)
 
 lemma fps_binomial_ODE_unique:
-  fixes c :: "'a::{field, recpower,ring_char_0}"
+  fixes c :: "'a::{field, ring_char_0}"
   shows "fps_deriv a = (fps_const c * a) / (1 + X) \<longleftrightarrow> a = fps_const (a$0) * fps_binomial c"
   (is "?lhs \<longleftrightarrow> ?rhs")
 proof-

--- a/src/HOL/ex/Groebner_Examples.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/ex/Groebner_Examples.thy	Fri May 15 15:56:28 2009 +0200
@@ -1,5 +1,4 @@
 (*  Title:      HOL/ex/Groebner_Examples.thy
-    ID:         $Id$
     Author:     Amine Chaieb, TU Muenchen
 *)
 
@@ -11,7 +10,7 @@
 
 subsection {* Basic examples *}
 
-lemma "3 ^ 3 == (?X::'a::{number_ring,recpower})"
+lemma "3 ^ 3 == (?X::'a::{number_ring})"
   by sring_norm
 
 lemma "(x - (-2))^5 == ?X::int"
@@ -20,7 +19,7 @@
 lemma "(x - (-2))^5  * (y - 78) ^ 8 == ?X::int"
   by sring_norm
 
-lemma "((-3) ^ (Suc (Suc (Suc 0)))) == (X::'a::{number_ring,recpower})"
+lemma "((-3) ^ (Suc (Suc (Suc 0)))) == (X::'a::{number_ring})"
   apply (simp only: power_Suc power_0)
   apply (simp only: comp_arith)
   oops
@@ -47,7 +46,7 @@
   by algebra
 
 lemma
-  fixes x::"'a::{idom,recpower,number_ring}"
+  fixes x::"'a::{idom,number_ring}"
   shows "x^2*y = x^2 & x*y^2 = y^2 \<longleftrightarrow>  x=1 & y=1 | x=0 & y=0"
   by algebra
 
@@ -58,7 +57,7 @@
   "sq x == x*x"
 
 lemma
-  fixes x1 :: "'a::{idom,recpower,number_ring}"
+  fixes x1 :: "'a::{idom,number_ring}"
   shows
   "(sq x1 + sq x2 + sq x3 + sq x4) * (sq y1 + sq y2 + sq y3 + sq y4) =
     sq (x1*y1 - x2*y2 - x3*y3 - x4*y4)  +
@@ -68,7 +67,7 @@
   by (algebra add: sq_def)
 
 lemma
-  fixes p1 :: "'a::{idom,recpower,number_ring}"
+  fixes p1 :: "'a::{idom,number_ring}"
   shows
   "(sq p1 + sq q1 + sq r1 + sq s1 + sq t1 + sq u1 + sq v1 + sq w1) *
    (sq p2 + sq q2 + sq r2 + sq s2 + sq t2 + sq u2 + sq v2 + sq w2)

--- a/src/HOL/ex/NormalForm.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/ex/NormalForm.thy	Fri May 15 15:56:28 2009 +0200
@@ -1,7 +1,6 @@
-(*  Authors:    Klaus Aehlig, Tobias Nipkow
-*)
+(*  Authors:  Klaus Aehlig, Tobias Nipkow *)
 
-header {* Test of normalization function *}
+header {* Testing implementation of normalization by evaluation *}
 
 theory NormalForm
 imports Main Rational
@@ -11,7 +10,6 @@
 lemma "p \<longrightarrow> True" by normalization
 declare disj_assoc [code nbe]
 lemma "((P | Q) | R) = (P | (Q | R))" by normalization
-declare disj_assoc [code del]
 lemma "0 + (n::nat) = n" by normalization
 lemma "0 + Suc n = Suc n" by normalization
 lemma "Suc n + Suc m = n + Suc (Suc m)" by normalization
@@ -19,18 +17,13 @@
 
 datatype n = Z | S n
 
-consts
-  add :: "n \<Rightarrow> n \<Rightarrow> n"
-  add2 :: "n \<Rightarrow> n \<Rightarrow> n"
-  mul :: "n \<Rightarrow> n \<Rightarrow> n"
-  mul2 :: "n \<Rightarrow> n \<Rightarrow> n"
-  exp :: "n \<Rightarrow> n \<Rightarrow> n"
-primrec
-  "add Z = id"
-  "add (S m) = S o add m"
-primrec
-  "add2 Z n = n"
-  "add2 (S m) n = S(add2 m n)"
+primrec add :: "n \<Rightarrow> n \<Rightarrow> n" where
+   "add Z = id"
+ | "add (S m) = S o add m"
+
+primrec add2 :: "n \<Rightarrow> n \<Rightarrow> n" where
+   "add2 Z n = n"
+ | "add2 (S m) n = S(add2 m n)"
 
 declare add2.simps [code]
 lemma [code nbe]: "add2 (add2 n m) k = add2 n (add2 m k)"
@@ -44,15 +37,17 @@
 lemma "add2 (add2 (S n) (S m)) (S k) = S(S(S(add2 n (add2 m k))))" by normalization
 lemma "add2 (add2 (S n) (add2 (S m) Z)) (S k) = S(S(S(add2 n (add2 m k))))" by normalization
 
-primrec
-  "mul Z = (%n. Z)"
-  "mul (S m) = (%n. add (mul m n) n)"
-primrec
-  "mul2 Z n = Z"
-  "mul2 (S m) n = add2 n (mul2 m n)"
-primrec
-  "exp m Z = S Z"
-  "exp m (S n) = mul (exp m n) m"
+primrec mul :: "n \<Rightarrow> n \<Rightarrow> n" where
+   "mul Z = (%n. Z)"
+ | "mul (S m) = (%n. add (mul m n) n)"
+
+primrec mul2 :: "n \<Rightarrow> n \<Rightarrow> n" where
+   "mul2 Z n = Z"
+ | "mul2 (S m) n = add2 n (mul2 m n)"
+
+primrec exp :: "n \<Rightarrow> n \<Rightarrow> n" where
+   "exp m Z = S Z"
+ | "exp m (S n) = mul (exp m n) m"
 
 lemma "mul2 (S(S(S(S(S Z))))) (S(S(S Z))) = S(S(S(S(S(S(S(S(S(S(S(S(S(S(S Z))))))))))))))" by normalization
 lemma "mul (S(S(S(S(S Z))))) (S(S(S Z))) = S(S(S(S(S(S(S(S(S(S(S(S(S(S(S Z))))))))))))))" by normalization

--- a/src/HOL/ex/Numeral.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/ex/Numeral.thy	Fri May 15 15:56:28 2009 +0200
@@ -14,32 +14,26 @@
 
 text {* Increment function for type @{typ num} *}
 
-primrec
-  inc :: "num \<Rightarrow> num"
-where
+primrec inc :: "num \<Rightarrow> num" where
   "inc One = Dig0 One"
 | "inc (Dig0 x) = Dig1 x"
 | "inc (Dig1 x) = Dig0 (inc x)"
 
 text {* Converting between type @{typ num} and type @{typ nat} *}
 
-primrec
-  nat_of_num :: "num \<Rightarrow> nat"
-where
+primrec nat_of_num :: "num \<Rightarrow> nat" where
   "nat_of_num One = Suc 0"
 | "nat_of_num (Dig0 x) = nat_of_num x + nat_of_num x"
 | "nat_of_num (Dig1 x) = Suc (nat_of_num x + nat_of_num x)"
 
-primrec
-  num_of_nat :: "nat \<Rightarrow> num"
-where
+primrec num_of_nat :: "nat \<Rightarrow> num" where
   "num_of_nat 0 = One"
 | "num_of_nat (Suc n) = (if 0 < n then inc (num_of_nat n) else One)"
 
 lemma nat_of_num_pos: "0 < nat_of_num x"
   by (induct x) simp_all
 
-lemma nat_of_num_neq_0: " nat_of_num x \<noteq> 0"
+lemma nat_of_num_neq_0: "nat_of_num x \<noteq> 0"
   by (induct x) simp_all
 
 lemma nat_of_num_inc: "nat_of_num (inc x) = Suc (nat_of_num x)"
@@ -247,13 +241,24 @@
 begin
 
 primrec of_num :: "num \<Rightarrow> 'a" where
-  of_num_one [numeral]: "of_num One = 1"
+  of_num_One [numeral]: "of_num One = 1"
   | "of_num (Dig0 n) = of_num n + of_num n"
   | "of_num (Dig1 n) = of_num n + of_num n + 1"
 
 lemma of_num_inc: "of_num (inc x) = of_num x + 1"
   by (induct x) (simp_all add: add_ac)
 
+lemma of_num_add: "of_num (m + n) = of_num m + of_num n"
+  apply (induct n rule: num_induct)
+  apply (simp_all add: add_One add_inc of_num_inc add_ac)
+  done
+
+lemma of_num_mult: "of_num (m * n) = of_num m * of_num n"
+  apply (induct n rule: num_induct)
+  apply (simp add: mult_One)
+  apply (simp add: mult_inc of_num_add of_num_inc right_distrib)
+  done
+
 declare of_num.simps [simp del]
 
 end
@@ -263,16 +268,19 @@
 *}
 
 ML {*
-fun mk_num 1 = @{term One}
-  | mk_num k =
-      let
-        val (l, b) = Integer.div_mod k 2;
-        val bit = (if b = 0 then @{term Dig0} else @{term Dig1});
-      in bit $ (mk_num l) end;
+fun mk_num k =
+  if k > 1 then
+    let
+      val (l, b) = Integer.div_mod k 2;
+      val bit = (if b = 0 then @{term Dig0} else @{term Dig1});
+    in bit $ (mk_num l) end
+  else if k = 1 then @{term One}
+  else error ("mk_num " ^ string_of_int k);
 
 fun dest_num @{term One} = 1
   | dest_num (@{term Dig0} $ n) = 2 * dest_num n
-  | dest_num (@{term Dig1} $ n) = 2 * dest_num n + 1;
+  | dest_num (@{term Dig1} $ n) = 2 * dest_num n + 1
+  | dest_num t = raise TERM ("dest_num", [t]);
 
 (*FIXME these have to gain proper context via morphisms phi*)
 
@@ -348,16 +356,15 @@
 
 lemma of_num_plus_one [numeral]:
   "of_num n + 1 = of_num (n + One)"
-  by (rule sym, induct n) (simp_all add: of_num.simps add_ac)
+  by (simp only: of_num_add of_num_One)
 
 lemma of_num_one_plus [numeral]:
-  "1 + of_num n = of_num (n + One)"
-  unfolding of_num_plus_one [symmetric] add_commute ..
+  "1 + of_num n = of_num (One + n)"
+  by (simp only: of_num_add of_num_One)
 
 lemma of_num_plus [numeral]:
   "of_num m + of_num n = of_num (m + n)"
-  by (induct n rule: num_induct)
-     (simp_all add: add_One add_inc of_num_one of_num_inc add_ac)
+  unfolding of_num_add ..
 
 lemma of_num_times_one [numeral]:
   "of_num n * 1 = of_num n"
@@ -369,9 +376,7 @@
 
 lemma of_num_times [numeral]:
   "of_num m * of_num n = of_num (m * n)"
-  by (induct n rule: num_induct)
-    (simp_all add: of_num_plus [symmetric] mult_One mult_inc
-    semiring_class.right_distrib right_distrib of_num_one of_num_inc)
+  unfolding of_num_mult ..
 
 end
 
@@ -421,21 +426,15 @@
 context semiring_char_0
 begin
 
-lemma of_num_eq_iff [numeral]:
-  "of_num m = of_num n \<longleftrightarrow> m = n"
+lemma of_num_eq_iff [numeral]: "of_num m = of_num n \<longleftrightarrow> m = n"
   unfolding of_nat_of_num [symmetric] nat_of_num_of_num [symmetric]
     of_nat_eq_iff num_eq_iff ..
 
-lemma of_num_eq_one_iff [numeral]:
-  "of_num n = 1 \<longleftrightarrow> n = One"
-proof -
-  have "of_num n = of_num One \<longleftrightarrow> n = One" unfolding of_num_eq_iff ..
-  then show ?thesis by (simp add: of_num_one)
-qed
+lemma of_num_eq_one_iff [numeral]: "of_num n = 1 \<longleftrightarrow> n = One"
+  using of_num_eq_iff [of n One] by (simp add: of_num_One)
 
-lemma one_eq_of_num_iff [numeral]:
-  "1 = of_num n \<longleftrightarrow> n = One"
-  unfolding of_num_eq_one_iff [symmetric] by auto
+lemma one_eq_of_num_iff [numeral]: "1 = of_num n \<longleftrightarrow> One = n"
+  using of_num_eq_iff [of One n] by (simp add: of_num_One)
 
 end
 
@@ -458,19 +457,11 @@
   then show ?thesis by (simp add: of_nat_of_num)
 qed
 
-lemma of_num_less_eq_one_iff [numeral]: "of_num n \<le> 1 \<longleftrightarrow> n = One"
-proof -
-  have "of_num n \<le> of_num One \<longleftrightarrow> n = One"
-    by (cases n) (simp_all add: of_num_less_eq_iff)
-  then show ?thesis by (simp add: of_num_one)
-qed
+lemma of_num_less_eq_one_iff [numeral]: "of_num n \<le> 1 \<longleftrightarrow> n \<le> One"
+  using of_num_less_eq_iff [of n One] by (simp add: of_num_One)
 
 lemma one_less_eq_of_num_iff [numeral]: "1 \<le> of_num n"
-proof -
-  have "of_num One \<le> of_num n"
-    by (cases n) (simp_all add: of_num_less_eq_iff)
-  then show ?thesis by (simp add: of_num_one)
-qed
+  using of_num_less_eq_iff [of One n] by (simp add: of_num_One)
 
 lemma of_num_less_iff [numeral]: "of_num m < of_num n \<longleftrightarrow> m < n"
 proof -
@@ -480,18 +471,10 @@
 qed
 
 lemma of_num_less_one_iff [numeral]: "\<not> of_num n < 1"
-proof -
-  have "\<not> of_num n < of_num One"
-    by (cases n) (simp_all add: of_num_less_iff)
-  then show ?thesis by (simp add: of_num_one)
-qed
+  using of_num_less_iff [of n One] by (simp add: of_num_One)
 
-lemma one_less_of_num_iff [numeral]: "1 < of_num n \<longleftrightarrow> n \<noteq> One"
-proof -
-  have "of_num One < of_num n \<longleftrightarrow> n \<noteq> One"
-    by (cases n) (simp_all add: of_num_less_iff)
-  then show ?thesis by (simp add: of_num_one)
-qed
+lemma one_less_of_num_iff [numeral]: "1 < of_num n \<longleftrightarrow> One < n"
+  using of_num_less_iff [of One n] by (simp add: of_num_One)
 
 lemma of_num_nonneg [numeral]: "0 \<le> of_num n"
   by (induct n) (simp_all add: of_num.simps add_nonneg_nonneg)
@@ -515,13 +498,13 @@
 qed
 
 lemma minus_of_num_less_one_iff: "- of_num n < 1"
-using minus_of_num_less_of_num_iff [of n One] by (simp add: of_num_one)
+  using minus_of_num_less_of_num_iff [of n One] by (simp add: of_num_One)
 
 lemma minus_one_less_of_num_iff: "- 1 < of_num n"
-using minus_of_num_less_of_num_iff [of One n] by (simp add: of_num_one)
+  using minus_of_num_less_of_num_iff [of One n] by (simp add: of_num_One)
 
 lemma minus_one_less_one_iff: "- 1 < 1"
-using minus_of_num_less_of_num_iff [of One One] by (simp add: of_num_one)
+  using minus_of_num_less_of_num_iff [of One One] by (simp add: of_num_One)
 
 lemma minus_of_num_le_of_num_iff: "- of_num m \<le> of_num n"
   by (simp add: less_imp_le minus_of_num_less_of_num_iff)
@@ -700,7 +683,7 @@
   "- of_num n * of_num m = - (of_num n * of_num m)"
   "of_num n * - of_num m = - (of_num n * of_num m)"
   "- of_num n * - of_num m = of_num n * of_num m"
-  by (simp_all add: minus_mult_left [symmetric] minus_mult_right [symmetric])
+  by simp_all
 
 lemma of_int_of_num [numeral]: "of_int (of_num n) = of_num n"
 by (induct n)
@@ -716,38 +699,29 @@
 
 lemma of_num_square: "of_num (square x) = of_num x * of_num x"
 by (induct x)
-   (simp_all add: of_num.simps of_num_plus [symmetric] algebra_simps)
+   (simp_all add: of_num.simps of_num_add algebra_simps)
 
-lemma of_num_pow:
-  "(of_num (pow x y)::'a::{semiring_numeral,recpower}) = of_num x ^ of_num y"
+lemma of_num_pow: "of_num (pow x y) = of_num x ^ of_num y"
 by (induct y)
-   (simp_all add: of_num.simps of_num_square of_num_times [symmetric]
-                  power_Suc power_add)
+   (simp_all add: of_num.simps of_num_square of_num_mult power_add)
 
-lemma power_of_num [numeral]:
-  "of_num x ^ of_num y = (of_num (pow x y)::'a::{semiring_numeral,recpower})"
-  by (rule of_num_pow [symmetric])
+lemma power_of_num [numeral]: "of_num x ^ of_num y = of_num (pow x y)"
+  unfolding of_num_pow ..
 
 lemma power_zero_of_num [numeral]:
-  "0 ^ of_num n = (0::'a::{semiring_0,recpower})"
+  "0 ^ of_num n = (0::'a::semiring_1)"
   using of_num_pos [where n=n and ?'a=nat]
   by (simp add: power_0_left)
 
-lemma power_minus_one_double:
-  "(- 1) ^ (n + n) = (1::'a::{ring_1,recpower})"
-  by (induct n) (simp_all add: power_Suc)
-
 lemma power_minus_Dig0 [numeral]:
-  fixes x :: "'a::{ring_1,recpower}"
+  fixes x :: "'a::ring_1"
   shows "(- x) ^ of_num (Dig0 n) = x ^ of_num (Dig0 n)"
-  by (subst power_minus)
-     (simp add: of_num.simps power_minus_one_double)
+  by (induct n rule: num_induct) (simp_all add: of_num.simps of_num_inc)
 
 lemma power_minus_Dig1 [numeral]:
-  fixes x :: "'a::{ring_1,recpower}"
+  fixes x :: "'a::ring_1"
   shows "(- x) ^ of_num (Dig1 n) = - (x ^ of_num (Dig1 n))"
-  by (subst power_minus)
-     (simp add: of_num.simps power_Suc power_minus_one_double)
+  by (induct n rule: num_induct) (simp_all add: of_num.simps of_num_inc)
 
 declare power_one [numeral]
 
@@ -823,7 +797,7 @@
 
 lemma one_int_code [code]:
   "1 = Pls One"
-  by (simp add: of_num_one)
+  by (simp add: of_num_One)
 
 lemma plus_int_code [code]:
   "k + 0 = (k::int)"
@@ -832,7 +806,7 @@
   "Pls m - Pls n = sub m n"
   "Mns m + Mns n = Mns (m + n)"
   "Mns m - Mns n = sub n m"
-  by (simp_all add: of_num_plus [symmetric])
+  by (simp_all add: of_num_add)
 
 lemma uminus_int_code [code]:
   "uminus 0 = (0::int)"
@@ -847,7 +821,7 @@
   "Pls m - Mns n = Pls (m + n)"
   "Mns m - Pls n = Mns (m + n)"
   "Mns m - Mns n = sub n m"
-  by (simp_all add: of_num_plus [symmetric])
+  by (simp_all add: of_num_add)
 
 lemma times_int_code [code]:
   "k * 0 = (0::int)"
@@ -856,7 +830,7 @@
   "Pls m * Mns n = Mns (m * n)"
   "Mns m * Pls n = Mns (m * n)"
   "Mns m * Mns n = Pls (m * n)"
-  by (simp_all add: of_num_times [symmetric])
+  by (simp_all add: of_num_mult)
 
 lemma eq_int_code [code]:
   "eq_class.eq 0 (0::int) \<longleftrightarrow> True"
@@ -907,15 +881,109 @@
 
 subsection {* Numeral equations as default simplification rules *}
 
-text {* TODO.  Be more precise here with respect to subsumed facts.  Or use named theorems anyway. *}
-declare (in semiring_numeral) numeral [simp]
-declare (in semiring_1) numeral [simp]
-declare (in semiring_char_0) numeral [simp]
-declare (in ring_1) numeral [simp]
+declare (in semiring_numeral) of_num_One [simp]
+declare (in semiring_numeral) of_num_plus_one [simp]
+declare (in semiring_numeral) of_num_one_plus [simp]
+declare (in semiring_numeral) of_num_plus [simp]
+declare (in semiring_numeral) of_num_times [simp]
+
+declare (in semiring_1) of_nat_of_num [simp]
+
+declare (in semiring_char_0) of_num_eq_iff [simp]
+declare (in semiring_char_0) of_num_eq_one_iff [simp]
+declare (in semiring_char_0) one_eq_of_num_iff [simp]
+
+declare (in ordered_semidom) of_num_pos [simp]
+declare (in ordered_semidom) of_num_less_eq_iff [simp]
+declare (in ordered_semidom) of_num_less_eq_one_iff [simp]
+declare (in ordered_semidom) one_less_eq_of_num_iff [simp]
+declare (in ordered_semidom) of_num_less_iff [simp]
+declare (in ordered_semidom) of_num_less_one_iff [simp]
+declare (in ordered_semidom) one_less_of_num_iff [simp]
+declare (in ordered_semidom) of_num_nonneg [simp]
+declare (in ordered_semidom) of_num_less_zero_iff [simp]
+declare (in ordered_semidom) of_num_le_zero_iff [simp]
+
+declare (in ordered_idom) le_signed_numeral_special [simp]
+declare (in ordered_idom) less_signed_numeral_special [simp]
+
+declare (in semiring_1_minus) Dig_of_num_minus_one [simp]
+declare (in semiring_1_minus) Dig_one_minus_of_num [simp]
+
+declare (in ring_1) Dig_plus_uminus [simp]
+declare (in ring_1) of_int_of_num [simp]
+
+declare power_of_num [simp]
+declare power_zero_of_num [simp]
+declare power_minus_Dig0 [simp]
+declare power_minus_Dig1 [simp]
+
+declare Suc_of_num [simp]
+
 thm numeral
 
 
-text {* Toy examples *}
+subsection {* Simplification Procedures *}
+
+subsubsection {* Reorientation of equalities *}
+
+setup {*
+  ReorientProc.add
+    (fn Const(@{const_name of_num}, _) $ _ => true
+      | Const(@{const_name uminus}, _) $
+          (Const(@{const_name of_num}, _) $ _) => true
+      | _ => false)
+*}
+
+simproc_setup reorient_num ("of_num n = x" | "- of_num m = y") = ReorientProc.proc
+
+subsubsection {* Constant folding for multiplication in semirings *}
+
+context semiring_numeral
+begin
+
+lemma mult_of_num_commute: "x * of_num n = of_num n * x"
+by (induct n)
+  (simp_all only: of_num.simps left_distrib right_distrib mult_1_left mult_1_right)
+
+definition
+  "commutes_with a b \<longleftrightarrow> a * b = b * a"
+
+lemma commutes_with_commute: "commutes_with a b \<Longrightarrow> a * b = b * a"
+unfolding commutes_with_def .
+
+lemma commutes_with_left_commute: "commutes_with a b \<Longrightarrow> a * (b * c) = b * (a * c)"
+unfolding commutes_with_def by (simp only: mult_assoc [symmetric])
+
+lemma commutes_with_numeral: "commutes_with x (of_num n)" "commutes_with (of_num n) x"
+unfolding commutes_with_def by (simp_all add: mult_of_num_commute)
+
+lemmas mult_ac_numeral =
+  mult_assoc
+  commutes_with_commute
+  commutes_with_left_commute
+  commutes_with_numeral
+
+end
+
+ML {*
+structure Semiring_Times_Assoc_Data : ASSOC_FOLD_DATA =
+struct
+  val assoc_ss = HOL_ss addsimps @{thms mult_ac_numeral}
+  val eq_reflection = eq_reflection
+  fun is_numeral (Const(@{const_name of_num}, _) $ _) = true
+    | is_numeral _ = false;
+end;
+
+structure Semiring_Times_Assoc = Assoc_Fold (Semiring_Times_Assoc_Data);
+*}
+
+simproc_setup semiring_assoc_fold' ("(a::'a::semiring_numeral) * b") =
+  {* fn phi => fn ss => fn ct =>
+    Semiring_Times_Assoc.proc ss (Thm.term_of ct) *}
+
+
+subsection {* Toy examples *}
 
 definition "bar \<longleftrightarrow> #4 * #2 + #7 = (#8 :: nat) \<and> #4 * #2 + #7 \<ge> (#8 :: int) - #3"
 code_thms bar

--- a/src/HOL/ex/Predicate_Compile.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/ex/Predicate_Compile.thy	Fri May 15 15:56:28 2009 +0200
@@ -1,56 +1,47 @@
 theory Predicate_Compile
-imports Complex_Main Code_Index Lattice_Syntax
+imports Complex_Main Lattice_Syntax Code_Eval
 uses "predicate_compile.ML"
 begin
 
+text {* Package setup *}
+
 setup {* Predicate_Compile.setup *}
 
-ML {*
-  OuterSyntax.local_theory_to_proof "code_pred" "sets up goal for cases rule from given introduction rules and compiles predicate"
-  OuterKeyword.thy_goal (OuterParse.term_group >> Predicate_Compile.code_pred_cmd)
-*}
 
-primrec "next" :: "('a Predicate.pred \<Rightarrow> ('a \<times> 'a Predicate.pred) option)
-  \<Rightarrow> 'a Predicate.seq \<Rightarrow> ('a \<times> 'a Predicate.pred) option" where
-    "next yield Predicate.Empty = None"
-  | "next yield (Predicate.Insert x P) = Some (x, P)"
-  | "next yield (Predicate.Join P xq) = (case yield P
-   of None \<Rightarrow> next yield xq | Some (x, Q) \<Rightarrow> Some (x, Predicate.Seq (\<lambda>_. Predicate.Join Q xq)))"
+text {* Experimental code *}
 
-ML {*
-let
-  fun yield (@{code Predicate.Seq} f) = @{code next} yield (f ())
-in
-  yield @{code "\<bottom> :: 'a Predicate.pred"} (*replace bottom with sequence to evaluate*)
-end
-*}
-
-fun anamorph :: "('b \<Rightarrow> ('a \<times> 'b) option) \<Rightarrow> index \<Rightarrow> 'b \<Rightarrow> 'a list \<times> 'b" where
-  "anamorph f k x = (if k = 0 then ([], x)
-    else case f x of None \<Rightarrow> ([], x) | Some (v, y) \<Rightarrow> let (vs, z) = anamorph f (k - 1) y in (v # vs, z))"
+definition pred_map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a Predicate.pred \<Rightarrow> 'b Predicate.pred" where
+  "pred_map f P = Predicate.bind P (Predicate.single o f)"
 
 ML {*
-let
-  fun yield (@{code Predicate.Seq} f) = @{code next} yield (f ())
-  fun yieldn k = @{code anamorph} yield k
-in
-  yieldn 0 (*replace with number of elements to retrieve*)
-    @{code "\<bottom> :: 'a Predicate.pred"} (*replace bottom with sequence to evaluate*)
-end
+structure Predicate =
+struct
+
+open Predicate;
+
+val pred_ref = ref (NONE : (unit -> term Predicate.pred) option);
+
+fun eval_pred thy t =
+  Code_ML.eval NONE ("Predicate.pred_ref", pred_ref) @{code pred_map} thy (HOLogic.mk_term_of (fastype_of t) t) [];
+
+fun eval_pred_elems thy t T length =
+  t |> eval_pred thy |> yieldn length |> fst |> HOLogic.mk_list T;
+
+fun analyze_compr thy t =
+  let
+    val split = case t of (Const (@{const_name Collect}, _) $ t') => t'
+      | _ => error ("Not a set comprehension: " ^ Syntax.string_of_term_global thy t);
+    val (body, Ts, fp) = HOLogic.strip_split split;
+    val (t_pred, args) = strip_comb body;
+    val pred = case t_pred of Const (pred, _) => pred
+      | _ => error ("Not a constant: " ^ Syntax.string_of_term_global thy t_pred);
+    val mode = map is_Bound args; (*FIXME what about higher-order modes?*)
+    val args' = filter_out is_Bound args;
+    val T = HOLogic.mk_tupleT fp Ts;
+    val mk = HOLogic.mk_tuple' fp T;
+  in (((pred, mode), args), (mk, T)) end;
+
+end;
 *}
 
-section {* Example for user interface *}
-
-inductive append ::  "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
-where
-  "append [] ys ys"
-| "append xs' ys zs' \<Longrightarrow> append (x#xs') ys (x#zs')"
-
-code_pred append
-  using assms by (rule append.cases)
-
-thm append_codegen
-thm append_cases
-
-
 end
\ No newline at end of file

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/ex/Predicate_Compile_ex.thy	Fri May 15 15:56:28 2009 +0200
@@ -0,0 +1,43 @@
+theory Predicate_Compile_ex
+imports Complex_Main Predicate_Compile
+begin
+
+inductive even :: "nat \<Rightarrow> bool" and odd :: "nat \<Rightarrow> bool" where
+    "even 0"
+  | "even n \<Longrightarrow> odd (Suc n)"
+  | "odd n \<Longrightarrow> even (Suc n)"
+
+code_pred even
+  using assms by (rule even.cases)
+
+thm even.equation
+
+
+inductive append :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
+    append_Nil: "append [] xs xs"
+  | append_Cons: "append xs ys zs \<Longrightarrow> append (x # xs) ys (x # zs)"
+
+code_pred append
+  using assms by (rule append.cases)
+
+thm append.equation
+
+
+inductive partition :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
+  for f where
+    "partition f [] [] []"
+  | "f x \<Longrightarrow> partition f xs ys zs \<Longrightarrow> partition f (x # xs) (x # ys) zs"
+  | "\<not> f x \<Longrightarrow> partition f xs ys zs \<Longrightarrow> partition f (x # xs) ys (x # zs)"
+
+code_pred partition
+  using assms by (rule partition.cases)
+
+thm partition.equation
+
+
+code_pred tranclp
+  using assms by (rule tranclp.cases)
+
+thm tranclp.equation
+
+end
\ No newline at end of file

--- a/src/HOL/ex/Quickcheck_Generators.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/ex/Quickcheck_Generators.thy	Fri May 15 15:56:28 2009 +0200
@@ -6,62 +6,6 @@
 imports Quickcheck State_Monad
 begin
 
-subsection {* Type @{typ "'a \<Rightarrow> 'b"} *}
-
-ML {*
-structure Random_Engine =
-struct
-
-open Random_Engine;
-
-fun random_fun (T1 : typ) (T2 : typ) (eq : 'a -> 'a -> bool) (term_of : 'a -> term)
-    (random : Random_Engine.seed -> ('b * (unit -> term)) * Random_Engine.seed)
-    (random_split : Random_Engine.seed -> Random_Engine.seed * Random_Engine.seed)
-    (seed : Random_Engine.seed) =
-  let
-    val (seed', seed'') = random_split seed;
-    val state = ref (seed', [], Const (@{const_name undefined}, T1 --> T2));
-    val fun_upd = Const (@{const_name fun_upd},
-      (T1 --> T2) --> T1 --> T2 --> T1 --> T2);
-    fun random_fun' x =
-      let
-        val (seed, fun_map, f_t) = ! state;
-      in case AList.lookup (uncurry eq) fun_map x
-       of SOME y => y
-        | NONE => let
-              val t1 = term_of x;
-              val ((y, t2), seed') = random seed;
-              val fun_map' = (x, y) :: fun_map;
-              val f_t' = fun_upd $ f_t $ t1 $ t2 ();
-              val _ = state := (seed', fun_map', f_t');
-            in y end
-      end;
-    fun term_fun' () = #3 (! state);
-  in ((random_fun', term_fun'), seed'') end;
-
-end
-*}
-
-axiomatization
-  random_fun_aux :: "typerep \<Rightarrow> typerep \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> term)
-    \<Rightarrow> (seed \<Rightarrow> ('b \<times> (unit \<Rightarrow> term)) \<times> seed) \<Rightarrow> (seed \<Rightarrow> seed \<times> seed)
-    \<Rightarrow> seed \<Rightarrow> (('a \<Rightarrow> 'b) \<times> (unit \<Rightarrow> term)) \<times> seed"
-
-code_const random_fun_aux (SML "Random'_Engine.random'_fun")
-
-instantiation "fun" :: ("{eq, term_of}", "{type, random}") random
-begin
-
-definition random_fun :: "index \<Rightarrow> seed \<Rightarrow> (('a \<Rightarrow> 'b) \<times> (unit \<Rightarrow> term)) \<times> seed" where
-  "random n = random_fun_aux TYPEREP('a) TYPEREP('b) (op =) Code_Eval.term_of (random n) split_seed"
-
-instance ..
-
-end
-
-code_reserved SML Random_Engine
-
-
 subsection {* Datatypes *}
 
 definition
@@ -110,7 +54,7 @@
       val t_indices = map (curry ( op * ) 2) (length tys - 1 downto 0);
       val c_indices = map (curry ( op + ) 1) t_indices;
       val c_t = list_comb (c, map Bound c_indices);
-      val t_t = Abs ("", @{typ unit}, Eval.mk_term Free Typerep.typerep
+      val t_t = Abs ("", @{typ unit}, HOLogic.reflect_term
         (list_comb (c, map (fn k => Bound (k + 1)) t_indices))
         |> map_aterms (fn t as Bound _ => t $ @{term "()"} | t => t));
       val return = StateMonad.return (term_ty this_ty) @{typ seed}

--- a/src/HOL/ex/ROOT.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/ex/ROOT.ML	Fri May 15 15:56:28 2009 +0200
@@ -16,7 +16,8 @@
   "Codegenerator_Pretty",
   "NormalForm",
   "../NumberTheory/Factorization",
-  "Predicate_Compile"
+  "Predicate_Compile",
+  "Predicate_Compile_ex"
 ];
 
 use_thys [

--- a/src/HOL/ex/ReflectionEx.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/ex/ReflectionEx.thy	Fri May 15 15:56:28 2009 +0200
@@ -385,7 +385,7 @@
   (* An example for equations containing type variables *)	
 datatype prod = Zero | One | Var nat | Mul prod prod 
   | Pw prod nat | PNM nat nat prod
-consts Iprod :: " prod \<Rightarrow> ('a::{ordered_idom,recpower}) list \<Rightarrow>'a" 
+consts Iprod :: " prod \<Rightarrow> ('a::{ordered_idom}) list \<Rightarrow>'a" 
 primrec
   "Iprod Zero vs = 0"
   "Iprod One vs = 1"
@@ -397,7 +397,7 @@
 datatype sgn = Pos prod | Neg prod | ZeroEq prod | NZeroEq prod | Tr | F 
   | Or sgn sgn | And sgn sgn
 
-consts Isgn :: " sgn \<Rightarrow> ('a::{ordered_idom, recpower}) list \<Rightarrow>bool"
+consts Isgn :: " sgn \<Rightarrow> ('a::{ordered_idom}) list \<Rightarrow>bool"
 primrec 
   "Isgn Tr vs = True"
   "Isgn F vs = False"
@@ -410,7 +410,7 @@
 
 lemmas eqs = Isgn.simps Iprod.simps
 
-lemma "(x::'a::{ordered_idom, recpower})^4 * y * z * y^2 * z^23 > 0"
+lemma "(x::'a::{ordered_idom})^4 * y * z * y^2 * z^23 > 0"
   apply (reify eqs)
   oops
 

--- a/src/HOL/ex/Term_Of_Syntax.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/ex/Term_Of_Syntax.thy	Fri May 15 15:56:28 2009 +0200
@@ -31,9 +31,9 @@
 
 setup {*
 let
-  val subst_rterm_of = Eval.mk_term
-    (fn (v, _) => error ("illegal free variable in term quotation: " ^ quote v))
-    (Typerep.mk (fn (v, sort) => Typerep.typerep (TFree (v, sort))));
+  val subst_rterm_of = map_aterms
+    (fn Free (v, _) => error ("illegal free variable in term quotation: " ^ quote v) | t => t)
+      o HOLogic.reflect_term;
   fun subst_rterm_of' (Const (@{const_name rterm_of}, _), [t]) = subst_rterm_of t
     | subst_rterm_of' (Const (@{const_name rterm_of}, _), _) =
         error ("illegal number of arguments for " ^ quote @{const_name rterm_of})

--- a/src/HOL/ex/predicate_compile.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOL/ex/predicate_compile.ML	Fri May 15 15:56:28 2009 +0200
@@ -6,43 +6,121 @@
 
 signature PREDICATE_COMPILE =
 sig
-  val create_def_equation': string -> (int list option list * int list) option -> theory -> theory
-  val create_def_equation: string -> theory -> theory
-  val intro_rule: theory -> string -> (int list option list * int list) -> thm
-  val elim_rule: theory -> string -> (int list option list * int list) -> thm
-  val strip_intro_concl : term -> int -> (term * (term list * term list))
-  val code_ind_intros_attrib : attribute
-  val code_ind_cases_attrib : attribute
-  val setup : theory -> theory
-  val code_pred : string -> Proof.context -> Proof.state
-  val code_pred_cmd : string -> Proof.context -> Proof.state
-  val print_alternative_rules : theory -> theory
+  type mode = int list option list * int list
+  val prove_equation: string -> mode option -> theory -> theory
+  val intro_rule: theory -> string -> mode -> thm
+  val elim_rule: theory -> string -> mode -> thm
+  val strip_intro_concl: term -> int -> term * (term list * term list)
+  val modename_of: theory -> string -> mode -> string
+  val modes_of: theory -> string -> mode list
+  val setup: theory -> theory
+  val code_pred: string -> Proof.context -> Proof.state
+  val code_pred_cmd: string -> Proof.context -> Proof.state
+  val print_alternative_rules: theory -> theory (*FIXME diagnostic command?*)
   val do_proofs: bool ref
   val pred_intros : theory -> string -> thm list
   val get_nparams : theory -> string -> int
   val pred_term_of : theory -> term -> term option
 end;
 
-structure Predicate_Compile: PREDICATE_COMPILE =
+structure Predicate_Compile : PREDICATE_COMPILE =
 struct
 
+(** auxiliary **)
+
+(* debug stuff *)
+
+fun tracing s = (if ! Toplevel.debug then Output.tracing s else ());
+
+fun print_tac s = (if ! Toplevel.debug then Tactical.print_tac s else Seq.single);
+fun debug_tac msg = (fn st => (tracing msg; Seq.single st));
+
+val do_proofs = ref true;
+
+
+(** fundamentals **)
+
+(* syntactic operations *)
+
+fun mk_eq (x, xs) =
+  let fun mk_eqs _ [] = []
+        | mk_eqs a (b::cs) =
+            HOLogic.mk_eq (Free (a, fastype_of b), b) :: mk_eqs a cs
+  in mk_eqs x xs end;
+
+fun mk_tupleT [] = HOLogic.unitT
+  | mk_tupleT Ts = foldr1 HOLogic.mk_prodT Ts;
+
+fun mk_tuple [] = HOLogic.unit
+  | mk_tuple ts = foldr1 HOLogic.mk_prod ts;
+
+fun dest_tuple (Const (@{const_name Product_Type.Unity}, _)) = []
+  | dest_tuple (Const (@{const_name Pair}, _) $ t1 $ t2) = t1 :: (dest_tuple t2)
+  | dest_tuple t = [t]
+
+fun mk_pred_enumT T = Type ("Predicate.pred", [T])
+
+fun dest_pred_enumT (Type ("Predicate.pred", [T])) = T
+  | dest_pred_enumT T = raise TYPE ("dest_pred_enumT", [T], []);
+
+fun mk_Enum f =
+  let val T as Type ("fun", [T', _]) = fastype_of f
+  in
+    Const (@{const_name Predicate.Pred}, T --> mk_pred_enumT T') $ f    
+  end;
+
+fun mk_Eval (f, x) =
+  let val T = fastype_of x
+  in
+    Const (@{const_name Predicate.eval}, mk_pred_enumT T --> T --> HOLogic.boolT) $ f $ x
+  end;
+
+fun mk_empty T = Const (@{const_name Orderings.bot}, mk_pred_enumT T);
+
+fun mk_single t =
+  let val T = fastype_of t
+  in Const(@{const_name Predicate.single}, T --> mk_pred_enumT T) $ t end;
+
+fun mk_bind (x, f) =
+  let val T as Type ("fun", [_, U]) = fastype_of f
+  in
+    Const (@{const_name Predicate.bind}, fastype_of x --> T --> U) $ x $ f
+  end;
+
+val mk_sup = HOLogic.mk_binop @{const_name sup};
+
+fun mk_if_predenum cond = Const (@{const_name Predicate.if_pred},
+  HOLogic.boolT --> mk_pred_enumT HOLogic.unitT) $ cond;
+
+fun mk_not_pred t = let val T = mk_pred_enumT HOLogic.unitT
+  in Const (@{const_name Predicate.not_pred}, T --> T) $ t end
+
+
+(* data structures *)
+
+type mode = int list option list * int list;
+
+val mode_ord = prod_ord (list_ord (option_ord (list_ord int_ord))) (list_ord int_ord);
+
 structure PredModetab = TableFun(
-  type key = (string * (int list option list * int list))
-  val ord = prod_ord fast_string_ord (prod_ord
-            (list_ord (option_ord (list_ord int_ord))) (list_ord int_ord)))
+  type key = string * mode
+  val ord = prod_ord fast_string_ord mode_ord
+);
 
 
+(*FIXME scrap boilerplate*)
+
 structure IndCodegenData = TheoryDataFun
 (
   type T = {names : string PredModetab.table,
-            modes : ((int list option list * int list) list) Symtab.table,
+            modes : mode list Symtab.table,
             function_defs : Thm.thm Symtab.table,
             function_intros : Thm.thm Symtab.table,
             function_elims : Thm.thm Symtab.table,
-            intro_rules : (Thm.thm list) Symtab.table,
+            intro_rules : Thm.thm list Symtab.table,
             elim_rules : Thm.thm Symtab.table,
             nparams : int Symtab.table
-           };
+           }; (*FIXME: better group tables according to key*)
       (* names: map from inductive predicate and mode to function name (string).
          modes: map from inductive predicates to modes
          function_defs: map from function name to definition
@@ -120,26 +198,12 @@
             intro_rules = #intro_rules x, elim_rules = #elim_rules x,
             nparams = f (#nparams x)}) thy
 
-(* Debug stuff and tactics ***********************************************************)
-
-fun tracing s = (if ! Toplevel.debug then Output.tracing s else ());
-fun print_tac s = (if ! Toplevel.debug then Tactical.print_tac s else Seq.single);
-
-fun debug_tac msg = (fn st =>
-     (tracing msg; Seq.single st));
-
 (* removes first subgoal *)
 fun mycheat_tac thy i st =
   (Tactic.rtac (SkipProof.make_thm thy (Var (("A", 0), propT))) i) st
 
-val (do_proofs : bool ref) = ref true;
-
 (* Lightweight mode analysis **********************************************)
 
-(* Hack for message from old code generator *)
-val message = tracing;
-
-
 (**************************************************************************)
 (* source code from old code generator ************************************)
 
@@ -158,7 +222,8 @@
       | _ => false)
   in check end;
 
-(**** check if a type is an equality type (i.e. doesn't contain fun) ****)
+(**** check if a type is an equality type (i.e. doesn't contain fun)
+  FIXME this is only an approximation ****)
 
 fun is_eqT (Type (s, Ts)) = s <> "fun" andalso forall is_eqT Ts
   | is_eqT _ = true;
@@ -170,7 +235,7 @@
     | SOME js => enclose "[" "]" (commas (map string_of_int js)))
        (iss @ [SOME is]));
 
-fun print_modes modes = message ("Inferred modes:\n" ^
+fun print_modes modes = tracing ("Inferred modes:\n" ^
   cat_lines (map (fn (s, ms) => s ^ ": " ^ commas (map
     string_of_mode ms)) modes));
 
@@ -187,6 +252,7 @@
         (get_args' is (i+1) ts)
 in get_args' is 1 ts end
 
+(*FIXME this function should not be named merge... make it local instead*)
 fun merge xs [] = xs
   | merge [] ys = ys
   | merge (x::xs) (y::ys) = if length x >= length y then x::merge xs (y::ys)
@@ -202,9 +268,10 @@
 
 fun cprods xss = foldr (map op :: o cprod) [[]] xss;
 
-datatype mode = Mode of (int list option list * int list) * int list * mode option list;
+datatype hmode = Mode of mode * int list * hmode option list; (*FIXME don't understand
+  why there is another mode type!?*)
 
-fun modes_of modes t =
+fun modes_of_term modes t =
   let
     val ks = 1 upto length (binder_types (fastype_of t));
     val default = [Mode (([], ks), ks, [])];
@@ -222,7 +289,7 @@
           in map (fn x => Mode (m, is', x)) (cprods (map
             (fn (NONE, _) => [NONE]
               | (SOME js, arg) => map SOME (filter
-                  (fn Mode (_, js', _) => js=js') (modes_of modes arg)))
+                  (fn Mode (_, js', _) => js=js') (modes_of_term modes arg)))
                     (iss ~~ args1)))
           end
         end)) (AList.lookup op = modes name)
@@ -251,13 +318,13 @@
             term_vs t subset vs andalso
             forall is_eqT dupTs
           end)
-            (modes_of modes t handle Option =>
+            (modes_of_term modes t handle Option =>
                error ("Bad predicate: " ^ Syntax.string_of_term_global thy t))
       | Negprem (us, t) => find_first (fn Mode (_, is, _) =>
             length us = length is andalso
             terms_vs us subset vs andalso
             term_vs t subset vs)
-            (modes_of modes t handle Option =>
+            (modes_of_term modes t handle Option =>
                error ("Bad predicate: " ^ Syntax.string_of_term_global thy t))
       | Sidecond t => if term_vs t subset vs then SOME (Mode (([], []), [], []))
           else NONE
@@ -290,11 +357,11 @@
   in (p, List.filter (fn m => case find_index
     (not o check_mode_clause thy param_vs modes m) rs of
       ~1 => true
-    | i => (message ("Clause " ^ string_of_int (i+1) ^ " of " ^
+    | i => (tracing ("Clause " ^ string_of_int (i+1) ^ " of " ^
       p ^ " violates mode " ^ string_of_mode m); false)) ms)
   end;
 
-fun fixp f (x : (string * (int list option list * int list) list) list) =
+fun fixp f (x : (string * mode list) list) =
   let val y = f x
   in if x = y then x else fixp f y end;
 
@@ -311,66 +378,6 @@
 (*****************************************************************************************)
 (**** term construction ****)
 
-fun mk_eq (x, xs) =
-  let fun mk_eqs _ [] = []
-        | mk_eqs a (b::cs) =
-            HOLogic.mk_eq (Free (a, fastype_of b), b) :: mk_eqs a cs
-  in mk_eqs x xs end;
-
-fun mk_tuple [] = HOLogic.unit
-  | mk_tuple ts = foldr1 HOLogic.mk_prod ts;
-
-fun dest_tuple (Const (@{const_name Product_Type.Unity}, _)) = []
-  | dest_tuple (Const (@{const_name Pair}, _) $ t1 $ t2) = t1 :: (dest_tuple t2)
-  | dest_tuple t = [t]
-
-fun mk_tupleT [] = HOLogic.unitT
-  | mk_tupleT Ts = foldr1 HOLogic.mk_prodT Ts;
-
-fun mk_pred_enumT T = Type ("Predicate.pred", [T])
-
-fun dest_pred_enumT (Type ("Predicate.pred", [T])) = T
-  | dest_pred_enumT T = raise TYPE ("dest_pred_enumT", [T], []);
-
-fun mk_single t =
-  let val T = fastype_of t
-  in Const(@{const_name Predicate.single}, T --> mk_pred_enumT T) $ t end;
-
-fun mk_empty T = Const (@{const_name Orderings.bot}, mk_pred_enumT T);
-
-fun mk_if_predenum cond = Const (@{const_name Predicate.if_pred},
-                          HOLogic.boolT --> mk_pred_enumT HOLogic.unitT) 
-                         $ cond
-
-fun mk_not_pred t = let val T = mk_pred_enumT HOLogic.unitT
-  in Const (@{const_name Predicate.not_pred}, T --> T) $ t end
-
-fun mk_bind (x, f) =
-  let val T as Type ("fun", [_, U]) = fastype_of f
-  in
-    Const (@{const_name Predicate.bind}, fastype_of x --> T --> U) $ x $ f
-  end;
-
-fun mk_Enum f =
-  let val T as Type ("fun", [T', _]) = fastype_of f
-  in
-    Const (@{const_name Predicate.Pred}, T --> mk_pred_enumT T') $ f    
-  end;
-
-fun mk_Eval (f, x) =
-  let val T = fastype_of x
-  in
-    Const (@{const_name Predicate.eval}, mk_pred_enumT T --> T --> HOLogic.boolT) $ f $ x
-  end;
-
-fun mk_Eval' f =
-  let val T = fastype_of f
-  in
-    Const (@{const_name Predicate.eval}, T --> dest_pred_enumT T --> HOLogic.boolT) $ f
-  end; 
-
-val mk_sup = HOLogic.mk_binop @{const_name sup};
-
 (* for simple modes (e.g. parameters) only: better call it param_funT *)
 (* or even better: remove it and only use funT'_of - some modifications to funT'_of necessary *) 
 fun funT_of T NONE = T
@@ -429,13 +436,16 @@
        (v', mk_empty U')]))
   end;
 
-fun modename thy name mode = let
+fun modename_of thy name mode = let
     val v = (PredModetab.lookup (#names (IndCodegenData.get thy)) (name, mode))
-  in if (is_some v) then the v
-     else error ("fun modename - definition not found: name: " ^ name ^ " mode: " ^  (makestring mode))
+  in if (is_some v) then the v (*FIXME use case here*)
+     else error ("fun modename_of - definition not found: name: " ^ name ^ " mode: " ^  (makestring mode))
   end
 
-(* function can be removed *)
+fun modes_of thy =
+  these o Symtab.lookup ((#modes o IndCodegenData.get) thy);
+
+(*FIXME function can be removed*)
 fun mk_funcomp f t =
   let
     val names = Term.add_free_names t [];
@@ -454,7 +464,7 @@
     val f' = case f of
         Const (name, T) =>
           if AList.defined op = modes name then
-            Const (modename thy name (iss, is'), funT'_of (iss, is') T)
+            Const (modename_of thy name (iss, is'), funT'_of (iss, is') T)
           else error "compile param: Not an inductive predicate with correct mode"
       | Free (name, T) => Free (name, funT_of T (SOME is'))
     in list_comb (f', params' @ args') end
@@ -468,7 +478,7 @@
                val (Ts, Us) = get_args is
                  (curry Library.drop (length ms) (fst (strip_type T)))
                val params' = map (compile_param thy modes) (ms ~~ params)
-               val mode_id = modename thy name mode
+               val mode_id = modename_of thy name mode
              in list_comb (Const (mode_id, ((map fastype_of params') @ Ts) --->
                mk_pred_enumT (mk_tupleT Us)), params')
              end
@@ -561,7 +571,7 @@
     val cl_ts =
       map (fn cl => compile_clause thy
         all_vs param_vs modes mode cl (mk_tuple xs)) cls;
-    val mode_id = modename thy s mode
+    val mode_id = modename_of thy s mode
   in
     HOLogic.mk_Trueprop (HOLogic.mk_eq
       (list_comb (Const (mode_id, (Ts1' @ Us1) --->
@@ -596,7 +606,7 @@
     fold Term.add_consts intrs [] |> map fst
     |> filter_out (member (op =) preds) |> filter (is_ind_pred thy)
 
-fun print_arities arities = message ("Arities:\n" ^
+fun print_arities arities = tracing ("Arities:\n" ^
   cat_lines (map (fn (s, (ks, k)) => s ^ ": " ^
     space_implode " -> " (map
       (fn NONE => "X" | SOME k' => string_of_int k')
@@ -696,10 +706,10 @@
 (* Proving equivalence of term *)
 
 
-fun intro_rule thy pred mode = modename thy pred mode
+fun intro_rule thy pred mode = modename_of thy pred mode
     |> Symtab.lookup (#function_intros (IndCodegenData.get thy)) |> the
 
-fun elim_rule thy pred mode = modename thy pred mode
+fun elim_rule thy pred mode = modename_of thy pred mode
     |> Symtab.lookup (#function_elims (IndCodegenData.get thy)) |> the
 
 fun pred_intros thy predname = let
@@ -716,7 +726,7 @@
   end
 
 fun function_definition thy pred mode =
-  modename thy pred mode |> Symtab.lookup (#function_defs (IndCodegenData.get thy)) |> the
+  modename_of thy pred mode |> Symtab.lookup (#function_defs (IndCodegenData.get thy)) |> the
 
 fun is_Type (Type _) = true
   | is_Type _ = false
@@ -978,7 +988,7 @@
     in nth (#elims (snd ind_result)) index end)
 
 fun prove_one_direction thy all_vs param_vs modes clauses ((pred, T), mode) = let
-  val elim_rule = the (Symtab.lookup (#function_elims (IndCodegenData.get thy)) (modename thy pred mode))
+  val elim_rule = the (Symtab.lookup (#function_elims (IndCodegenData.get thy)) (modename_of thy pred mode))
 (*  val ind_result = InductivePackage.the_inductive (ProofContext.init thy) pred
   val index = find_index (fn s => s = pred) (#names (fst ind_result))
   val (_, T) = dest_Const (nth (#preds (snd ind_result)) index) *)
@@ -1212,7 +1222,7 @@
   val Ts = binder_types T
   val names = Name.variant_list []
         (map (fn i => "x" ^ (string_of_int i)) (1 upto (length Ts)))
-  val vs = map Free (names ~~ Ts)
+  val vs = map2 (curry Free) names Ts
   val clausehd =  HOLogic.mk_Trueprop (list_comb(Const (predname, T), vs))
   val intro_t = Logic.mk_implies (@{prop False}, clausehd)
   val P = HOLogic.mk_Trueprop (Free ("P", HOLogic.boolT))
@@ -1230,9 +1240,9 @@
 (* main function *********************************************************************)
 (*************************************************************************************)
 
-fun create_def_equation' ind_name (mode : (int list option list * int list) option) thy =
+fun prove_equation ind_name mode thy =
 let
-  val _ = tracing ("starting create_def_equation' with " ^ ind_name)
+  val _ = tracing ("starting prove_equation' with " ^ ind_name)
   val (prednames, preds) = 
     case (try (InductivePackage.the_inductive (ProofContext.init thy)) ind_name) of
       SOME info => let val preds = info |> snd |> #preds
@@ -1254,8 +1264,9 @@
   val _ = tracing ("calling preds: " ^ makestring name_of_calls)
   val _ = tracing "starting recursive compilations"
   fun rec_call name thy = 
+    (*FIXME use member instead of infix mem*)
     if not (name mem (Symtab.keys (#modes (IndCodegenData.get thy)))) then
-      create_def_equation name thy else thy
+      prove_equation name NONE thy else thy
   val thy'' = fold rec_call name_of_calls thy'
   val _ = tracing "returning from recursive calls"
   val _ = tracing "starting mode inference"
@@ -1309,12 +1320,11 @@
   val _ = tracing "starting proof"
   val result_thms = prove_preds thy''' all_vs param_vs (extra_modes @ modes) clauses (pred_mode ~~ (flat ts))
   val (_, thy'''') = yield_singleton PureThy.add_thmss
-    ((Binding.name (Long_Name.base_name ind_name ^ "_codegen" (*FIXME other suffix*)), result_thms),
+    ((Binding.qualify true (Long_Name.base_name ind_name) (Binding.name "equation"), result_thms),
       [Attrib.attribute_i thy''' Code.add_default_eqn_attrib]) thy'''
 in
   thy''''
 end
-and create_def_equation ind_name thy = create_def_equation' ind_name NONE thy
 
 fun set_nparams (pred, nparams) thy = map_nparams (Symtab.update (pred, nparams)) thy
 
@@ -1332,22 +1342,12 @@
     in () end
     val _ = map print preds
  in thy end; 
-  
-fun attrib f = Thm.declaration_attribute (fn thm => Context.mapping (f thm) I)
 
-val code_ind_intros_attrib = attrib add_intro_thm
-
-val code_ind_cases_attrib = attrib add_elim_thm
-
-val setup =
-  Attrib.setup @{binding code_ind_intros} (Scan.succeed code_ind_intros_attrib)
-    "adding alternative introduction rules for code generation of inductive predicates" #>
-  Attrib.setup @{binding code_ind_cases} (Scan.succeed code_ind_cases_attrib)
-    "adding alternative elimination rules for code generation of inductive predicates";
 
 (* generation of case rules from user-given introduction rules *)
 
-   fun mk_casesrule introrules nparams ctxt = let
+fun mk_casesrule introrules nparams ctxt =
+  let
     val intros = map prop_of introrules
     val (pred, (params, args)) = strip_intro_concl (hd intros) nparams
     val ([propname], ctxt1) = Variable.variant_fixes ["thesis"] ctxt
@@ -1355,6 +1355,7 @@
     val (argnames, ctxt2) = Variable.variant_fixes
       (map (fn i => "a" ^ string_of_int i) (1 upto (length args))) ctxt1
     val argvs = map Free (argnames ~~ (map fastype_of args))
+      (*FIXME map2*)
     fun mk_case intro = let
         val (_, (_, args)) = strip_intro_concl intro nparams
         val prems = Logic.strip_imp_prems intro
@@ -1371,30 +1372,60 @@
               ctxt2
   in (pred, prop, ctxt3) end;
 
-(* setup for user interface *)
+
+(** user interface **)
+
+local
+
+fun attrib f = Thm.declaration_attribute (fn thm => Context.mapping (f thm) I);
+
+val add_elim_attrib = attrib add_elim_thm;
 
-  fun generic_code_pred prep_const raw_const lthy =
-    let
-      val thy = (ProofContext.theory_of lthy)
-      val const = prep_const thy raw_const
-      val nparams = get_nparams thy const
-      val intro_rules = pred_intros thy const
-      val (((tfrees, frees), fact), lthy') =
-        Variable.import_thms true intro_rules lthy;
-      val (pred, prop, lthy'') = mk_casesrule fact nparams lthy'
-      val (predname, _) = dest_Const pred
-      fun after_qed [[th]] lthy'' =
-        LocalTheory.note Thm.theoremK
-          ((Binding.name (Long_Name.base_name predname ^ "_cases"), (* FIXME: other suffix *)
-            [Attrib.internal (K (code_ind_cases_attrib))]) , [th]) lthy''
-        |> snd
-        |> LocalTheory.theory (create_def_equation predname)
-    in
-      Proof.theorem_i NONE after_qed [[(prop, [])]] lthy''
-    end;
+fun generic_code_pred prep_const raw_const lthy =
+  let
+    val thy = ProofContext.theory_of lthy
+    val const = prep_const thy raw_const
+    val nparams = get_nparams thy const
+    val intro_rules = pred_intros thy const
+    val (((tfrees, frees), fact), lthy') =
+      Variable.import_thms true intro_rules lthy;
+    val (pred, prop, lthy'') = mk_casesrule fact nparams lthy'
+    val (predname, _) = dest_Const pred
+    fun after_qed [[th]] lthy'' =
+      lthy''
+      |> LocalTheory.note Thm.theoremK
+           ((Binding.empty, [Attrib.internal (K add_elim_attrib)]), [th])
+      |> snd
+      |> LocalTheory.theory (prove_equation predname NONE)
+  in
+    Proof.theorem_i NONE after_qed [[(prop, [])]] lthy''
+  end;
+
+structure P = OuterParse
 
-  val code_pred = generic_code_pred (K I);
-  val code_pred_cmd = generic_code_pred Code_Unit.read_const
+in
+
+val code_pred = generic_code_pred (K I);
+val code_pred_cmd = generic_code_pred Code.read_const
+
+val setup =
+  Attrib.setup @{binding code_ind_intros} (Scan.succeed (attrib add_intro_thm))
+    "adding alternative introduction rules for code generation of inductive predicates" #>
+  Attrib.setup @{binding code_ind_cases} (Scan.succeed add_elim_attrib)
+    "adding alternative elimination rules for code generation of inductive predicates";
+  (*FIXME name discrepancy in attribs and ML code*)
+  (*FIXME intros should be better named intro*)
+  (*FIXME why distinguished atribute for cases?*)
+
+val _ = OuterSyntax.local_theory_to_proof "code_pred"
+  "prove equations for predicate specified by intro/elim rules"
+  OuterKeyword.thy_goal (P.term_group >> code_pred_cmd)
+
+end
+
+(*FIXME
+- Naming of auxiliary rules necessary?
+*)
 
 (* transformation for code generation *)
 
@@ -1408,7 +1439,7 @@
         args)
   val (inargs, _) = get_args user_mode args
   val all_modes = Symtab.dest (#modes (IndCodegenData.get thy))
-  val modes = filter (fn Mode (_, is, _) => is = user_mode) (modes_of all_modes (list_comb (pred, params)))
+  val modes = filter (fn Mode (_, is, _) => is = user_mode) (modes_of_term all_modes (list_comb (pred, params)))
   fun compile m = list_comb (compile_expr thy all_modes (SOME m, list_comb (pred, params)), inargs)
   in
     case modes of
@@ -1420,6 +1451,3 @@
 
 end;
 
-fun pred_compile name thy = Predicate_Compile.create_def_equation
-  (Sign.intern_const thy name) thy;
-

--- a/src/HOLCF/Adm.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Adm.thy	Fri May 15 15:56:28 2009 +0200
@@ -78,7 +78,7 @@
   "\<lbrakk>chain (Y::nat \<Rightarrow> 'a::cpo); \<forall>i. \<exists>j\<ge>i. P (Y j)\<rbrakk> \<Longrightarrow> 
     (\<Squnion>i. Y i) = (\<Squnion>i. Y (LEAST j. i \<le> j \<and> P (Y j)))"
  apply (frule (1) adm_disj_lemma1)
- apply (rule antisym_less)
+ apply (rule below_antisym)
   apply (rule lub_mono, assumption+)
   apply (erule chain_mono)
   apply (simp add: adm_disj_lemma2)
@@ -122,7 +122,7 @@
 
 text {* admissibility and continuity *}
 
-lemma adm_less: "\<lbrakk>cont u; cont v\<rbrakk> \<Longrightarrow> adm (\<lambda>x. u x \<sqsubseteq> v x)"
+lemma adm_below: "\<lbrakk>cont u; cont v\<rbrakk> \<Longrightarrow> adm (\<lambda>x. u x \<sqsubseteq> v x)"
 apply (rule admI)
 apply (simp add: cont2contlubE)
 apply (rule lub_mono)
@@ -132,7 +132,7 @@
 done
 
 lemma adm_eq: "\<lbrakk>cont u; cont v\<rbrakk> \<Longrightarrow> adm (\<lambda>x. u x = v x)"
-by (simp add: po_eq_conv adm_conj adm_less)
+by (simp add: po_eq_conv adm_conj adm_below)
 
 lemma adm_subst: "\<lbrakk>cont t; adm P\<rbrakk> \<Longrightarrow> adm (\<lambda>x. P (t x))"
 apply (rule admI)
@@ -142,11 +142,11 @@
 apply (erule spec)
 done
 
-lemma adm_not_less: "cont t \<Longrightarrow> adm (\<lambda>x. \<not> t x \<sqsubseteq> u)"
+lemma adm_not_below: "cont t \<Longrightarrow> adm (\<lambda>x. \<not> t x \<sqsubseteq> u)"
 apply (rule admI)
 apply (drule_tac x=0 in spec)
 apply (erule contrapos_nn)
-apply (erule rev_trans_less)
+apply (erule rev_below_trans)
 apply (erule cont2mono [THEN monofunE])
 apply (erule is_ub_thelub)
 done
@@ -179,21 +179,21 @@
 apply (drule (1) compactD2, simp)
 apply (erule exE, rule_tac x=i in exI)
 apply (rule max_in_chainI)
-apply (rule antisym_less)
+apply (rule below_antisym)
 apply (erule (1) chain_mono)
-apply (erule (1) trans_less [OF is_ub_thelub])
+apply (erule (1) below_trans [OF is_ub_thelub])
 done
 
 text {* admissibility and compactness *}
 
-lemma adm_compact_not_less: "\<lbrakk>compact k; cont t\<rbrakk> \<Longrightarrow> adm (\<lambda>x. \<not> k \<sqsubseteq> t x)"
+lemma adm_compact_not_below: "\<lbrakk>compact k; cont t\<rbrakk> \<Longrightarrow> adm (\<lambda>x. \<not> k \<sqsubseteq> t x)"
 unfolding compact_def by (rule adm_subst)
 
 lemma adm_neq_compact: "\<lbrakk>compact k; cont t\<rbrakk> \<Longrightarrow> adm (\<lambda>x. t x \<noteq> k)"
-by (simp add: po_eq_conv adm_imp adm_not_less adm_compact_not_less)
+by (simp add: po_eq_conv adm_imp adm_not_below adm_compact_not_below)
 
 lemma adm_compact_neq: "\<lbrakk>compact k; cont t\<rbrakk> \<Longrightarrow> adm (\<lambda>x. k \<noteq> t x)"
-by (simp add: po_eq_conv adm_imp adm_not_less adm_compact_not_less)
+by (simp add: po_eq_conv adm_imp adm_not_below adm_compact_not_below)
 
 lemma compact_UU [simp, intro]: "compact \<bottom>"
 by (rule compactI, simp add: adm_not_free)
@@ -210,7 +210,7 @@
 
 lemmas adm_lemmas [simp] =
   adm_not_free adm_conj adm_all adm_ball adm_disj adm_imp adm_iff
-  adm_less adm_eq adm_not_less
-  adm_compact_not_less adm_compact_neq adm_neq_compact adm_not_UU
+  adm_below adm_eq adm_not_below
+  adm_compact_not_below adm_compact_neq adm_neq_compact adm_not_UU
 
 end

--- a/src/HOLCF/Algebraic.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Algebraic.thy	Fri May 15 15:56:28 2009 +0200
@@ -33,21 +33,21 @@
 
 locale pre_deflation =
   fixes f :: "'a \<rightarrow> 'a::cpo"
-  assumes less: "\<And>x. f\<cdot>x \<sqsubseteq> x"
+  assumes below: "\<And>x. f\<cdot>x \<sqsubseteq> x"
   assumes finite_range: "finite (range (\<lambda>x. f\<cdot>x))"
 begin
 
-lemma iterate_less: "iterate i\<cdot>f\<cdot>x \<sqsubseteq> x"
-by (induct i, simp_all add: trans_less [OF less])
+lemma iterate_below: "iterate i\<cdot>f\<cdot>x \<sqsubseteq> x"
+by (induct i, simp_all add: below_trans [OF below])
 
 lemma iterate_fixed: "f\<cdot>x = x \<Longrightarrow> iterate i\<cdot>f\<cdot>x = x"
 by (induct i, simp_all)
 
 lemma antichain_iterate_app: "i \<le> j \<Longrightarrow> iterate j\<cdot>f\<cdot>x \<sqsubseteq> iterate i\<cdot>f\<cdot>x"
 apply (erule le_Suc_induct)
-apply (simp add: less)
-apply (rule refl_less)
-apply (erule (1) trans_less)
+apply (simp add: below)
+apply (rule below_refl)
+apply (erule (1) below_trans)
 done
 
 lemma finite_range_iterate_app: "finite (range (\<lambda>i. iterate i\<cdot>f\<cdot>x))"
@@ -144,7 +144,7 @@
 next
   fix x :: 'a
   show "d\<cdot>x \<sqsubseteq> x"
-    by (rule MOST_d, simp add: iterate_less)
+    by (rule MOST_d, simp add: iterate_below)
 next
   from finite_range
   have "finite {x. f\<cdot>x = x}"
@@ -163,7 +163,7 @@
   interpret d: finite_deflation d by fact
   fix x
   show "\<And>x. (d oo f)\<cdot>x \<sqsubseteq> x"
-    by (simp, rule trans_less [OF d.less f])
+    by (simp, rule below_trans [OF d.below f])
   show "finite (range (\<lambda>x. (d oo f)\<cdot>x))"
     by (rule finite_subset [OF _ d.finite_range], auto)
 qed
@@ -185,9 +185,9 @@
     apply safe
     apply (erule subst)
     apply (rule d.idem)
-    apply (rule antisym_less)
+    apply (rule below_antisym)
     apply (rule f)
-    apply (erule subst, rule d.less)
+    apply (erule subst, rule d.below)
     apply simp
     done
 qed
@@ -199,18 +199,17 @@
 typedef (open) 'a fin_defl = "{d::'a \<rightarrow> 'a. finite_deflation d}"
 by (fast intro: finite_deflation_approx)
 
-instantiation fin_defl :: (profinite) sq_ord
+instantiation fin_defl :: (profinite) below
 begin
 
-definition
-  sq_le_fin_defl_def:
+definition below_fin_defl_def:
     "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep_fin_defl x \<sqsubseteq> Rep_fin_defl y"
 
 instance ..
 end
 
 instance fin_defl :: (profinite) po
-by (rule typedef_po [OF type_definition_fin_defl sq_le_fin_defl_def])
+by (rule typedef_po [OF type_definition_fin_defl below_fin_defl_def])
 
 lemma finite_deflation_Rep_fin_defl: "finite_deflation (Rep_fin_defl d)"
 using Rep_fin_defl by simp
@@ -218,27 +217,27 @@
 interpretation Rep_fin_defl: finite_deflation "Rep_fin_defl d"
 by (rule finite_deflation_Rep_fin_defl)
 
-lemma fin_defl_lessI:
+lemma fin_defl_belowI:
   "(\<And>x. Rep_fin_defl a\<cdot>x = x \<Longrightarrow> Rep_fin_defl b\<cdot>x = x) \<Longrightarrow> a \<sqsubseteq> b"
-unfolding sq_le_fin_defl_def
-by (rule Rep_fin_defl.lessI)
+unfolding below_fin_defl_def
+by (rule Rep_fin_defl.belowI)
 
-lemma fin_defl_lessD:
+lemma fin_defl_belowD:
   "\<lbrakk>a \<sqsubseteq> b; Rep_fin_defl a\<cdot>x = x\<rbrakk> \<Longrightarrow> Rep_fin_defl b\<cdot>x = x"
-unfolding sq_le_fin_defl_def
-by (rule Rep_fin_defl.lessD)
+unfolding below_fin_defl_def
+by (rule Rep_fin_defl.belowD)
 
 lemma fin_defl_eqI:
   "(\<And>x. Rep_fin_defl a\<cdot>x = x \<longleftrightarrow> Rep_fin_defl b\<cdot>x = x) \<Longrightarrow> a = b"
-apply (rule antisym_less)
-apply (rule fin_defl_lessI, simp)
-apply (rule fin_defl_lessI, simp)
+apply (rule below_antisym)
+apply (rule fin_defl_belowI, simp)
+apply (rule fin_defl_belowI, simp)
 done
 
 lemma Abs_fin_defl_mono:
   "\<lbrakk>finite_deflation a; finite_deflation b; a \<sqsubseteq> b\<rbrakk>
     \<Longrightarrow> Abs_fin_defl a \<sqsubseteq> Abs_fin_defl b"
-unfolding sq_le_fin_defl_def
+unfolding below_fin_defl_def
 by (simp add: Abs_fin_defl_inverse)
 
 
@@ -257,7 +256,7 @@
 apply (rule pre_deflation.finite_deflation_d)
 apply (rule pre_deflation_d_f)
 apply (rule finite_deflation_approx)
-apply (rule Rep_fin_defl.less)
+apply (rule Rep_fin_defl.below)
 done
 
 lemma fd_take_fixed_iff:
@@ -265,10 +264,10 @@
     approx i\<cdot>x = x \<and> Rep_fin_defl d\<cdot>x = x"
 unfolding Rep_fin_defl_fd_take
 by (rule eventual_iterate_oo_fixed_iff
-    [OF finite_deflation_approx Rep_fin_defl.less])
+    [OF finite_deflation_approx Rep_fin_defl.below])
 
-lemma fd_take_less: "fd_take n d \<sqsubseteq> d"
-apply (rule fin_defl_lessI)
+lemma fd_take_below: "fd_take n d \<sqsubseteq> d"
+apply (rule fin_defl_belowI)
 apply (simp add: fd_take_fixed_iff)
 done
 
@@ -278,16 +277,16 @@
 done
 
 lemma fd_take_mono: "a \<sqsubseteq> b \<Longrightarrow> fd_take n a \<sqsubseteq> fd_take n b"
-apply (rule fin_defl_lessI)
+apply (rule fin_defl_belowI)
 apply (simp add: fd_take_fixed_iff)
-apply (simp add: fin_defl_lessD)
+apply (simp add: fin_defl_belowD)
 done
 
 lemma approx_fixed_le_lemma: "\<lbrakk>i \<le> j; approx i\<cdot>x = x\<rbrakk> \<Longrightarrow> approx j\<cdot>x = x"
 by (erule subst, simp add: min_def)
 
 lemma fd_take_chain: "m \<le> n \<Longrightarrow> fd_take m a \<sqsubseteq> fd_take n a"
-apply (rule fin_defl_lessI)
+apply (rule fin_defl_belowI)
 apply (simp add: fd_take_fixed_iff)
 apply (simp add: approx_fixed_le_lemma)
 done
@@ -304,9 +303,9 @@
 lemma fd_take_covers: "\<exists>n. fd_take n a = a"
 apply (rule_tac x=
   "Max ((\<lambda>x. LEAST n. approx n\<cdot>x = x) ` {x. Rep_fin_defl a\<cdot>x = x})" in exI)
-apply (rule antisym_less)
-apply (rule fd_take_less)
-apply (rule fin_defl_lessI)
+apply (rule below_antisym)
+apply (rule fd_take_below)
+apply (rule fin_defl_belowI)
 apply (simp add: fd_take_fixed_iff)
 apply (rule approx_fixed_le_lemma)
 apply (rule Max_ge)
@@ -320,9 +319,9 @@
 apply (rule Rep_fin_defl.compact)
 done
 
-interpretation fin_defl: basis_take sq_le fd_take
+interpretation fin_defl: basis_take below fd_take
 apply default
-apply (rule fd_take_less)
+apply (rule fd_take_below)
 apply (rule fd_take_idem)
 apply (erule fd_take_mono)
 apply (rule fd_take_chain, simp)
@@ -333,10 +332,10 @@
 subsection {* Defining algebraic deflations by ideal completion *}
 
 typedef (open) 'a alg_defl =
-  "{S::'a fin_defl set. sq_le.ideal S}"
-by (fast intro: sq_le.ideal_principal)
+  "{S::'a fin_defl set. below.ideal S}"
+by (fast intro: below.ideal_principal)
 
-instantiation alg_defl :: (profinite) sq_ord
+instantiation alg_defl :: (profinite) below
 begin
 
 definition
@@ -346,19 +345,19 @@
 end
 
 instance alg_defl :: (profinite) po
-by (rule sq_le.typedef_ideal_po
-    [OF type_definition_alg_defl sq_le_alg_defl_def])
+by (rule below.typedef_ideal_po
+    [OF type_definition_alg_defl below_alg_defl_def])
 
 instance alg_defl :: (profinite) cpo
-by (rule sq_le.typedef_ideal_cpo
-    [OF type_definition_alg_defl sq_le_alg_defl_def])
+by (rule below.typedef_ideal_cpo
+    [OF type_definition_alg_defl below_alg_defl_def])
 
 lemma Rep_alg_defl_lub:
   "chain Y \<Longrightarrow> Rep_alg_defl (\<Squnion>i. Y i) = (\<Union>i. Rep_alg_defl (Y i))"
-by (rule sq_le.typedef_ideal_rep_contlub
-    [OF type_definition_alg_defl sq_le_alg_defl_def])
+by (rule below.typedef_ideal_rep_contlub
+    [OF type_definition_alg_defl below_alg_defl_def])
 
-lemma ideal_Rep_alg_defl: "sq_le.ideal (Rep_alg_defl xs)"
+lemma ideal_Rep_alg_defl: "below.ideal (Rep_alg_defl xs)"
 by (rule Rep_alg_defl [unfolded mem_Collect_eq])
 
 definition
@@ -368,15 +367,15 @@
 lemma Rep_alg_defl_principal:
   "Rep_alg_defl (alg_defl_principal t) = {u. u \<sqsubseteq> t}"
 unfolding alg_defl_principal_def
-by (simp add: Abs_alg_defl_inverse sq_le.ideal_principal)
+by (simp add: Abs_alg_defl_inverse below.ideal_principal)
 
 interpretation alg_defl:
-  ideal_completion sq_le fd_take alg_defl_principal Rep_alg_defl
+  ideal_completion below fd_take alg_defl_principal Rep_alg_defl
 apply default
 apply (rule ideal_Rep_alg_defl)
 apply (erule Rep_alg_defl_lub)
 apply (rule Rep_alg_defl_principal)
-apply (simp only: sq_le_alg_defl_def)
+apply (simp only: below_alg_defl_def)
 done
 
 text {* Algebraic deflations are pointed *}
@@ -443,7 +442,7 @@
   "cast\<cdot>(alg_defl_principal a) = Rep_fin_defl a"
 unfolding cast_def
 apply (rule alg_defl.basis_fun_principal)
-apply (simp only: sq_le_fin_defl_def)
+apply (simp only: below_fin_defl_def)
 done
 
 lemma deflation_cast: "deflation (cast\<cdot>d)"
@@ -522,10 +521,10 @@
     apply (rule finite_deflation_p_d_e)
     apply (rule finite_deflation_cast)
     apply (rule compact_approx)
-    apply (rule sq_ord_less_eq_trans [OF _ d])
+    apply (rule below_eq_trans [OF _ d])
     apply (rule monofun_cfun_fun)
     apply (rule monofun_cfun_arg)
-    apply (rule approx_less)
+    apply (rule approx_below)
     done
   show "(\<Squnion>i. ?a i) = ID"
     apply (rule ext_cfun, simp)

--- a/src/HOLCF/Bifinite.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Bifinite.thy	Fri May 15 15:56:28 2009 +0200
@@ -19,7 +19,7 @@
 
 class bifinite = profinite + pcpo
 
-lemma approx_less: "approx i\<cdot>x \<sqsubseteq> x"
+lemma approx_below: "approx i\<cdot>x \<sqsubseteq> x"
 proof -
   have "chain (\<lambda>i. approx i\<cdot>x)" by simp
   hence "approx i\<cdot>x \<sqsubseteq> (\<Squnion>i. approx i\<cdot>x)" by (rule is_ub_thelub)
@@ -32,7 +32,7 @@
   show "approx i\<cdot>(approx i\<cdot>x) = approx i\<cdot>x"
     by (rule approx_idem)
   show "approx i\<cdot>x \<sqsubseteq> x"
-    by (rule approx_less)
+    by (rule approx_below)
   show "finite {x. approx i\<cdot>x = x}"
     by (rule finite_fixes_approx)
 qed
@@ -49,17 +49,17 @@
 by (rule ext_cfun, simp add: contlub_cfun_fun)
 
 lemma approx_strict [simp]: "approx i\<cdot>\<bottom> = \<bottom>"
-by (rule UU_I, rule approx_less)
+by (rule UU_I, rule approx_below)
 
 lemma approx_approx1:
   "i \<le> j \<Longrightarrow> approx i\<cdot>(approx j\<cdot>x) = approx i\<cdot>x"
-apply (rule deflation_less_comp1 [OF deflation_approx deflation_approx])
+apply (rule deflation_below_comp1 [OF deflation_approx deflation_approx])
 apply (erule chain_mono [OF chain_approx])
 done
 
 lemma approx_approx2:
   "j \<le> i \<Longrightarrow> approx i\<cdot>(approx j\<cdot>x) = approx j\<cdot>x"
-apply (rule deflation_less_comp2 [OF deflation_approx deflation_approx])
+apply (rule deflation_below_comp2 [OF deflation_approx deflation_approx])
 apply (erule chain_mono [OF chain_approx])
 done
 
@@ -99,11 +99,51 @@
   thus "P x" by simp
 qed
 
-lemma profinite_less_ext: "(\<And>i. approx i\<cdot>x \<sqsubseteq> approx i\<cdot>y) \<Longrightarrow> x \<sqsubseteq> y"
+lemma profinite_below_ext: "(\<And>i. approx i\<cdot>x \<sqsubseteq> approx i\<cdot>y) \<Longrightarrow> x \<sqsubseteq> y"
 apply (subgoal_tac "(\<Squnion>i. approx i\<cdot>x) \<sqsubseteq> (\<Squnion>i. approx i\<cdot>y)", simp)
 apply (rule lub_mono, simp, simp, simp)
 done
 
+subsection {* Instance for product type *}
+
+instantiation "*" :: (profinite, profinite) profinite
+begin
+
+definition approx_prod_def:
+  "approx = (\<lambda>n. \<Lambda> x. (approx n\<cdot>(fst x), approx n\<cdot>(snd x)))"
+
+instance proof
+  fix i :: nat and x :: "'a \<times> 'b"
+  show "chain (approx :: nat \<Rightarrow> 'a \<times> 'b \<rightarrow> 'a \<times> 'b)"
+    unfolding approx_prod_def by simp
+  show "(\<Squnion>i. approx i\<cdot>x) = x"
+    unfolding approx_prod_def
+    by (simp add: lub_distribs thelub_Pair)
+  show "approx i\<cdot>(approx i\<cdot>x) = approx i\<cdot>x"
+    unfolding approx_prod_def by simp
+  have "{x::'a \<times> 'b. approx i\<cdot>x = x} \<subseteq>
+        {x::'a. approx i\<cdot>x = x} \<times> {x::'b. approx i\<cdot>x = x}"
+    unfolding approx_prod_def by clarsimp
+  thus "finite {x::'a \<times> 'b. approx i\<cdot>x = x}"
+    by (rule finite_subset,
+        intro finite_cartesian_product finite_fixes_approx)
+qed
+
+end
+
+instance "*" :: (bifinite, bifinite) bifinite ..
+
+lemma approx_Pair [simp]:
+  "approx i\<cdot>(x, y) = (approx i\<cdot>x, approx i\<cdot>y)"
+unfolding approx_prod_def by simp
+
+lemma fst_approx: "fst (approx i\<cdot>p) = approx i\<cdot>(fst p)"
+by (induct p, simp)
+
+lemma snd_approx: "snd (approx i\<cdot>p) = approx i\<cdot>(snd p)"
+by (induct p, simp)
+
+
 subsection {* Instance for continuous function space *}
 
 lemma finite_range_cfun_lemma:

--- a/src/HOLCF/Cfun.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Cfun.thy	Fri May 15 15:56:28 2009 +0200
@@ -105,19 +105,19 @@
 by (rule typedef_finite_po [OF type_definition_CFun])
 
 instance "->" :: (finite_po, chfin) chfin
-by (rule typedef_chfin [OF type_definition_CFun less_CFun_def])
+by (rule typedef_chfin [OF type_definition_CFun below_CFun_def])
 
 instance "->" :: (cpo, discrete_cpo) discrete_cpo
-by intro_classes (simp add: less_CFun_def Rep_CFun_inject)
+by intro_classes (simp add: below_CFun_def Rep_CFun_inject)
 
 instance "->" :: (cpo, pcpo) pcpo
-by (rule typedef_pcpo [OF type_definition_CFun less_CFun_def UU_CFun])
+by (rule typedef_pcpo [OF type_definition_CFun below_CFun_def UU_CFun])
 
 lemmas Rep_CFun_strict =
-  typedef_Rep_strict [OF type_definition_CFun less_CFun_def UU_CFun]
+  typedef_Rep_strict [OF type_definition_CFun below_CFun_def UU_CFun]
 
 lemmas Abs_CFun_strict =
-  typedef_Abs_strict [OF type_definition_CFun less_CFun_def UU_CFun]
+  typedef_Abs_strict [OF type_definition_CFun below_CFun_def UU_CFun]
 
 text {* function application is strict in its first argument *}
 
@@ -153,11 +153,11 @@
 
 text {* Extensionality wrt. ordering for continuous functions *}
 
-lemma expand_cfun_less: "f \<sqsubseteq> g = (\<forall>x. f\<cdot>x \<sqsubseteq> g\<cdot>x)" 
-by (simp add: less_CFun_def expand_fun_less)
+lemma expand_cfun_below: "f \<sqsubseteq> g = (\<forall>x. f\<cdot>x \<sqsubseteq> g\<cdot>x)" 
+by (simp add: below_CFun_def expand_fun_below)
 
-lemma less_cfun_ext: "(\<And>x. f\<cdot>x \<sqsubseteq> g\<cdot>x) \<Longrightarrow> f \<sqsubseteq> g"
-by (simp add: expand_cfun_less)
+lemma below_cfun_ext: "(\<And>x. f\<cdot>x \<sqsubseteq> g\<cdot>x) \<Longrightarrow> f \<sqsubseteq> g"
+by (simp add: expand_cfun_below)
 
 text {* Congruence for continuous function application *}
 
@@ -205,13 +205,13 @@
 text {* monotonicity of application *}
 
 lemma monofun_cfun_fun: "f \<sqsubseteq> g \<Longrightarrow> f\<cdot>x \<sqsubseteq> g\<cdot>x"
-by (simp add: expand_cfun_less)
+by (simp add: expand_cfun_below)
 
 lemma monofun_cfun_arg: "x \<sqsubseteq> y \<Longrightarrow> f\<cdot>x \<sqsubseteq> f\<cdot>y"
 by (rule monofun_Rep_CFun2 [THEN monofunE])
 
 lemma monofun_cfun: "\<lbrakk>f \<sqsubseteq> g; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> f\<cdot>x \<sqsubseteq> g\<cdot>y"
-by (rule trans_less [OF monofun_cfun_fun monofun_cfun_arg])
+by (rule below_trans [OF monofun_cfun_fun monofun_cfun_arg])
 
 text {* ch2ch - rules for the type @{typ "'a -> 'b"} *}
 
@@ -230,7 +230,7 @@
 
 lemma ch2ch_LAM [simp]:
   "\<lbrakk>\<And>x. chain (\<lambda>i. S i x); \<And>i. cont (\<lambda>x. S i x)\<rbrakk> \<Longrightarrow> chain (\<lambda>i. \<Lambda> x. S i x)"
-by (simp add: chain_def expand_cfun_less)
+by (simp add: chain_def expand_cfun_below)
 
 text {* contlub, cont properties of @{term Rep_CFun} in both arguments *}
 
@@ -316,7 +316,7 @@
 lemma cont2mono_LAM:
   "\<lbrakk>\<And>x. cont (\<lambda>y. f x y); \<And>y. monofun (\<lambda>x. f x y)\<rbrakk>
     \<Longrightarrow> monofun (\<lambda>x. \<Lambda> y. f x y)"
-  unfolding monofun_def expand_cfun_less by simp
+  unfolding monofun_def expand_cfun_below by simp
 
 text {* cont2cont Lemma for @{term "%x. LAM y. f x y"} *}
 
@@ -345,21 +345,11 @@
   assumes f: "cont (\<lambda>p. f (fst p) (snd p))"
   shows "cont (\<lambda>x. \<Lambda> y. f x y)"
 proof (rule cont2cont_LAM)
-  fix x :: 'a
-  have "cont (\<lambda>y. (x, y))"
-    by (rule cont_pair2)
-  with f have "cont (\<lambda>y. f (fst (x, y)) (snd (x, y)))"
-    by (rule cont2cont_app3)
-  thus "cont (\<lambda>y. f x y)"
-    by (simp only: fst_conv snd_conv)
+  fix x :: 'a show "cont (\<lambda>y. f x y)"
+    using f by (rule cont_fst_snd_D2)
 next
-  fix y :: 'b
-  have "cont (\<lambda>x. (x, y))"
-    by (rule cont_pair1)
-  with f have "cont (\<lambda>x. f (fst (x, y)) (snd (x, y)))"
-    by (rule cont2cont_app3)
-  thus "cont (\<lambda>x. f x y)"
-    by (simp only: fst_conv snd_conv)
+  fix y :: 'b show "cont (\<lambda>x. f x y)"
+    using f by (rule cont_fst_snd_D1)
 qed
 
 lemma cont2cont_LAM_discrete [cont2cont]:
@@ -375,7 +365,7 @@
 
 lemma semi_monofun_Abs_CFun:
   "\<lbrakk>cont f; cont g; f \<sqsubseteq> g\<rbrakk> \<Longrightarrow> Abs_CFun f \<sqsubseteq> Abs_CFun g"
-by (simp add: less_CFun_def Abs_CFun_inverse2)
+by (simp add: below_CFun_def Abs_CFun_inverse2)
 
 text {* some lemmata for functions with flat/chfin domain/range types *}
 
@@ -411,7 +401,7 @@
 apply simp
 done
 
-lemma injection_less:
+lemma injection_below:
   "\<forall>x. f\<cdot>(g\<cdot>x) = x \<Longrightarrow> (g\<cdot>x \<sqsubseteq> g\<cdot>y) = (x \<sqsubseteq> y)"
 apply (rule iffI)
 apply (drule_tac f=f in monofun_cfun_arg)

--- a/src/HOLCF/CompactBasis.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/CompactBasis.thy	Fri May 15 15:56:28 2009 +0200
@@ -18,7 +18,7 @@
 lemma compact_Rep_compact_basis: "compact (Rep_compact_basis a)"
 by (rule Rep_compact_basis [unfolded mem_Collect_eq])
 
-instantiation compact_basis :: (profinite) sq_ord
+instantiation compact_basis :: (profinite) below
 begin
 
 definition
@@ -47,12 +47,12 @@
 lemmas approx_Rep_compact_basis = Rep_compact_take [symmetric]
 
 interpretation compact_basis:
-  basis_take sq_le compact_take
+  basis_take below compact_take
 proof
   fix n :: nat and a :: "'a compact_basis"
   show "compact_take n a \<sqsubseteq> a"
     unfolding compact_le_def
-    by (simp add: Rep_compact_take approx_less)
+    by (simp add: Rep_compact_take approx_below)
 next
   fix n :: nat and a :: "'a compact_basis"
   show "compact_take n (compact_take n a) = compact_take n a"
@@ -93,15 +93,15 @@
   "approximants = (\<lambda>x. {a. Rep_compact_basis a \<sqsubseteq> x})"
 
 interpretation compact_basis:
-  ideal_completion sq_le compact_take Rep_compact_basis approximants
+  ideal_completion below compact_take Rep_compact_basis approximants
 proof
   fix w :: 'a
-  show "preorder.ideal sq_le (approximants w)"
-  proof (rule sq_le.idealI)
+  show "preorder.ideal below (approximants w)"
+  proof (rule below.idealI)
     show "\<exists>x. x \<in> approximants w"
       unfolding approximants_def
       apply (rule_tac x="Abs_compact_basis (approx 0\<cdot>w)" in exI)
-      apply (simp add: Abs_compact_basis_inverse approx_less)
+      apply (simp add: Abs_compact_basis_inverse approx_below)
       done
   next
     fix x y :: "'a compact_basis"
@@ -116,7 +116,7 @@
       apply (clarify, rename_tac i j)
       apply (rule_tac x="Abs_compact_basis (approx (max i j)\<cdot>w)" in exI)
       apply (simp add: compact_le_def)
-      apply (simp add: Abs_compact_basis_inverse approx_less)
+      apply (simp add: Abs_compact_basis_inverse approx_below)
       apply (erule subst, erule subst)
       apply (simp add: monofun_cfun chain_mono [OF chain_approx])
       done
@@ -126,7 +126,7 @@
       unfolding approximants_def
       apply simp
       apply (simp add: compact_le_def)
-      apply (erule (1) trans_less)
+      apply (erule (1) below_trans)
       done
   qed
 next
@@ -136,7 +136,7 @@
     unfolding approximants_def
     apply safe
     apply (simp add: compactD2 [OF compact_Rep_compact_basis Y])
-    apply (erule trans_less, rule is_ub_thelub [OF Y])
+    apply (erule below_trans, rule is_ub_thelub [OF Y])
     done
 next
   fix a :: "'a compact_basis"
@@ -148,7 +148,7 @@
     apply (subgoal_tac "(\<Squnion>i. approx i\<cdot>x) \<sqsubseteq> y", simp)
     apply (rule admD, simp, simp)
     apply (drule_tac c="Abs_compact_basis (approx i\<cdot>x)" in subsetD)
-    apply (simp add: approximants_def Abs_compact_basis_inverse approx_less)
+    apply (simp add: approximants_def Abs_compact_basis_inverse approx_below)
     apply (simp add: approximants_def Abs_compact_basis_inverse)
     done
 qed
@@ -288,7 +288,7 @@
 apply (cut_tac a=a in compact_basis.take_covers)
 apply (clarify, rule_tac x=n in exI)
 apply (clarify, simp)
-apply (rule antisym_less)
+apply (rule below_antisym)
 apply (rule compact_basis.take_less)
 apply (drule_tac a=a in compact_basis.take_chain_le)
 apply simp

--- a/src/HOLCF/Completion.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Completion.thy	Fri May 15 15:56:28 2009 +0200
@@ -108,11 +108,11 @@
 done
 
 lemma typedef_ideal_po:
-  fixes Abs :: "'a set \<Rightarrow> 'b::sq_ord"
+  fixes Abs :: "'a set \<Rightarrow> 'b::below"
   assumes type: "type_definition Rep Abs {S. ideal S}"
-  assumes less: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
+  assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
   shows "OFCLASS('b, po_class)"
- apply (intro_classes, unfold less)
+ apply (intro_classes, unfold below)
    apply (rule subset_refl)
   apply (erule (1) subset_trans)
  apply (rule type_definition.Rep_inject [OF type, THEN iffD1])
@@ -122,7 +122,7 @@
 lemma
   fixes Abs :: "'a set \<Rightarrow> 'b::po"
   assumes type: "type_definition Rep Abs {S. ideal S}"
-  assumes less: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
+  assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
   assumes S: "chain S"
   shows typedef_ideal_lub: "range S <<| Abs (\<Union>i. Rep (S i))"
     and typedef_ideal_rep_contlub: "Rep (\<Squnion>i. S i) = (\<Union>i. Rep (S i))"
@@ -130,7 +130,7 @@
   have 1: "ideal (\<Union>i. Rep (S i))"
     apply (rule ideal_UN)
      apply (rule type_definition.Rep [OF type, unfolded mem_Collect_eq])
-    apply (subst less [symmetric])
+    apply (subst below [symmetric])
     apply (erule chain_mono [OF S])
     done
   hence 2: "Rep (Abs (\<Union>i. Rep (S i))) = (\<Union>i. Rep (S i))"
@@ -138,8 +138,8 @@
   show 3: "range S <<| Abs (\<Union>i. Rep (S i))"
     apply (rule is_lubI)
      apply (rule is_ubI)
-     apply (simp add: less 2, fast)
-    apply (simp add: less 2 is_ub_def, fast)
+     apply (simp add: below 2, fast)
+    apply (simp add: below 2 is_ub_def, fast)
     done
   hence 4: "(\<Squnion>i. S i) = Abs (\<Union>i. Rep (S i))"
     by (rule thelubI)
@@ -150,16 +150,16 @@
 lemma typedef_ideal_cpo:
   fixes Abs :: "'a set \<Rightarrow> 'b::po"
   assumes type: "type_definition Rep Abs {S. ideal S}"
-  assumes less: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
+  assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
   shows "OFCLASS('b, cpo_class)"
-by (default, rule exI, erule typedef_ideal_lub [OF type less])
+by (default, rule exI, erule typedef_ideal_lub [OF type below])
 
 end
 
-interpretation sq_le: preorder "sq_le :: 'a::po \<Rightarrow> 'a \<Rightarrow> bool"
+interpretation below: preorder "below :: 'a::po \<Rightarrow> 'a \<Rightarrow> bool"
 apply unfold_locales
-apply (rule refl_less)
-apply (erule (1) trans_less)
+apply (rule below_refl)
+apply (erule (1) below_trans)
 done
 
 subsection {* Lemmas about least upper bounds *}
@@ -229,43 +229,43 @@
 apply (rule subsetI, rule UN_I [where a=0], simp_all)
 done
 
-lemma less_def: "x \<sqsubseteq> y \<longleftrightarrow> rep x \<subseteq> rep y"
+lemma below_def: "x \<sqsubseteq> y \<longleftrightarrow> rep x \<subseteq> rep y"
 by (rule iffI [OF rep_mono subset_repD])
 
 lemma rep_eq: "rep x = {a. principal a \<sqsubseteq> x}"
-unfolding less_def rep_principal
+unfolding below_def rep_principal
 apply safe
 apply (erule (1) idealD3 [OF ideal_rep])
 apply (erule subsetD, simp add: r_refl)
 done
 
-lemma mem_rep_iff_principal_less: "a \<in> rep x \<longleftrightarrow> principal a \<sqsubseteq> x"
+lemma mem_rep_iff_principal_below: "a \<in> rep x \<longleftrightarrow> principal a \<sqsubseteq> x"
 by (simp add: rep_eq)
 
-lemma principal_less_iff_mem_rep: "principal a \<sqsubseteq> x \<longleftrightarrow> a \<in> rep x"
+lemma principal_below_iff_mem_rep: "principal a \<sqsubseteq> x \<longleftrightarrow> a \<in> rep x"
 by (simp add: rep_eq)
 
-lemma principal_less_iff [simp]: "principal a \<sqsubseteq> principal b \<longleftrightarrow> a \<preceq> b"
-by (simp add: principal_less_iff_mem_rep rep_principal)
+lemma principal_below_iff [simp]: "principal a \<sqsubseteq> principal b \<longleftrightarrow> a \<preceq> b"
+by (simp add: principal_below_iff_mem_rep rep_principal)
 
 lemma principal_eq_iff: "principal a = principal b \<longleftrightarrow> a \<preceq> b \<and> b \<preceq> a"
-unfolding po_eq_conv [where 'a='b] principal_less_iff ..
+unfolding po_eq_conv [where 'a='b] principal_below_iff ..
 
 lemma repD: "a \<in> rep x \<Longrightarrow> principal a \<sqsubseteq> x"
 by (simp add: rep_eq)
 
 lemma principal_mono: "a \<preceq> b \<Longrightarrow> principal a \<sqsubseteq> principal b"
-by (simp only: principal_less_iff)
+by (simp only: principal_below_iff)
 
-lemma lessI: "(\<And>a. principal a \<sqsubseteq> x \<Longrightarrow> principal a \<sqsubseteq> u) \<Longrightarrow> x \<sqsubseteq> u"
-unfolding principal_less_iff_mem_rep
-by (simp add: less_def subset_eq)
+lemma belowI: "(\<And>a. principal a \<sqsubseteq> x \<Longrightarrow> principal a \<sqsubseteq> u) \<Longrightarrow> x \<sqsubseteq> u"
+unfolding principal_below_iff_mem_rep
+by (simp add: below_def subset_eq)
 
 lemma lub_principal_rep: "principal ` rep x <<| x"
 apply (rule is_lubI)
 apply (rule ub_imageI)
 apply (erule repD)
-apply (subst less_def)
+apply (subst below_def)
 apply (rule subsetI)
 apply (drule (1) ub_imageD)
 apply (simp add: rep_eq)
@@ -299,7 +299,7 @@
  apply (rule is_lub_thelub0)
   apply (rule basis_fun_lemma0, erule f_mono)
  apply (rule is_ubI, clarsimp, rename_tac a)
- apply (rule trans_less [OF f_mono [OF take_chain]])
+ apply (rule below_trans [OF f_mono [OF take_chain]])
  apply (rule is_ub_thelub0)
   apply (rule basis_fun_lemma0, erule f_mono)
  apply simp
@@ -313,7 +313,7 @@
  apply (rule ub_imageI, rename_tac a)
   apply (cut_tac a=a in take_covers, erule exE, rename_tac i)
   apply (erule subst)
-  apply (rule rev_trans_less)
+  apply (rule rev_below_trans)
    apply (rule_tac x=i in is_ub_thelub)
    apply (rule basis_fun_lemma1, erule f_mono)
   apply (rule is_ub_thelub0)
@@ -324,7 +324,7 @@
  apply (rule is_lub_thelub0)
   apply (rule basis_fun_lemma0, erule f_mono)
  apply (rule is_ubI, clarsimp, rename_tac a)
- apply (rule trans_less [OF f_mono [OF take_less]])
+ apply (rule below_trans [OF f_mono [OF take_less]])
  apply (erule (1) ub_imageD)
 done
 
@@ -350,7 +350,7 @@
      apply (erule (1) subsetD [OF rep_mono])
     apply (rule is_lub_thelub0 [OF lub ub_imageI])
     apply (simp add: rep_contlub, clarify)
-    apply (erule rev_trans_less [OF is_ub_thelub])
+    apply (erule rev_below_trans [OF is_ub_thelub])
     apply (erule is_ub_thelub0 [OF lub imageI])
     done
 qed
@@ -367,21 +367,21 @@
 lemma basis_fun_mono:
   assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
   assumes g_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> g a \<sqsubseteq> g b"
-  assumes less: "\<And>a. f a \<sqsubseteq> g a"
+  assumes below: "\<And>a. f a \<sqsubseteq> g a"
   shows "basis_fun f \<sqsubseteq> basis_fun g"
- apply (rule less_cfun_ext)
+ apply (rule below_cfun_ext)
  apply (simp only: basis_fun_beta f_mono g_mono)
  apply (rule is_lub_thelub0)
   apply (rule basis_fun_lemma, erule f_mono)
  apply (rule ub_imageI, rename_tac a)
- apply (rule trans_less [OF less])
+ apply (rule below_trans [OF below])
  apply (rule is_ub_thelub0)
   apply (rule basis_fun_lemma, erule g_mono)
  apply (erule imageI)
 done
 
 lemma compact_principal [simp]: "compact (principal a)"
-by (rule compactI2, simp add: principal_less_iff_mem_rep rep_contlub)
+by (rule compactI2, simp add: principal_below_iff_mem_rep rep_contlub)
 
 subsection {* Bifiniteness of ideal completions *}
 

--- a/src/HOLCF/Cont.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Cont.thy	Fri May 15 15:56:28 2009 +0200
@@ -121,14 +121,14 @@
 
 lemma contI2:
   assumes mono: "monofun f"
-  assumes less: "\<And>Y. \<lbrakk>chain Y; chain (\<lambda>i. f (Y i))\<rbrakk>
+  assumes below: "\<And>Y. \<lbrakk>chain Y; chain (\<lambda>i. f (Y i))\<rbrakk>
      \<Longrightarrow> f (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. f (Y i))"
   shows "cont f"
 apply (rule monocontlub2cont)
 apply (rule mono)
 apply (rule contlubI)
-apply (rule antisym_less)
-apply (rule less, assumption)
+apply (rule below_antisym)
+apply (rule below, assumption)
 apply (erule ch2ch_monofun [OF mono])
 apply (rule is_lub_thelub)
 apply (erule ch2ch_monofun [OF mono])
@@ -144,7 +144,7 @@
   ( val name = "cont2cont" val description = "continuity intro rule" )
 *}
 
-setup {* Cont2ContData.setup *}
+setup Cont2ContData.setup
 
 text {*
   Given the term @{term "cont f"}, the procedure tries to construct the
@@ -153,20 +153,13 @@
   conditional rewrite rule with the unsolved subgoals as premises.
 *}
 
-setup {*
-let
-  fun solve_cont thy ss t =
+simproc_setup cont_proc ("cont f") = {*
+  fn phi => fn ss => fn ct =>
     let
-      val tr = instantiate' [] [SOME (cterm_of thy t)] Eq_TrueI;
+      val tr = instantiate' [] [SOME ct] @{thm Eq_TrueI};
       val rules = Cont2ContData.get (Simplifier.the_context ss);
       val tac = REPEAT_ALL_NEW (match_tac rules);
-    in Option.map fst (Seq.pull (tac 1 tr)) end
-
-  val proc =
-    Simplifier.simproc @{theory} "cont_proc" ["cont f"] solve_cont;
-in
-  Simplifier.map_simpset (fn ss => ss addsimprocs [proc])
-end
+    in SINGLE (tac 1) tr end
 *}
 
 subsection {* Continuity of basic functions *}
@@ -187,31 +180,31 @@
 
 text {* application of functions is continuous *}
 
-lemma cont2cont_apply:
+lemma cont_apply:
   fixes f :: "'a::cpo \<Rightarrow> 'b::cpo \<Rightarrow> 'c::cpo" and t :: "'a \<Rightarrow> 'b"
-  assumes f1: "\<And>y. cont (\<lambda>x. f x y)"
-  assumes f2: "\<And>x. cont (\<lambda>y. f x y)"
-  assumes t: "cont (\<lambda>x. t x)"
+  assumes 1: "cont (\<lambda>x. t x)"
+  assumes 2: "\<And>x. cont (\<lambda>y. f x y)"
+  assumes 3: "\<And>y. cont (\<lambda>x. f x y)"
   shows "cont (\<lambda>x. (f x) (t x))"
 proof (rule monocontlub2cont [OF monofunI contlubI])
   fix x y :: "'a" assume "x \<sqsubseteq> y"
   then show "f x (t x) \<sqsubseteq> f y (t y)"
-    by (auto intro: cont2monofunE [OF f1]
-                    cont2monofunE [OF f2]
-                    cont2monofunE [OF t]
-                    trans_less)
+    by (auto intro: cont2monofunE [OF 1]
+                    cont2monofunE [OF 2]
+                    cont2monofunE [OF 3]
+                    below_trans)
 next
   fix Y :: "nat \<Rightarrow> 'a" assume "chain Y"
   then show "f (\<Squnion>i. Y i) (t (\<Squnion>i. Y i)) = (\<Squnion>i. f (Y i) (t (Y i)))"
-    by (simp only: cont2contlubE [OF t]  ch2ch_cont [OF t]
-                   cont2contlubE [OF f1] ch2ch_cont [OF f1]
-                   cont2contlubE [OF f2] ch2ch_cont [OF f2]
+    by (simp only: cont2contlubE [OF 1] ch2ch_cont [OF 1]
+                   cont2contlubE [OF 2] ch2ch_cont [OF 2]
+                   cont2contlubE [OF 3] ch2ch_cont [OF 3]
                    diag_lub)
 qed
 
-lemma cont2cont_compose:
+lemma cont_compose:
   "\<lbrakk>cont c; cont (\<lambda>x. f x)\<rbrakk> \<Longrightarrow> cont (\<lambda>x. c (f x))"
-by (rule cont2cont_apply [OF cont_const])
+by (rule cont_apply [OF _ _ cont_const])
 
 text {* if-then-else is continuous *}
 

--- a/src/HOLCF/ConvexPD.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/ConvexPD.thy	Fri May 15 15:56:28 2009 +0200
@@ -144,7 +144,7 @@
   "{S::'a pd_basis set. convex_le.ideal S}"
 by (fast intro: convex_le.ideal_principal)
 
-instantiation convex_pd :: (profinite) sq_ord
+instantiation convex_pd :: (profinite) below
 begin
 
 definition
@@ -155,16 +155,16 @@
 
 instance convex_pd :: (profinite) po
 by (rule convex_le.typedef_ideal_po
-    [OF type_definition_convex_pd sq_le_convex_pd_def])
+    [OF type_definition_convex_pd below_convex_pd_def])
 
 instance convex_pd :: (profinite) cpo
 by (rule convex_le.typedef_ideal_cpo
-    [OF type_definition_convex_pd sq_le_convex_pd_def])
+    [OF type_definition_convex_pd below_convex_pd_def])
 
 lemma Rep_convex_pd_lub:
   "chain Y \<Longrightarrow> Rep_convex_pd (\<Squnion>i. Y i) = (\<Union>i. Rep_convex_pd (Y i))"
 by (rule convex_le.typedef_ideal_rep_contlub
-    [OF type_definition_convex_pd sq_le_convex_pd_def])
+    [OF type_definition_convex_pd below_convex_pd_def])
 
 lemma ideal_Rep_convex_pd: "convex_le.ideal (Rep_convex_pd xs)"
 by (rule Rep_convex_pd [unfolded mem_Collect_eq])
@@ -190,7 +190,7 @@
 apply (rule ideal_Rep_convex_pd)
 apply (erule Rep_convex_pd_lub)
 apply (rule Rep_convex_principal)
-apply (simp only: sq_le_convex_pd_def)
+apply (simp only: below_convex_pd_def)
 done
 
 text {* Convex powerdomain is pointed *}
@@ -311,7 +311,7 @@
 lemmas convex_plus_aci =
   convex_plus_ac convex_plus_absorb convex_plus_left_absorb
 
-lemma convex_unit_less_plus_iff [simp]:
+lemma convex_unit_below_plus_iff [simp]:
   "{x}\<natural> \<sqsubseteq> ys +\<natural> zs \<longleftrightarrow> {x}\<natural> \<sqsubseteq> ys \<and> {x}\<natural> \<sqsubseteq> zs"
  apply (rule iffI)
   apply (subgoal_tac
@@ -329,7 +329,7 @@
  apply (erule (1) monofun_cfun [OF monofun_cfun_arg])
 done
 
-lemma convex_plus_less_unit_iff [simp]:
+lemma convex_plus_below_unit_iff [simp]:
   "xs +\<natural> ys \<sqsubseteq> {z}\<natural> \<longleftrightarrow> xs \<sqsubseteq> {z}\<natural> \<and> ys \<sqsubseteq> {z}\<natural>"
  apply (rule iffI)
   apply (subgoal_tac
@@ -347,9 +347,9 @@
  apply (erule (1) monofun_cfun [OF monofun_cfun_arg])
 done
 
-lemma convex_unit_less_iff [simp]: "{x}\<natural> \<sqsubseteq> {y}\<natural> \<longleftrightarrow> x \<sqsubseteq> y"
+lemma convex_unit_below_iff [simp]: "{x}\<natural> \<sqsubseteq> {y}\<natural> \<longleftrightarrow> x \<sqsubseteq> y"
  apply (rule iffI)
-  apply (rule profinite_less_ext)
+  apply (rule profinite_below_ext)
   apply (drule_tac f="approx i" in monofun_cfun_arg, simp)
   apply (cut_tac x="approx i\<cdot>x" in compact_basis.compact_imp_principal, simp)
   apply (cut_tac x="approx i\<cdot>y" in compact_basis.compact_imp_principal, simp)
@@ -433,12 +433,12 @@
 
 lemma monofun_LAM:
   "\<lbrakk>cont f; cont g; \<And>x. f x \<sqsubseteq> g x\<rbrakk> \<Longrightarrow> (\<Lambda> x. f x) \<sqsubseteq> (\<Lambda> x. g x)"
-by (simp add: expand_cfun_less)
+by (simp add: expand_cfun_below)
 
 lemma convex_bind_basis_mono:
   "t \<le>\<natural> u \<Longrightarrow> convex_bind_basis t \<sqsubseteq> convex_bind_basis u"
 apply (erule convex_le_induct)
-apply (erule (1) trans_less)
+apply (erule (1) below_trans)
 apply (simp add: monofun_LAM monofun_cfun)
 apply (simp add: monofun_LAM monofun_cfun)
 done
@@ -606,12 +606,12 @@
 
 text {* Ordering property *}
 
-lemma convex_pd_less_iff:
+lemma convex_pd_below_iff:
   "(xs \<sqsubseteq> ys) =
     (convex_to_upper\<cdot>xs \<sqsubseteq> convex_to_upper\<cdot>ys \<and>
      convex_to_lower\<cdot>xs \<sqsubseteq> convex_to_lower\<cdot>ys)"
  apply (safe elim!: monofun_cfun_arg)
- apply (rule profinite_less_ext)
+ apply (rule profinite_below_ext)
  apply (drule_tac f="approx i" in monofun_cfun_arg)
  apply (drule_tac f="approx i" in monofun_cfun_arg)
  apply (cut_tac x="approx i\<cdot>xs" in convex_pd.compact_imp_principal, simp)
@@ -620,19 +620,19 @@
  apply (simp add: approx_convex_to_upper approx_convex_to_lower convex_le_def)
 done
 
-lemmas convex_plus_less_plus_iff =
-  convex_pd_less_iff [where xs="xs +\<natural> ys" and ys="zs +\<natural> ws", standard]
+lemmas convex_plus_below_plus_iff =
+  convex_pd_below_iff [where xs="xs +\<natural> ys" and ys="zs +\<natural> ws", standard]
 
-lemmas convex_pd_less_simps =
-  convex_unit_less_plus_iff
-  convex_plus_less_unit_iff
-  convex_plus_less_plus_iff
-  convex_unit_less_iff
+lemmas convex_pd_below_simps =
+  convex_unit_below_plus_iff
+  convex_plus_below_unit_iff
+  convex_plus_below_plus_iff
+  convex_unit_below_iff
   convex_to_upper_unit
   convex_to_upper_plus
   convex_to_lower_unit
   convex_to_lower_plus
-  upper_pd_less_simps
-  lower_pd_less_simps
+  upper_pd_below_simps
+  lower_pd_below_simps
 
 end

--- a/src/HOLCF/Cprod.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Cprod.thy	Fri May 15 15:56:28 2009 +0200
@@ -68,7 +68,7 @@
 lemma cpair_eq [iff]: "(<a, b> = <a', b'>) = (a = a' \<and> b = b')"
 by (simp add: cpair_eq_pair)
 
-lemma cpair_less [iff]: "(<a, b> \<sqsubseteq> <a', b'>) = (a \<sqsubseteq> a' \<and> b \<sqsubseteq> b')"
+lemma cpair_below [iff]: "(<a, b> \<sqsubseteq> <a', b'>) = (a \<sqsubseteq> a' \<and> b \<sqsubseteq> b')"
 by (simp add: cpair_eq_pair)
 
 lemma cpair_defined_iff [iff]: "(<x, y> = \<bottom>) = (x = \<bottom> \<and> y = \<bottom>)"
@@ -91,10 +91,10 @@
 by (cut_tac Exh_Cprod2, auto)
 
 lemma cfst_cpair [simp]: "cfst\<cdot><x, y> = x"
-by (simp add: cpair_eq_pair cfst_def cont_fst)
+by (simp add: cpair_eq_pair cfst_def)
 
 lemma csnd_cpair [simp]: "csnd\<cdot><x, y> = y"
-by (simp add: cpair_eq_pair csnd_def cont_snd)
+by (simp add: cpair_eq_pair csnd_def)
 
 lemma cfst_strict [simp]: "cfst\<cdot>\<bottom> = \<bottom>"
 by (simp add: cfst_def)
@@ -107,23 +107,23 @@
 
 lemmas surjective_pairing_Cprod2 = cpair_cfst_csnd
 
-lemma less_cprod: "x \<sqsubseteq> y = (cfst\<cdot>x \<sqsubseteq> cfst\<cdot>y \<and> csnd\<cdot>x \<sqsubseteq> csnd\<cdot>y)"
-by (simp add: less_cprod_def cfst_def csnd_def cont_fst cont_snd)
+lemma below_cprod: "x \<sqsubseteq> y = (cfst\<cdot>x \<sqsubseteq> cfst\<cdot>y \<and> csnd\<cdot>x \<sqsubseteq> csnd\<cdot>y)"
+by (simp add: below_prod_def cfst_def csnd_def)
 
 lemma eq_cprod: "(x = y) = (cfst\<cdot>x = cfst\<cdot>y \<and> csnd\<cdot>x = csnd\<cdot>y)"
-by (auto simp add: po_eq_conv less_cprod)
+by (auto simp add: po_eq_conv below_cprod)
 
-lemma cfst_less_iff: "cfst\<cdot>x \<sqsubseteq> y = x \<sqsubseteq> <y, csnd\<cdot>x>"
-by (simp add: less_cprod)
+lemma cfst_below_iff: "cfst\<cdot>x \<sqsubseteq> y = x \<sqsubseteq> <y, csnd\<cdot>x>"
+by (simp add: below_cprod)
 
-lemma csnd_less_iff: "csnd\<cdot>x \<sqsubseteq> y = x \<sqsubseteq> <cfst\<cdot>x, y>"
-by (simp add: less_cprod)
+lemma csnd_below_iff: "csnd\<cdot>x \<sqsubseteq> y = x \<sqsubseteq> <cfst\<cdot>x, y>"
+by (simp add: below_cprod)
 
 lemma compact_cfst: "compact x \<Longrightarrow> compact (cfst\<cdot>x)"
-by (rule compactI, simp add: cfst_less_iff)
+by (rule compactI, simp add: cfst_below_iff)
 
 lemma compact_csnd: "compact x \<Longrightarrow> compact (csnd\<cdot>x)"
-by (rule compactI, simp add: csnd_less_iff)
+by (rule compactI, simp add: csnd_below_iff)
 
 lemma compact_cpair: "\<lbrakk>compact x; compact y\<rbrakk> \<Longrightarrow> compact <x, y>"
 by (simp add: cpair_eq_pair)
@@ -133,7 +133,7 @@
 
 lemma lub_cprod2: 
   "chain S \<Longrightarrow> range S <<| <\<Squnion>i. cfst\<cdot>(S i), \<Squnion>i. csnd\<cdot>(S i)>"
-apply (simp add: cpair_eq_pair cfst_def csnd_def cont_fst cont_snd)
+apply (simp add: cpair_eq_pair cfst_def csnd_def)
 apply (erule lub_cprod)
 done
 
@@ -154,38 +154,9 @@
 
 subsection {* Product type is a bifinite domain *}
 
-instantiation "*" :: (profinite, profinite) profinite
-begin
-
-definition
-  approx_cprod_def:
-    "approx = (\<lambda>n. \<Lambda>\<langle>x, y\<rangle>. \<langle>approx n\<cdot>x, approx n\<cdot>y\<rangle>)"
-
-instance proof
-  fix i :: nat and x :: "'a \<times> 'b"
-  show "chain (approx :: nat \<Rightarrow> 'a \<times> 'b \<rightarrow> 'a \<times> 'b)"
-    unfolding approx_cprod_def by simp
-  show "(\<Squnion>i. approx i\<cdot>x) = x"
-    unfolding approx_cprod_def
-    by (simp add: lub_distribs eta_cfun)
-  show "approx i\<cdot>(approx i\<cdot>x) = approx i\<cdot>x"
-    unfolding approx_cprod_def csplit_def by simp
-  have "{x::'a \<times> 'b. approx i\<cdot>x = x} \<subseteq>
-        {x::'a. approx i\<cdot>x = x} \<times> {x::'b. approx i\<cdot>x = x}"
-    unfolding approx_cprod_def
-    by (clarsimp simp add: pair_eq_cpair)
-  thus "finite {x::'a \<times> 'b. approx i\<cdot>x = x}"
-    by (rule finite_subset,
-        intro finite_cartesian_product finite_fixes_approx)
-qed
-
-end
-
-instance "*" :: (bifinite, bifinite) bifinite ..
-
 lemma approx_cpair [simp]:
   "approx i\<cdot>\<langle>x, y\<rangle> = \<langle>approx i\<cdot>x, approx i\<cdot>y\<rangle>"
-unfolding approx_cprod_def by simp
+by (simp add: cpair_eq_pair)
 
 lemma cfst_approx: "cfst\<cdot>(approx i\<cdot>p) = approx i\<cdot>(cfst\<cdot>p)"
 by (cases p rule: cprodE, simp)

--- a/src/HOLCF/Deflation.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Deflation.thy	Fri May 15 15:56:28 2009 +0200
@@ -15,11 +15,11 @@
 locale deflation =
   fixes d :: "'a \<rightarrow> 'a"
   assumes idem: "\<And>x. d\<cdot>(d\<cdot>x) = d\<cdot>x"
-  assumes less: "\<And>x. d\<cdot>x \<sqsubseteq> x"
+  assumes below: "\<And>x. d\<cdot>x \<sqsubseteq> x"
 begin
 
-lemma less_ID: "d \<sqsubseteq> ID"
-by (rule less_cfun_ext, simp add: less)
+lemma below_ID: "d \<sqsubseteq> ID"
+by (rule below_cfun_ext, simp add: below)
 
 text {* The set of fixed points is the same as the range. *}
 
@@ -34,18 +34,18 @@
   the subset ordering of their sets of fixed-points.
 *}
 
-lemma lessI:
+lemma belowI:
   assumes f: "\<And>x. d\<cdot>x = x \<Longrightarrow> f\<cdot>x = x" shows "d \<sqsubseteq> f"
-proof (rule less_cfun_ext)
+proof (rule below_cfun_ext)
   fix x
-  from less have "f\<cdot>(d\<cdot>x) \<sqsubseteq> f\<cdot>x" by (rule monofun_cfun_arg)
+  from below have "f\<cdot>(d\<cdot>x) \<sqsubseteq> f\<cdot>x" by (rule monofun_cfun_arg)
   also from idem have "f\<cdot>(d\<cdot>x) = d\<cdot>x" by (rule f)
   finally show "d\<cdot>x \<sqsubseteq> f\<cdot>x" .
 qed
 
-lemma lessD: "\<lbrakk>f \<sqsubseteq> d; f\<cdot>x = x\<rbrakk> \<Longrightarrow> d\<cdot>x = x"
-proof (rule antisym_less)
-  from less show "d\<cdot>x \<sqsubseteq> x" .
+lemma belowD: "\<lbrakk>f \<sqsubseteq> d; f\<cdot>x = x\<rbrakk> \<Longrightarrow> d\<cdot>x = x"
+proof (rule below_antisym)
+  from below show "d\<cdot>x \<sqsubseteq> x" .
 next
   assume "f \<sqsubseteq> d"
   hence "f\<cdot>x \<sqsubseteq> d\<cdot>x" by (rule monofun_cfun_fun)
@@ -64,11 +64,11 @@
 lemma deflation_UU: "deflation \<bottom>"
 by (simp add: deflation.intro)
 
-lemma deflation_less_iff:
+lemma deflation_below_iff:
   "\<lbrakk>deflation p; deflation q\<rbrakk> \<Longrightarrow> p \<sqsubseteq> q \<longleftrightarrow> (\<forall>x. p\<cdot>x = x \<longrightarrow> q\<cdot>x = x)"
  apply safe
-  apply (simp add: deflation.lessD)
- apply (simp add: deflation.lessI)
+  apply (simp add: deflation.belowD)
+ apply (simp add: deflation.belowI)
 done
 
 text {*
@@ -76,13 +76,13 @@
   the lesser of the two (if they are comparable).
 *}
 
-lemma deflation_less_comp1:
+lemma deflation_below_comp1:
   assumes "deflation f"
   assumes "deflation g"
   shows "f \<sqsubseteq> g \<Longrightarrow> f\<cdot>(g\<cdot>x) = f\<cdot>x"
-proof (rule antisym_less)
+proof (rule below_antisym)
   interpret g: deflation g by fact
-  from g.less show "f\<cdot>(g\<cdot>x) \<sqsubseteq> f\<cdot>x" by (rule monofun_cfun_arg)
+  from g.below show "f\<cdot>(g\<cdot>x) \<sqsubseteq> f\<cdot>x" by (rule monofun_cfun_arg)
 next
   interpret f: deflation f by fact
   assume "f \<sqsubseteq> g" hence "f\<cdot>x \<sqsubseteq> g\<cdot>x" by (rule monofun_cfun_fun)
@@ -91,9 +91,9 @@
   finally show "f\<cdot>x \<sqsubseteq> f\<cdot>(g\<cdot>x)" .
 qed
 
-lemma deflation_less_comp2:
+lemma deflation_below_comp2:
   "\<lbrakk>deflation f; deflation g; f \<sqsubseteq> g\<rbrakk> \<Longrightarrow> g\<cdot>(f\<cdot>x) = f\<cdot>x"
-by (simp only: deflation.lessD deflation.idem)
+by (simp only: deflation.belowD deflation.idem)
 
 
 subsection {* Deflations with finite range *}
@@ -143,7 +143,7 @@
   hence "d\<cdot>x \<sqsubseteq> d\<cdot>(Y j)"
     using j by simp
   hence "d\<cdot>x \<sqsubseteq> Y j"
-    using less by (rule trans_less)
+    using below by (rule below_trans)
   thus "\<exists>j. d\<cdot>x \<sqsubseteq> Y j" ..
 qed
 
@@ -155,10 +155,10 @@
 locale ep_pair =
   fixes e :: "'a \<rightarrow> 'b" and p :: "'b \<rightarrow> 'a"
   assumes e_inverse [simp]: "\<And>x. p\<cdot>(e\<cdot>x) = x"
-  and e_p_less: "\<And>y. e\<cdot>(p\<cdot>y) \<sqsubseteq> y"
+  and e_p_below: "\<And>y. e\<cdot>(p\<cdot>y) \<sqsubseteq> y"
 begin
 
-lemma e_less_iff [simp]: "e\<cdot>x \<sqsubseteq> e\<cdot>y \<longleftrightarrow> x \<sqsubseteq> y"
+lemma e_below_iff [simp]: "e\<cdot>x \<sqsubseteq> e\<cdot>y \<longleftrightarrow> x \<sqsubseteq> y"
 proof
   assume "e\<cdot>x \<sqsubseteq> e\<cdot>y"
   hence "p\<cdot>(e\<cdot>x) \<sqsubseteq> p\<cdot>(e\<cdot>y)" by (rule monofun_cfun_arg)
@@ -169,7 +169,7 @@
 qed
 
 lemma e_eq_iff [simp]: "e\<cdot>x = e\<cdot>y \<longleftrightarrow> x = y"
-unfolding po_eq_conv e_less_iff ..
+unfolding po_eq_conv e_below_iff ..
 
 lemma p_eq_iff:
   "\<lbrakk>e\<cdot>(p\<cdot>x) = x; e\<cdot>(p\<cdot>y) = y\<rbrakk> \<Longrightarrow> p\<cdot>x = p\<cdot>y \<longleftrightarrow> x = y"
@@ -178,7 +178,7 @@
 lemma p_inverse: "(\<exists>x. y = e\<cdot>x) = (e\<cdot>(p\<cdot>y) = y)"
 by (auto, rule exI, erule sym)
 
-lemma e_less_iff_less_p: "e\<cdot>x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> p\<cdot>y"
+lemma e_below_iff_below_p: "e\<cdot>x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> p\<cdot>y"
 proof
   assume "e\<cdot>x \<sqsubseteq> y"
   then have "p\<cdot>(e\<cdot>x) \<sqsubseteq> p\<cdot>y" by (rule monofun_cfun_arg)
@@ -186,7 +186,7 @@
 next
   assume "x \<sqsubseteq> p\<cdot>y"
   then have "e\<cdot>x \<sqsubseteq> e\<cdot>(p\<cdot>y)" by (rule monofun_cfun_arg)
-  then show "e\<cdot>x \<sqsubseteq> y" using e_p_less by (rule trans_less)
+  then show "e\<cdot>x \<sqsubseteq> y" using e_p_below by (rule below_trans)
 qed
 
 lemma compact_e_rev: "compact (e\<cdot>x) \<Longrightarrow> compact x"
@@ -203,7 +203,7 @@
   assume "compact x"
   hence "adm (\<lambda>y. \<not> x \<sqsubseteq> y)" by (rule compactD)
   hence "adm (\<lambda>y. \<not> x \<sqsubseteq> p\<cdot>y)" by (rule adm_subst [OF cont_Rep_CFun2])
-  hence "adm (\<lambda>y. \<not> e\<cdot>x \<sqsubseteq> y)" by (simp add: e_less_iff_less_p)
+  hence "adm (\<lambda>y. \<not> e\<cdot>x \<sqsubseteq> y)" by (simp add: e_below_iff_below_p)
   thus "compact (e\<cdot>x)" by (rule compactI)
 qed
 
@@ -213,7 +213,7 @@
 text {* Deflations from ep-pairs *}
 
 lemma deflation_e_p: "deflation (e oo p)"
-by (simp add: deflation.intro e_p_less)
+by (simp add: deflation.intro e_p_below)
 
 lemma deflation_e_d_p:
   assumes "deflation d"
@@ -224,7 +224,7 @@
   show "(e oo d oo p)\<cdot>((e oo d oo p)\<cdot>x) = (e oo d oo p)\<cdot>x"
     by (simp add: idem)
   show "(e oo d oo p)\<cdot>x \<sqsubseteq> x"
-    by (simp add: e_less_iff_less_p less)
+    by (simp add: e_below_iff_below_p below)
 qed
 
 lemma finite_deflation_e_d_p:
@@ -236,7 +236,7 @@
   show "(e oo d oo p)\<cdot>((e oo d oo p)\<cdot>x) = (e oo d oo p)\<cdot>x"
     by (simp add: idem)
   show "(e oo d oo p)\<cdot>x \<sqsubseteq> x"
-    by (simp add: e_less_iff_less_p less)
+    by (simp add: e_below_iff_below_p below)
   have "finite ((\<lambda>x. e\<cdot>x) ` (\<lambda>x. d\<cdot>x) ` range (\<lambda>x. p\<cdot>x))"
     by (simp add: finite_image)
   hence "finite (range (\<lambda>x. (e oo d oo p)\<cdot>x))"
@@ -254,24 +254,24 @@
   {
     fix x
     have "d\<cdot>(e\<cdot>x) \<sqsubseteq> e\<cdot>x"
-      by (rule d.less)
+      by (rule d.below)
     hence "p\<cdot>(d\<cdot>(e\<cdot>x)) \<sqsubseteq> p\<cdot>(e\<cdot>x)"
       by (rule monofun_cfun_arg)
     hence "(p oo d oo e)\<cdot>x \<sqsubseteq> x"
       by simp
   }
-  note p_d_e_less = this
+  note p_d_e_below = this
   show ?thesis
   proof
     fix x
     show "(p oo d oo e)\<cdot>x \<sqsubseteq> x"
-      by (rule p_d_e_less)
+      by (rule p_d_e_below)
   next
     fix x
     show "(p oo d oo e)\<cdot>((p oo d oo e)\<cdot>x) = (p oo d oo e)\<cdot>x"
-    proof (rule antisym_less)
+    proof (rule below_antisym)
       show "(p oo d oo e)\<cdot>((p oo d oo e)\<cdot>x) \<sqsubseteq> (p oo d oo e)\<cdot>x"
-        by (rule p_d_e_less)
+        by (rule p_d_e_below)
       have "p\<cdot>(d\<cdot>(d\<cdot>(d\<cdot>(e\<cdot>x)))) \<sqsubseteq> p\<cdot>(d\<cdot>(e\<cdot>(p\<cdot>(d\<cdot>(e\<cdot>x)))))"
         by (intro monofun_cfun_arg d)
       hence "p\<cdot>(d\<cdot>(e\<cdot>x)) \<sqsubseteq> p\<cdot>(d\<cdot>(e\<cdot>(p\<cdot>(d\<cdot>(e\<cdot>x)))))"
@@ -315,29 +315,29 @@
 lemma ep_pair_unique_e_lemma:
   assumes "ep_pair e1 p" and "ep_pair e2 p"
   shows "e1 \<sqsubseteq> e2"
-proof (rule less_cfun_ext)
+proof (rule below_cfun_ext)
   interpret e1: ep_pair e1 p by fact
   interpret e2: ep_pair e2 p by fact
   fix x
   have "e1\<cdot>(p\<cdot>(e2\<cdot>x)) \<sqsubseteq> e2\<cdot>x"
-    by (rule e1.e_p_less)
+    by (rule e1.e_p_below)
   thus "e1\<cdot>x \<sqsubseteq> e2\<cdot>x"
     by (simp only: e2.e_inverse)
 qed
 
 lemma ep_pair_unique_e:
   "\<lbrakk>ep_pair e1 p; ep_pair e2 p\<rbrakk> \<Longrightarrow> e1 = e2"
-by (fast intro: antisym_less elim: ep_pair_unique_e_lemma)
+by (fast intro: below_antisym elim: ep_pair_unique_e_lemma)
 
 lemma ep_pair_unique_p_lemma:
   assumes "ep_pair e p1" and "ep_pair e p2"
   shows "p1 \<sqsubseteq> p2"
-proof (rule less_cfun_ext)
+proof (rule below_cfun_ext)
   interpret p1: ep_pair e p1 by fact
   interpret p2: ep_pair e p2 by fact
   fix x
   have "e\<cdot>(p1\<cdot>x) \<sqsubseteq> x"
-    by (rule p1.e_p_less)
+    by (rule p1.e_p_below)
   hence "p2\<cdot>(e\<cdot>(p1\<cdot>x)) \<sqsubseteq> p2\<cdot>x"
     by (rule monofun_cfun_arg)
   thus "p1\<cdot>x \<sqsubseteq> p2\<cdot>x"
@@ -346,7 +346,7 @@
 
 lemma ep_pair_unique_p:
   "\<lbrakk>ep_pair e p1; ep_pair e p2\<rbrakk> \<Longrightarrow> p1 = p2"
-by (fast intro: antisym_less elim: ep_pair_unique_p_lemma)
+by (fast intro: below_antisym elim: ep_pair_unique_p_lemma)
 
 subsection {* Composing ep-pairs *}
 
@@ -363,11 +363,11 @@
   show "(p1 oo p2)\<cdot>((e2 oo e1)\<cdot>x) = x"
     by simp
   have "e1\<cdot>(p1\<cdot>(p2\<cdot>y)) \<sqsubseteq> p2\<cdot>y"
-    by (rule ep1.e_p_less)
+    by (rule ep1.e_p_below)
   hence "e2\<cdot>(e1\<cdot>(p1\<cdot>(p2\<cdot>y))) \<sqsubseteq> e2\<cdot>(p2\<cdot>y)"
     by (rule monofun_cfun_arg)
   also have "e2\<cdot>(p2\<cdot>y) \<sqsubseteq> y"
-    by (rule ep2.e_p_less)
+    by (rule ep2.e_p_below)
   finally show "(e2 oo e1)\<cdot>((p1 oo p2)\<cdot>y) \<sqsubseteq> y"
     by simp
 qed
@@ -381,7 +381,7 @@
 proof -
   have "\<bottom> \<sqsubseteq> p\<cdot>\<bottom>" by (rule minimal)
   hence "e\<cdot>\<bottom> \<sqsubseteq> e\<cdot>(p\<cdot>\<bottom>)" by (rule monofun_cfun_arg)
-  also have "e\<cdot>(p\<cdot>\<bottom>) \<sqsubseteq> \<bottom>" by (rule e_p_less)
+  also have "e\<cdot>(p\<cdot>\<bottom>) \<sqsubseteq> \<bottom>" by (rule e_p_below)
   finally show "e\<cdot>\<bottom> = \<bottom>" by simp
 qed
 

--- a/src/HOLCF/Discrete.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Discrete.thy	Fri May 15 15:56:28 2009 +0200
@@ -12,21 +12,21 @@
 
 subsection {* Type @{typ "'a discr"} is a discrete cpo *}
 
-instantiation discr :: (type) sq_ord
+instantiation discr :: (type) below
 begin
 
 definition
-  less_discr_def:
+  below_discr_def:
     "(op \<sqsubseteq> :: 'a discr \<Rightarrow> 'a discr \<Rightarrow> bool) = (op =)"
 
 instance ..
 end
 
 instance discr :: (type) discrete_cpo
-by intro_classes (simp add: less_discr_def)
+by intro_classes (simp add: below_discr_def)
 
-lemma discr_less_eq [iff]: "((x::('a::type)discr) << y) = (x = y)"
-by simp
+lemma discr_below_eq [iff]: "((x::('a::type)discr) << y) = (x = y)"
+by simp (* FIXME: same discrete_cpo - remove? is [iff] important? *)
 
 subsection {* Type @{typ "'a discr"} is a cpo *}
 

--- a/src/HOLCF/Domain.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Domain.thy	Fri May 15 15:56:28 2009 +0200
@@ -6,6 +6,14 @@
 
 theory Domain
 imports Ssum Sprod Up One Tr Fixrec
+uses
+  ("Tools/cont_consts.ML")
+  ("Tools/cont_proc.ML")
+  ("Tools/domain/domain_library.ML")
+  ("Tools/domain/domain_syntax.ML")
+  ("Tools/domain/domain_axioms.ML")
+  ("Tools/domain/domain_theorems.ML")
+  ("Tools/domain/domain_extender.ML")
 begin
 
 defaultsort pcpo
@@ -25,7 +33,7 @@
 lemma swap: "iso rep abs"
   by (rule iso.intro [OF rep_iso abs_iso])
 
-lemma abs_less: "(abs\<cdot>x \<sqsubseteq> abs\<cdot>y) = (x \<sqsubseteq> y)"
+lemma abs_below: "(abs\<cdot>x \<sqsubseteq> abs\<cdot>y) = (x \<sqsubseteq> y)"
 proof
   assume "abs\<cdot>x \<sqsubseteq> abs\<cdot>y"
   then have "rep\<cdot>(abs\<cdot>x) \<sqsubseteq> rep\<cdot>(abs\<cdot>y)" by (rule monofun_cfun_arg)
@@ -35,11 +43,11 @@
   then show "abs\<cdot>x \<sqsubseteq> abs\<cdot>y" by (rule monofun_cfun_arg)
 qed
 
-lemma rep_less: "(rep\<cdot>x \<sqsubseteq> rep\<cdot>y) = (x \<sqsubseteq> y)"
-  by (rule iso.abs_less [OF swap])
+lemma rep_below: "(rep\<cdot>x \<sqsubseteq> rep\<cdot>y) = (x \<sqsubseteq> y)"
+  by (rule iso.abs_below [OF swap])
 
 lemma abs_eq: "(abs\<cdot>x = abs\<cdot>y) = (x = y)"
-  by (simp add: po_eq_conv abs_less)
+  by (simp add: po_eq_conv abs_below)
 
 lemma rep_eq: "(rep\<cdot>x = rep\<cdot>y) = (x = y)"
   by (rule iso.abs_eq [OF swap])
@@ -83,7 +91,7 @@
   assume "adm (\<lambda>y. \<not> abs\<cdot>x \<sqsubseteq> y)"
   with cont_Rep_CFun2
   have "adm (\<lambda>y. \<not> abs\<cdot>x \<sqsubseteq> abs\<cdot>y)" by (rule adm_subst)
-  then show "adm (\<lambda>y. \<not> x \<sqsubseteq> y)" using abs_less by simp
+  then show "adm (\<lambda>y. \<not> x \<sqsubseteq> y)" using abs_below by simp
 qed
 
 lemma compact_rep_rev: "compact (rep\<cdot>x) \<Longrightarrow> compact x"
@@ -193,4 +201,24 @@
 
 lemmas exh_casedists = exh_casedist1 exh_casedist2 exh_casedist3
 
+
+subsection {* Installing the domain package *}
+
+lemmas con_strict_rules =
+  sinl_strict sinr_strict spair_strict1 spair_strict2
+
+lemmas con_defin_rules =
+  sinl_defined sinr_defined spair_defined up_defined ONE_defined
+
+lemmas con_defined_iff_rules =
+  sinl_defined_iff sinr_defined_iff spair_strict_iff up_defined ONE_defined
+
+use "Tools/cont_consts.ML"
+use "Tools/cont_proc.ML"
+use "Tools/domain/domain_library.ML"
+use "Tools/domain/domain_syntax.ML"
+use "Tools/domain/domain_axioms.ML"
+use "Tools/domain/domain_theorems.ML"
+use "Tools/domain/domain_extender.ML"
+
 end

--- a/src/HOLCF/FOCUS/Stream_adm.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/FOCUS/Stream_adm.thy	Fri May 15 15:56:28 2009 +0200
@@ -50,11 +50,7 @@
 apply (   erule spec)
 apply (  assumption)
 apply ( assumption)
-apply (drule not_ex [THEN iffD1])
-apply (subst slen_infinite)
-apply (erule thin_rl)
-apply (erule_tac x = j in allE)
-apply auto
+apply (metis inat_ord_code(4) slen_infinite)
 done
 
 (* should be without reference to stream length? *)

--- a/src/HOLCF/Ffun.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Ffun.thy	Fri May 15 15:56:28 2009 +0200
@@ -10,11 +10,11 @@
 
 subsection {* Full function space is a partial order *}
 
-instantiation "fun"  :: (type, sq_ord) sq_ord
+instantiation "fun"  :: (type, below) below
 begin
 
 definition
-  less_fun_def: "(op \<sqsubseteq>) \<equiv> (\<lambda>f g. \<forall>x. f x \<sqsubseteq> g x)"  
+  below_fun_def: "(op \<sqsubseteq>) \<equiv> (\<lambda>f g. \<forall>x. f x \<sqsubseteq> g x)"
 
 instance ..
 end
@@ -23,45 +23,45 @@
 proof
   fix f :: "'a \<Rightarrow> 'b"
   show "f \<sqsubseteq> f"
-    by (simp add: less_fun_def)
+    by (simp add: below_fun_def)
 next
   fix f g :: "'a \<Rightarrow> 'b"
   assume "f \<sqsubseteq> g" and "g \<sqsubseteq> f" thus "f = g"
-    by (simp add: less_fun_def expand_fun_eq antisym_less)
+    by (simp add: below_fun_def expand_fun_eq below_antisym)
 next
   fix f g h :: "'a \<Rightarrow> 'b"
   assume "f \<sqsubseteq> g" and "g \<sqsubseteq> h" thus "f \<sqsubseteq> h"
-    unfolding less_fun_def by (fast elim: trans_less)
+    unfolding below_fun_def by (fast elim: below_trans)
 qed
 
 text {* make the symbol @{text "<<"} accessible for type fun *}
 
-lemma expand_fun_less: "(f \<sqsubseteq> g) = (\<forall>x. f x \<sqsubseteq> g x)"
-by (simp add: less_fun_def)
+lemma expand_fun_below: "(f \<sqsubseteq> g) = (\<forall>x. f x \<sqsubseteq> g x)"
+by (simp add: below_fun_def)
 
-lemma less_fun_ext: "(\<And>x. f x \<sqsubseteq> g x) \<Longrightarrow> f \<sqsubseteq> g"
-by (simp add: less_fun_def)
+lemma below_fun_ext: "(\<And>x. f x \<sqsubseteq> g x) \<Longrightarrow> f \<sqsubseteq> g"
+by (simp add: below_fun_def)
 
 subsection {* Full function space is chain complete *}
 
 text {* function application is monotone *}
 
 lemma monofun_app: "monofun (\<lambda>f. f x)"
-by (rule monofunI, simp add: less_fun_def)
+by (rule monofunI, simp add: below_fun_def)
 
 text {* chains of functions yield chains in the po range *}
 
 lemma ch2ch_fun: "chain S \<Longrightarrow> chain (\<lambda>i. S i x)"
-by (simp add: chain_def less_fun_def)
+by (simp add: chain_def below_fun_def)
 
 lemma ch2ch_lambda: "(\<And>x. chain (\<lambda>i. S i x)) \<Longrightarrow> chain S"
-by (simp add: chain_def less_fun_def)
+by (simp add: chain_def below_fun_def)
 
 text {* upper bounds of function chains yield upper bound in the po range *}
 
 lemma ub2ub_fun:
   "range S <| u \<Longrightarrow> range (\<lambda>i. S i x) <| u x"
-by (auto simp add: is_ub_def less_fun_def)
+by (auto simp add: is_ub_def below_fun_def)
 
 text {* Type @{typ "'a::type => 'b::cpo"} is chain complete *}
 
@@ -70,9 +70,9 @@
   shows "range Y <<| f"
 apply (rule is_lubI)
 apply (rule ub_rangeI)
-apply (rule less_fun_ext)
+apply (rule below_fun_ext)
 apply (rule is_ub_lub [OF f])
-apply (rule less_fun_ext)
+apply (rule below_fun_ext)
 apply (rule is_lub_lub [OF f])
 apply (erule ub2ub_fun)
 done
@@ -103,7 +103,7 @@
 proof
   fix f g :: "'a \<Rightarrow> 'b"
   show "f \<sqsubseteq> g \<longleftrightarrow> f = g" 
-    unfolding expand_fun_less expand_fun_eq
+    unfolding expand_fun_below expand_fun_eq
     by simp
 qed
 
@@ -148,7 +148,7 @@
 subsection {* Full function space is pointed *}
 
 lemma minimal_fun: "(\<lambda>x. \<bottom>) \<sqsubseteq> f"
-by (simp add: less_fun_def)
+by (simp add: below_fun_def)
 
 lemma least_fun: "\<exists>x::'a::type \<Rightarrow> 'b::pcpo. \<forall>y. x \<sqsubseteq> y"
 apply (rule_tac x = "\<lambda>x. \<bottom>" in exI)
@@ -171,13 +171,13 @@
 *}
 
 lemma monofun_fun_fun: "f \<sqsubseteq> g \<Longrightarrow> f x \<sqsubseteq> g x"
-by (simp add: less_fun_def)
+by (simp add: below_fun_def)
 
 lemma monofun_fun_arg: "\<lbrakk>monofun f; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> f x \<sqsubseteq> f y"
 by (rule monofunE)
 
 lemma monofun_fun: "\<lbrakk>monofun f; monofun g; f \<sqsubseteq> g; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> f x \<sqsubseteq> g y"
-by (rule trans_less [OF monofun_fun_arg monofun_fun_fun])
+by (rule below_trans [OF monofun_fun_arg monofun_fun_fun])
 
 subsection {* Propagation of monotonicity and continuity *}
 
@@ -236,7 +236,7 @@
 lemma mono2mono_lambda:
   assumes f: "\<And>y. monofun (\<lambda>x. f x y)" shows "monofun f"
 apply (rule monofunI)
-apply (rule less_fun_ext)
+apply (rule below_fun_ext)
 apply (erule monofunE [OF f])
 done
 
@@ -296,4 +296,3 @@
 by (rule cont2cont_app2 [OF cont_const])
 
 end
-

--- a/src/HOLCF/Fix.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Fix.thy	Fri May 15 15:56:28 2009 +0200
@@ -90,7 +90,7 @@
 apply simp
 done
 
-lemma fix_least_less: "F\<cdot>x \<sqsubseteq> x \<Longrightarrow> fix\<cdot>F \<sqsubseteq> x"
+lemma fix_least_below: "F\<cdot>x \<sqsubseteq> x \<Longrightarrow> fix\<cdot>F \<sqsubseteq> x"
 apply (simp add: fix_def2)
 apply (rule is_lub_thelub)
 apply (rule chain_iterate)
@@ -98,17 +98,17 @@
 apply (induct_tac i)
 apply simp
 apply simp
-apply (erule rev_trans_less)
+apply (erule rev_below_trans)
 apply (erule monofun_cfun_arg)
 done
 
 lemma fix_least: "F\<cdot>x = x \<Longrightarrow> fix\<cdot>F \<sqsubseteq> x"
-by (rule fix_least_less, simp)
+by (rule fix_least_below, simp)
 
 lemma fix_eqI:
   assumes fixed: "F\<cdot>x = x" and least: "\<And>z. F\<cdot>z = z \<Longrightarrow> x \<sqsubseteq> z"
   shows "fix\<cdot>F = x"
-apply (rule antisym_less)
+apply (rule below_antisym)
 apply (rule fix_least [OF fixed])
 apply (rule least [OF fix_eq [symmetric]])
 done
@@ -230,10 +230,10 @@
   have "?y1 \<sqsubseteq> y" by (rule fix_least, simp add: F_y)
   hence "cfst\<cdot>(F\<cdot>\<langle>x, ?y1\<rangle>) \<sqsubseteq> cfst\<cdot>(F\<cdot>\<langle>x, y\<rangle>)" by (simp add: monofun_cfun)
   hence "cfst\<cdot>(F\<cdot>\<langle>x, ?y1\<rangle>) \<sqsubseteq> x" using F_x by simp
-  hence 1: "?x \<sqsubseteq> x" by (simp add: fix_least_less)
+  hence 1: "?x \<sqsubseteq> x" by (simp add: fix_least_below)
   hence "csnd\<cdot>(F\<cdot>\<langle>?x, y\<rangle>) \<sqsubseteq> csnd\<cdot>(F\<cdot>\<langle>x, y\<rangle>)" by (simp add: monofun_cfun)
   hence "csnd\<cdot>(F\<cdot>\<langle>?x, y\<rangle>) \<sqsubseteq> y" using F_y by simp
-  hence 2: "?y \<sqsubseteq> y" by (simp add: fix_least_less)
+  hence 2: "?y \<sqsubseteq> y" by (simp add: fix_least_below)
   show "\<langle>?x, ?y\<rangle> \<sqsubseteq> z" using z 1 2 by simp
 qed
 

--- a/src/HOLCF/Fixrec.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Fixrec.thy	Fri May 15 15:56:28 2009 +0200
@@ -475,86 +475,96 @@
 defaultsort pcpo
 
 definition
-  match_UU :: "'a \<rightarrow> unit maybe" where
-  "match_UU = (\<Lambda> x. fail)"
+  match_UU :: "'a \<rightarrow> 'c maybe \<rightarrow> 'c maybe"
+where
+  "match_UU = strictify\<cdot>(\<Lambda> x k. fail)"
 
 definition
-  match_cpair :: "'a::cpo \<times> 'b::cpo \<rightarrow> ('a \<times> 'b) maybe" where
-  "match_cpair = csplit\<cdot>(\<Lambda> x y. return\<cdot><x,y>)"
+  match_cpair :: "'a::cpo \<times> 'b::cpo \<rightarrow> ('a \<rightarrow> 'b \<rightarrow> 'c maybe) \<rightarrow> 'c maybe"
+where
+  "match_cpair = (\<Lambda> x k. csplit\<cdot>k\<cdot>x)"
 
 definition
-  match_spair :: "'a \<otimes> 'b \<rightarrow> ('a \<times> 'b) maybe" where
-  "match_spair = ssplit\<cdot>(\<Lambda> x y. return\<cdot><x,y>)"
+  match_spair :: "'a \<otimes> 'b \<rightarrow> ('a \<rightarrow> 'b \<rightarrow> 'c maybe) \<rightarrow> 'c maybe"
+where
+  "match_spair = (\<Lambda> x k. ssplit\<cdot>k\<cdot>x)"
 
 definition
-  match_sinl :: "'a \<oplus> 'b \<rightarrow> 'a maybe" where
-  "match_sinl = sscase\<cdot>return\<cdot>(\<Lambda> y. fail)"
+  match_sinl :: "'a \<oplus> 'b \<rightarrow> ('a \<rightarrow> 'c maybe) \<rightarrow> 'c maybe"
+where
+  "match_sinl = (\<Lambda> x k. sscase\<cdot>k\<cdot>(\<Lambda> b. fail)\<cdot>x)"
 
 definition
-  match_sinr :: "'a \<oplus> 'b \<rightarrow> 'b maybe" where
-  "match_sinr = sscase\<cdot>(\<Lambda> x. fail)\<cdot>return"
+  match_sinr :: "'a \<oplus> 'b \<rightarrow> ('b \<rightarrow> 'c maybe) \<rightarrow> 'c maybe"
+where
+  "match_sinr = (\<Lambda> x k. sscase\<cdot>(\<Lambda> a. fail)\<cdot>k\<cdot>x)"
 
 definition
-  match_up :: "'a::cpo u \<rightarrow> 'a maybe" where
-  "match_up = fup\<cdot>return"
+  match_up :: "'a::cpo u \<rightarrow> ('a \<rightarrow> 'c maybe) \<rightarrow> 'c maybe"
+where
+  "match_up = (\<Lambda> x k. fup\<cdot>k\<cdot>x)"
 
 definition
-  match_ONE :: "one \<rightarrow> unit maybe" where
-  "match_ONE = (\<Lambda> ONE. return\<cdot>())"
+  match_ONE :: "one \<rightarrow> 'c maybe \<rightarrow> 'c maybe"
+where
+  "match_ONE = (\<Lambda> ONE k. k)"
+
+definition
+  match_TT :: "tr \<rightarrow> 'c maybe \<rightarrow> 'c maybe"
+where
+  "match_TT = (\<Lambda> x k. If x then k else fail fi)"
  
 definition
-  match_TT :: "tr \<rightarrow> unit maybe" where
-  "match_TT = (\<Lambda> b. If b then return\<cdot>() else fail fi)"
- 
-definition
-  match_FF :: "tr \<rightarrow> unit maybe" where
-  "match_FF = (\<Lambda> b. If b then fail else return\<cdot>() fi)"
+  match_FF :: "tr \<rightarrow> 'c maybe \<rightarrow> 'c maybe"
+where
+  "match_FF = (\<Lambda> x k. If x then fail else k fi)"
 
 lemma match_UU_simps [simp]:
-  "match_UU\<cdot>x = fail"
-by (simp add: match_UU_def)
+  "match_UU\<cdot>\<bottom>\<cdot>k = \<bottom>"
+  "x \<noteq> \<bottom> \<Longrightarrow> match_UU\<cdot>x\<cdot>k = fail"
+by (simp_all add: match_UU_def)
 
 lemma match_cpair_simps [simp]:
-  "match_cpair\<cdot><x,y> = return\<cdot><x,y>"
+  "match_cpair\<cdot>\<langle>x, y\<rangle>\<cdot>k = k\<cdot>x\<cdot>y"
 by (simp add: match_cpair_def)
 
 lemma match_spair_simps [simp]:
-  "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> match_spair\<cdot>(:x,y:) = return\<cdot><x,y>"
-  "match_spair\<cdot>\<bottom> = \<bottom>"
+  "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> match_spair\<cdot>(:x, y:)\<cdot>k = k\<cdot>x\<cdot>y"
+  "match_spair\<cdot>\<bottom>\<cdot>k = \<bottom>"
 by (simp_all add: match_spair_def)
 
 lemma match_sinl_simps [simp]:
-  "x \<noteq> \<bottom> \<Longrightarrow> match_sinl\<cdot>(sinl\<cdot>x) = return\<cdot>x"
-  "x \<noteq> \<bottom> \<Longrightarrow> match_sinl\<cdot>(sinr\<cdot>x) = fail"
-  "match_sinl\<cdot>\<bottom> = \<bottom>"
+  "x \<noteq> \<bottom> \<Longrightarrow> match_sinl\<cdot>(sinl\<cdot>x)\<cdot>k = k\<cdot>x"
+  "y \<noteq> \<bottom> \<Longrightarrow> match_sinl\<cdot>(sinr\<cdot>y)\<cdot>k = fail"
+  "match_sinl\<cdot>\<bottom>\<cdot>k = \<bottom>"
 by (simp_all add: match_sinl_def)
 
 lemma match_sinr_simps [simp]:
-  "x \<noteq> \<bottom> \<Longrightarrow> match_sinr\<cdot>(sinr\<cdot>x) = return\<cdot>x"
-  "x \<noteq> \<bottom> \<Longrightarrow> match_sinr\<cdot>(sinl\<cdot>x) = fail"
-  "match_sinr\<cdot>\<bottom> = \<bottom>"
+  "x \<noteq> \<bottom> \<Longrightarrow> match_sinr\<cdot>(sinl\<cdot>x)\<cdot>k = fail"
+  "y \<noteq> \<bottom> \<Longrightarrow> match_sinr\<cdot>(sinr\<cdot>y)\<cdot>k = k\<cdot>y"
+  "match_sinr\<cdot>\<bottom>\<cdot>k = \<bottom>"
 by (simp_all add: match_sinr_def)
 
 lemma match_up_simps [simp]:
-  "match_up\<cdot>(up\<cdot>x) = return\<cdot>x"
-  "match_up\<cdot>\<bottom> = \<bottom>"
+  "match_up\<cdot>(up\<cdot>x)\<cdot>k = k\<cdot>x"
+  "match_up\<cdot>\<bottom>\<cdot>k = \<bottom>"
 by (simp_all add: match_up_def)
 
 lemma match_ONE_simps [simp]:
-  "match_ONE\<cdot>ONE = return\<cdot>()"
-  "match_ONE\<cdot>\<bottom> = \<bottom>"
+  "match_ONE\<cdot>ONE\<cdot>k = k"
+  "match_ONE\<cdot>\<bottom>\<cdot>k = \<bottom>"
 by (simp_all add: match_ONE_def)
 
 lemma match_TT_simps [simp]:
-  "match_TT\<cdot>TT = return\<cdot>()"
-  "match_TT\<cdot>FF = fail"
-  "match_TT\<cdot>\<bottom> = \<bottom>"
+  "match_TT\<cdot>TT\<cdot>k = k"
+  "match_TT\<cdot>FF\<cdot>k = fail"
+  "match_TT\<cdot>\<bottom>\<cdot>k = \<bottom>"
 by (simp_all add: match_TT_def)
 
 lemma match_FF_simps [simp]:
-  "match_FF\<cdot>FF = return\<cdot>()"
-  "match_FF\<cdot>TT = fail"
-  "match_FF\<cdot>\<bottom> = \<bottom>"
+  "match_FF\<cdot>FF\<cdot>k = k"
+  "match_FF\<cdot>TT\<cdot>k = fail"
+  "match_FF\<cdot>\<bottom>\<cdot>k = \<bottom>"
 by (simp_all add: match_FF_def)
 
 subsection {* Mutual recursion *}
@@ -564,15 +574,23 @@
   fixed-point definitions of mutually recursive functions.
 *}
 
-lemma cpair_equalI: "\<lbrakk>x \<equiv> cfst\<cdot>p; y \<equiv> csnd\<cdot>p\<rbrakk> \<Longrightarrow> <x,y> \<equiv> p"
-by (simp add: surjective_pairing_Cprod2)
+lemma Pair_equalI: "\<lbrakk>x \<equiv> fst p; y \<equiv> snd p\<rbrakk> \<Longrightarrow> (x, y) \<equiv> p"
+by simp
 
-lemma cpair_eqD1: "<x,y> = <x',y'> \<Longrightarrow> x = x'"
+lemma Pair_eqD1: "(x, y) = (x', y') \<Longrightarrow> x = x'"
 by simp
 
-lemma cpair_eqD2: "<x,y> = <x',y'> \<Longrightarrow> y = y'"
+lemma Pair_eqD2: "(x, y) = (x', y') \<Longrightarrow> y = y'"
 by simp
 
+lemma def_cont_fix_eq:
+  "\<lbrakk>f \<equiv> fix\<cdot>(Abs_CFun F); cont F\<rbrakk> \<Longrightarrow> f = F f"
+by (simp, subst fix_eq, simp)
+
+lemma def_cont_fix_ind:
+  "\<lbrakk>f \<equiv> fix\<cdot>(Abs_CFun F); cont F; adm P; P \<bottom>; \<And>x. P x \<Longrightarrow> P (F x)\<rbrakk> \<Longrightarrow> P f"
+by (simp add: fix_ind)
+
 text {* lemma for proving rewrite rules *}
 
 lemma ssubst_lhs: "\<lbrakk>t = s; P s = Q\<rbrakk> \<Longrightarrow> P t = Q"
@@ -594,7 +612,8 @@
       (@{const_name cpair}, @{const_name match_cpair}),
       (@{const_name ONE}, @{const_name match_ONE}),
       (@{const_name TT}, @{const_name match_TT}),
-      (@{const_name FF}, @{const_name match_FF}) ]
+      (@{const_name FF}, @{const_name match_FF}),
+      (@{const_name UU}, @{const_name match_UU}) ]
 *}
 
 hide (open) const return bind fail run cases

--- a/src/HOLCF/HOLCF.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/HOLCF.thy	Fri May 15 15:56:28 2009 +0200
@@ -9,13 +9,6 @@
   Domain ConvexPD Algebraic Universal Sum_Cpo Main
 uses
   "holcf_logic.ML"
-  "Tools/cont_consts.ML"
-  "Tools/cont_proc.ML"
-  "Tools/domain/domain_library.ML"
-  "Tools/domain/domain_syntax.ML"
-  "Tools/domain/domain_axioms.ML"
-  "Tools/domain/domain_theorems.ML"
-  "Tools/domain/domain_extender.ML"
   "Tools/adm_tac.ML"
 begin
 
@@ -28,4 +21,58 @@
         (cut_facts_tac (Simplifier.prems_of_ss ss) THEN' cont_tacRs ss))));
 *}
 
+text {* Legacy theorem names *}
+
+lemmas sq_ord_less_eq_trans = below_eq_trans
+lemmas sq_ord_eq_less_trans = eq_below_trans
+lemmas refl_less = below_refl
+lemmas trans_less = below_trans
+lemmas antisym_less = below_antisym
+lemmas antisym_less_inverse = below_antisym_inverse
+lemmas box_less = box_below
+lemmas rev_trans_less = rev_below_trans
+lemmas not_less2not_eq = not_below2not_eq
+lemmas less_UU_iff = below_UU_iff
+lemmas flat_less_iff = flat_below_iff
+lemmas adm_less = adm_below
+lemmas adm_not_less = adm_not_below
+lemmas adm_compact_not_less = adm_compact_not_below
+lemmas less_fun_def = below_fun_def
+lemmas expand_fun_less = expand_fun_below
+lemmas less_fun_ext = below_fun_ext
+lemmas less_discr_def = below_discr_def
+lemmas discr_less_eq = discr_below_eq
+lemmas less_unit_def = below_unit_def
+lemmas less_cprod_def = below_prod_def
+lemmas prod_lessI = prod_belowI
+lemmas Pair_less_iff = Pair_below_iff
+lemmas fst_less_iff = fst_below_iff
+lemmas snd_less_iff = snd_below_iff
+lemmas expand_cfun_less = expand_cfun_below
+lemmas less_cfun_ext = below_cfun_ext
+lemmas injection_less = injection_below
+lemmas approx_less = approx_below
+lemmas profinite_less_ext = profinite_below_ext
+lemmas less_up_def = below_up_def
+lemmas not_Iup_less = not_Iup_below
+lemmas Iup_less = Iup_below
+lemmas up_less = up_below
+lemmas cpair_less = cpair_below
+lemmas less_cprod = below_cprod
+lemmas cfst_less_iff = cfst_below_iff
+lemmas csnd_less_iff = csnd_below_iff
+lemmas Def_inject_less_eq = Def_below_Def
+lemmas Def_less_is_eq = Def_below_iff
+lemmas spair_less_iff = spair_below_iff
+lemmas less_sprod = below_sprod
+lemmas spair_less = spair_below
+lemmas sfst_less_iff = sfst_below_iff
+lemmas ssnd_less_iff = ssnd_below_iff
+lemmas fix_least_less = fix_least_below
+lemmas dist_less_one = dist_below_one
+lemmas less_ONE = below_ONE
+lemmas ONE_less_iff = ONE_below_iff
+lemmas less_sinlD = below_sinlD
+lemmas less_sinrD = below_sinrD
+
 end

--- a/src/HOLCF/IOA/meta_theory/Sequence.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/IOA/meta_theory/Sequence.thy	Fri May 15 15:56:28 2009 +0200
@@ -288,8 +288,7 @@
 
 lemma Cons_not_UU: "a>>s ~= UU"
 apply (subst Consq_def2)
-apply (rule seq.con_rews)
-apply (rule Def_not_UU)
+apply simp
 done
 
 

--- a/src/HOLCF/IOA/meta_theory/ioa_package.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/IOA/meta_theory/ioa_package.ML	Fri May 15 15:56:28 2009 +0200
@@ -347,12 +347,12 @@
 val alt_string = make_alt_string thy inp_head_list out_head_list int_head_list 
 							atyp statetupel trans;
 val thy2 = (thy
-|> ContConsts.add_consts
-[(automaton_name ^ "_initial", "(" ^ state_type_string ^ ")set" ,NoSyn),
-(automaton_name ^ "_asig", "(" ^ action_type ^ ")signature" ,NoSyn),
-(automaton_name ^ "_trans",
+|> Sign.add_consts
+[(Binding.name (automaton_name ^ "_initial"), "(" ^ state_type_string ^ ")set" ,NoSyn),
+(Binding.name (automaton_name ^ "_asig"), "(" ^ action_type ^ ")signature" ,NoSyn),
+(Binding.name (automaton_name ^ "_trans"),
  "(" ^ action_type ^ "," ^ state_type_string ^ ")transition set" ,NoSyn),
-(automaton_name, "(" ^ action_type ^ "," ^ state_type_string ^ ")ioa" ,NoSyn)]
+(Binding.name automaton_name, "(" ^ action_type ^ "," ^ state_type_string ^ ")ioa" ,NoSyn)]
 |> add_defs
 [(automaton_name ^ "_initial_def",
 automaton_name ^ "_initial == {" ^ state_vars_tupel ^ "." ^ ini ^ "}"),
@@ -386,8 +386,8 @@
 val comp_list = clist aut_list;
 in
 thy
-|> ContConsts.add_consts_i
-[(automaton_name,
+|> Sign.add_consts_i
+[(Binding.name automaton_name,
 Type("*",
 [Type("*",[Type("set",[acttyp]),Type("*",[Type("set",[acttyp]),Type("set",[acttyp])])]),
  Type("*",[Type("set",[st_typ]),
@@ -407,8 +407,8 @@
 val rest_set = action_set_string thy acttyp actlist
 in
 thy
-|> ContConsts.add_consts_i
-[(automaton_name, auttyp,NoSyn)]
+|> Sign.add_consts_i
+[(Binding.name automaton_name, auttyp,NoSyn)]
 |> add_defs
 [(automaton_name ^ "_def",
 automaton_name ^ " == restrict " ^ aut_source ^ " " ^ rest_set)] 
@@ -421,8 +421,8 @@
 val hid_set = action_set_string thy acttyp actlist
 in
 thy
-|> ContConsts.add_consts_i
-[(automaton_name, auttyp,NoSyn)]
+|> Sign.add_consts_i
+[(Binding.name automaton_name, auttyp,NoSyn)]
 |> add_defs
 [(automaton_name ^ "_def",
 automaton_name ^ " == hide " ^ aut_source ^ " " ^ hid_set)] 
@@ -441,8 +441,8 @@
 val acttyp = ren_act_type_of thy fun_name
 in
 thy
-|> ContConsts.add_consts_i
-[(automaton_name,
+|> Sign.add_consts_i
+[(Binding.name automaton_name,
 Type("*",
 [Type("*",[Type("set",[acttyp]),Type("*",[Type("set",[acttyp]),Type("set",[acttyp])])]),
  Type("*",[Type("set",[st_typ]),

--- a/src/HOLCF/IsaMakefile	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/IsaMakefile	Fri May 15 15:56:28 2009 +0200
@@ -87,10 +87,19 @@
 
 HOLCF-ex: HOLCF $(LOG)/HOLCF-ex.gz
 
-$(LOG)/HOLCF-ex.gz: $(OUT)/HOLCF ex/Stream.thy ex/Dagstuhl.thy \
-  ex/Dnat.thy ex/Fix2.thy ex/Focus_ex.thy ex/Hoare.thy ex/Loop.thy \
+$(LOG)/HOLCF-ex.gz: $(OUT)/HOLCF \
+  ../HOL/Library/Nat_Infinity.thy \
+  ex/Dagstuhl.thy \
+  ex/Dnat.thy \
+  ex/Domain_ex.thy \
+  ex/Fix2.thy \
+  ex/Fixrec_ex.thy \
+  ex/Focus_ex.thy \
+  ex/Hoare.thy \
+  ex/Loop.thy \
   ex/Powerdomain_ex.thy \
-  ex/ROOT.ML ex/Fixrec_ex.thy ../HOL/Library/Nat_Infinity.thy
+  ex/Stream.thy \
+  ex/ROOT.ML
 	@$(ISABELLE_TOOL) usedir $(OUT)/HOLCF ex
 
 

--- a/src/HOLCF/Lift.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Lift.thy	Fri May 15 15:56:28 2009 +0200
@@ -70,11 +70,11 @@
 lemma DefE2: "\<lbrakk>x = Def s; x = \<bottom>\<rbrakk> \<Longrightarrow> R"
   by simp
 
-lemma Def_inject_less_eq: "Def x \<sqsubseteq> Def y \<longleftrightarrow> x = y"
-by (simp add: less_lift_def Def_def Abs_lift_inverse lift_def)
+lemma Def_below_Def: "Def x \<sqsubseteq> Def y \<longleftrightarrow> x = y"
+by (simp add: below_lift_def Def_def Abs_lift_inverse lift_def)
 
-lemma Def_less_is_eq [simp]: "Def x \<sqsubseteq> y \<longleftrightarrow> Def x = y"
-by (induct y, simp, simp add: Def_inject_less_eq)
+lemma Def_below_iff [simp]: "Def x \<sqsubseteq> y \<longleftrightarrow> Def x = y"
+by (induct y, simp, simp add: Def_below_Def)
 
 
 subsection {* Lift is flat *}
@@ -134,7 +134,7 @@
   "(\<And>x. f x \<sqsubseteq> g x) \<Longrightarrow> (FLIFT x. f x) \<sqsubseteq> (FLIFT x. g x)"
 apply (rule monofunE [where f=flift1])
 apply (rule cont2mono [OF cont_flift1])
-apply (simp add: less_fun_ext)
+apply (simp add: below_fun_ext)
 done
 
 lemma cont2cont_flift1 [simp]:
@@ -216,7 +216,7 @@
     apply (rule is_lubI)
      apply (rule ub_rangeI, simp)
     apply (drule ub_rangeD)
-    apply (erule rev_trans_less)
+    apply (erule rev_below_trans)
     apply simp
     apply (rule lessI)
     done

--- a/src/HOLCF/LowerPD.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/LowerPD.thy	Fri May 15 15:56:28 2009 +0200
@@ -23,7 +23,7 @@
 apply (drule (1) bspec, erule bexE)
 apply (drule (1) bspec, erule bexE)
 apply (erule rev_bexI)
-apply (erule (1) trans_less)
+apply (erule (1) below_trans)
 done
 
 interpretation lower_le: preorder lower_le
@@ -39,7 +39,7 @@
 lemma PDPlus_lower_mono: "\<lbrakk>s \<le>\<flat> t; u \<le>\<flat> v\<rbrakk> \<Longrightarrow> PDPlus s u \<le>\<flat> PDPlus t v"
 unfolding lower_le_def Rep_PDPlus by fast
 
-lemma PDPlus_lower_less: "t \<le>\<flat> PDPlus t u"
+lemma PDPlus_lower_le: "t \<le>\<flat> PDPlus t u"
 unfolding lower_le_def Rep_PDPlus by fast
 
 lemma lower_le_PDUnit_PDUnit_iff [simp]:
@@ -99,7 +99,7 @@
   "{S::'a pd_basis set. lower_le.ideal S}"
 by (fast intro: lower_le.ideal_principal)
 
-instantiation lower_pd :: (profinite) sq_ord
+instantiation lower_pd :: (profinite) below
 begin
 
 definition
@@ -110,16 +110,16 @@
 
 instance lower_pd :: (profinite) po
 by (rule lower_le.typedef_ideal_po
-    [OF type_definition_lower_pd sq_le_lower_pd_def])
+    [OF type_definition_lower_pd below_lower_pd_def])
 
 instance lower_pd :: (profinite) cpo
 by (rule lower_le.typedef_ideal_cpo
-    [OF type_definition_lower_pd sq_le_lower_pd_def])
+    [OF type_definition_lower_pd below_lower_pd_def])
 
 lemma Rep_lower_pd_lub:
   "chain Y \<Longrightarrow> Rep_lower_pd (\<Squnion>i. Y i) = (\<Union>i. Rep_lower_pd (Y i))"
 by (rule lower_le.typedef_ideal_rep_contlub
-    [OF type_definition_lower_pd sq_le_lower_pd_def])
+    [OF type_definition_lower_pd below_lower_pd_def])
 
 lemma ideal_Rep_lower_pd: "lower_le.ideal (Rep_lower_pd xs)"
 by (rule Rep_lower_pd [unfolded mem_Collect_eq])
@@ -145,7 +145,7 @@
 apply (rule ideal_Rep_lower_pd)
 apply (erule Rep_lower_pd_lub)
 apply (rule Rep_lower_principal)
-apply (simp only: sq_le_lower_pd_def)
+apply (simp only: below_lower_pd_def)
 done
 
 text {* Lower powerdomain is pointed *}
@@ -264,28 +264,28 @@
 lemmas lower_plus_aci =
   lower_plus_ac lower_plus_absorb lower_plus_left_absorb
 
-lemma lower_plus_less1: "xs \<sqsubseteq> xs +\<flat> ys"
+lemma lower_plus_below1: "xs \<sqsubseteq> xs +\<flat> ys"
 apply (induct xs ys rule: lower_pd.principal_induct2, simp, simp)
-apply (simp add: PDPlus_lower_less)
+apply (simp add: PDPlus_lower_le)
 done
 
-lemma lower_plus_less2: "ys \<sqsubseteq> xs +\<flat> ys"
-by (subst lower_plus_commute, rule lower_plus_less1)
+lemma lower_plus_below2: "ys \<sqsubseteq> xs +\<flat> ys"
+by (subst lower_plus_commute, rule lower_plus_below1)
 
 lemma lower_plus_least: "\<lbrakk>xs \<sqsubseteq> zs; ys \<sqsubseteq> zs\<rbrakk> \<Longrightarrow> xs +\<flat> ys \<sqsubseteq> zs"
 apply (subst lower_plus_absorb [of zs, symmetric])
 apply (erule (1) monofun_cfun [OF monofun_cfun_arg])
 done
 
-lemma lower_plus_less_iff:
+lemma lower_plus_below_iff:
   "xs +\<flat> ys \<sqsubseteq> zs \<longleftrightarrow> xs \<sqsubseteq> zs \<and> ys \<sqsubseteq> zs"
 apply safe
-apply (erule trans_less [OF lower_plus_less1])
-apply (erule trans_less [OF lower_plus_less2])
+apply (erule below_trans [OF lower_plus_below1])
+apply (erule below_trans [OF lower_plus_below2])
 apply (erule (1) lower_plus_least)
 done
 
-lemma lower_unit_less_plus_iff:
+lemma lower_unit_below_plus_iff:
   "{x}\<flat> \<sqsubseteq> ys +\<flat> zs \<longleftrightarrow> {x}\<flat> \<sqsubseteq> ys \<or> {x}\<flat> \<sqsubseteq> zs"
  apply (rule iffI)
   apply (subgoal_tac
@@ -299,13 +299,13 @@
    apply simp
   apply simp
  apply (erule disjE)
-  apply (erule trans_less [OF _ lower_plus_less1])
- apply (erule trans_less [OF _ lower_plus_less2])
+  apply (erule below_trans [OF _ lower_plus_below1])
+ apply (erule below_trans [OF _ lower_plus_below2])
 done
 
-lemma lower_unit_less_iff [simp]: "{x}\<flat> \<sqsubseteq> {y}\<flat> \<longleftrightarrow> x \<sqsubseteq> y"
+lemma lower_unit_below_iff [simp]: "{x}\<flat> \<sqsubseteq> {y}\<flat> \<longleftrightarrow> x \<sqsubseteq> y"
  apply (rule iffI)
-  apply (rule profinite_less_ext)
+  apply (rule profinite_below_ext)
   apply (drule_tac f="approx i" in monofun_cfun_arg, simp)
   apply (cut_tac x="approx i\<cdot>x" in compact_basis.compact_imp_principal, simp)
   apply (cut_tac x="approx i\<cdot>y" in compact_basis.compact_imp_principal, simp)
@@ -313,10 +313,10 @@
  apply (erule monofun_cfun_arg)
 done
 
-lemmas lower_pd_less_simps =
-  lower_unit_less_iff
-  lower_plus_less_iff
-  lower_unit_less_plus_iff
+lemmas lower_pd_below_simps =
+  lower_unit_below_iff
+  lower_plus_below_iff
+  lower_unit_below_plus_iff
 
 lemma lower_unit_eq_iff [simp]: "{x}\<flat> = {y}\<flat> \<longleftrightarrow> x = y"
 by (simp add: po_eq_conv)
@@ -330,18 +330,18 @@
 lemma lower_plus_strict_iff [simp]:
   "xs +\<flat> ys = \<bottom> \<longleftrightarrow> xs = \<bottom> \<and> ys = \<bottom>"
 apply safe
-apply (rule UU_I, erule subst, rule lower_plus_less1)
-apply (rule UU_I, erule subst, rule lower_plus_less2)
+apply (rule UU_I, erule subst, rule lower_plus_below1)
+apply (rule UU_I, erule subst, rule lower_plus_below2)
 apply (rule lower_plus_absorb)
 done
 
 lemma lower_plus_strict1 [simp]: "\<bottom> +\<flat> ys = ys"
-apply (rule antisym_less [OF _ lower_plus_less2])
+apply (rule below_antisym [OF _ lower_plus_below2])
 apply (simp add: lower_plus_least)
 done
 
 lemma lower_plus_strict2 [simp]: "xs +\<flat> \<bottom> = xs"
-apply (rule antisym_less [OF _ lower_plus_less1])
+apply (rule below_antisym [OF _ lower_plus_below1])
 apply (simp add: lower_plus_least)
 done
 
@@ -412,11 +412,11 @@
 
 lemma lower_bind_basis_mono:
   "t \<le>\<flat> u \<Longrightarrow> lower_bind_basis t \<sqsubseteq> lower_bind_basis u"
-unfolding expand_cfun_less
+unfolding expand_cfun_below
 apply (erule lower_le_induct, safe)
 apply (simp add: monofun_cfun)
-apply (simp add: rev_trans_less [OF lower_plus_less1])
-apply (simp add: lower_plus_less_iff)
+apply (simp add: rev_below_trans [OF lower_plus_below1])
+apply (simp add: lower_plus_below_iff)
 done
 
 definition

--- a/src/HOLCF/One.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/One.thy	Fri May 15 15:56:28 2009 +0200
@@ -28,17 +28,17 @@
 lemma one_induct: "\<lbrakk>P \<bottom>; P ONE\<rbrakk> \<Longrightarrow> P x"
 by (cases x rule: oneE) simp_all
 
-lemma dist_less_one [simp]: "\<not> ONE \<sqsubseteq> \<bottom>"
+lemma dist_below_one [simp]: "\<not> ONE \<sqsubseteq> \<bottom>"
 unfolding ONE_def by simp
 
-lemma less_ONE [simp]: "x \<sqsubseteq> ONE"
+lemma below_ONE [simp]: "x \<sqsubseteq> ONE"
 by (induct x rule: one_induct) simp_all
 
-lemma ONE_less_iff [simp]: "ONE \<sqsubseteq> x \<longleftrightarrow> x = ONE"
+lemma ONE_below_iff [simp]: "ONE \<sqsubseteq> x \<longleftrightarrow> x = ONE"
 by (induct x rule: one_induct) simp_all
 
-lemma dist_eq_one [simp]: "ONE \<noteq> \<bottom>" "\<bottom> \<noteq> ONE"
-unfolding ONE_def by simp_all
+lemma ONE_defined [simp]: "ONE \<noteq> \<bottom>"
+unfolding ONE_def by simp
 
 lemma one_neq_iffs [simp]:
   "x \<noteq> ONE \<longleftrightarrow> x = \<bottom>"

--- a/src/HOLCF/Pcpo.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Pcpo.thy	Fri May 15 15:56:28 2009 +0200
@@ -13,28 +13,28 @@
 text {* The class cpo of chain complete partial orders *}
 
 class cpo = po +
-        -- {* class axiom: *}
-  assumes cpo:   "chain S \<Longrightarrow> \<exists>x :: 'a::po. range S <<| x"
+  assumes cpo: "chain S \<Longrightarrow> \<exists>x. range S <<| x"
+begin
 
 text {* in cpo's everthing equal to THE lub has lub properties for every chain *}
 
-lemma cpo_lubI: "chain (S::nat \<Rightarrow> 'a::cpo) \<Longrightarrow> range S <<| (\<Squnion>i. S i)"
-by (fast dest: cpo elim: lubI)
+lemma cpo_lubI: "chain S \<Longrightarrow> range S <<| (\<Squnion>i. S i)"
+  by (fast dest: cpo elim: lubI)
 
-lemma thelubE: "\<lbrakk>chain S; (\<Squnion>i. S i) = (l::'a::cpo)\<rbrakk> \<Longrightarrow> range S <<| l"
-by (blast dest: cpo intro: lubI)
+lemma thelubE: "\<lbrakk>chain S; (\<Squnion>i. S i) = l\<rbrakk> \<Longrightarrow> range S <<| l"
+  by (blast dest: cpo intro: lubI)
 
 text {* Properties of the lub *}
 
-lemma is_ub_thelub: "chain (S::nat \<Rightarrow> 'a::cpo) \<Longrightarrow> S x \<sqsubseteq> (\<Squnion>i. S i)"
-by (blast dest: cpo intro: lubI [THEN is_ub_lub])
+lemma is_ub_thelub: "chain S \<Longrightarrow> S x \<sqsubseteq> (\<Squnion>i. S i)"
+  by (blast dest: cpo intro: lubI [THEN is_ub_lub])
 
 lemma is_lub_thelub:
-  "\<lbrakk>chain (S::nat \<Rightarrow> 'a::cpo); range S <| x\<rbrakk> \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x"
-by (blast dest: cpo intro: lubI [THEN is_lub_lub])
+  "\<lbrakk>chain S; range S <| x\<rbrakk> \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x"
+  by (blast dest: cpo intro: lubI [THEN is_lub_lub])
 
 lemma lub_range_mono:
-  "\<lbrakk>range X \<subseteq> range Y; chain Y; chain (X::nat \<Rightarrow> 'a::cpo)\<rbrakk>
+  "\<lbrakk>range X \<subseteq> range Y; chain Y; chain X\<rbrakk>
     \<Longrightarrow> (\<Squnion>i. X i) \<sqsubseteq> (\<Squnion>i. Y i)"
 apply (erule is_lub_thelub)
 apply (rule ub_rangeI)
@@ -45,8 +45,8 @@
 done
 
 lemma lub_range_shift:
-  "chain (Y::nat \<Rightarrow> 'a::cpo) \<Longrightarrow> (\<Squnion>i. Y (i + j)) = (\<Squnion>i. Y i)"
-apply (rule antisym_less)
+  "chain Y \<Longrightarrow> (\<Squnion>i. Y (i + j)) = (\<Squnion>i. Y i)"
+apply (rule below_antisym)
 apply (rule lub_range_mono)
 apply    fast
 apply   assumption
@@ -54,7 +54,7 @@
 apply (rule is_lub_thelub)
 apply assumption
 apply (rule ub_rangeI)
-apply (rule_tac y="Y (i + j)" in trans_less)
+apply (rule_tac y="Y (i + j)" in below_trans)
 apply (erule chain_mono)
 apply (rule le_add1)
 apply (rule is_ub_thelub)
@@ -62,11 +62,11 @@
 done
 
 lemma maxinch_is_thelub:
-  "chain Y \<Longrightarrow> max_in_chain i Y = ((\<Squnion>i. Y i) = ((Y i)::'a::cpo))"
+  "chain Y \<Longrightarrow> max_in_chain i Y = ((\<Squnion>i. Y i) = Y i)"
 apply (rule iffI)
 apply (fast intro!: thelubI lub_finch1)
 apply (unfold max_in_chain_def)
-apply (safe intro!: antisym_less)
+apply (safe intro!: below_antisym)
 apply (fast elim!: chain_mono)
 apply (drule sym)
 apply (force elim!: is_ub_thelub)
@@ -75,11 +75,11 @@
 text {* the @{text "\<sqsubseteq>"} relation between two chains is preserved by their lubs *}
 
 lemma lub_mono:
-  "\<lbrakk>chain (X::nat \<Rightarrow> 'a::cpo); chain Y; \<And>i. X i \<sqsubseteq> Y i\<rbrakk> 
+  "\<lbrakk>chain X; chain Y; \<And>i. X i \<sqsubseteq> Y i\<rbrakk> 
     \<Longrightarrow> (\<Squnion>i. X i) \<sqsubseteq> (\<Squnion>i. Y i)"
 apply (erule is_lub_thelub)
 apply (rule ub_rangeI)
-apply (rule trans_less)
+apply (rule below_trans)
 apply (erule meta_spec)
 apply (erule is_ub_thelub)
 done
@@ -87,14 +87,14 @@
 text {* the = relation between two chains is preserved by their lubs *}
 
 lemma lub_equal:
-  "\<lbrakk>chain (X::nat \<Rightarrow> 'a::cpo); chain Y; \<forall>k. X k = Y k\<rbrakk>
+  "\<lbrakk>chain X; chain Y; \<forall>k. X k = Y k\<rbrakk>
     \<Longrightarrow> (\<Squnion>i. X i) = (\<Squnion>i. Y i)"
-by (simp only: expand_fun_eq [symmetric])
+  by (simp only: expand_fun_eq [symmetric])
 
 text {* more results about mono and = of lubs of chains *}
 
 lemma lub_mono2:
-  "\<lbrakk>\<exists>j. \<forall>i>j. X i = Y i; chain (X::nat \<Rightarrow> 'a::cpo); chain Y\<rbrakk>
+  "\<lbrakk>\<exists>j. \<forall>i>j. X i = Y i; chain X; chain Y\<rbrakk>
     \<Longrightarrow> (\<Squnion>i. X i) \<sqsubseteq> (\<Squnion>i. Y i)"
 apply (erule exE)
 apply (subgoal_tac "(\<Squnion>i. X (i + Suc j)) \<sqsubseteq> (\<Squnion>i. Y (i + Suc j))")
@@ -104,23 +104,22 @@
 done
 
 lemma lub_equal2:
-  "\<lbrakk>\<exists>j. \<forall>i>j. X i = Y i; chain (X::nat \<Rightarrow> 'a::cpo); chain Y\<rbrakk>
+  "\<lbrakk>\<exists>j. \<forall>i>j. X i = Y i; chain X; chain Y\<rbrakk>
     \<Longrightarrow> (\<Squnion>i. X i) = (\<Squnion>i. Y i)"
-by (blast intro: antisym_less lub_mono2 sym)
+  by (blast intro: below_antisym lub_mono2 sym)
 
 lemma lub_mono3:
-  "\<lbrakk>chain (Y::nat \<Rightarrow> 'a::cpo); chain X; \<forall>i. \<exists>j. Y i \<sqsubseteq> X j\<rbrakk>
+  "\<lbrakk>chain Y; chain X; \<forall>i. \<exists>j. Y i \<sqsubseteq> X j\<rbrakk>
     \<Longrightarrow> (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. X i)"
 apply (erule is_lub_thelub)
 apply (rule ub_rangeI)
 apply (erule allE)
 apply (erule exE)
-apply (erule trans_less)
+apply (erule below_trans)
 apply (erule is_ub_thelub)
 done
 
 lemma ch2ch_lub:
-  fixes Y :: "nat \<Rightarrow> nat \<Rightarrow> 'a::cpo"
   assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
   assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
   shows "chain (\<lambda>i. \<Squnion>j. Y i j)"
@@ -130,14 +129,13 @@
 done
 
 lemma diag_lub:
-  fixes Y :: "nat \<Rightarrow> nat \<Rightarrow> 'a::cpo"
   assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
   assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
   shows "(\<Squnion>i. \<Squnion>j. Y i j) = (\<Squnion>i. Y i i)"
-proof (rule antisym_less)
+proof (rule below_antisym)
   have 3: "chain (\<lambda>i. Y i i)"
     apply (rule chainI)
-    apply (rule trans_less)
+    apply (rule below_trans)
     apply (rule chainE [OF 1])
     apply (rule chainE [OF 2])
     done
@@ -148,7 +146,7 @@
     apply (rule ub_rangeI)
     apply (rule lub_mono3 [rule_format, OF 2 3])
     apply (rule exI)
-    apply (rule trans_less)
+    apply (rule below_trans)
     apply (rule chain_mono [OF 1 le_maxI1])
     apply (rule chain_mono [OF 2 le_maxI2])
     done
@@ -159,12 +157,12 @@
 qed
 
 lemma ex_lub:
-  fixes Y :: "nat \<Rightarrow> nat \<Rightarrow> 'a::cpo"
   assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
   assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
   shows "(\<Squnion>i. \<Squnion>j. Y i j) = (\<Squnion>j. \<Squnion>i. Y i j)"
-by (simp add: diag_lub 1 2)
+  by (simp add: diag_lub 1 2)
 
+end
 
 subsection {* Pointed cpos *}
 
@@ -172,9 +170,9 @@
 
 class pcpo = cpo +
   assumes least: "\<exists>x. \<forall>y. x \<sqsubseteq> y"
+begin
 
-definition
-  UU :: "'a::pcpo" where
+definition UU :: 'a where
   "UU = (THE x. \<forall>y. x \<sqsubseteq> y)"
 
 notation (xsymbols)
@@ -187,36 +185,29 @@
 apply (rule theI')
 apply (rule ex_ex1I)
 apply (rule least)
-apply (blast intro: antisym_less)
+apply (blast intro: below_antisym)
 done
 
 lemma minimal [iff]: "\<bottom> \<sqsubseteq> x"
 by (rule UU_least [THEN spec])
 
-lemma UU_reorient: "(\<bottom> = x) = (x = \<bottom>)"
-by auto
+end
+
+text {* Simproc to rewrite @{term "\<bottom> = x"} to @{term "x = \<bottom>"}. *}
 
-ML {*
-local
-  val meta_UU_reorient = thm "UU_reorient" RS eq_reflection;
-  fun reorient_proc sg _ (_ $ t $ u) =
-    case u of
-        Const("Pcpo.UU",_) => NONE
-      | Const("HOL.zero", _) => NONE
-      | Const("HOL.one", _) => NONE
-      | Const("Numeral.number_of", _) $ _ => NONE
-      | _ => SOME meta_UU_reorient;
-in
-  val UU_reorient_simproc = 
-    Simplifier.simproc (the_context ()) "UU_reorient_simproc" ["UU=x"] reorient_proc
-end;
+setup {*
+  ReorientProc.add
+    (fn Const(@{const_name UU}, _) => true | _ => false)
+*}
 
-Addsimprocs [UU_reorient_simproc];
-*}
+simproc_setup reorient_bottom ("\<bottom> = x") = ReorientProc.proc
+
+context pcpo
+begin
 
 text {* useful lemmas about @{term \<bottom>} *}
 
-lemma less_UU_iff [simp]: "(x \<sqsubseteq> \<bottom>) = (x = \<bottom>)"
+lemma below_UU_iff [simp]: "(x \<sqsubseteq> \<bottom>) = (x = \<bottom>)"
 by (simp add: po_eq_conv)
 
 lemma eq_UU_iff: "(x = \<bottom>) = (x \<sqsubseteq> \<bottom>)"
@@ -225,9 +216,6 @@
 lemma UU_I: "x \<sqsubseteq> \<bottom> \<Longrightarrow> x = \<bottom>"
 by (subst eq_UU_iff)
 
-lemma not_less2not_eq: "\<not> (x::'a::po) \<sqsubseteq> y \<Longrightarrow> x \<noteq> y"
-by auto
-
 lemma chain_UU_I: "\<lbrakk>chain Y; (\<Squnion>i. Y i) = \<bottom>\<rbrakk> \<Longrightarrow> \<forall>i. Y i = \<bottom>"
 apply (rule allI)
 apply (rule UU_I)
@@ -242,49 +230,53 @@
 done
 
 lemma chain_UU_I_inverse2: "(\<Squnion>i. Y i) \<noteq> \<bottom> \<Longrightarrow> \<exists>i::nat. Y i \<noteq> \<bottom>"
-by (blast intro: chain_UU_I_inverse)
+  by (blast intro: chain_UU_I_inverse)
 
 lemma notUU_I: "\<lbrakk>x \<sqsubseteq> y; x \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> y \<noteq> \<bottom>"
-by (blast intro: UU_I)
+  by (blast intro: UU_I)
 
 lemma chain_mono2: "\<lbrakk>\<exists>j. Y j \<noteq> \<bottom>; chain Y\<rbrakk> \<Longrightarrow> \<exists>j. \<forall>i>j. Y i \<noteq> \<bottom>"
-by (blast dest: notUU_I chain_mono_less)
+  by (blast dest: notUU_I chain_mono_less)
+
+end
 
 subsection {* Chain-finite and flat cpos *}
 
 text {* further useful classes for HOLCF domains *}
 
-class finite_po = finite + po
+class chfin = po +
+  assumes chfin: "chain Y \<Longrightarrow> \<exists>n. max_in_chain n Y"
+begin
 
-class chfin = po +
-  assumes chfin: "chain Y \<Longrightarrow> \<exists>n. max_in_chain n (Y :: nat => 'a::po)"
+subclass cpo
+apply default
+apply (frule chfin)
+apply (blast intro: lub_finch1)
+done
 
-class flat = pcpo +
-  assumes ax_flat: "(x :: 'a::pcpo) \<sqsubseteq> y \<Longrightarrow> x = \<bottom> \<or> x = y"
+lemma chfin2finch: "chain Y \<Longrightarrow> finite_chain Y"
+  by (simp add: chfin finite_chain_def)
+
+end
 
-text {* finite partial orders are chain-finite *}
+class finite_po = finite + po
+begin
 
-instance finite_po < chfin
-apply intro_classes
+subclass chfin
+apply default
 apply (drule finite_range_imp_finch)
 apply (rule finite)
 apply (simp add: finite_chain_def)
 done
 
-text {* some properties for chfin and flat *}
-
-text {* chfin types are cpo *}
+end
 
-instance chfin < cpo
-apply intro_classes
-apply (frule chfin)
-apply (blast intro: lub_finch1)
-done
+class flat = pcpo +
+  assumes ax_flat: "x \<sqsubseteq> y \<Longrightarrow> x = \<bottom> \<or> x = y"
+begin
 
-text {* flat types are chfin *}
-
-instance flat < chfin
-apply intro_classes
+subclass chfin
+apply default
 apply (unfold max_in_chain_def)
 apply (case_tac "\<forall>i. Y i = \<bottom>")
 apply simp
@@ -295,31 +287,28 @@
 apply (blast dest: chain_mono ax_flat)
 done
 
-text {* flat subclass of chfin; @{text adm_flat} not needed *}
-
-lemma flat_less_iff:
-  fixes x y :: "'a::flat"
+lemma flat_below_iff:
   shows "(x \<sqsubseteq> y) = (x = \<bottom> \<or> x = y)"
-by (safe dest!: ax_flat)
+  by (safe dest!: ax_flat)
 
-lemma flat_eq: "(a::'a::flat) \<noteq> \<bottom> \<Longrightarrow> a \<sqsubseteq> b = (a = b)"
-by (safe dest!: ax_flat)
+lemma flat_eq: "a \<noteq> \<bottom> \<Longrightarrow> a \<sqsubseteq> b = (a = b)"
+  by (safe dest!: ax_flat)
 
-lemma chfin2finch: "chain (Y::nat \<Rightarrow> 'a::chfin) \<Longrightarrow> finite_chain Y"
-by (simp add: chfin finite_chain_def)
+end
 
 text {* Discrete cpos *}
 
-class discrete_cpo = sq_ord +
+class discrete_cpo = below +
   assumes discrete_cpo [simp]: "x \<sqsubseteq> y \<longleftrightarrow> x = y"
+begin
 
-subclass (in discrete_cpo) po
+subclass po
 proof qed simp_all
 
 text {* In a discrete cpo, every chain is constant *}
 
 lemma discrete_chain_const:
-  assumes S: "chain (S::nat \<Rightarrow> 'a::discrete_cpo)"
+  assumes S: "chain S"
   shows "\<exists>x. S = (\<lambda>i. x)"
 proof (intro exI ext)
   fix i :: nat
@@ -328,7 +317,7 @@
   thus "S i = S 0" by (rule sym)
 qed
 
-instance discrete_cpo < cpo
+subclass cpo
 proof
   fix S :: "nat \<Rightarrow> 'a"
   assume S: "chain S"
@@ -338,31 +327,6 @@
     by (fast intro: lub_const)
 qed
 
-text {* lemmata for improved admissibility introdution rule *}
-
-lemma infinite_chain_adm_lemma:
-  "\<lbrakk>chain Y; \<forall>i. P (Y i);  
-    \<And>Y. \<lbrakk>chain Y; \<forall>i. P (Y i); \<not> finite_chain Y\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)\<rbrakk>
-      \<Longrightarrow> P (\<Squnion>i. Y i)"
-apply (case_tac "finite_chain Y")
-prefer 2 apply fast
-apply (unfold finite_chain_def)
-apply safe
-apply (erule lub_finch1 [THEN thelubI, THEN ssubst])
-apply assumption
-apply (erule spec)
-done
-
-lemma increasing_chain_adm_lemma:
-  "\<lbrakk>chain Y;  \<forall>i. P (Y i); \<And>Y. \<lbrakk>chain Y; \<forall>i. P (Y i);
-    \<forall>i. \<exists>j>i. Y i \<noteq> Y j \<and> Y i \<sqsubseteq> Y j\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)\<rbrakk>
-      \<Longrightarrow> P (\<Squnion>i. Y i)"
-apply (erule infinite_chain_adm_lemma)
-apply assumption
-apply (erule thin_rl)
-apply (unfold finite_chain_def)
-apply (unfold max_in_chain_def)
-apply (fast dest: le_imp_less_or_eq elim: chain_mono_less)
-done
+end
 
 end

--- a/src/HOLCF/Pcpodef.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Pcpodef.thy	Fri May 15 15:56:28 2009 +0200
@@ -16,22 +16,22 @@
   if the ordering is defined in the standard way.
 *}
 
-setup {* Sign.add_const_constraint (@{const_name Porder.sq_le}, NONE) *}
+setup {* Sign.add_const_constraint (@{const_name Porder.below}, NONE) *}
 
 theorem typedef_po:
   fixes Abs :: "'a::po \<Rightarrow> 'b::type"
   assumes type: "type_definition Rep Abs A"
-    and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
   shows "OFCLASS('b, po_class)"
- apply (intro_classes, unfold less)
-   apply (rule refl_less)
-  apply (erule (1) trans_less)
+ apply (intro_classes, unfold below)
+   apply (rule below_refl)
+  apply (erule (1) below_trans)
  apply (rule type_definition.Rep_inject [OF type, THEN iffD1])
- apply (erule (1) antisym_less)
+ apply (erule (1) below_antisym)
 done
 
-setup {* Sign.add_const_constraint (@{const_name Porder.sq_le},
-  SOME @{typ "'a::sq_ord \<Rightarrow> 'a::sq_ord \<Rightarrow> bool"}) *}
+setup {* Sign.add_const_constraint (@{const_name Porder.below},
+  SOME @{typ "'a::below \<Rightarrow> 'a::below \<Rightarrow> bool"}) *}
 
 subsection {* Proving a subtype is finite *}
 
@@ -58,9 +58,9 @@
 subsection {* Proving a subtype is chain-finite *}
 
 lemma monofun_Rep:
-  assumes less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+  assumes below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
   shows "monofun Rep"
-by (rule monofunI, unfold less)
+by (rule monofunI, unfold below)
 
 lemmas ch2ch_Rep = ch2ch_monofun [OF monofun_Rep]
 lemmas ub2ub_Rep = ub2ub_monofun [OF monofun_Rep]
@@ -68,10 +68,10 @@
 theorem typedef_chfin:
   fixes Abs :: "'a::chfin \<Rightarrow> 'b::po"
   assumes type: "type_definition Rep Abs A"
-    and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
   shows "OFCLASS('b, chfin_class)"
  apply intro_classes
- apply (drule ch2ch_Rep [OF less])
+ apply (drule ch2ch_Rep [OF below])
  apply (drule chfin)
  apply (unfold max_in_chain_def)
  apply (simp add: type_definition.Rep_inject [OF type])
@@ -90,28 +90,28 @@
 lemma Abs_inverse_lub_Rep:
   fixes Abs :: "'a::cpo \<Rightarrow> 'b::po"
   assumes type: "type_definition Rep Abs A"
-    and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
     and adm:  "adm (\<lambda>x. x \<in> A)"
   shows "chain S \<Longrightarrow> Rep (Abs (\<Squnion>i. Rep (S i))) = (\<Squnion>i. Rep (S i))"
  apply (rule type_definition.Abs_inverse [OF type])
- apply (erule admD [OF adm ch2ch_Rep [OF less]])
+ apply (erule admD [OF adm ch2ch_Rep [OF below]])
  apply (rule type_definition.Rep [OF type])
 done
 
 theorem typedef_lub:
   fixes Abs :: "'a::cpo \<Rightarrow> 'b::po"
   assumes type: "type_definition Rep Abs A"
-    and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
     and adm: "adm (\<lambda>x. x \<in> A)"
   shows "chain S \<Longrightarrow> range S <<| Abs (\<Squnion>i. Rep (S i))"
- apply (frule ch2ch_Rep [OF less])
+ apply (frule ch2ch_Rep [OF below])
  apply (rule is_lubI)
   apply (rule ub_rangeI)
-  apply (simp only: less Abs_inverse_lub_Rep [OF type less adm])
+  apply (simp only: below Abs_inverse_lub_Rep [OF type below adm])
   apply (erule is_ub_thelub)
- apply (simp only: less Abs_inverse_lub_Rep [OF type less adm])
+ apply (simp only: below Abs_inverse_lub_Rep [OF type below adm])
  apply (erule is_lub_thelub)
- apply (erule ub2ub_Rep [OF less])
+ apply (erule ub2ub_Rep [OF below])
 done
 
 lemmas typedef_thelub = typedef_lub [THEN thelubI, standard]
@@ -119,13 +119,13 @@
 theorem typedef_cpo:
   fixes Abs :: "'a::cpo \<Rightarrow> 'b::po"
   assumes type: "type_definition Rep Abs A"
-    and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
     and adm: "adm (\<lambda>x. x \<in> A)"
   shows "OFCLASS('b, cpo_class)"
 proof
   fix S::"nat \<Rightarrow> 'b" assume "chain S"
   hence "range S <<| Abs (\<Squnion>i. Rep (S i))"
-    by (rule typedef_lub [OF type less adm])
+    by (rule typedef_lub [OF type below adm])
   thus "\<exists>x. range S <<| x" ..
 qed
 
@@ -136,14 +136,14 @@
 theorem typedef_cont_Rep:
   fixes Abs :: "'a::cpo \<Rightarrow> 'b::cpo"
   assumes type: "type_definition Rep Abs A"
-    and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
     and adm: "adm (\<lambda>x. x \<in> A)"
   shows "cont Rep"
  apply (rule contI)
- apply (simp only: typedef_thelub [OF type less adm])
- apply (simp only: Abs_inverse_lub_Rep [OF type less adm])
+ apply (simp only: typedef_thelub [OF type below adm])
+ apply (simp only: Abs_inverse_lub_Rep [OF type below adm])
  apply (rule cpo_lubI)
- apply (erule ch2ch_Rep [OF less])
+ apply (erule ch2ch_Rep [OF below])
 done
 
 text {*
@@ -153,28 +153,28 @@
 *}
 
 theorem typedef_is_lubI:
-  assumes less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+  assumes below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
   shows "range (\<lambda>i. Rep (S i)) <<| Rep x \<Longrightarrow> range S <<| x"
  apply (rule is_lubI)
   apply (rule ub_rangeI)
-  apply (subst less)
+  apply (subst below)
   apply (erule is_ub_lub)
- apply (subst less)
+ apply (subst below)
  apply (erule is_lub_lub)
- apply (erule ub2ub_Rep [OF less])
+ apply (erule ub2ub_Rep [OF below])
 done
 
 theorem typedef_cont_Abs:
   fixes Abs :: "'a::cpo \<Rightarrow> 'b::cpo"
   fixes f :: "'c::cpo \<Rightarrow> 'a::cpo"
   assumes type: "type_definition Rep Abs A"
-    and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
     and adm: "adm (\<lambda>x. x \<in> A)" (* not used *)
     and f_in_A: "\<And>x. f x \<in> A"
     and cont_f: "cont f"
   shows "cont (\<lambda>x. Abs (f x))"
  apply (rule contI)
- apply (rule typedef_is_lubI [OF less])
+ apply (rule typedef_is_lubI [OF below])
  apply (simp only: type_definition.Abs_inverse [OF type f_in_A])
  apply (erule cont_f [THEN contE])
 done
@@ -184,15 +184,15 @@
 theorem typedef_compact:
   fixes Abs :: "'a::cpo \<Rightarrow> 'b::cpo"
   assumes type: "type_definition Rep Abs A"
-    and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
     and adm: "adm (\<lambda>x. x \<in> A)"
   shows "compact (Rep k) \<Longrightarrow> compact k"
 proof (unfold compact_def)
   have cont_Rep: "cont Rep"
-    by (rule typedef_cont_Rep [OF type less adm])
+    by (rule typedef_cont_Rep [OF type below adm])
   assume "adm (\<lambda>x. \<not> Rep k \<sqsubseteq> x)"
   with cont_Rep have "adm (\<lambda>x. \<not> Rep k \<sqsubseteq> Rep x)" by (rule adm_subst)
-  thus "adm (\<lambda>x. \<not> k \<sqsubseteq> x)" by (unfold less)
+  thus "adm (\<lambda>x. \<not> k \<sqsubseteq> x)" by (unfold below)
 qed
 
 subsection {* Proving a subtype is pointed *}
@@ -205,13 +205,13 @@
 theorem typedef_pcpo_generic:
   fixes Abs :: "'a::cpo \<Rightarrow> 'b::cpo"
   assumes type: "type_definition Rep Abs A"
-    and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
     and z_in_A: "z \<in> A"
     and z_least: "\<And>x. x \<in> A \<Longrightarrow> z \<sqsubseteq> x"
   shows "OFCLASS('b, pcpo_class)"
  apply (intro_classes)
  apply (rule_tac x="Abs z" in exI, rule allI)
- apply (unfold less)
+ apply (unfold below)
  apply (subst type_definition.Abs_inverse [OF type z_in_A])
  apply (rule z_least [OF type_definition.Rep [OF type]])
 done
@@ -224,10 +224,10 @@
 theorem typedef_pcpo:
   fixes Abs :: "'a::pcpo \<Rightarrow> 'b::cpo"
   assumes type: "type_definition Rep Abs A"
-    and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
     and UU_in_A: "\<bottom> \<in> A"
   shows "OFCLASS('b, pcpo_class)"
-by (rule typedef_pcpo_generic [OF type less UU_in_A], rule minimal)
+by (rule typedef_pcpo_generic [OF type below UU_in_A], rule minimal)
 
 subsubsection {* Strictness of @{term Rep} and @{term Abs} *}
 
@@ -238,66 +238,66 @@
 
 theorem typedef_Abs_strict:
   assumes type: "type_definition Rep Abs A"
-    and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
     and UU_in_A: "\<bottom> \<in> A"
   shows "Abs \<bottom> = \<bottom>"
- apply (rule UU_I, unfold less)
+ apply (rule UU_I, unfold below)
  apply (simp add: type_definition.Abs_inverse [OF type UU_in_A])
 done
 
 theorem typedef_Rep_strict:
   assumes type: "type_definition Rep Abs A"
-    and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
     and UU_in_A: "\<bottom> \<in> A"
   shows "Rep \<bottom> = \<bottom>"
- apply (rule typedef_Abs_strict [OF type less UU_in_A, THEN subst])
+ apply (rule typedef_Abs_strict [OF type below UU_in_A, THEN subst])
  apply (rule type_definition.Abs_inverse [OF type UU_in_A])
 done
 
 theorem typedef_Abs_strict_iff:
   assumes type: "type_definition Rep Abs A"
-    and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
     and UU_in_A: "\<bottom> \<in> A"
   shows "x \<in> A \<Longrightarrow> (Abs x = \<bottom>) = (x = \<bottom>)"
- apply (rule typedef_Abs_strict [OF type less UU_in_A, THEN subst])
+ apply (rule typedef_Abs_strict [OF type below UU_in_A, THEN subst])
  apply (simp add: type_definition.Abs_inject [OF type] UU_in_A)
 done
 
 theorem typedef_Rep_strict_iff:
   assumes type: "type_definition Rep Abs A"
-    and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
     and UU_in_A: "\<bottom> \<in> A"
   shows "(Rep x = \<bottom>) = (x = \<bottom>)"
- apply (rule typedef_Rep_strict [OF type less UU_in_A, THEN subst])
+ apply (rule typedef_Rep_strict [OF type below UU_in_A, THEN subst])
  apply (simp add: type_definition.Rep_inject [OF type])
 done
 
 theorem typedef_Abs_defined:
   assumes type: "type_definition Rep Abs A"
-    and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
     and UU_in_A: "\<bottom> \<in> A"
   shows "\<lbrakk>x \<noteq> \<bottom>; x \<in> A\<rbrakk> \<Longrightarrow> Abs x \<noteq> \<bottom>"
-by (simp add: typedef_Abs_strict_iff [OF type less UU_in_A])
+by (simp add: typedef_Abs_strict_iff [OF type below UU_in_A])
 
 theorem typedef_Rep_defined:
   assumes type: "type_definition Rep Abs A"
-    and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
     and UU_in_A: "\<bottom> \<in> A"
   shows "x \<noteq> \<bottom> \<Longrightarrow> Rep x \<noteq> \<bottom>"
-by (simp add: typedef_Rep_strict_iff [OF type less UU_in_A])
+by (simp add: typedef_Rep_strict_iff [OF type below UU_in_A])
 
 subsection {* Proving a subtype is flat *}
 
 theorem typedef_flat:
   fixes Abs :: "'a::flat \<Rightarrow> 'b::pcpo"
   assumes type: "type_definition Rep Abs A"
-    and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
+    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
     and UU_in_A: "\<bottom> \<in> A"
   shows "OFCLASS('b, flat_class)"
  apply (intro_classes)
- apply (unfold less)
+ apply (unfold below)
  apply (simp add: type_definition.Rep_inject [OF type, symmetric])
- apply (simp add: typedef_Rep_strict [OF type less UU_in_A])
+ apply (simp add: typedef_Rep_strict [OF type below UU_in_A])
  apply (simp add: ax_flat)
 done
 

--- a/src/HOLCF/Porder.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Porder.thy	Fri May 15 15:56:28 2009 +0200
@@ -10,94 +10,105 @@
 
 subsection {* Type class for partial orders *}
 
-class sq_ord =
-  fixes sq_le :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
+class below =
+  fixes below :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
+begin
 
 notation
-  sq_le (infixl "<<" 55)
+  below (infixl "<<" 55)
 
 notation (xsymbols)
-  sq_le (infixl "\<sqsubseteq>" 55)
+  below (infixl "\<sqsubseteq>" 55)
+
+lemma below_eq_trans: "\<lbrakk>a \<sqsubseteq> b; b = c\<rbrakk> \<Longrightarrow> a \<sqsubseteq> c"
+  by (rule subst)
+
+lemma eq_below_trans: "\<lbrakk>a = b; b \<sqsubseteq> c\<rbrakk> \<Longrightarrow> a \<sqsubseteq> c"
+  by (rule ssubst)
 
-class po = sq_ord +
-  assumes refl_less [iff]: "x \<sqsubseteq> x"
-  assumes trans_less: "\<lbrakk>x \<sqsubseteq> y; y \<sqsubseteq> z\<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"
-  assumes antisym_less: "\<lbrakk>x \<sqsubseteq> y; y \<sqsubseteq> x\<rbrakk> \<Longrightarrow> x = y"
+end
+
+class po = below +
+  assumes below_refl [iff]: "x \<sqsubseteq> x"
+  assumes below_trans: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> z"
+  assumes below_antisym: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> x \<Longrightarrow> x = y"
+begin
 
 text {* minimal fixes least element *}
 
-lemma minimal2UU[OF allI] : "\<forall>x::'a::po. uu \<sqsubseteq> x \<Longrightarrow> uu = (THE u. \<forall>y. u \<sqsubseteq> y)"
-by (blast intro: theI2 antisym_less)
+lemma minimal2UU[OF allI] : "\<forall>x. uu \<sqsubseteq> x \<Longrightarrow> uu = (THE u. \<forall>y. u \<sqsubseteq> y)"
+  by (blast intro: theI2 below_antisym)
 
 text {* the reverse law of anti-symmetry of @{term "op <<"} *}
+(* Is this rule ever useful? *)
+lemma below_antisym_inverse: "x = y \<Longrightarrow> x \<sqsubseteq> y \<and> y \<sqsubseteq> x"
+  by simp
 
-lemma antisym_less_inverse: "(x::'a::po) = y \<Longrightarrow> x \<sqsubseteq> y \<and> y \<sqsubseteq> x"
-by simp
-
-lemma box_less: "\<lbrakk>(a::'a::po) \<sqsubseteq> b; c \<sqsubseteq> a; b \<sqsubseteq> d\<rbrakk> \<Longrightarrow> c \<sqsubseteq> d"
-by (rule trans_less [OF trans_less])
+lemma box_below: "a \<sqsubseteq> b \<Longrightarrow> c \<sqsubseteq> a \<Longrightarrow> b \<sqsubseteq> d \<Longrightarrow> c \<sqsubseteq> d"
+  by (rule below_trans [OF below_trans])
 
-lemma po_eq_conv: "((x::'a::po) = y) = (x \<sqsubseteq> y \<and> y \<sqsubseteq> x)"
-by (fast elim!: antisym_less_inverse intro!: antisym_less)
-
-lemma rev_trans_less: "\<lbrakk>(y::'a::po) \<sqsubseteq> z; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"
-by (rule trans_less)
+lemma po_eq_conv: "x = y \<longleftrightarrow> x \<sqsubseteq> y \<and> y \<sqsubseteq> x"
+  by (fast intro!: below_antisym)
 
-lemma sq_ord_less_eq_trans: "\<lbrakk>a \<sqsubseteq> b; b = c\<rbrakk> \<Longrightarrow> a \<sqsubseteq> c"
-by (rule subst)
+lemma rev_below_trans: "y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> x \<sqsubseteq> z"
+  by (rule below_trans)
 
-lemma sq_ord_eq_less_trans: "\<lbrakk>a = b; b \<sqsubseteq> c\<rbrakk> \<Longrightarrow> a \<sqsubseteq> c"
-by (rule ssubst)
+lemma not_below2not_eq: "\<not> x \<sqsubseteq> y \<Longrightarrow> x \<noteq> y"
+  by auto
+
+end
 
 lemmas HOLCF_trans_rules [trans] =
-  trans_less
-  antisym_less
-  sq_ord_less_eq_trans
-  sq_ord_eq_less_trans
+  below_trans
+  below_antisym
+  below_eq_trans
+  eq_below_trans
+
+context po
+begin
 
 subsection {* Upper bounds *}
 
-definition
-  is_ub :: "['a set, 'a::po] \<Rightarrow> bool"  (infixl "<|" 55)  where
-  "(S <| x) = (\<forall>y. y \<in> S \<longrightarrow> y \<sqsubseteq> x)"
+definition is_ub :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infixl "<|" 55) where
+  "S <| x \<longleftrightarrow> (\<forall>y. y \<in> S \<longrightarrow> y \<sqsubseteq> x)"
 
 lemma is_ubI: "(\<And>x. x \<in> S \<Longrightarrow> x \<sqsubseteq> u) \<Longrightarrow> S <| u"
-by (simp add: is_ub_def)
+  by (simp add: is_ub_def)
 
 lemma is_ubD: "\<lbrakk>S <| u; x \<in> S\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
-by (simp add: is_ub_def)
+  by (simp add: is_ub_def)
 
 lemma ub_imageI: "(\<And>x. x \<in> S \<Longrightarrow> f x \<sqsubseteq> u) \<Longrightarrow> (\<lambda>x. f x) ` S <| u"
-unfolding is_ub_def by fast
+  unfolding is_ub_def by fast
 
 lemma ub_imageD: "\<lbrakk>f ` S <| u; x \<in> S\<rbrakk> \<Longrightarrow> f x \<sqsubseteq> u"
-unfolding is_ub_def by fast
+  unfolding is_ub_def by fast
 
 lemma ub_rangeI: "(\<And>i. S i \<sqsubseteq> x) \<Longrightarrow> range S <| x"
-unfolding is_ub_def by fast
+  unfolding is_ub_def by fast
 
 lemma ub_rangeD: "range S <| x \<Longrightarrow> S i \<sqsubseteq> x"
-unfolding is_ub_def by fast
+  unfolding is_ub_def by fast
 
 lemma is_ub_empty [simp]: "{} <| u"
-unfolding is_ub_def by fast
+  unfolding is_ub_def by fast
 
 lemma is_ub_insert [simp]: "(insert x A) <| y = (x \<sqsubseteq> y \<and> A <| y)"
-unfolding is_ub_def by fast
+  unfolding is_ub_def by fast
 
 lemma is_ub_upward: "\<lbrakk>S <| x; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> S <| y"
-unfolding is_ub_def by (fast intro: trans_less)
+  unfolding is_ub_def by (fast intro: below_trans)
 
 subsection {* Least upper bounds *}
 
-definition
-  is_lub :: "['a set, 'a::po] \<Rightarrow> bool"  (infixl "<<|" 55)  where
-  "(S <<| x) = (S <| x \<and> (\<forall>u. S <| u \<longrightarrow> x \<sqsubseteq> u))"
+definition is_lub :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infixl "<<|" 55) where
+  "S <<| x \<longleftrightarrow> S <| x \<and> (\<forall>u. S <| u \<longrightarrow> x \<sqsubseteq> u)"
 
-definition
-  lub :: "'a set \<Rightarrow> 'a::po" where
+definition lub :: "'a set \<Rightarrow> 'a" where
   "lub S = (THE x. S <<| x)"
 
+end
+
 syntax
   "_BLub" :: "[pttrn, 'a set, 'b] \<Rightarrow> 'b" ("(3LUB _:_./ _)" [0,0, 10] 10)
 
@@ -107,6 +118,9 @@
 translations
   "LUB x:A. t" == "CONST lub ((%x. t) ` A)"
 
+context po
+begin
+
 abbreviation
   Lub  (binder "LUB " 10) where
   "LUB n. t n == lub (range t)"
@@ -117,19 +131,19 @@
 text {* access to some definition as inference rule *}
 
 lemma is_lubD1: "S <<| x \<Longrightarrow> S <| x"
-unfolding is_lub_def by fast
+  unfolding is_lub_def by fast
 
 lemma is_lub_lub: "\<lbrakk>S <<| x; S <| u\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
-unfolding is_lub_def by fast
+  unfolding is_lub_def by fast
 
 lemma is_lubI: "\<lbrakk>S <| x; \<And>u. S <| u \<Longrightarrow> x \<sqsubseteq> u\<rbrakk> \<Longrightarrow> S <<| x"
-unfolding is_lub_def by fast
+  unfolding is_lub_def by fast
 
 text {* lubs are unique *}
 
 lemma unique_lub: "\<lbrakk>S <<| x; S <<| y\<rbrakk> \<Longrightarrow> x = y"
 apply (unfold is_lub_def is_ub_def)
-apply (blast intro: antisym_less)
+apply (blast intro: below_antisym)
 done
 
 text {* technical lemmas about @{term lub} and @{term is_lub} *}
@@ -142,60 +156,59 @@
 done
 
 lemma thelubI: "M <<| l \<Longrightarrow> lub M = l"
-by (rule unique_lub [OF lubI])
+  by (rule unique_lub [OF lubI])
 
 lemma is_lub_singleton: "{x} <<| x"
-by (simp add: is_lub_def)
+  by (simp add: is_lub_def)
 
 lemma lub_singleton [simp]: "lub {x} = x"
-by (rule thelubI [OF is_lub_singleton])
+  by (rule thelubI [OF is_lub_singleton])
 
 lemma is_lub_bin: "x \<sqsubseteq> y \<Longrightarrow> {x, y} <<| y"
-by (simp add: is_lub_def)
+  by (simp add: is_lub_def)
 
 lemma lub_bin: "x \<sqsubseteq> y \<Longrightarrow> lub {x, y} = y"
-by (rule is_lub_bin [THEN thelubI])
+  by (rule is_lub_bin [THEN thelubI])
 
 lemma is_lub_maximal: "\<lbrakk>S <| x; x \<in> S\<rbrakk> \<Longrightarrow> S <<| x"
-by (erule is_lubI, erule (1) is_ubD)
+  by (erule is_lubI, erule (1) is_ubD)
 
 lemma lub_maximal: "\<lbrakk>S <| x; x \<in> S\<rbrakk> \<Longrightarrow> lub S = x"
-by (rule is_lub_maximal [THEN thelubI])
+  by (rule is_lub_maximal [THEN thelubI])
 
 subsection {* Countable chains *}
 
-definition
+definition chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool" where
   -- {* Here we use countable chains and I prefer to code them as functions! *}
-  chain :: "(nat \<Rightarrow> 'a::po) \<Rightarrow> bool" where
   "chain Y = (\<forall>i. Y i \<sqsubseteq> Y (Suc i))"
 
 lemma chainI: "(\<And>i. Y i \<sqsubseteq> Y (Suc i)) \<Longrightarrow> chain Y"
-unfolding chain_def by fast
+  unfolding chain_def by fast
 
 lemma chainE: "chain Y \<Longrightarrow> Y i \<sqsubseteq> Y (Suc i)"
-unfolding chain_def by fast
+  unfolding chain_def by fast
 
 text {* chains are monotone functions *}
 
 lemma chain_mono_less: "\<lbrakk>chain Y; i < j\<rbrakk> \<Longrightarrow> Y i \<sqsubseteq> Y j"
-by (erule less_Suc_induct, erule chainE, erule trans_less)
+  by (erule less_Suc_induct, erule chainE, erule below_trans)
 
 lemma chain_mono: "\<lbrakk>chain Y; i \<le> j\<rbrakk> \<Longrightarrow> Y i \<sqsubseteq> Y j"
-by (cases "i = j", simp, simp add: chain_mono_less)
+  by (cases "i = j", simp, simp add: chain_mono_less)
 
 lemma chain_shift: "chain Y \<Longrightarrow> chain (\<lambda>i. Y (i + j))"
-by (rule chainI, simp, erule chainE)
+  by (rule chainI, simp, erule chainE)
 
 text {* technical lemmas about (least) upper bounds of chains *}
 
 lemma is_ub_lub: "range S <<| x \<Longrightarrow> S i \<sqsubseteq> x"
-by (rule is_lubD1 [THEN ub_rangeD])
+  by (rule is_lubD1 [THEN ub_rangeD])
 
 lemma is_ub_range_shift:
   "chain S \<Longrightarrow> range (\<lambda>i. S (i + j)) <| x = range S <| x"
 apply (rule iffI)
 apply (rule ub_rangeI)
-apply (rule_tac y="S (i + j)" in trans_less)
+apply (rule_tac y="S (i + j)" in below_trans)
 apply (erule chain_mono)
 apply (rule le_add1)
 apply (erule ub_rangeD)
@@ -205,45 +218,43 @@
 
 lemma is_lub_range_shift:
   "chain S \<Longrightarrow> range (\<lambda>i. S (i + j)) <<| x = range S <<| x"
-by (simp add: is_lub_def is_ub_range_shift)
+  by (simp add: is_lub_def is_ub_range_shift)
 
 text {* the lub of a constant chain is the constant *}
 
 lemma chain_const [simp]: "chain (\<lambda>i. c)"
-by (simp add: chainI)
+  by (simp add: chainI)
 
 lemma lub_const: "range (\<lambda>x. c) <<| c"
 by (blast dest: ub_rangeD intro: is_lubI ub_rangeI)
 
 lemma thelub_const [simp]: "(\<Squnion>i. c) = c"
-by (rule lub_const [THEN thelubI])
+  by (rule lub_const [THEN thelubI])
 
 subsection {* Finite chains *}
 
-definition
+definition max_in_chain :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool" where
   -- {* finite chains, needed for monotony of continuous functions *}
-  max_in_chain :: "[nat, nat \<Rightarrow> 'a::po] \<Rightarrow> bool" where
-  "max_in_chain i C = (\<forall>j. i \<le> j \<longrightarrow> C i = C j)"
+  "max_in_chain i C \<longleftrightarrow> (\<forall>j. i \<le> j \<longrightarrow> C i = C j)"
 
-definition
-  finite_chain :: "(nat \<Rightarrow> 'a::po) \<Rightarrow> bool" where
+definition finite_chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool" where
   "finite_chain C = (chain C \<and> (\<exists>i. max_in_chain i C))"
 
 text {* results about finite chains *}
 
 lemma max_in_chainI: "(\<And>j. i \<le> j \<Longrightarrow> Y i = Y j) \<Longrightarrow> max_in_chain i Y"
-unfolding max_in_chain_def by fast
+  unfolding max_in_chain_def by fast
 
 lemma max_in_chainD: "\<lbrakk>max_in_chain i Y; i \<le> j\<rbrakk> \<Longrightarrow> Y i = Y j"
-unfolding max_in_chain_def by fast
+  unfolding max_in_chain_def by fast
 
 lemma finite_chainI:
   "\<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> finite_chain C"
-unfolding finite_chain_def by fast
+  unfolding finite_chain_def by fast
 
 lemma finite_chainE:
   "\<lbrakk>finite_chain C; \<And>i. \<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
-unfolding finite_chain_def by fast
+  unfolding finite_chain_def by fast
 
 lemma lub_finch1: "\<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> range C <<| C i"
 apply (rule is_lubI)
@@ -302,7 +313,7 @@
   apply (erule exE)
   apply (rule finite_chainI, assumption)
   apply (rule max_in_chainI)
-  apply (rule antisym_less)
+  apply (rule below_antisym)
    apply (erule (1) chain_mono)
   apply (erule spec)
  apply (rule finite_range_has_max)
@@ -311,11 +322,11 @@
 done
 
 lemma bin_chain: "x \<sqsubseteq> y \<Longrightarrow> chain (\<lambda>i. if i=0 then x else y)"
-by (rule chainI, simp)
+  by (rule chainI, simp)
 
 lemma bin_chainmax:
   "x \<sqsubseteq> y \<Longrightarrow> max_in_chain (Suc 0) (\<lambda>i. if i=0 then x else y)"
-unfolding max_in_chain_def by simp
+  unfolding max_in_chain_def by simp
 
 lemma lub_bin_chain:
   "x \<sqsubseteq> y \<Longrightarrow> range (\<lambda>i::nat. if i=0 then x else y) <<| y"
@@ -328,36 +339,35 @@
 text {* the maximal element in a chain is its lub *}
 
 lemma lub_chain_maxelem: "\<lbrakk>Y i = c; \<forall>i. Y i \<sqsubseteq> c\<rbrakk> \<Longrightarrow> lub (range Y) = c"
-by (blast dest: ub_rangeD intro: thelubI is_lubI ub_rangeI)
+  by (blast dest: ub_rangeD intro: thelubI is_lubI ub_rangeI)
 
 subsection {* Directed sets *}
 
-definition
-  directed :: "'a::po set \<Rightarrow> bool" where
-  "directed S = ((\<exists>x. x \<in> S) \<and> (\<forall>x\<in>S. \<forall>y\<in>S. \<exists>z\<in>S. x \<sqsubseteq> z \<and> y \<sqsubseteq> z))"
+definition directed :: "'a set \<Rightarrow> bool" where
+  "directed S \<longleftrightarrow> (\<exists>x. x \<in> S) \<and> (\<forall>x\<in>S. \<forall>y\<in>S. \<exists>z\<in>S. x \<sqsubseteq> z \<and> y \<sqsubseteq> z)"
 
 lemma directedI:
   assumes 1: "\<exists>z. z \<in> S"
   assumes 2: "\<And>x y. \<lbrakk>x \<in> S; y \<in> S\<rbrakk> \<Longrightarrow> \<exists>z\<in>S. x \<sqsubseteq> z \<and> y \<sqsubseteq> z"
   shows "directed S"
-unfolding directed_def using prems by fast
+  unfolding directed_def using prems by fast
 
 lemma directedD1: "directed S \<Longrightarrow> \<exists>z. z \<in> S"
-unfolding directed_def by fast
+  unfolding directed_def by fast
 
 lemma directedD2: "\<lbrakk>directed S; x \<in> S; y \<in> S\<rbrakk> \<Longrightarrow> \<exists>z\<in>S. x \<sqsubseteq> z \<and> y \<sqsubseteq> z"
-unfolding directed_def by fast
+  unfolding directed_def by fast
 
 lemma directedE1:
   assumes S: "directed S"
   obtains z where "z \<in> S"
-by (insert directedD1 [OF S], fast)
+  by (insert directedD1 [OF S], fast)
 
 lemma directedE2:
   assumes S: "directed S"
   assumes x: "x \<in> S" and y: "y \<in> S"
   obtains z where "z \<in> S" "x \<sqsubseteq> z" "y \<sqsubseteq> z"
-by (insert directedD2 [OF S x y], fast)
+  by (insert directedD2 [OF S x y], fast)
 
 lemma directed_finiteI:
   assumes U: "\<And>U. \<lbrakk>finite U; U \<subseteq> S\<rbrakk> \<Longrightarrow> \<exists>z\<in>S. U <| z"
@@ -395,13 +405,13 @@
 qed
 
 lemma not_directed_empty [simp]: "\<not> directed {}"
-by (rule notI, drule directedD1, simp)
+  by (rule notI, drule directedD1, simp)
 
 lemma directed_singleton: "directed {x}"
-by (rule directedI, auto)
+  by (rule directedI, auto)
 
 lemma directed_bin: "x \<sqsubseteq> y \<Longrightarrow> directed {x, y}"
-by (rule directedI, auto)
+  by (rule directedI, auto)
 
 lemma directed_chain: "chain S \<Longrightarrow> directed (range S)"
 apply (rule directedI)
@@ -412,4 +422,33 @@
 apply simp
 done
 
+text {* lemmata for improved admissibility introdution rule *}
+
+lemma infinite_chain_adm_lemma:
+  "\<lbrakk>chain Y; \<forall>i. P (Y i);  
+    \<And>Y. \<lbrakk>chain Y; \<forall>i. P (Y i); \<not> finite_chain Y\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)\<rbrakk>
+      \<Longrightarrow> P (\<Squnion>i. Y i)"
+apply (case_tac "finite_chain Y")
+prefer 2 apply fast
+apply (unfold finite_chain_def)
+apply safe
+apply (erule lub_finch1 [THEN thelubI, THEN ssubst])
+apply assumption
+apply (erule spec)
+done
+
+lemma increasing_chain_adm_lemma:
+  "\<lbrakk>chain Y;  \<forall>i. P (Y i); \<And>Y. \<lbrakk>chain Y; \<forall>i. P (Y i);
+    \<forall>i. \<exists>j>i. Y i \<noteq> Y j \<and> Y i \<sqsubseteq> Y j\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)\<rbrakk>
+      \<Longrightarrow> P (\<Squnion>i. Y i)"
+apply (erule infinite_chain_adm_lemma)
+apply assumption
+apply (erule thin_rl)
+apply (unfold finite_chain_def)
+apply (unfold max_in_chain_def)
+apply (fast dest: le_imp_less_or_eq elim: chain_mono_less)
+done
+
 end
+
+end

--- a/src/HOLCF/Product_Cpo.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Product_Cpo.thy	Fri May 15 15:56:28 2009 +0200
@@ -12,11 +12,11 @@
 
 subsection {* Type @{typ unit} is a pcpo *}
 
-instantiation unit :: sq_ord
+instantiation unit :: below
 begin
 
 definition
-  less_unit_def [simp]: "x \<sqsubseteq> (y::unit) \<equiv> True"
+  below_unit_def [simp]: "x \<sqsubseteq> (y::unit) \<longleftrightarrow> True"
 
 instance ..
 end
@@ -32,11 +32,11 @@
 
 subsection {* Product type is a partial order *}
 
-instantiation "*" :: (sq_ord, sq_ord) sq_ord
+instantiation "*" :: (below, below) below
 begin
 
 definition
-  less_cprod_def: "(op \<sqsubseteq>) \<equiv> \<lambda>p1 p2. (fst p1 \<sqsubseteq> fst p2 \<and> snd p1 \<sqsubseteq> snd p2)"
+  below_prod_def: "(op \<sqsubseteq>) \<equiv> \<lambda>p1 p2. (fst p1 \<sqsubseteq> fst p2 \<and> snd p1 \<sqsubseteq> snd p2)"
 
 instance ..
 end
@@ -45,26 +45,26 @@
 proof
   fix x :: "'a \<times> 'b"
   show "x \<sqsubseteq> x"
-    unfolding less_cprod_def by simp
+    unfolding below_prod_def by simp
 next
   fix x y :: "'a \<times> 'b"
   assume "x \<sqsubseteq> y" "y \<sqsubseteq> x" thus "x = y"
-    unfolding less_cprod_def Pair_fst_snd_eq
-    by (fast intro: antisym_less)
+    unfolding below_prod_def Pair_fst_snd_eq
+    by (fast intro: below_antisym)
 next
   fix x y z :: "'a \<times> 'b"
   assume "x \<sqsubseteq> y" "y \<sqsubseteq> z" thus "x \<sqsubseteq> z"
-    unfolding less_cprod_def
-    by (fast intro: trans_less)
+    unfolding below_prod_def
+    by (fast intro: below_trans)
 qed
 
 subsection {* Monotonicity of @{text "(_,_)"}, @{term fst}, @{term snd} *}
 
-lemma prod_lessI: "\<lbrakk>fst p \<sqsubseteq> fst q; snd p \<sqsubseteq> snd q\<rbrakk> \<Longrightarrow> p \<sqsubseteq> q"
-unfolding less_cprod_def by simp
+lemma prod_belowI: "\<lbrakk>fst p \<sqsubseteq> fst q; snd p \<sqsubseteq> snd q\<rbrakk> \<Longrightarrow> p \<sqsubseteq> q"
+unfolding below_prod_def by simp
 
-lemma Pair_less_iff [simp]: "(a, b) \<sqsubseteq> (c, d) \<longleftrightarrow> a \<sqsubseteq> c \<and> b \<sqsubseteq> d"
-unfolding less_cprod_def by simp
+lemma Pair_below_iff [simp]: "(a, b) \<sqsubseteq> (c, d) \<longleftrightarrow> a \<sqsubseteq> c \<and> b \<sqsubseteq> d"
+unfolding below_prod_def by simp
 
 text {* Pair @{text "(_,_)"}  is monotone in both arguments *}
 
@@ -78,36 +78,59 @@
   "\<lbrakk>x1 \<sqsubseteq> x2; y1 \<sqsubseteq> y2\<rbrakk> \<Longrightarrow> (x1, y1) \<sqsubseteq> (x2, y2)"
 by simp
 
+lemma ch2ch_Pair [simp]:
+  "chain X \<Longrightarrow> chain Y \<Longrightarrow> chain (\<lambda>i. (X i, Y i))"
+by (rule chainI, simp add: chainE)
+
 text {* @{term fst} and @{term snd} are monotone *}
 
 lemma monofun_fst: "monofun fst"
-by (simp add: monofun_def less_cprod_def)
+by (simp add: monofun_def below_prod_def)
 
 lemma monofun_snd: "monofun snd"
-by (simp add: monofun_def less_cprod_def)
+by (simp add: monofun_def below_prod_def)
+
+lemmas ch2ch_fst [simp] = ch2ch_monofun [OF monofun_fst]
+
+lemmas ch2ch_snd [simp] = ch2ch_monofun [OF monofun_snd]
+
+lemma prod_chain_cases:
+  assumes "chain Y"
+  obtains A B
+  where "chain A" and "chain B" and "Y = (\<lambda>i. (A i, B i))"
+proof
+  from `chain Y` show "chain (\<lambda>i. fst (Y i))" by (rule ch2ch_fst)
+  from `chain Y` show "chain (\<lambda>i. snd (Y i))" by (rule ch2ch_snd)
+  show "Y = (\<lambda>i. (fst (Y i), snd (Y i)))" by simp
+qed
 
 subsection {* Product type is a cpo *}
 
 lemma is_lub_Pair:
-  "\<lbrakk>range X <<| x; range Y <<| y\<rbrakk> \<Longrightarrow> range (\<lambda>i. (X i, Y i)) <<| (x, y)"
+  "\<lbrakk>range A <<| x; range B <<| y\<rbrakk> \<Longrightarrow> range (\<lambda>i. (A i, B i)) <<| (x, y)"
 apply (rule is_lubI [OF ub_rangeI])
-apply (simp add: less_cprod_def is_ub_lub)
+apply (simp add: is_ub_lub)
 apply (frule ub2ub_monofun [OF monofun_fst])
 apply (drule ub2ub_monofun [OF monofun_snd])
-apply (simp add: less_cprod_def is_lub_lub)
+apply (simp add: below_prod_def is_lub_lub)
 done
 
+lemma thelub_Pair:
+  "\<lbrakk>chain (A::nat \<Rightarrow> 'a::cpo); chain (B::nat \<Rightarrow> 'b::cpo)\<rbrakk>
+    \<Longrightarrow> (\<Squnion>i. (A i, B i)) = (\<Squnion>i. A i, \<Squnion>i. B i)"
+by (fast intro: thelubI is_lub_Pair elim: thelubE)
+
 lemma lub_cprod:
   fixes S :: "nat \<Rightarrow> ('a::cpo \<times> 'b::cpo)"
   assumes S: "chain S"
   shows "range S <<| (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
 proof -
-  have "chain (\<lambda>i. fst (S i))"
-    using monofun_fst S by (rule ch2ch_monofun)
+  from `chain S` have "chain (\<lambda>i. fst (S i))"
+    by (rule ch2ch_fst)
   hence 1: "range (\<lambda>i. fst (S i)) <<| (\<Squnion>i. fst (S i))"
     by (rule cpo_lubI)
-  have "chain (\<lambda>i. snd (S i))"
-    using monofun_snd S by (rule ch2ch_monofun)
+  from `chain S` have "chain (\<lambda>i. snd (S i))"
+    by (rule ch2ch_snd)
   hence 2: "range (\<lambda>i. snd (S i)) <<| (\<Squnion>i. snd (S i))"
     by (rule cpo_lubI)
   show "range S <<| (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
@@ -134,14 +157,14 @@
 proof
   fix x y :: "'a \<times> 'b"
   show "x \<sqsubseteq> y \<longleftrightarrow> x = y"
-    unfolding less_cprod_def Pair_fst_snd_eq
+    unfolding below_prod_def Pair_fst_snd_eq
     by simp
 qed
 
 subsection {* Product type is pointed *}
 
 lemma minimal_cprod: "(\<bottom>, \<bottom>) \<sqsubseteq> p"
-by (simp add: less_cprod_def)
+by (simp add: below_prod_def)
 
 instance "*" :: (pcpo, pcpo) pcpo
 by intro_classes (fast intro: minimal_cprod)
@@ -206,31 +229,71 @@
   assumes f: "cont (\<lambda>x. f x)"
   assumes g: "cont (\<lambda>x. g x)"
   shows "cont (\<lambda>x. (f x, g x))"
-apply (rule cont2cont_apply [OF _ cont_pair1 f])
-apply (rule cont2cont_apply [OF _ cont_pair2 g])
+apply (rule cont_apply [OF f cont_pair1])
+apply (rule cont_apply [OF g cont_pair2])
 apply (rule cont_const)
 done
 
-lemmas cont2cont_fst [cont2cont] = cont2cont_compose [OF cont_fst]
+lemmas cont2cont_fst [cont2cont] = cont_compose [OF cont_fst]
+
+lemmas cont2cont_snd [cont2cont] = cont_compose [OF cont_snd]
+
+lemma cont2cont_split:
+  assumes f1: "\<And>a b. cont (\<lambda>x. f x a b)"
+  assumes f2: "\<And>x b. cont (\<lambda>a. f x a b)"
+  assumes f3: "\<And>x a. cont (\<lambda>b. f x a b)"
+  assumes g: "cont (\<lambda>x. g x)"
+  shows "cont (\<lambda>x. split (\<lambda>a b. f x a b) (g x))"
+unfolding split_def
+apply (rule cont_apply [OF g])
+apply (rule cont_apply [OF cont_fst f2])
+apply (rule cont_apply [OF cont_snd f3])
+apply (rule cont_const)
+apply (rule f1)
+done
+
+lemma cont_fst_snd_D1:
+  "cont (\<lambda>p. f (fst p) (snd p)) \<Longrightarrow> cont (\<lambda>x. f x y)"
+by (drule cont_compose [OF _ cont_pair1], simp)
 
-lemmas cont2cont_snd [cont2cont] = cont2cont_compose [OF cont_snd]
+lemma cont_fst_snd_D2:
+  "cont (\<lambda>p. f (fst p) (snd p)) \<Longrightarrow> cont (\<lambda>y. f x y)"
+by (drule cont_compose [OF _ cont_pair2], simp)
+
+lemma cont2cont_split' [cont2cont]:
+  assumes f: "cont (\<lambda>p. f (fst p) (fst (snd p)) (snd (snd p)))"
+  assumes g: "cont (\<lambda>x. g x)"
+  shows "cont (\<lambda>x. split (f x) (g x))"
+proof -
+  note f1 = f [THEN cont_fst_snd_D1]
+  note f2 = f [THEN cont_fst_snd_D2, THEN cont_fst_snd_D1]
+  note f3 = f [THEN cont_fst_snd_D2, THEN cont_fst_snd_D2]
+  show ?thesis
+    unfolding split_def
+    apply (rule cont_apply [OF g])
+    apply (rule cont_apply [OF cont_fst f2])
+    apply (rule cont_apply [OF cont_snd f3])
+    apply (rule cont_const)
+    apply (rule f1)
+    done
+qed
 
 subsection {* Compactness and chain-finiteness *}
 
-lemma fst_less_iff: "fst (x::'a \<times> 'b) \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (y, snd x)"
-unfolding less_cprod_def by simp
+lemma fst_below_iff: "fst (x::'a \<times> 'b) \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (y, snd x)"
+unfolding below_prod_def by simp
 
-lemma snd_less_iff: "snd (x::'a \<times> 'b) \<sqsubseteq> y = x \<sqsubseteq> (fst x, y)"
-unfolding less_cprod_def by simp
+lemma snd_below_iff: "snd (x::'a \<times> 'b) \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (fst x, y)"
+unfolding below_prod_def by simp
 
 lemma compact_fst: "compact x \<Longrightarrow> compact (fst x)"
-by (rule compactI, simp add: fst_less_iff)
+by (rule compactI, simp add: fst_below_iff)
 
 lemma compact_snd: "compact x \<Longrightarrow> compact (snd x)"
-by (rule compactI, simp add: snd_less_iff)
+by (rule compactI, simp add: snd_below_iff)
 
 lemma compact_Pair: "\<lbrakk>compact x; compact y\<rbrakk> \<Longrightarrow> compact (x, y)"
-by (rule compactI, simp add: less_cprod_def)
+by (rule compactI, simp add: below_prod_def)
 
 lemma compact_Pair_iff [simp]: "compact (x, y) \<longleftrightarrow> compact x \<and> compact y"
 apply (safe intro!: compact_Pair)

--- a/src/HOLCF/Sprod.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Sprod.thy	Fri May 15 15:56:28 2009 +0200
@@ -5,7 +5,7 @@
 header {* The type of strict products *}
 
 theory Sprod
-imports Cprod
+imports Bifinite
 begin
 
 defaultsort pcpo
@@ -13,14 +13,14 @@
 subsection {* Definition of strict product type *}
 
 pcpodef (Sprod)  ('a, 'b) "**" (infixr "**" 20) =
-        "{p::'a \<times> 'b. p = \<bottom> \<or> (cfst\<cdot>p \<noteq> \<bottom> \<and> csnd\<cdot>p \<noteq> \<bottom>)}"
+        "{p::'a \<times> 'b. p = \<bottom> \<or> (fst p \<noteq> \<bottom> \<and> snd p \<noteq> \<bottom>)}"
 by simp_all
 
 instance "**" :: ("{finite_po,pcpo}", "{finite_po,pcpo}") finite_po
 by (rule typedef_finite_po [OF type_definition_Sprod])
 
 instance "**" :: ("{chfin,pcpo}", "{chfin,pcpo}") chfin
-by (rule typedef_chfin [OF type_definition_Sprod less_Sprod_def])
+by (rule typedef_chfin [OF type_definition_Sprod below_Sprod_def])
 
 syntax (xsymbols)
   "**"		:: "[type, type] => type"	 ("(_ \<otimes>/ _)" [21,20] 20)
@@ -28,23 +28,23 @@
   "**"		:: "[type, type] => type"	 ("(_ \<otimes>/ _)" [21,20] 20)
 
 lemma spair_lemma:
-  "<strictify\<cdot>(\<Lambda> b. a)\<cdot>b, strictify\<cdot>(\<Lambda> a. b)\<cdot>a> \<in> Sprod"
+  "(strictify\<cdot>(\<Lambda> b. a)\<cdot>b, strictify\<cdot>(\<Lambda> a. b)\<cdot>a) \<in> Sprod"
 by (simp add: Sprod_def strictify_conv_if)
 
 subsection {* Definitions of constants *}
 
 definition
   sfst :: "('a ** 'b) \<rightarrow> 'a" where
-  "sfst = (\<Lambda> p. cfst\<cdot>(Rep_Sprod p))"
+  "sfst = (\<Lambda> p. fst (Rep_Sprod p))"
 
 definition
   ssnd :: "('a ** 'b) \<rightarrow> 'b" where
-  "ssnd = (\<Lambda> p. csnd\<cdot>(Rep_Sprod p))"
+  "ssnd = (\<Lambda> p. snd (Rep_Sprod p))"
 
 definition
   spair :: "'a \<rightarrow> 'b \<rightarrow> ('a ** 'b)" where
   "spair = (\<Lambda> a b. Abs_Sprod
-             <strictify\<cdot>(\<Lambda> b. a)\<cdot>b, strictify\<cdot>(\<Lambda> a. b)\<cdot>a>)"
+             (strictify\<cdot>(\<Lambda> b. a)\<cdot>b, strictify\<cdot>(\<Lambda> a. b)\<cdot>a))"
 
 definition
   ssplit :: "('a \<rightarrow> 'b \<rightarrow> 'c) \<rightarrow> ('a ** 'b) \<rightarrow> 'c" where
@@ -62,18 +62,18 @@
 subsection {* Case analysis *}
 
 lemma Rep_Sprod_spair:
-  "Rep_Sprod (:a, b:) = <strictify\<cdot>(\<Lambda> b. a)\<cdot>b, strictify\<cdot>(\<Lambda> a. b)\<cdot>a>"
+  "Rep_Sprod (:a, b:) = (strictify\<cdot>(\<Lambda> b. a)\<cdot>b, strictify\<cdot>(\<Lambda> a. b)\<cdot>a)"
 unfolding spair_def
 by (simp add: cont_Abs_Sprod Abs_Sprod_inverse spair_lemma)
 
 lemmas Rep_Sprod_simps =
-  Rep_Sprod_inject [symmetric] less_Sprod_def
+  Rep_Sprod_inject [symmetric] below_Sprod_def
   Rep_Sprod_strict Rep_Sprod_spair
 
 lemma Exh_Sprod:
   "z = \<bottom> \<or> (\<exists>a b. z = (:a, b:) \<and> a \<noteq> \<bottom> \<and> b \<noteq> \<bottom>)"
 apply (insert Rep_Sprod [of z])
-apply (simp add: Rep_Sprod_simps eq_cprod)
+apply (simp add: Rep_Sprod_simps Pair_fst_snd_eq)
 apply (simp add: Sprod_def)
 apply (erule disjE, simp)
 apply (simp add: strictify_conv_if)
@@ -99,7 +99,7 @@
 lemma spair_strict_iff [simp]: "((:x, y:) = \<bottom>) = (x = \<bottom> \<or> y = \<bottom>)"
 by (simp add: Rep_Sprod_simps strictify_conv_if)
 
-lemma spair_less_iff:
+lemma spair_below_iff:
   "((:a, b:) \<sqsubseteq> (:c, d:)) = (a = \<bottom> \<or> b = \<bottom> \<or> (a \<sqsubseteq> c \<and> b \<sqsubseteq> d))"
 by (simp add: Rep_Sprod_simps strictify_conv_if)
 
@@ -160,38 +160,38 @@
 lemma surjective_pairing_Sprod2: "(:sfst\<cdot>p, ssnd\<cdot>p:) = p"
 by (cases p, simp_all)
 
-lemma less_sprod: "x \<sqsubseteq> y = (sfst\<cdot>x \<sqsubseteq> sfst\<cdot>y \<and> ssnd\<cdot>x \<sqsubseteq> ssnd\<cdot>y)"
-apply (simp add: less_Sprod_def sfst_def ssnd_def cont_Rep_Sprod)
-apply (rule less_cprod)
+lemma below_sprod: "x \<sqsubseteq> y = (sfst\<cdot>x \<sqsubseteq> sfst\<cdot>y \<and> ssnd\<cdot>x \<sqsubseteq> ssnd\<cdot>y)"
+apply (simp add: below_Sprod_def sfst_def ssnd_def cont_Rep_Sprod)
+apply (simp only: below_prod_def)
 done
 
 lemma eq_sprod: "(x = y) = (sfst\<cdot>x = sfst\<cdot>y \<and> ssnd\<cdot>x = ssnd\<cdot>y)"
-by (auto simp add: po_eq_conv less_sprod)
+by (auto simp add: po_eq_conv below_sprod)
 
-lemma spair_less:
+lemma spair_below:
   "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> (:x, y:) \<sqsubseteq> (:a, b:) = (x \<sqsubseteq> a \<and> y \<sqsubseteq> b)"
 apply (cases "a = \<bottom>", simp)
 apply (cases "b = \<bottom>", simp)
-apply (simp add: less_sprod)
+apply (simp add: below_sprod)
 done
 
-lemma sfst_less_iff: "sfst\<cdot>x \<sqsubseteq> y = x \<sqsubseteq> (:y, ssnd\<cdot>x:)"
+lemma sfst_below_iff: "sfst\<cdot>x \<sqsubseteq> y = x \<sqsubseteq> (:y, ssnd\<cdot>x:)"
 apply (cases "x = \<bottom>", simp, cases "y = \<bottom>", simp)
-apply (simp add: less_sprod)
+apply (simp add: below_sprod)
 done
 
-lemma ssnd_less_iff: "ssnd\<cdot>x \<sqsubseteq> y = x \<sqsubseteq> (:sfst\<cdot>x, y:)"
+lemma ssnd_below_iff: "ssnd\<cdot>x \<sqsubseteq> y = x \<sqsubseteq> (:sfst\<cdot>x, y:)"
 apply (cases "x = \<bottom>", simp, cases "y = \<bottom>", simp)
-apply (simp add: less_sprod)
+apply (simp add: below_sprod)
 done
 
 subsection {* Compactness *}
 
 lemma compact_sfst: "compact x \<Longrightarrow> compact (sfst\<cdot>x)"
-by (rule compactI, simp add: sfst_less_iff)
+by (rule compactI, simp add: sfst_below_iff)
 
 lemma compact_ssnd: "compact x \<Longrightarrow> compact (ssnd\<cdot>x)"
-by (rule compactI, simp add: ssnd_less_iff)
+by (rule compactI, simp add: ssnd_below_iff)
 
 lemma compact_spair: "\<lbrakk>compact x; compact y\<rbrakk> \<Longrightarrow> compact (:x, y:)"
 by (rule compact_Sprod, simp add: Rep_Sprod_spair strictify_conv_if)
@@ -224,7 +224,7 @@
   assume "x \<sqsubseteq> y" thus "x = \<bottom> \<or> x = y"
     apply (induct x, simp)
     apply (induct y, simp)
-    apply (simp add: spair_less_iff flat_less_iff)
+    apply (simp add: spair_below_iff flat_below_iff)
     done
 qed
 

--- a/src/HOLCF/Ssum.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Ssum.thy	Fri May 15 15:56:28 2009 +0200
@@ -5,7 +5,7 @@
 header {* The type of strict sums *}
 
 theory Ssum
-imports Cprod Tr
+imports Tr
 begin
 
 defaultsort pcpo
@@ -14,15 +14,15 @@
 
 pcpodef (Ssum)  ('a, 'b) "++" (infixr "++" 10) = 
   "{p :: tr \<times> ('a \<times> 'b).
-    (cfst\<cdot>p \<sqsubseteq> TT \<longleftrightarrow> csnd\<cdot>(csnd\<cdot>p) = \<bottom>) \<and>
-    (cfst\<cdot>p \<sqsubseteq> FF \<longleftrightarrow> cfst\<cdot>(csnd\<cdot>p) = \<bottom>)}"
+    (fst p \<sqsubseteq> TT \<longleftrightarrow> snd (snd p) = \<bottom>) \<and>
+    (fst p \<sqsubseteq> FF \<longleftrightarrow> fst (snd p) = \<bottom>)}"
 by simp_all
 
 instance "++" :: ("{finite_po,pcpo}", "{finite_po,pcpo}") finite_po
 by (rule typedef_finite_po [OF type_definition_Ssum])
 
 instance "++" :: ("{chfin,pcpo}", "{chfin,pcpo}") chfin
-by (rule typedef_chfin [OF type_definition_Ssum less_Ssum_def])
+by (rule typedef_chfin [OF type_definition_Ssum below_Ssum_def])
 
 syntax (xsymbols)
   "++"		:: "[type, type] => type"	("(_ \<oplus>/ _)" [21, 20] 20)
@@ -33,45 +33,45 @@
 
 definition
   sinl :: "'a \<rightarrow> ('a ++ 'b)" where
-  "sinl = (\<Lambda> a. Abs_Ssum <strictify\<cdot>(\<Lambda> _. TT)\<cdot>a, a, \<bottom>>)"
+  "sinl = (\<Lambda> a. Abs_Ssum (strictify\<cdot>(\<Lambda> _. TT)\<cdot>a, a, \<bottom>))"
 
 definition
   sinr :: "'b \<rightarrow> ('a ++ 'b)" where
-  "sinr = (\<Lambda> b. Abs_Ssum <strictify\<cdot>(\<Lambda> _. FF)\<cdot>b, \<bottom>, b>)"
+  "sinr = (\<Lambda> b. Abs_Ssum (strictify\<cdot>(\<Lambda> _. FF)\<cdot>b, \<bottom>, b))"
 
-lemma sinl_Ssum: "<strictify\<cdot>(\<Lambda> _. TT)\<cdot>a, a, \<bottom>> \<in> Ssum"
+lemma sinl_Ssum: "(strictify\<cdot>(\<Lambda> _. TT)\<cdot>a, a, \<bottom>) \<in> Ssum"
 by (simp add: Ssum_def strictify_conv_if)
 
-lemma sinr_Ssum: "<strictify\<cdot>(\<Lambda> _. FF)\<cdot>b, \<bottom>, b> \<in> Ssum"
+lemma sinr_Ssum: "(strictify\<cdot>(\<Lambda> _. FF)\<cdot>b, \<bottom>, b) \<in> Ssum"
 by (simp add: Ssum_def strictify_conv_if)
 
-lemma sinl_Abs_Ssum: "sinl\<cdot>a = Abs_Ssum <strictify\<cdot>(\<Lambda> _. TT)\<cdot>a, a, \<bottom>>"
+lemma sinl_Abs_Ssum: "sinl\<cdot>a = Abs_Ssum (strictify\<cdot>(\<Lambda> _. TT)\<cdot>a, a, \<bottom>)"
 by (unfold sinl_def, simp add: cont_Abs_Ssum sinl_Ssum)
 
-lemma sinr_Abs_Ssum: "sinr\<cdot>b = Abs_Ssum <strictify\<cdot>(\<Lambda> _. FF)\<cdot>b, \<bottom>, b>"
+lemma sinr_Abs_Ssum: "sinr\<cdot>b = Abs_Ssum (strictify\<cdot>(\<Lambda> _. FF)\<cdot>b, \<bottom>, b)"
 by (unfold sinr_def, simp add: cont_Abs_Ssum sinr_Ssum)
 
-lemma Rep_Ssum_sinl: "Rep_Ssum (sinl\<cdot>a) = <strictify\<cdot>(\<Lambda> _. TT)\<cdot>a, a, \<bottom>>"
+lemma Rep_Ssum_sinl: "Rep_Ssum (sinl\<cdot>a) = (strictify\<cdot>(\<Lambda> _. TT)\<cdot>a, a, \<bottom>)"
 by (simp add: sinl_Abs_Ssum Abs_Ssum_inverse sinl_Ssum)
 
-lemma Rep_Ssum_sinr: "Rep_Ssum (sinr\<cdot>b) = <strictify\<cdot>(\<Lambda> _. FF)\<cdot>b, \<bottom>, b>"
+lemma Rep_Ssum_sinr: "Rep_Ssum (sinr\<cdot>b) = (strictify\<cdot>(\<Lambda> _. FF)\<cdot>b, \<bottom>, b)"
 by (simp add: sinr_Abs_Ssum Abs_Ssum_inverse sinr_Ssum)
 
 subsection {* Properties of @{term sinl} and @{term sinr} *}
 
 text {* Ordering *}
 
-lemma sinl_less [simp]: "(sinl\<cdot>x \<sqsubseteq> sinl\<cdot>y) = (x \<sqsubseteq> y)"
-by (simp add: less_Ssum_def Rep_Ssum_sinl strictify_conv_if)
+lemma sinl_below [simp]: "(sinl\<cdot>x \<sqsubseteq> sinl\<cdot>y) = (x \<sqsubseteq> y)"
+by (simp add: below_Ssum_def Rep_Ssum_sinl strictify_conv_if)
 
-lemma sinr_less [simp]: "(sinr\<cdot>x \<sqsubseteq> sinr\<cdot>y) = (x \<sqsubseteq> y)"
-by (simp add: less_Ssum_def Rep_Ssum_sinr strictify_conv_if)
+lemma sinr_below [simp]: "(sinr\<cdot>x \<sqsubseteq> sinr\<cdot>y) = (x \<sqsubseteq> y)"
+by (simp add: below_Ssum_def Rep_Ssum_sinr strictify_conv_if)
 
-lemma sinl_less_sinr [simp]: "(sinl\<cdot>x \<sqsubseteq> sinr\<cdot>y) = (x = \<bottom>)"
-by (simp add: less_Ssum_def Rep_Ssum_sinl Rep_Ssum_sinr strictify_conv_if)
+lemma sinl_below_sinr [simp]: "(sinl\<cdot>x \<sqsubseteq> sinr\<cdot>y) = (x = \<bottom>)"
+by (simp add: below_Ssum_def Rep_Ssum_sinl Rep_Ssum_sinr strictify_conv_if)
 
-lemma sinr_less_sinl [simp]: "(sinr\<cdot>x \<sqsubseteq> sinl\<cdot>y) = (x = \<bottom>)"
-by (simp add: less_Ssum_def Rep_Ssum_sinl Rep_Ssum_sinr strictify_conv_if)
+lemma sinr_below_sinl [simp]: "(sinr\<cdot>x \<sqsubseteq> sinl\<cdot>y) = (x = \<bottom>)"
+by (simp add: below_Ssum_def Rep_Ssum_sinl Rep_Ssum_sinr strictify_conv_if)
 
 text {* Equality *}
 
@@ -139,12 +139,11 @@
 
 lemma Exh_Ssum: 
   "z = \<bottom> \<or> (\<exists>a. z = sinl\<cdot>a \<and> a \<noteq> \<bottom>) \<or> (\<exists>b. z = sinr\<cdot>b \<and> b \<noteq> \<bottom>)"
-apply (rule_tac x=z in Abs_Ssum_induct)
-apply (rule_tac p=y in cprodE, rename_tac t x)
-apply (rule_tac p=x in cprodE, rename_tac a b)
-apply (rule_tac p=t in trE)
+apply (induct z rule: Abs_Ssum_induct)
+apply (case_tac y, rename_tac t a b)
+apply (case_tac t rule: trE)
 apply (rule disjI1)
-apply (simp add: Ssum_def cpair_strict Abs_Ssum_strict)
+apply (simp add: Ssum_def Abs_Ssum_strict)
 apply (rule disjI2, rule disjI1, rule_tac x=a in exI)
 apply (simp add: sinl_Abs_Ssum Ssum_def)
 apply (rule disjI2, rule disjI2, rule_tac x=b in exI)
@@ -167,17 +166,17 @@
   "\<lbrakk>\<And>x. p = sinl\<cdot>x \<Longrightarrow> Q; \<And>y. p = sinr\<cdot>y \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
 by (cases p, simp only: sinl_strict [symmetric], simp, simp)
 
-lemma less_sinlD: "p \<sqsubseteq> sinl\<cdot>x \<Longrightarrow> \<exists>y. p = sinl\<cdot>y \<and> y \<sqsubseteq> x"
+lemma below_sinlD: "p \<sqsubseteq> sinl\<cdot>x \<Longrightarrow> \<exists>y. p = sinl\<cdot>y \<and> y \<sqsubseteq> x"
 by (cases p, rule_tac x="\<bottom>" in exI, simp_all)
 
-lemma less_sinrD: "p \<sqsubseteq> sinr\<cdot>x \<Longrightarrow> \<exists>y. p = sinr\<cdot>y \<and> y \<sqsubseteq> x"
+lemma below_sinrD: "p \<sqsubseteq> sinr\<cdot>x \<Longrightarrow> \<exists>y. p = sinr\<cdot>y \<and> y \<sqsubseteq> x"
 by (cases p, rule_tac x="\<bottom>" in exI, simp_all)
 
 subsection {* Case analysis combinator *}
 
 definition
   sscase :: "('a \<rightarrow> 'c) \<rightarrow> ('b \<rightarrow> 'c) \<rightarrow> ('a ++ 'b) \<rightarrow> 'c" where
-  "sscase = (\<Lambda> f g s. (\<Lambda><t, x, y>. If t then f\<cdot>x else g\<cdot>y fi)\<cdot>(Rep_Ssum s))"
+  "sscase = (\<Lambda> f g s. (\<lambda>(t, x, y). If t then f\<cdot>x else g\<cdot>y fi) (Rep_Ssum s))"
 
 translations
   "case s of XCONST sinl\<cdot>x \<Rightarrow> t1 | XCONST sinr\<cdot>y \<Rightarrow> t2" == "CONST sscase\<cdot>(\<Lambda> x. t1)\<cdot>(\<Lambda> y. t2)\<cdot>s"
@@ -187,8 +186,8 @@
   "\<Lambda>(XCONST sinr\<cdot>y). t" == "CONST sscase\<cdot>\<bottom>\<cdot>(\<Lambda> y. t)"
 
 lemma beta_sscase:
-  "sscase\<cdot>f\<cdot>g\<cdot>s = (\<Lambda><t, x, y>. If t then f\<cdot>x else g\<cdot>y fi)\<cdot>(Rep_Ssum s)"
-unfolding sscase_def by (simp add: cont_Rep_Ssum cont2cont_LAM)
+  "sscase\<cdot>f\<cdot>g\<cdot>s = (\<lambda>(t, x, y). If t then f\<cdot>x else g\<cdot>y fi) (Rep_Ssum s)"
+unfolding sscase_def by (simp add: cont_Rep_Ssum [THEN cont_compose])
 
 lemma sscase1 [simp]: "sscase\<cdot>f\<cdot>g\<cdot>\<bottom> = \<bottom>"
 unfolding beta_sscase by (simp add: Rep_Ssum_strict)
@@ -206,9 +205,9 @@
 
 instance "++" :: (flat, flat) flat
 apply (intro_classes, clarify)
-apply (rule_tac p=x in ssumE, simp)
-apply (rule_tac p=y in ssumE, simp_all add: flat_less_iff)
-apply (rule_tac p=y in ssumE, simp_all add: flat_less_iff)
+apply (case_tac x, simp)
+apply (case_tac y, simp_all add: flat_below_iff)
+apply (case_tac y, simp_all add: flat_below_iff)
 done
 
 subsection {* Strict sum is a bifinite domain *}

--- a/src/HOLCF/Sum_Cpo.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Sum_Cpo.thy	Fri May 15 15:56:28 2009 +0200
@@ -10,28 +10,28 @@
 
 subsection {* Ordering on type @{typ "'a + 'b"} *}
 
-instantiation "+" :: (sq_ord, sq_ord) sq_ord
+instantiation "+" :: (below, below) below
 begin
 
-definition
-  less_sum_def: "x \<sqsubseteq> y \<equiv> case x of
+definition below_sum_def:
+  "x \<sqsubseteq> y \<equiv> case x of
          Inl a \<Rightarrow> (case y of Inl b \<Rightarrow> a \<sqsubseteq> b | Inr b \<Rightarrow> False) |
          Inr a \<Rightarrow> (case y of Inl b \<Rightarrow> False | Inr b \<Rightarrow> a \<sqsubseteq> b)"
 
 instance ..
 end
 
-lemma Inl_less_iff [simp]: "Inl x \<sqsubseteq> Inl y = x \<sqsubseteq> y"
-unfolding less_sum_def by simp
+lemma Inl_below_Inl [simp]: "Inl x \<sqsubseteq> Inl y = x \<sqsubseteq> y"
+unfolding below_sum_def by simp
 
-lemma Inr_less_iff [simp]: "Inr x \<sqsubseteq> Inr y = x \<sqsubseteq> y"
-unfolding less_sum_def by simp
+lemma Inr_below_Inr [simp]: "Inr x \<sqsubseteq> Inr y = x \<sqsubseteq> y"
+unfolding below_sum_def by simp
 
-lemma Inl_less_Inr [simp]: "\<not> Inl x \<sqsubseteq> Inr y"
-unfolding less_sum_def by simp
+lemma Inl_below_Inr [simp]: "\<not> Inl x \<sqsubseteq> Inr y"
+unfolding below_sum_def by simp
 
-lemma Inr_less_Inl [simp]: "\<not> Inr x \<sqsubseteq> Inl y"
-unfolding less_sum_def by simp
+lemma Inr_below_Inl [simp]: "\<not> Inr x \<sqsubseteq> Inl y"
+unfolding below_sum_def by simp
 
 lemma Inl_mono: "x \<sqsubseteq> y \<Longrightarrow> Inl x \<sqsubseteq> Inl y"
 by simp
@@ -39,20 +39,20 @@
 lemma Inr_mono: "x \<sqsubseteq> y \<Longrightarrow> Inr x \<sqsubseteq> Inr y"
 by simp
 
-lemma Inl_lessE: "\<lbrakk>Inl a \<sqsubseteq> x; \<And>b. \<lbrakk>x = Inl b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
+lemma Inl_belowE: "\<lbrakk>Inl a \<sqsubseteq> x; \<And>b. \<lbrakk>x = Inl b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
 by (cases x, simp_all)
 
-lemma Inr_lessE: "\<lbrakk>Inr a \<sqsubseteq> x; \<And>b. \<lbrakk>x = Inr b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
+lemma Inr_belowE: "\<lbrakk>Inr a \<sqsubseteq> x; \<And>b. \<lbrakk>x = Inr b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
 by (cases x, simp_all)
 
-lemmas sum_less_elims = Inl_lessE Inr_lessE
+lemmas sum_below_elims = Inl_belowE Inr_belowE
 
-lemma sum_less_cases:
+lemma sum_below_cases:
   "\<lbrakk>x \<sqsubseteq> y;
     \<And>a b. \<lbrakk>x = Inl a; y = Inl b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R;
     \<And>a b. \<lbrakk>x = Inr a; y = Inr b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk>
       \<Longrightarrow> R"
-by (cases x, safe elim!: sum_less_elims, auto)
+by (cases x, safe elim!: sum_below_elims, auto)
 
 subsection {* Sum type is a complete partial order *}
 
@@ -64,18 +64,18 @@
 next
   fix x y :: "'a + 'b"
   assume "x \<sqsubseteq> y" and "y \<sqsubseteq> x" thus "x = y"
-    by (induct x, auto elim!: sum_less_elims intro: antisym_less)
+    by (induct x, auto elim!: sum_below_elims intro: below_antisym)
 next
   fix x y z :: "'a + 'b"
   assume "x \<sqsubseteq> y" and "y \<sqsubseteq> z" thus "x \<sqsubseteq> z"
-    by (induct x, auto elim!: sum_less_elims intro: trans_less)
+    by (induct x, auto elim!: sum_below_elims intro: below_trans)
 qed
 
 lemma monofun_inv_Inl: "monofun (\<lambda>p. THE a. p = Inl a)"
-by (rule monofunI, erule sum_less_cases, simp_all)
+by (rule monofunI, erule sum_below_cases, simp_all)
 
 lemma monofun_inv_Inr: "monofun (\<lambda>p. THE b. p = Inr b)"
-by (rule monofunI, erule sum_less_cases, simp_all)
+by (rule monofunI, erule sum_below_cases, simp_all)
 
 lemma sum_chain_cases:
   assumes Y: "chain Y"
@@ -87,12 +87,12 @@
    apply (rule ch2ch_monofun [OF monofun_inv_Inl Y])
   apply (rule ext)
   apply (cut_tac j=i in chain_mono [OF Y le0], simp)
-  apply (erule Inl_lessE, simp)
+  apply (erule Inl_belowE, simp)
  apply (rule B)
   apply (rule ch2ch_monofun [OF monofun_inv_Inr Y])
  apply (rule ext)
  apply (cut_tac j=i in chain_mono [OF Y le0], simp)
- apply (erule Inr_lessE, simp)
+ apply (erule Inr_belowE, simp)
 done
 
 lemma is_lub_Inl: "range S <<| x \<Longrightarrow> range (\<lambda>i. Inl (S i)) <<| Inl x"
@@ -100,7 +100,7 @@
   apply (rule ub_rangeI)
   apply (simp add: is_ub_lub)
  apply (frule ub_rangeD [where i=arbitrary])
- apply (erule Inl_lessE, simp)
+ apply (erule Inl_belowE, simp)
  apply (erule is_lub_lub)
  apply (rule ub_rangeI)
  apply (drule ub_rangeD, simp)
@@ -111,7 +111,7 @@
   apply (rule ub_rangeI)
   apply (simp add: is_ub_lub)
  apply (frule ub_rangeD [where i=arbitrary])
- apply (erule Inr_lessE, simp)
+ apply (erule Inr_belowE, simp)
  apply (erule is_lub_lub)
  apply (rule ub_rangeI)
  apply (drule ub_rangeD, simp)
@@ -130,17 +130,14 @@
 
 subsection {* Continuity of @{term Inl}, @{term Inr}, @{term sum_case} *}
 
-lemma cont2cont_Inl [simp]: "cont f \<Longrightarrow> cont (\<lambda>x. Inl (f x))"
-by (fast intro: contI is_lub_Inl elim: contE)
-
-lemma cont2cont_Inr [simp]: "cont f \<Longrightarrow> cont (\<lambda>x. Inr (f x))"
-by (fast intro: contI is_lub_Inr elim: contE)
-
 lemma cont_Inl: "cont Inl"
-by (rule cont2cont_Inl [OF cont_id])
+by (intro contI is_lub_Inl cpo_lubI)
 
 lemma cont_Inr: "cont Inr"
-by (rule cont2cont_Inr [OF cont_id])
+by (intro contI is_lub_Inr cpo_lubI)
+
+lemmas cont2cont_Inl [cont2cont] = cont_compose [OF cont_Inl]
+lemmas cont2cont_Inr [cont2cont] = cont_compose [OF cont_Inr]
 
 lemmas ch2ch_Inl [simp] = ch2ch_cont [OF cont_Inl]
 lemmas ch2ch_Inr [simp] = ch2ch_cont [OF cont_Inr]
@@ -161,16 +158,33 @@
 apply (simp add: cont2contlubE [OF cont_Inr, symmetric] contE)
 done
 
-lemma cont2cont_sum_case [simp]:
+lemma cont2cont_sum_case:
   assumes f1: "\<And>a. cont (\<lambda>x. f x a)" and f2: "\<And>x. cont (\<lambda>a. f x a)"
   assumes g1: "\<And>b. cont (\<lambda>x. g x b)" and g2: "\<And>x. cont (\<lambda>b. g x b)"
   assumes h: "cont (\<lambda>x. h x)"
   shows "cont (\<lambda>x. case h x of Inl a \<Rightarrow> f x a | Inr b \<Rightarrow> g x b)"
-apply (rule cont2cont_app2 [OF cont2cont_lambda _ h])
+apply (rule cont_apply [OF h])
+apply (rule cont_sum_case2 [OF f2 g2])
 apply (rule cont_sum_case1 [OF f1 g1])
-apply (rule cont_sum_case2 [OF f2 g2])
 done
 
+lemma cont2cont_sum_case' [cont2cont]:
+  assumes f: "cont (\<lambda>p. f (fst p) (snd p))"
+  assumes g: "cont (\<lambda>p. g (fst p) (snd p))"
+  assumes h: "cont (\<lambda>x. h x)"
+  shows "cont (\<lambda>x. case h x of Inl a \<Rightarrow> f x a | Inr b \<Rightarrow> g x b)"
+proof -
+  note f1 = f [THEN cont_fst_snd_D1]
+  note f2 = f [THEN cont_fst_snd_D2]
+  note g1 = g [THEN cont_fst_snd_D1]
+  note g2 = g [THEN cont_fst_snd_D2]
+  show ?thesis
+    apply (rule cont_apply [OF h])
+    apply (rule cont_sum_case2 [OF f2 g2])
+    apply (rule cont_sum_case1 [OF f1 g1])
+    done
+qed
+
 subsection {* Compactness and chain-finiteness *}
 
 lemma compact_Inl: "compact a \<Longrightarrow> compact (Inl a)"
@@ -212,7 +226,7 @@
 instance "+" :: (finite_po, finite_po) finite_po ..
 
 instance "+" :: (discrete_cpo, discrete_cpo) discrete_cpo
-by intro_classes (simp add: less_sum_def split: sum.split)
+by intro_classes (simp add: below_sum_def split: sum.split)
 
 subsection {* Sum type is a bifinite domain *}
 

--- a/src/HOLCF/Tools/adm_tac.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Tools/adm_tac.ML	Fri May 15 15:56:28 2009 +0200
@@ -18,7 +18,7 @@
   val adm_tac: Proof.context -> (int -> tactic) -> int -> tactic
 end;
 
-structure Adm: ADM =
+structure Adm :> ADM =
 struct
 
 

--- a/src/HOLCF/Tools/cont_consts.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Tools/cont_consts.ML	Fri May 15 15:56:28 2009 +0200
@@ -8,18 +8,16 @@
 
 signature CONT_CONSTS =
 sig
-  val add_consts: (bstring * string * mixfix) list -> theory -> theory
-  val add_consts_i: (bstring * typ * mixfix) list -> theory -> theory
+  val add_consts: (binding * string * mixfix) list -> theory -> theory
+  val add_consts_i: (binding * typ * mixfix) list -> theory -> theory
 end;
 
-structure ContConsts: CONT_CONSTS =
+structure ContConsts :> CONT_CONSTS =
 struct
 
 
 (* misc utils *)
 
-open HOLCFLogic;
-
 fun first  (x,_,_) = x;
 fun second (_,x,_) = x;
 fun third  (_,_,x) = x;
@@ -51,29 +49,33 @@
    declaration with the original name, type ...=>..., and the original mixfix
    is generated and connected to the other declaration via some translation.
 *)
-fun fix_mixfix (syn                     , T, mx as Infix           p ) =
-               (Syntax.const_name mx syn, T,       InfixName (syn, p))
-  | fix_mixfix (syn                     , T, mx as Infixl           p ) =
-               (Syntax.const_name mx syn, T,       InfixlName (syn, p))
-  | fix_mixfix (syn                     , T, mx as Infixr           p ) =
-               (Syntax.const_name mx syn, T,       InfixrName (syn, p))
+fun const_binding mx = Binding.name o Syntax.const_name mx o Binding.name_of;
+
+fun fix_mixfix (syn                 , T, mx as Infix           p ) =
+               (const_binding mx syn, T,       InfixName (Binding.name_of syn, p))
+  | fix_mixfix (syn                 , T, mx as Infixl           p ) =
+               (const_binding mx syn, T,       InfixlName (Binding.name_of syn, p))
+  | fix_mixfix (syn                 , T, mx as Infixr           p ) =
+               (const_binding mx syn, T,       InfixrName (Binding.name_of syn, p))
   | fix_mixfix decl = decl;
+
 fun transform decl = let
         val (c, T, mx) = fix_mixfix decl;
-        val c2 = "_cont_" ^ c;
+        val c1 = Binding.name_of c;
+        val c2 = "_cont_" ^ c1;
         val n  = Syntax.mixfix_args mx
-    in     ((c ,               T,NoSyn),
-            (c2,change_arrow n T,mx   ),
-            trans_rules c2 c n mx) end;
+    in     ((c, T, NoSyn),
+            (Binding.name c2, change_arrow n T, mx),
+            trans_rules c2 c1 n mx) end;
 
-fun cfun_arity (Type(n,[_,T])) = if n = cfun_arrow then 1+cfun_arity T else 0
+fun cfun_arity (Type(n,[_,T])) = if n = @{type_name "->"} then 1+cfun_arity T else 0
 |   cfun_arity _               = 0;
 
 fun is_contconst (_,_,NoSyn   ) = false
 |   is_contconst (_,_,Binder _) = false
 |   is_contconst (c,T,mx      ) = cfun_arity T >= Syntax.mixfix_args mx
                          handle ERROR msg => cat_error msg ("in mixfix annotation for " ^
-                                               quote (Syntax.const_name mx c));
+                                               quote (Syntax.const_name mx (Binding.name_of c)));
 
 
 (* add_consts(_i) *)
@@ -85,7 +87,7 @@
     val transformed_decls = map transform contconst_decls;
   in
     thy
-    |> (Sign.add_consts_i o map (upd_first Binding.name))
+    |> Sign.add_consts_i
       (normal_decls @ map first transformed_decls @ map second transformed_decls)
     |> Sign.add_trrules_i (maps third transformed_decls)
   end;
@@ -100,7 +102,7 @@
 
 val _ =
   OuterSyntax.command "consts" "declare constants (HOLCF)" K.thy_decl
-    (Scan.repeat1 P.const >> (Toplevel.theory o add_consts));
+    (Scan.repeat1 P.const_binding >> (Toplevel.theory o add_consts));
 
 end;
 

--- a/src/HOLCF/Tools/cont_proc.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Tools/cont_proc.ML	Fri May 15 15:56:28 2009 +0200
@@ -12,7 +12,7 @@
   val setup: theory -> theory
 end;
 
-structure ContProc: CONT_PROC =
+structure ContProc :> CONT_PROC =
 struct
 
 (** theory context references **)

--- a/src/HOLCF/Tools/domain/domain_axioms.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Tools/domain/domain_axioms.ML	Fri May 15 15:56:28 2009 +0200
@@ -4,7 +4,14 @@
 Syntax generator for domain command.
 *)
 
-structure Domain_Axioms = struct
+signature DOMAIN_AXIOMS =
+sig
+  val add_axioms : bstring -> Domain_Library.eq list -> theory -> theory
+end;
+
+
+structure Domain_Axioms :> DOMAIN_AXIOMS =
+struct
 
 local
 
@@ -60,14 +67,18 @@
 			   (if con'=con then TT else FF) args)) cons))
 	in map ddef cons end;
 
-  val mat_defs = let
-	fun mdef (con,_) = (mat_name con ^"_def",%%:(mat_name con) == 
-		 list_ccomb(%%:(dname^"_when"),map 
-			(fn (con',args) => (List.foldr /\#
-			   (if con'=con
-                               then mk_return (mk_ctuple (map (bound_arg args) args))
-                               else mk_fail) args)) cons))
-	in map mdef cons end;
+  val mat_defs =
+    let
+      fun mdef (con,_) =
+        let
+          val k = Bound 0
+          val x = Bound 1
+          fun one_con (con', args') =
+	    if con'=con then k else List.foldr /\# mk_fail args'
+          val w = list_ccomb(%%:(dname^"_when"), map one_con cons)
+          val rhs = /\ "x" (/\ "k" (w ` x))
+        in (mat_name con ^"_def", %%:(mat_name con) == rhs) end
+    in map mdef cons end;
 
   val pat_defs =
     let
@@ -135,7 +146,7 @@
 
 in (* local *)
 
-fun add_axioms (comp_dnam, eqs : eq list) thy' = let
+fun add_axioms comp_dnam (eqs : eq list) thy' = let
   val comp_dname = Sign.full_bname thy' comp_dnam;
   val dnames = map (fst o fst) eqs;
   val x_name = idx_name dnames "x"; 

--- a/src/HOLCF/Tools/domain/domain_extender.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Tools/domain/domain_extender.ML	Fri May 15 15:56:28 2009 +0200
@@ -1,55 +1,40 @@
 (*  Title:      HOLCF/Tools/domain/domain_extender.ML
-    ID:         $Id$
     Author:     David von Oheimb
 
 Theory extender for domain command, including theory syntax.
-
-###TODO: 
-
-this definition
-domain empty = silly empty
-yields
-Exception-
-   TERM
-      ("typ_of_term: bad encoding of type",
-         [Abs ("uu", "_", Const ("NONE", "_"))]) raised
-but this works fine:
-domain Empty = silly Empty
-
-strange syntax errors are produced for:
-domain xx = xx ("x yy")
-domain 'a foo = foo (sel::"'a") 
-and bar = bar ("'a dummy")
-
 *)
 
 signature DOMAIN_EXTENDER =
 sig
-  val add_domain: string * ((bstring * string list) *
-    (string * mixfix * (bool * string option * string) list) list) list
+  val add_domain_cmd: string -> (string list * binding * mixfix *
+    (binding * (bool * binding option * string) list * mixfix) list) list
     -> theory -> theory
-  val add_domain_i: string * ((bstring * string list) *
-    (string * mixfix * (bool * string option * typ) list) list) list
+  val add_domain: string -> (string list * binding * mixfix *
+    (binding * (bool * binding option * typ) list * mixfix) list) list
     -> theory -> theory
 end;
 
-structure Domain_Extender: DOMAIN_EXTENDER =
+structure Domain_Extender :> DOMAIN_EXTENDER =
 struct
 
 open Domain_Library;
 
 (* ----- general testing and preprocessing of constructor list -------------- *)
-fun check_and_sort_domain (dtnvs: (string * typ list) list, 
-     cons'' : ((string * mixfix * (bool * string option * typ) list) list) list) sg =
+fun check_and_sort_domain
+  (dtnvs : (string * typ list) list)
+  (cons'' : ((binding * (bool * binding option * typ) list * mixfix) list) list)
+  (sg : theory)
+  : ((string * typ list) *
+      (binding * (bool * binding option * typ) list * mixfix) list) list =
   let
     val defaultS = Sign.defaultS sg;
     val test_dupl_typs = (case duplicates (op =) (map fst dtnvs) of 
 	[] => false | dups => error ("Duplicate types: " ^ commas_quote dups));
-    val test_dupl_cons = (case duplicates (op =) (map first (List.concat cons'')) of 
+    val test_dupl_cons = (case duplicates (op =) (map (Binding.name_of o first) (List.concat cons'')) of 
 	[] => false | dups => error ("Duplicate constructors: " 
 							 ^ commas_quote dups));
-    val test_dupl_sels = (case duplicates (op =) (List.mapPartial second
-			       (List.concat (map third (List.concat cons'')))) of
+    val test_dupl_sels = (case duplicates (op =) (map Binding.name_of (List.mapPartial second
+			       (List.concat (map second (List.concat cons''))))) of
         [] => false | dups => error("Duplicate selectors: "^commas_quote dups));
     val test_dupl_tvars = exists(fn s=>case duplicates (op =) (map(fst o dest_TFree)s)of
 	[] => false | dups => error("Duplicate type arguments: " 
@@ -90,26 +75,31 @@
         |   analyse indirect (TVar _) = Imposs "extender:analyse";
 	fun check_pcpo T = if pcpo_type sg T then T
           else error("Constructor argument type is not of sort pcpo: "^string_of_typ sg T);
-	val analyse_con = upd_third (map (upd_third (check_pcpo o analyse false)));
+	val analyse_con = upd_second (map (upd_third (check_pcpo o analyse false)));
       in ((dname,distinct_typevars), map analyse_con cons') end; 
   in ListPair.map analyse_equation (dtnvs,cons'')
   end; (* let *)
 
 (* ----- calls for building new thy and thms -------------------------------- *)
 
-fun gen_add_domain prep_typ (comp_dnam, eqs''') thy''' =
+fun gen_add_domain
+  (prep_typ : theory -> 'a -> typ)
+  (comp_dnam : string)
+  (eqs''' : (string list * binding * mixfix *
+              (binding * (bool * binding option * 'a) list * mixfix) list) list)
+  (thy''' : theory) =
   let
-    val dtnvs = map ((fn (dname,vs) => 
-			 (Sign.full_bname thy''' dname, map (Syntax.read_typ_global thy''') vs))
-                   o fst) eqs''';
-    val cons''' = map snd eqs''';
-    fun thy_type  (dname,tvars)  = (Binding.name (Long_Name.base_name dname), length tvars, NoSyn);
-    fun thy_arity (dname,tvars)  = (dname, map (snd o dest_TFree) tvars, pcpoS);
-    val thy'' = thy''' |> Sign.add_types     (map thy_type  dtnvs)
+    val dtnvs = map (fn (vs,dname:binding,mx,_) => 
+                  (dname, map (Syntax.read_typ_global thy''') vs, mx)) eqs''';
+    val cons''' = map (fn (_,_,_,cons) => cons) eqs''';
+    fun thy_type  (dname,tvars,mx) = (dname, length tvars, mx);
+    fun thy_arity (dname,tvars,mx) = (Sign.full_name thy''' dname, map (snd o dest_TFree) tvars, pcpoS);
+    val thy'' = thy''' |> Sign.add_types (map thy_type dtnvs)
 		       |> fold (AxClass.axiomatize_arity o thy_arity) dtnvs;
-    val cons'' = map (map (upd_third (map (upd_third (prep_typ thy''))))) cons''';
-    val eqs' = check_and_sort_domain (dtnvs,cons'') thy'';
-    val thy' = thy'' |> Domain_Syntax.add_syntax (comp_dnam,eqs');
+    val cons'' = map (map (upd_second (map (upd_third (prep_typ thy''))))) cons''';
+    val dtnvs' = map (fn (dname,vs,mx) => (Sign.full_name thy''' dname,vs)) dtnvs;
+    val eqs' : ((string * typ list) * (binding * (bool * binding option * typ) list * mixfix) list) list = check_and_sort_domain dtnvs' cons'' thy'';
+    val thy' = thy'' |> Domain_Syntax.add_syntax comp_dnam eqs';
     val dts  = map (Type o fst) eqs';
     val new_dts = map (fn ((s,Ts),_) => (s, map (fst o dest_TFree) Ts)) eqs';
     fun strip ss = Library.drop (find_index_eq "'" ss +1, ss);
@@ -118,16 +108,16 @@
           in if Symbol.is_letter c then c else "t" end
       | typid (TFree (id,_)   ) = hd (strip (tl (Symbol.explode id)))
       | typid (TVar ((id,_),_)) = hd (tl (Symbol.explode id));
-    fun one_con (con,mx,args) =
-	((Syntax.const_name mx con),
+    fun one_con (con,args,mx) =
+	((Syntax.const_name mx (Binding.name_of con)),
 	 ListPair.map (fn ((lazy,sel,tp),vn) => ((lazy,
 					find_index_eq tp dts,
 					DatatypeAux.dtyp_of_typ new_dts tp),
-					sel,vn))
+					Option.map Binding.name_of sel,vn))
 	     (args,(mk_var_names(map (typid o third) args)))
 	 ) : cons;
     val eqs = map (fn (dtnvs,cons') => (dtnvs, map one_con cons')) eqs' : eq list;
-    val thy        = thy' |> Domain_Axioms.add_axioms (comp_dnam,eqs);
+    val thy = thy' |> Domain_Axioms.add_axioms comp_dnam eqs;
     val ((rewss, take_rews), theorems_thy) = thy |> fold_map (fn eq =>
       Domain_Theorems.theorems (eq, eqs)) eqs
       ||>> Domain_Theorems.comp_theorems (comp_dnam, eqs);
@@ -138,8 +128,8 @@
     |> Sign.parent_path
   end;
 
-val add_domain_i = gen_add_domain Sign.certify_typ;
-val add_domain = gen_add_domain Syntax.read_typ_global;
+val add_domain = gen_add_domain Sign.certify_typ;
+val add_domain_cmd = gen_add_domain Syntax.read_typ_global;
 
 
 (** outer syntax **)
@@ -148,33 +138,47 @@
 
 val _ = OuterKeyword.keyword "lazy";
 
-val dest_decl =
+val dest_decl : (bool * binding option * string) parser =
   P.$$$ "(" |-- Scan.optional (P.$$$ "lazy" >> K true) false --
-    (P.name >> SOME) -- (P.$$$ "::" |-- P.typ)  --| P.$$$ ")" >> P.triple1
+    (P.binding >> SOME) -- (P.$$$ "::" |-- P.typ)  --| P.$$$ ")" >> P.triple1
   || P.$$$ "(" |-- P.$$$ "lazy" |-- P.typ --| P.$$$ ")"
        >> (fn t => (true,NONE,t))
   || P.typ >> (fn t => (false,NONE,t));
 
 val cons_decl =
-  P.name -- Scan.repeat dest_decl -- P.opt_mixfix
-  >> (fn ((c, ds), mx) => (c, mx, ds));
+  P.binding -- Scan.repeat dest_decl -- P.opt_mixfix;
+
+val type_var' =
+  (P.type_ident ^^ Scan.optional (P.$$$ "::" ^^ P.!!! P.sort) "");
+
+val type_args' =
+  type_var' >> single ||
+  P.$$$ "(" |-- P.!!! (P.list1 type_var' --| P.$$$ ")") ||
+  Scan.succeed [];
+
+val domain_decl =
+  (type_args' -- P.binding -- P.opt_infix) --
+  (P.$$$ "=" |-- P.enum1 "|" cons_decl);
 
-val type_var' = (P.type_ident ^^ 
-                 Scan.optional (P.$$$ "::" ^^ P.!!! P.sort) "");
-val type_args' = type_var' >> single ||
-                 P.$$$ "(" |-- P.!!! (P.list1 type_var' --| P.$$$ ")") ||
- 		 Scan.succeed [];
+val domains_decl =
+  Scan.option (P.$$$ "(" |-- P.name --| P.$$$ ")") --
+  P.and_list1 domain_decl;
 
-val domain_decl = (type_args' -- P.name >> Library.swap) -- 
-                  (P.$$$ "=" |-- P.enum1 "|" cons_decl);
-val domains_decl =
-  Scan.option (P.$$$ "(" |-- P.name --| P.$$$ ")") -- P.and_list1 domain_decl
-  >> (fn (opt_name, doms) =>
-      (case opt_name of NONE => space_implode "_" (map (#1 o #1) doms) | SOME s => s, doms));
+fun mk_domain (opt_name : string option, doms : (((string list * binding) * mixfix) *
+    ((binding * (bool * binding option * string) list) * mixfix) list) list ) =
+  let
+    val names = map (fn (((_, t), _), _) => Binding.name_of t) doms;
+    val specs : (string list * binding * mixfix *
+      (binding * (bool * binding option * string) list * mixfix) list) list =
+        map (fn (((vs, t), mx), cons) =>
+          (vs, t, mx, map (fn ((c, ds), mx) => (c, ds, mx)) cons)) doms;
+    val comp_dnam =
+      case opt_name of NONE => space_implode "_" names | SOME s => s;
+  in add_domain_cmd comp_dnam specs end;
 
 val _ =
   OuterSyntax.command "domain" "define recursive domains (HOLCF)" K.thy_decl
-    (domains_decl >> (Toplevel.theory o add_domain));
+    (domains_decl >> (Toplevel.theory o mk_domain));
 
 end;
 

--- a/src/HOLCF/Tools/domain/domain_library.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Tools/domain/domain_library.ML	Fri May 15 15:56:28 2009 +0200
@@ -30,11 +30,129 @@
     | _				    => [thm];
 in map zero_var_indexes (at thm) end;
 
+(* infix syntax *)
+
+infixr 5 -->;
+infixr 6 ->>;
+infixr 0 ===>;
+infixr 0 ==>;
+infix 0 ==;
+infix 1 ===;
+infix 1 ~=;
+infix 1 <<;
+infix 1 ~<<;
+
+infix 9 `  ;
+infix 9 `% ;
+infix 9 `%%;
+
+
 (* ----- specific support for domain ---------------------------------------- *)
 
-structure Domain_Library = struct
+signature DOMAIN_LIBRARY =
+sig
+  val Imposs : string -> 'a;
+  val pcpo_type : theory -> typ -> bool;
+  val string_of_typ : theory -> typ -> string;
+
+  (* Creating HOLCF types *)
+  val mk_cfunT : typ * typ -> typ;
+  val ->> : typ * typ -> typ;
+  val mk_ssumT : typ * typ -> typ;
+  val mk_sprodT : typ * typ -> typ;
+  val mk_uT : typ -> typ;
+  val oneT : typ;
+  val trT : typ;
+  val mk_maybeT : typ -> typ;
+  val mk_ctupleT : typ list -> typ;
+  val mk_TFree : string -> typ;
+  val pcpoS : sort;
+
+  (* Creating HOLCF terms *)
+  val %: : string -> term;
+  val %%: : string -> term;
+  val ` : term * term -> term;
+  val `% : term * string -> term;
+  val /\ : string -> term -> term;
+  val UU : term;
+  val TT : term;
+  val FF : term;
+  val mk_up : term -> term;
+  val mk_sinl : term -> term;
+  val mk_sinr : term -> term;
+  val mk_stuple : term list -> term;
+  val mk_ctuple : term list -> term;
+  val mk_fix : term -> term;
+  val mk_iterate : term * term * term -> term;
+  val mk_fail : term;
+  val mk_return : term -> term;
+  val cproj : term -> 'a list -> int -> term;
+  val list_ccomb : term * term list -> term;
+  val con_app : string -> ('a * 'b * string) list -> term;
+  val con_app2 : string -> ('a -> term) -> 'a list -> term;
+  val proj : term -> 'a list -> int -> term;
+  val prj : ('a -> 'b -> 'a) -> ('a -> 'b -> 'a) -> 'a -> 'b list -> int -> 'a;
+  val mk_ctuple_pat : term list -> term;
+  val mk_branch : term -> term;
 
-open HOLCFLogic;
+  (* Creating propositions *)
+  val mk_conj : term * term -> term;
+  val mk_disj : term * term -> term;
+  val mk_imp : term * term -> term;
+  val mk_lam : string * term -> term;
+  val mk_all : string * term -> term;
+  val mk_ex : string * term -> term;
+  val mk_constrain : typ * term -> term;
+  val mk_constrainall : string * typ * term -> term;
+  val === : term * term -> term;
+  val << : term * term -> term;
+  val ~<< : term * term -> term;
+  val strict : term -> term;
+  val defined : term -> term;
+  val mk_adm : term -> term;
+  val mk_compact : term -> term;
+  val lift : ('a -> term) -> 'a list * term -> term;
+  val lift_defined : ('a -> term) -> 'a list * term -> term;
+
+  (* Creating meta-propositions *)
+  val mk_trp : term -> term; (* HOLogic.mk_Trueprop *)
+  val == : term * term -> term;
+  val ===> : term * term -> term;
+  val ==> : term * term -> term;
+  val mk_All : string * term -> term;
+
+  (* Domain specifications *)
+  type arg = (bool * int * DatatypeAux.dtyp) * string option * string;
+  type cons = string * arg list;
+  type eq = (string * typ list) * cons list;
+  val is_lazy : arg -> bool;
+  val rec_of : arg -> int;
+  val sel_of : arg -> string option;
+  val vname : arg -> string;
+  val upd_vname : (string -> string) -> arg -> arg;
+  val is_rec : arg -> bool;
+  val is_nonlazy_rec : arg -> bool;
+  val nonlazy : arg list -> string list;
+  val nonlazy_rec : arg list -> string list;
+  val %# : arg -> term;
+  val /\# : arg * term -> term;
+  val when_body : cons list -> (int * int -> term) -> term;
+  val when_funs : 'a list -> string list;
+  val bound_arg : ''a list -> ''a -> term; (* ''a = arg or string *)
+  val idx_name : 'a list -> string -> int -> string;
+  val app_rec_arg : (int -> term) -> arg -> term;
+
+  (* Name mangling *)
+  val strip_esc : string -> string;
+  val extern_name : string -> string;
+  val dis_name : string -> string;
+  val mat_name : string -> string;
+  val pat_name : string -> string;
+  val mk_var_names : string list -> string list;
+end;
+
+structure Domain_Library :> DOMAIN_LIBRARY =
+struct
 
 exception Impossible of string;
 fun Imposs msg = raise Impossible ("Domain:"^msg);
@@ -72,19 +190,24 @@
       | index_vnames([],occupied) = [];
 in index_vnames(map nonreserved ids, [("O",0),("o",0)]) end;
 
-fun pcpo_type sg t = Sign.of_sort sg (Sign.certify_typ sg t, pcpoS);
+fun pcpo_type sg t = Sign.of_sort sg (Sign.certify_typ sg t, @{sort pcpo});
 fun string_of_typ sg = Syntax.string_of_typ_global sg o Sign.certify_typ sg;
 
 (* ----- constructor list handling ----- *)
 
-type cons = (string *				(* operator name of constr *)
-	    ((bool*int*DatatypeAux.dtyp)*	(*  (lazy,recursive element or ~1) *)
-	      string option*			(*   selector name    *)
-	      string)				(*   argument name    *)
-	    list);				(* argument list      *)
-type eq = (string *		(* name      of abstracted type *)
-	   typ list) *		(* arguments of abstracted type *)
-	  cons list;		(* represented type, as a constructor list *)
+type arg =
+  (bool * int * DatatypeAux.dtyp) *	(*  (lazy,recursive element or ~1) *)
+  string option *			(*   selector name    *)
+  string;				(*   argument name    *)
+
+type cons =
+  string *				(* operator name of constr *)
+  arg list;				(* argument list      *)
+
+type eq =
+  (string *		(* name      of abstracted type *)
+   typ list) *		(* arguments of abstracted type *)
+  cons list;		(* represented type, as a constructor list *)
 
 fun rec_of arg  = second (first arg);
 fun is_lazy arg = first (first arg);
@@ -98,7 +221,16 @@
 
 (* ----- support for type and mixfix expressions ----- *)
 
-infixr 5 -->;
+fun mk_uT T = Type(@{type_name "u"}, [T]);
+fun mk_cfunT (T, U) = Type(@{type_name "->"}, [T, U]);
+fun mk_sprodT (T, U) = Type(@{type_name "**"}, [T, U]);
+fun mk_ssumT (T, U) = Type(@{type_name "++"}, [T, U]);
+val oneT = @{typ one};
+val trT = @{typ tr};
+
+val op ->> = mk_cfunT;
+
+fun mk_TFree s = TFree ("'" ^ s, @{sort pcpo});
 
 (* ----- support for term expressions ----- *)
 
@@ -125,7 +257,7 @@
 infix 0 ==;     fun S ==  T = %%:"==" $ S $ T;
 infix 1 ===;    fun S === T = %%:"op =" $ S $ T;
 infix 1 ~=;     fun S ~=  T = HOLogic.mk_not (S === T);
-infix 1 <<;     fun S <<  T = %%: @{const_name Porder.sq_le} $ S $ T;
+infix 1 <<;     fun S <<  T = %%: @{const_name Porder.below} $ S $ T;
 infix 1 ~<<;    fun S ~<< T = HOLogic.mk_not (S << T);
 
 infix 9 `  ; fun f ` x = %%: @{const_name Rep_CFun} $ f $ x;

--- a/src/HOLCF/Tools/domain/domain_syntax.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Tools/domain/domain_syntax.ML	Fri May 15 15:56:28 2009 +0200
@@ -4,32 +4,42 @@
 Syntax generator for domain command.
 *)
 
-structure Domain_Syntax = struct 
+signature DOMAIN_SYNTAX =
+sig
+  val add_syntax: string -> ((string * typ list) *
+	(binding * (bool * binding option * typ) list * mixfix) list) list
+    -> theory -> theory
+end;
+
+
+structure Domain_Syntax :> DOMAIN_SYNTAX =
+struct 
 
 local 
 
 open Domain_Library;
 infixr 5 -->; infixr 6 ->>;
 fun calc_syntax dtypeprod ((dname, typevars), 
-	(cons': (string * mixfix * (bool * string option * typ) list) list)) =
+	(cons': (binding * (bool * binding option * typ) list * mixfix) list)) : ((binding * typ * mixfix) list * ast Syntax.trrule list) =
 let
 (* ----- constants concerning the isomorphism ------------------------------- *)
 
 local
   fun opt_lazy (lazy,_,t) = if lazy then mk_uT t else t
-  fun prod     (_,_,args) = if args = [] then oneT
-			    else foldr1 mk_sprodT (map opt_lazy args);
+  fun prod     (_,args,_) = case args of [] => oneT
+                            | _ => foldr1 mk_sprodT (map opt_lazy args);
   fun freetvar s = let val tvar = mk_TFree s in
 		   if tvar mem typevars then freetvar ("t"^s) else tvar end;
-  fun when_type (_   ,_,args) = List.foldr (op ->>) (freetvar "t") (map third args);
+  fun when_type (_,args,_) = List.foldr (op ->>) (freetvar "t") (map third args);
 in
   val dtype  = Type(dname,typevars);
   val dtype2 = foldr1 mk_ssumT (map prod cons');
   val dnam = Long_Name.base_name dname;
-  val const_rep  = (dnam^"_rep" ,              dtype  ->> dtype2, NoSyn);
-  val const_abs  = (dnam^"_abs" ,              dtype2 ->> dtype , NoSyn);
-  val const_when = (dnam^"_when", List.foldr (op ->>) (dtype ->> freetvar "t") (map when_type cons'), NoSyn);
-  val const_copy = (dnam^"_copy", dtypeprod ->> dtype  ->> dtype , NoSyn);
+  fun dbind s = Binding.name (dnam ^ s);
+  val const_rep  = (dbind "_rep" ,              dtype  ->> dtype2, NoSyn);
+  val const_abs  = (dbind "_abs" ,              dtype2 ->> dtype , NoSyn);
+  val const_when = (dbind "_when", List.foldr (op ->>) (dtype ->> freetvar "t") (map when_type cons'), NoSyn);
+  val const_copy = (dbind "_copy", dtypeprod ->> dtype  ->> dtype , NoSyn);
 end;
 
 (* ----- constants concerning constructors, discriminators, and selectors --- *)
@@ -40,23 +50,28 @@
 							 else      c::esc cs
 	|   esc []      = []
 	in implode o esc o Symbol.explode end;
-  fun con (name,s,args) = (name, List.foldr (op ->>) dtype (map third args),s);
-  fun dis (con ,s,_   ) = (dis_name_ con, dtype->>trT,
-			   Mixfix(escape ("is_" ^ con), [], Syntax.max_pri));
+  fun dis_name_ con     = Binding.name ("is_" ^ strip_esc (Binding.name_of con));
+  fun mat_name_ con     = Binding.name ("match_" ^ strip_esc (Binding.name_of con));
+  fun pat_name_ con     = Binding.name (strip_esc (Binding.name_of con) ^ "_pat");
+  fun con (name,args,mx) = (name, List.foldr (op ->>) dtype (map third args), mx);
+  fun dis (con,args,mx) = (dis_name_ con, dtype->>trT,
+			   Mixfix(escape ("is_" ^ Binding.name_of con), [], Syntax.max_pri));
 			(* strictly speaking, these constants have one argument,
 			   but the mixfix (without arguments) is introduced only
 			   to generate parse rules for non-alphanumeric names*)
-  fun mat (con ,s,args) = (mat_name_ con, dtype->>mk_maybeT(mk_ctupleT(map third args)),
-			   Mixfix(escape ("match_" ^ con), [], Syntax.max_pri));
-  fun sel1 (_,sel,typ)  = Option.map (fn s => (s,dtype ->> typ,NoSyn)) sel;
-  fun sel (_   ,_,args) = List.mapPartial sel1 args;
   fun freetvar s n      = let val tvar = mk_TFree (s ^ string_of_int n) in
 			  if tvar mem typevars then freetvar ("t"^s) n else tvar end;
+  fun mk_matT (a,bs,c)  = a ->> foldr (op ->>) (mk_maybeT c) bs ->> mk_maybeT c;
+  fun mat (con,args,mx) = (mat_name_ con,
+                           mk_matT(dtype, map third args, freetvar "t" 1),
+			   Mixfix(escape ("match_" ^ Binding.name_of con), [], Syntax.max_pri));
+  fun sel1 (_,sel,typ)  = Option.map (fn s => (s,dtype ->> typ,NoSyn)) sel;
+  fun sel (con,args,mx) = List.mapPartial sel1 args;
   fun mk_patT (a,b)     = a ->> mk_maybeT b;
   fun pat_arg_typ n arg = mk_patT (third arg, freetvar "t" n);
-  fun pat (con ,s,args) = (pat_name_ con, (mapn pat_arg_typ 1 args) --->
+  fun pat (con,args,mx) = (pat_name_ con, (mapn pat_arg_typ 1 args) --->
 			   mk_patT (dtype, mk_ctupleT (map (freetvar "t") (1 upto length args))),
-			   Mixfix(escape (con ^ "_pat"), [], Syntax.max_pri));
+			   Mixfix(escape (Binding.name_of con ^ "_pat"), [], Syntax.max_pri));
 
 in
   val consts_con = map con cons';
@@ -68,14 +83,14 @@
 
 (* ----- constants concerning induction ------------------------------------- *)
 
-  val const_take   = (dnam^"_take"  , HOLogic.natT-->dtype->>dtype, NoSyn);
-  val const_finite = (dnam^"_finite", dtype-->HOLogic.boolT       , NoSyn);
+  val const_take   = (dbind "_take"  , HOLogic.natT-->dtype->>dtype, NoSyn);
+  val const_finite = (dbind "_finite", dtype-->HOLogic.boolT       , NoSyn);
 
 (* ----- case translation --------------------------------------------------- *)
 
 local open Syntax in
   local
-    fun c_ast con mx = Constant (Syntax.const_name mx con);
+    fun c_ast con mx = Constant (Syntax.const_name mx (Binding.name_of con));
     fun expvar n     = Variable ("e"^(string_of_int n));
     fun argvar n m _ = Variable ("a"^(string_of_int n)^"_"^
 				     (string_of_int m));
@@ -83,9 +98,9 @@
     fun app s (l,r)  = mk_appl (Constant s) [l,r];
     val cabs = app "_cabs";
     val capp = app "Rep_CFun";
-    fun con1 n (con,mx,args) = Library.foldl capp (c_ast con mx, argvars n args);
-    fun case1 n (con,mx,args) = app "_case1" (con1 n (con,mx,args), expvar n);
-    fun arg1 n (con,_,args) = List.foldr cabs (expvar n) (argvars n args);
+    fun con1 n (con,args,mx) = Library.foldl capp (c_ast con mx, argvars n args);
+    fun case1 n (con,args,mx) = app "_case1" (con1 n (con,args,mx), expvar n);
+    fun arg1 n (con,args,_) = List.foldr cabs (expvar n) (argvars n args);
     fun when1 n m = if n = m then arg1 n else K (Constant "UU");
 
     fun app_var x = mk_appl (Constant "_variable") [x, Variable "rhs"];
@@ -101,10 +116,10 @@
         (cabs (con1 n (con,mx,args), expvar n),
          Library.foldl capp (Constant (dnam^"_when"), mapn (when1 n) 1 cons'))) 1 cons';
     
-    val Case_trans = List.concat (map (fn (con,mx,args) =>
+    val Case_trans = List.concat (map (fn (con,args,mx) =>
       let
         val cname = c_ast con mx;
-        val pname = Constant (pat_name_ con);
+        val pname = Constant (strip_esc (Binding.name_of con) ^ "_pat");
         val ns = 1 upto length args;
         val xs = map (fn n => Variable ("x"^(string_of_int n))) ns;
         val ps = map (fn n => Variable ("p"^(string_of_int n))) ns;
@@ -130,16 +145,19 @@
 
 in (* local *)
 
-fun add_syntax (comp_dnam,eqs': ((string * typ list) *
-	(string * mixfix * (bool * string option * typ) list) list) list) thy'' =
+fun add_syntax
+  (comp_dnam : string)
+  (eqs' : ((string * typ list) *
+	(binding * (bool * binding option * typ) list * mixfix) list) list)
+  (thy'' : theory) =
 let
   val dtypes  = map (Type o fst) eqs';
   val boolT   = HOLogic.boolT;
   val funprod = foldr1 HOLogic.mk_prodT (map (fn tp => tp ->> tp          ) dtypes);
   val relprod = foldr1 HOLogic.mk_prodT (map (fn tp => tp --> tp --> boolT) dtypes);
-  val const_copy   = (comp_dnam^"_copy"  ,funprod ->> funprod, NoSyn);
-  val const_bisim  = (comp_dnam^"_bisim" ,relprod --> boolT  , NoSyn);
-  val ctt           = map (calc_syntax funprod) eqs';
+  val const_copy = (Binding.name (comp_dnam^"_copy"), funprod ->> funprod, NoSyn);
+  val const_bisim = (Binding.name (comp_dnam^"_bisim"), relprod --> boolT, NoSyn);
+  val ctt : ((binding * typ * mixfix) list * ast Syntax.trrule list) list = map (calc_syntax funprod) eqs';
 in thy'' |> ContConsts.add_consts_i (List.concat (map fst ctt) @ 
 				    (if length eqs'>1 then [const_copy] else[])@
 				    [const_bisim])

--- a/src/HOLCF/Tools/domain/domain_theorems.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Tools/domain/domain_theorems.ML	Fri May 15 15:56:28 2009 +0200
@@ -8,7 +8,14 @@
 
 val HOLCF_ss = @{simpset};
 
-structure Domain_Theorems = struct
+signature DOMAIN_THEOREMS =
+sig
+  val theorems: Domain_Library.eq * Domain_Library.eq list -> theory -> thm list * theory;
+  val comp_theorems: bstring * Domain_Library.eq list -> theory -> thm list * theory;
+end;
+
+structure Domain_Theorems :> DOMAIN_THEOREMS =
+struct
 
 val quiet_mode = ref false;
 val trace_domain = ref false;
@@ -22,7 +29,7 @@
 val adm_all = @{thm adm_all};
 val adm_conj = @{thm adm_conj};
 val adm_subst = @{thm adm_subst};
-val antisym_less_inverse = @{thm antisym_less_inverse};
+val antisym_less_inverse = @{thm below_antisym_inverse};
 val beta_cfun = @{thm beta_cfun};
 val cfun_arg_cong = @{thm cfun_arg_cong};
 val ch2ch_Rep_CFunL = @{thm ch2ch_Rep_CFunL};
@@ -37,12 +44,12 @@
 val contlub_cfun_fun = @{thm contlub_cfun_fun};
 val fix_def2 = @{thm fix_def2};
 val injection_eq = @{thm injection_eq};
-val injection_less = @{thm injection_less};
+val injection_less = @{thm injection_below};
 val lub_equal = @{thm lub_equal};
 val monofun_cfun_arg = @{thm monofun_cfun_arg};
 val retraction_strict = @{thm retraction_strict};
 val spair_eq = @{thm spair_eq};
-val spair_less = @{thm spair_less};
+val spair_less = @{thm spair_below};
 val sscase1 = @{thm sscase1};
 val ssplit1 = @{thm ssplit1};
 val strictify1 = @{thm strictify1};
@@ -114,7 +121,7 @@
 
 val all2E = @{lemma "!x y . P x y ==> (P x y ==> R) ==> R" by simp}
 
-val dist_eqI = @{lemma "!!x::'a::po. ~ x << y ==> x ~= y" by (blast dest!: antisym_less_inverse)}
+val dist_eqI = @{lemma "!!x::'a::po. ~ x << y ==> x ~= y" by (blast dest!: below_antisym_inverse)}
 
 in
 
@@ -314,8 +321,8 @@
 local
   fun mat_strict (con, _) =
     let
-      val goal = mk_trp (strict (%%:(mat_name con)));
-      val tacs = [rtac when_strict 1];
+      val goal = mk_trp (%%:(mat_name con) ` UU ` %:"rhs" === UU);
+      val tacs = [asm_simp_tac (HOLCF_ss addsimps [when_strict]) 1];
     in pg axs_mat_def goal (K tacs) end;
 
   val _ = trace " Proving mat_stricts...";
@@ -323,10 +330,10 @@
 
   fun one_mat c (con, args) =
     let
-      val lhs = %%:(mat_name c) ` con_app con args;
+      val lhs = %%:(mat_name c) ` con_app con args ` %:"rhs";
       val rhs =
         if con = c
-        then mk_return (mk_ctuple (map %# args))
+        then list_ccomb (%:"rhs", map %# args)
         else mk_fail;
       val goal = lift_defined %: (nonlazy args, mk_trp (lhs === rhs));
       val tacs = [asm_simp_tac (HOLCF_ss addsimps when_rews) 1];
@@ -374,30 +381,32 @@
 end;
 
 local
-  val rev_contrapos = @{thm rev_contrapos};
   fun con_strict (con, args) = 
     let
+      val rules = abs_strict :: @{thms con_strict_rules};
       fun one_strict vn =
         let
           fun f arg = if vname arg = vn then UU else %# arg;
           val goal = mk_trp (con_app2 con f args === UU);
-          val tacs = [asm_simp_tac (HOLCF_ss addsimps [abs_strict]) 1];
+          val tacs = [simp_tac (HOL_basic_ss addsimps rules) 1];
         in pg con_appls goal (K tacs) end;
     in map one_strict (nonlazy args) end;
 
   fun con_defin (con, args) =
     let
-      val concl = mk_trp (defined (con_app con args));
-      val goal = lift_defined %: (nonlazy args, concl);
-      fun tacs ctxt = [
-        rtac @{thm rev_contrapos} 1,
-        eres_inst_tac ctxt [(("f", 0), dis_name con)] cfun_arg_cong 1,
-        asm_simp_tac (HOLCF_ss addsimps dis_rews) 1];
-    in pg [] goal tacs end;
+      fun iff_disj (t, []) = HOLogic.mk_not t
+        | iff_disj (t, ts) = t === foldr1 HOLogic.mk_disj ts;
+      val lhs = con_app con args === UU;
+      val rhss = map (fn x => %:x === UU) (nonlazy args);
+      val goal = mk_trp (iff_disj (lhs, rhss));
+      val rule1 = iso_locale RS @{thm iso.abs_defined_iff};
+      val rules = rule1 :: @{thms con_defined_iff_rules};
+      val tacs = [simp_tac (HOL_ss addsimps rules) 1];
+    in pg con_appls goal (K tacs) end;
 in
   val _ = trace " Proving con_stricts...";
   val con_stricts = maps con_strict cons;
-  val _ = trace " Proving pat_defins...";
+  val _ = trace " Proving con_defins...";
   val con_defins = map con_defin cons;
   val con_rews = con_stricts @ con_defins;
 end;
@@ -488,7 +497,6 @@
 end;
 
 val sel_rews = sel_stricts @ sel_defins @ sel_apps;
-val rev_contrapos = @{thm rev_contrapos};
 
 val _ = trace " Proving dist_les...";
 val distincts_le =
@@ -607,23 +615,22 @@
 in
   thy
     |> Sign.add_path (Long_Name.base_name dname)
-    |> (snd o PureThy.add_thmss [
-        ((Binding.name "iso_rews" , iso_rews  ), [Simplifier.simp_add]),
-        ((Binding.name "exhaust"  , [exhaust] ), []),
-        ((Binding.name "casedist" , [casedist]), [Induct.cases_type dname]),
-        ((Binding.name "when_rews", when_rews ), [Simplifier.simp_add]),
-        ((Binding.name "compacts", con_compacts), [Simplifier.simp_add]),
-        ((Binding.name "con_rews", con_rews), [Simplifier.simp_add]),
-        ((Binding.name "sel_rews", sel_rews), [Simplifier.simp_add]),
-        ((Binding.name "dis_rews", dis_rews), [Simplifier.simp_add]),
-        ((Binding.name "pat_rews", pat_rews), [Simplifier.simp_add]),
-        ((Binding.name "dist_les", dist_les), [Simplifier.simp_add]),
-        ((Binding.name "dist_eqs", dist_eqs), [Simplifier.simp_add]),
-        ((Binding.name "inverts" , inverts ), [Simplifier.simp_add]),
-        ((Binding.name "injects" , injects ), [Simplifier.simp_add]),
-        ((Binding.name "copy_rews", copy_rews), [Simplifier.simp_add]),
-        ((Binding.name "match_rews", mat_rews), [Simplifier.simp_add])
-       ])
+    |> snd o PureThy.add_thmss [
+        ((Binding.name "iso_rews"  , iso_rews    ), [Simplifier.simp_add]),
+        ((Binding.name "exhaust"   , [exhaust]   ), []),
+        ((Binding.name "casedist"  , [casedist]  ), [Induct.cases_type dname]),
+        ((Binding.name "when_rews" , when_rews   ), [Simplifier.simp_add]),
+        ((Binding.name "compacts"  , con_compacts), [Simplifier.simp_add]),
+        ((Binding.name "con_rews"  , con_rews    ), [Simplifier.simp_add]),
+        ((Binding.name "sel_rews"  , sel_rews    ), [Simplifier.simp_add]),
+        ((Binding.name "dis_rews"  , dis_rews    ), [Simplifier.simp_add]),
+        ((Binding.name "pat_rews"  , pat_rews    ), [Simplifier.simp_add]),
+        ((Binding.name "dist_les"  , dist_les    ), [Simplifier.simp_add]),
+        ((Binding.name "dist_eqs"  , dist_eqs    ), [Simplifier.simp_add]),
+        ((Binding.name "inverts"   , inverts     ), [Simplifier.simp_add]),
+        ((Binding.name "injects"   , injects     ), [Simplifier.simp_add]),
+        ((Binding.name "copy_rews" , copy_rews   ), [Simplifier.simp_add]),
+        ((Binding.name "match_rews", mat_rews    ), [Simplifier.simp_add])]
     |> Sign.parent_path
     |> pair (iso_rews @ when_rews @ con_rews @ sel_rews @ dis_rews @
         pat_rews @ dist_les @ dist_eqs @ copy_rews)
@@ -1003,14 +1010,14 @@
 fun ind_rule (dname, rule) = ((Binding.empty, [rule]), [Induct.induct_type dname]);
 
 in thy |> Sign.add_path comp_dnam
-       |> (snd o (PureThy.add_thmss (map (Thm.no_attributes o apfst Binding.name) [
-		("take_rews"  , take_rews  ),
-		("take_lemmas", take_lemmas),
-		("finites"    , finites    ),
-		("finite_ind", [finite_ind]),
-		("ind"       , [ind       ]),
-		("coind"     , [coind     ])])))
-       |> (snd o (PureThy.add_thmss (map ind_rule (dnames ~~ inducts))))
+       |> snd o PureThy.add_thmss [
+           ((Binding.name "take_rews"  , take_rews   ), [Simplifier.simp_add]),
+           ((Binding.name "take_lemmas", take_lemmas ), []),
+           ((Binding.name "finites"    , finites     ), []),
+           ((Binding.name "finite_ind" , [finite_ind]), []),
+           ((Binding.name "ind"        , [ind]       ), []),
+           ((Binding.name "coind"      , [coind]     ), [])]
+       |> snd o PureThy.add_thmss (map ind_rule (dnames ~~ inducts))
        |> Sign.parent_path |> pair take_rews
 end; (* let *)
 end; (* local *)

--- a/src/HOLCF/Tools/fixrec_package.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Tools/fixrec_package.ML	Fri May 15 15:56:28 2009 +0200
@@ -16,11 +16,11 @@
   val setup: theory -> theory
 end;
 
-structure FixrecPackage: FIXREC_PACKAGE =
+structure FixrecPackage :> FIXREC_PACKAGE =
 struct
 
-val fix_eq2 = @{thm fix_eq2};
-val def_fix_ind = @{thm def_fix_ind};
+val def_cont_fix_eq = @{thm def_cont_fix_eq};
+val def_cont_fix_ind = @{thm def_cont_fix_ind};
 
 
 fun fixrec_err s = error ("fixrec definition error:\n" ^ s);
@@ -36,6 +36,8 @@
 
 infixr 6 ->>; val (op ->>) = cfunT;
 
+fun cfunsT (Ts, U) = foldr cfunT U Ts;
+
 fun dest_cfunT (Type(@{type_name "->"}, [T, U])) = (T, U)
   | dest_cfunT T = raise TYPE ("dest_cfunT", [T], []);
 
@@ -53,11 +55,13 @@
 fun dest_maybeT (Type(@{type_name "maybe"}, [T])) = T
   | dest_maybeT T = raise TYPE ("dest_maybeT", [T], []);
 
-fun tupleT [] = @{typ "unit"}
+fun tupleT [] = HOLogic.unitT
   | tupleT [T] = T
   | tupleT (T :: Ts) = HOLogic.mk_prodT (T, tupleT Ts);
 
-fun matchT T = body_cfun T ->> maybeT (tupleT (binder_cfun T));
+fun matchT (T, U) =
+  body_cfun T ->> cfunsT (binder_cfun T, U) ->> U;
+
 
 (*************************************************************************)
 (***************************** building terms ****************************)
@@ -78,6 +82,10 @@
 fun cabs_const (S, T) =
   Const(@{const_name Abs_CFun}, (S --> T) --> (S ->> T));
 
+fun mk_cabs t =
+  let val T = Term.fastype_of t
+  in cabs_const (Term.domain_type T, Term.range_type T) $ t end
+
 fun mk_capply (t, u) =
   let val (S, T) =
     case Term.fastype_of t of
@@ -89,29 +97,6 @@
 infix 1 ===; val (op ===) = HOLogic.mk_eq;
 infix 9 `  ; val (op `) = mk_capply;
 
-
-fun mk_cpair (t, u) =
-  let val T = Term.fastype_of t
-      val U = Term.fastype_of u
-      val cpairT = T ->> U ->> HOLogic.mk_prodT (T, U)
-  in Const(@{const_name cpair}, cpairT) ` t ` u end;
-
-fun mk_cfst t =
-  let val T = Term.fastype_of t;
-      val (U, _) = HOLogic.dest_prodT T;
-  in Const(@{const_name cfst}, T ->> U) ` t end;
-
-fun mk_csnd t =
-  let val T = Term.fastype_of t;
-      val (_, U) = HOLogic.dest_prodT T;
-  in Const(@{const_name csnd}, T ->> U) ` t end;
-
-fun mk_csplit t =
-  let val (S, TU) = dest_cfunT (Term.fastype_of t);
-      val (T, U) = dest_cfunT TU;
-      val csplitT = (S ->> T ->> U) ->> HOLogic.mk_prodT (S, T) ->> U;
-  in Const(@{const_name csplit}, csplitT) ` t end;
-
 (* builds the expression (LAM v. rhs) *)
 fun big_lambda v rhs =
   cabs_const (Term.fastype_of v, Term.fastype_of rhs) $ Term.lambda v rhs;
@@ -120,17 +105,6 @@
 fun big_lambdas [] rhs = rhs
   | big_lambdas (v::vs) rhs = big_lambda v (big_lambdas vs rhs);
 
-(* builds the expression (LAM <v1,v2,..,vn>. rhs) *)
-fun lambda_ctuple [] rhs = big_lambda (Free("unit", HOLogic.unitT)) rhs
-  | lambda_ctuple (v::[]) rhs = big_lambda v rhs
-  | lambda_ctuple (v::vs) rhs =
-      mk_csplit (big_lambda v (lambda_ctuple vs rhs));
-
-(* builds the expression <v1,v2,..,vn> *)
-fun mk_ctuple [] = @{term "UU::unit"}
-|   mk_ctuple (t::[]) = t
-|   mk_ctuple (t::ts) = mk_cpair (t, mk_ctuple ts);
-
 fun mk_return t =
   let val T = Term.fastype_of t
   in Const(@{const_name Fixrec.return}, T ->> maybeT T) ` t end;
@@ -153,6 +127,25 @@
   let val (T, _) = dest_cfunT (Term.fastype_of t)
   in Const(@{const_name fix}, (T ->> T) ->> T) ` t end;
 
+fun mk_cont t =
+  let val T = Term.fastype_of t
+  in Const(@{const_name cont}, T --> HOLogic.boolT) $ t end;
+
+val mk_fst = HOLogic.mk_fst
+val mk_snd = HOLogic.mk_snd
+
+(* builds the expression (v1,v2,..,vn) *)
+fun mk_tuple [] = HOLogic.unit
+|   mk_tuple (t::[]) = t
+|   mk_tuple (t::ts) = HOLogic.mk_prod (t, mk_tuple ts);
+
+(* builds the expression (%(v1,v2,..,vn). rhs) *)
+fun lambda_tuple [] rhs = Term.lambda (Free("unit", HOLogic.unitT)) rhs
+  | lambda_tuple (v::[]) rhs = Term.lambda v rhs
+  | lambda_tuple (v::vs) rhs =
+      HOLogic.mk_split (Term.lambda v (lambda_tuple vs rhs));
+
+
 (*************************************************************************)
 (************* fixed-point definitions and unfolding theorems ************)
 (*************************************************************************)
@@ -162,40 +155,48 @@
   (spec : (Attrib.binding * term) list)
   (lthy : local_theory) =
   let
+    val thy = ProofContext.theory_of lthy;
     val names = map (Binding.name_of o fst o fst) fixes;
     val all_names = space_implode "_" names;
     val (lhss,rhss) = ListPair.unzip (map (dest_eqs o snd) spec);
-    val fixpoint = mk_fix (lambda_ctuple lhss (mk_ctuple rhss));
+    val functional = lambda_tuple lhss (mk_tuple rhss);
+    val fixpoint = mk_fix (mk_cabs functional);
     
+    val cont_thm =
+      Goal.prove lthy [] [] (mk_trp (mk_cont functional))
+        (K (simp_tac (local_simpset_of lthy) 1));
+
     fun one_def (l as Free(n,_)) r =
           let val b = Long_Name.base_name n
           in ((Binding.name (b^"_def"), []), r) end
       | one_def _ _ = fixrec_err "fixdefs: lhs not of correct form";
     fun defs [] _ = []
       | defs (l::[]) r = [one_def l r]
-      | defs (l::ls) r = one_def l (mk_cfst r) :: defs ls (mk_csnd r);
+      | defs (l::ls) r = one_def l (mk_fst r) :: defs ls (mk_snd r);
     val fixdefs = defs lhss fixpoint;
     val define_all = fold_map (LocalTheory.define Thm.definitionK);
     val (fixdef_thms : (term * (string * thm)) list, lthy') = lthy
       |> define_all (map (apfst fst) fixes ~~ fixdefs);
-    fun cpair_equalI (thm1, thm2) = @{thm cpair_equalI} OF [thm1, thm2];
-    val ctuple_fixdef_thm = foldr1 cpair_equalI (map (snd o snd) fixdef_thms);
-    val ctuple_induct_thm = ctuple_fixdef_thm RS def_fix_ind;
-    val ctuple_unfold_thm =
-      Goal.prove lthy' [] [] (mk_trp (mk_ctuple lhss === mk_ctuple rhss))
-        (fn _ => EVERY [rtac (ctuple_fixdef_thm RS fix_eq2 RS trans) 1,
-                   simp_tac (local_simpset_of lthy') 1]);
+    fun pair_equalI (thm1, thm2) = @{thm Pair_equalI} OF [thm1, thm2];
+    val tuple_fixdef_thm = foldr1 pair_equalI (map (snd o snd) fixdef_thms);
+    val P = Var (("P", 0), map Term.fastype_of lhss ---> HOLogic.boolT);
+    val predicate = lambda_tuple lhss (list_comb (P, lhss));
+    val tuple_induct_thm = (def_cont_fix_ind OF [tuple_fixdef_thm, cont_thm])
+      |> Drule.instantiate' [] [SOME (Thm.cterm_of thy predicate)]
+      |> LocalDefs.unfold lthy @{thms split_paired_all split_conv split_strict};
+    val tuple_unfold_thm = (def_cont_fix_eq OF [tuple_fixdef_thm, cont_thm])
+      |> LocalDefs.unfold lthy' @{thms split_conv};
     fun unfolds [] thm = []
       | unfolds (n::[]) thm = [(n^"_unfold", thm)]
       | unfolds (n::ns) thm = let
-          val thmL = thm RS @{thm cpair_eqD1};
-          val thmR = thm RS @{thm cpair_eqD2};
+          val thmL = thm RS @{thm Pair_eqD1};
+          val thmR = thm RS @{thm Pair_eqD2};
         in (n^"_unfold", thmL) :: unfolds ns thmR end;
-    val unfold_thms = unfolds names ctuple_unfold_thm;
+    val unfold_thms = unfolds names tuple_unfold_thm;
     fun mk_note (n, thm) = ((Binding.name n, []), [thm]);
     val (thmss, lthy'') = lthy'
       |> fold_map (LocalTheory.note Thm.theoremK o mk_note)
-        ((all_names ^ "_induct", ctuple_induct_thm) :: unfold_thms);
+        ((all_names ^ "_induct", tuple_induct_thm) :: unfold_thms);
   in
     (lthy'', names, fixdef_thms, map snd unfold_thms)
   end;
@@ -240,10 +241,10 @@
         fun result_type (Type(@{type_name "->"},[_,T])) (x::xs) = result_type T xs
           | result_type T _ = T;
         val v = Free(n, result_type T vs);
-        val m = Const(match_name c, matchT T);
-        val k = lambda_ctuple vs rhs;
+        val m = Const(match_name c, matchT (T, fastype_of rhs));
+        val k = big_lambdas vs rhs;
       in
-        (mk_bind (m`v, k), v, n::taken)
+        (m`v`k, v, n::taken)
       end
   | Free(n,_) => fixrec_err ("expected constructor, found free variable " ^ quote n)
   | _ => fixrec_err "pre_build: invalid pattern";

--- a/src/HOLCF/Tools/pcpodef_package.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Tools/pcpodef_package.ML	Fri May 15 15:56:28 2009 +0200
@@ -17,7 +17,7 @@
     * (binding * binding) option -> theory -> Proof.state
 end;
 
-structure PcpodefPackage: PCPODEF_PACKAGE =
+structure PcpodefPackage :> PCPODEF_PACKAGE =
 struct
 
 (** type definitions **)
@@ -66,9 +66,9 @@
         NONE => (Binding.prefix_name "Rep_" name, Binding.prefix_name "Abs_" name)
       | SOME morphs => morphs);
     val RepC = Const (full Rep_name, newT --> oldT);
-    fun lessC T = Const (@{const_name sq_le}, T --> T --> HOLogic.boolT);
-    val less_def = Logic.mk_equals (lessC newT,
-      Abs ("x", newT, Abs ("y", newT, lessC oldT $ (RepC $ Bound 1) $ (RepC $ Bound 0))));
+    fun belowC T = Const (@{const_name below}, T --> T --> HOLogic.boolT);
+    val below_def = Logic.mk_equals (belowC newT,
+      Abs ("x", newT, Abs ("y", newT, belowC oldT $ (RepC $ Bound 1) $ (RepC $ Bound 0))));
 
     fun make_po tac thy1 =
       let
@@ -76,22 +76,22 @@
           |> TypedefPackage.add_typedef def (SOME name) (t, vs, mx) set opt_morphs tac;
         val lthy3 = thy2
           |> TheoryTarget.instantiation ([full_tname], lhs_tfrees, @{sort po});
-        val less_def' = Syntax.check_term lthy3 less_def;
-        val ((_, (_, less_definition')), lthy4) = lthy3
+        val below_def' = Syntax.check_term lthy3 below_def;
+        val ((_, (_, below_definition')), lthy4) = lthy3
           |> Specification.definition (NONE,
-              ((Binding.prefix_name "less_" (Binding.suffix_name "_def" name), []), less_def'));
+              ((Binding.prefix_name "below_" (Binding.suffix_name "_def" name), []), below_def'));
         val ctxt_thy = ProofContext.init (ProofContext.theory_of lthy4);
-        val less_definition = singleton (ProofContext.export lthy4 ctxt_thy) less_definition';
+        val below_definition = singleton (ProofContext.export lthy4 ctxt_thy) below_definition';
         val thy5 = lthy4
           |> Class.prove_instantiation_instance
-              (K (Tactic.rtac (@{thm typedef_po} OF [type_definition, less_definition]) 1))
+              (K (Tactic.rtac (@{thm typedef_po} OF [type_definition, below_definition]) 1))
           |> LocalTheory.exit_global;
-      in ((type_definition, less_definition, set_def), thy5) end;
+      in ((type_definition, below_definition, set_def), thy5) end;
 
-    fun make_cpo admissible (type_def, less_def, set_def) theory =
+    fun make_cpo admissible (type_def, below_def, set_def) theory =
       let
         val admissible' = fold_rule (the_list set_def) admissible;
-        val cpo_thms = map (Thm.transfer theory) [type_def, less_def, admissible'];
+        val cpo_thms = map (Thm.transfer theory) [type_def, below_def, admissible'];
         val theory' = theory
           |> AxClass.prove_arity (full_tname, lhs_sorts, @{sort cpo})
             (Tactic.rtac (@{thm typedef_cpo} OF cpo_thms) 1);
@@ -110,10 +110,10 @@
         |> Sign.parent_path
       end;
 
-    fun make_pcpo UU_mem (type_def, less_def, set_def) theory =
+    fun make_pcpo UU_mem (type_def, below_def, set_def) theory =
       let
         val UU_mem' = fold_rule (the_list set_def) UU_mem;
-        val pcpo_thms = map (Thm.transfer theory) [type_def, less_def, UU_mem'];
+        val pcpo_thms = map (Thm.transfer theory) [type_def, below_def, UU_mem'];
         val theory' = theory
           |> AxClass.prove_arity (full_tname, lhs_sorts, @{sort pcpo})
             (Tactic.rtac (@{thm typedef_pcpo} OF pcpo_thms) 1);

--- a/src/HOLCF/Tr.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Tr.thy	Fri May 15 15:56:28 2009 +0200
@@ -37,7 +37,7 @@
 
 text {* distinctness for type @{typ tr} *}
 
-lemma dist_less_tr [simp]:
+lemma dist_below_tr [simp]:
   "\<not> TT \<sqsubseteq> \<bottom>" "\<not> FF \<sqsubseteq> \<bottom>" "\<not> TT \<sqsubseteq> FF" "\<not> FF \<sqsubseteq> TT"
 unfolding TT_def FF_def by simp_all
 
@@ -45,16 +45,16 @@
   "TT \<noteq> \<bottom>" "FF \<noteq> \<bottom>" "TT \<noteq> FF" "\<bottom> \<noteq> TT" "\<bottom> \<noteq> FF" "FF \<noteq> TT"
 unfolding TT_def FF_def by simp_all
 
-lemma TT_less_iff [simp]: "TT \<sqsubseteq> x \<longleftrightarrow> x = TT"
+lemma TT_below_iff [simp]: "TT \<sqsubseteq> x \<longleftrightarrow> x = TT"
 by (induct x rule: tr_induct) simp_all
 
-lemma FF_less_iff [simp]: "FF \<sqsubseteq> x \<longleftrightarrow> x = FF"
+lemma FF_below_iff [simp]: "FF \<sqsubseteq> x \<longleftrightarrow> x = FF"
 by (induct x rule: tr_induct) simp_all
 
-lemma not_less_TT_iff [simp]: "\<not> (x \<sqsubseteq> TT) \<longleftrightarrow> x = FF"
+lemma not_below_TT_iff [simp]: "\<not> (x \<sqsubseteq> TT) \<longleftrightarrow> x = FF"
 by (induct x rule: tr_induct) simp_all
 
-lemma not_less_FF_iff [simp]: "\<not> (x \<sqsubseteq> FF) \<longleftrightarrow> x = TT"
+lemma not_below_FF_iff [simp]: "\<not> (x \<sqsubseteq> FF) \<longleftrightarrow> x = TT"
 by (induct x rule: tr_induct) simp_all
 
 

--- a/src/HOLCF/Universal.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Universal.thy	Fri May 15 15:56:28 2009 +0200
@@ -251,7 +251,7 @@
 typedef (open) udom = "{S. udom.ideal S}"
 by (fast intro: udom.ideal_principal)
 
-instantiation udom :: sq_ord
+instantiation udom :: below
 begin
 
 definition
@@ -262,16 +262,16 @@
 
 instance udom :: po
 by (rule udom.typedef_ideal_po
-    [OF type_definition_udom sq_le_udom_def])
+    [OF type_definition_udom below_udom_def])
 
 instance udom :: cpo
 by (rule udom.typedef_ideal_cpo
-    [OF type_definition_udom sq_le_udom_def])
+    [OF type_definition_udom below_udom_def])
 
 lemma Rep_udom_lub:
   "chain Y \<Longrightarrow> Rep_udom (\<Squnion>i. Y i) = (\<Union>i. Rep_udom (Y i))"
 by (rule udom.typedef_ideal_rep_contlub
-    [OF type_definition_udom sq_le_udom_def])
+    [OF type_definition_udom below_udom_def])
 
 lemma ideal_Rep_udom: "udom.ideal (Rep_udom xs)"
 by (rule Rep_udom [unfolded mem_Collect_eq])
@@ -291,7 +291,7 @@
 apply (rule ideal_Rep_udom)
 apply (erule Rep_udom_lub)
 apply (rule Rep_udom_principal)
-apply (simp only: sq_le_udom_def)
+apply (simp only: below_udom_def)
 done
 
 text {* Universal domain is pointed *}
@@ -359,9 +359,9 @@
     assume "y \<in> insert a A" and "(if x \<sqsubseteq> a then a else x) \<sqsubseteq> y"
     thus "(if x \<sqsubseteq> a then a else x) = y"
       apply auto
-      apply (frule (1) trans_less)
+      apply (frule (1) below_trans)
       apply (frule (1) x_eq)
-      apply (rule antisym_less, assumption)
+      apply (rule below_antisym, assumption)
       apply simp
       apply (erule (1) x_eq)
       done
@@ -503,7 +503,7 @@
 done
 
 lemma rank_leD: "rank x \<le> n \<Longrightarrow> cb_take n x = x"
-apply (rule antisym_less [OF cb_take_less])
+apply (rule below_antisym [OF cb_take_less])
 apply (subst compact_approx_rank [symmetric])
 apply (erule cb_take_chain_le)
 done
@@ -727,7 +727,7 @@
       apply (rule IH)
        apply (simp add: less_max_iff_disj)
        apply (erule place_sub_less)
-      apply (erule rev_trans_less)
+      apply (erule rev_below_trans)
       apply (rule sub_below)
       done
   qed
@@ -779,9 +779,9 @@
 
 lemma basis_prj_mono: "ubasis_le a b \<Longrightarrow> basis_prj a \<sqsubseteq> basis_prj b"
 proof (induct a b rule: ubasis_le.induct)
-  case (ubasis_le_refl a) show ?case by (rule refl_less)
+  case (ubasis_le_refl a) show ?case by (rule below_refl)
 next
-  case (ubasis_le_trans a b c) thus ?case by - (rule trans_less)
+  case (ubasis_le_trans a b c) thus ?case by - (rule below_trans)
 next
   case (ubasis_le_lower S a i) thus ?case
     apply (cases "node i a S \<in> range (basis_emb :: 'a compact_basis \<Rightarrow> nat)")

--- a/src/HOLCF/Up.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/Up.thy	Fri May 15 15:56:28 2009 +0200
@@ -26,11 +26,11 @@
 
 subsection {* Ordering on lifted cpo *}
 
-instantiation u :: (cpo) sq_ord
+instantiation u :: (cpo) below
 begin
 
 definition
-  less_up_def:
+  below_up_def:
     "(op \<sqsubseteq>) \<equiv> (\<lambda>x y. case x of Ibottom \<Rightarrow> True | Iup a \<Rightarrow>
       (case y of Ibottom \<Rightarrow> False | Iup b \<Rightarrow> a \<sqsubseteq> b))"
 
@@ -38,13 +38,13 @@
 end
 
 lemma minimal_up [iff]: "Ibottom \<sqsubseteq> z"
-by (simp add: less_up_def)
+by (simp add: below_up_def)
 
-lemma not_Iup_less [iff]: "\<not> Iup x \<sqsubseteq> Ibottom"
-by (simp add: less_up_def)
+lemma not_Iup_below [iff]: "\<not> Iup x \<sqsubseteq> Ibottom"
+by (simp add: below_up_def)
 
-lemma Iup_less [iff]: "(Iup x \<sqsubseteq> Iup y) = (x \<sqsubseteq> y)"
-by (simp add: less_up_def)
+lemma Iup_below [iff]: "(Iup x \<sqsubseteq> Iup y) = (x \<sqsubseteq> y)"
+by (simp add: below_up_def)
 
 subsection {* Lifted cpo is a partial order *}
 
@@ -52,17 +52,17 @@
 proof
   fix x :: "'a u"
   show "x \<sqsubseteq> x"
-    unfolding less_up_def by (simp split: u.split)
+    unfolding below_up_def by (simp split: u.split)
 next
   fix x y :: "'a u"
   assume "x \<sqsubseteq> y" "y \<sqsubseteq> x" thus "x = y"
-    unfolding less_up_def
-    by (auto split: u.split_asm intro: antisym_less)
+    unfolding below_up_def
+    by (auto split: u.split_asm intro: below_antisym)
 next
   fix x y z :: "'a u"
   assume "x \<sqsubseteq> y" "y \<sqsubseteq> z" thus "x \<sqsubseteq> z"
-    unfolding less_up_def
-    by (auto split: u.split_asm intro: trans_less)
+    unfolding below_up_def
+    by (auto split: u.split_asm intro: below_trans)
 qed
 
 lemma u_UNIV: "UNIV = insert Ibottom (range Iup)"
@@ -78,7 +78,7 @@
   "range S <<| x \<Longrightarrow> range (\<lambda>i. Iup (S i)) <<| Iup x"
 apply (rule is_lubI)
 apply (rule ub_rangeI)
-apply (subst Iup_less)
+apply (subst Iup_below)
 apply (erule is_ub_lub)
 apply (case_tac u)
 apply (drule ub_rangeD)
@@ -112,7 +112,7 @@
 lemma up_lemma4:
   "\<lbrakk>chain Y; Y j \<noteq> Ibottom\<rbrakk> \<Longrightarrow> chain (\<lambda>i. THE a. Iup a = Y (i + j))"
 apply (rule chainI)
-apply (rule Iup_less [THEN iffD1])
+apply (rule Iup_below [THEN iffD1])
 apply (subst up_lemma3, assumption+)+
 apply (simp add: chainE)
 done
@@ -235,9 +235,9 @@
 by (simp add: up_def cont_Iup inst_up_pcpo)
 
 lemma not_up_less_UU: "\<not> up\<cdot>x \<sqsubseteq> \<bottom>"
-by simp
+by simp (* FIXME: remove? *)
 
-lemma up_less [simp]: "(up\<cdot>x \<sqsubseteq> up\<cdot>y) = (x \<sqsubseteq> y)"
+lemma up_below [simp]: "up\<cdot>x \<sqsubseteq> up\<cdot>y \<longleftrightarrow> x \<sqsubseteq> y"
 by (simp add: up_def cont_Iup)
 
 lemma upE [cases type: u]: "\<lbrakk>p = \<bottom> \<Longrightarrow> Q; \<And>x. p = up\<cdot>x \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"

--- a/src/HOLCF/UpperPD.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/UpperPD.thy	Fri May 15 15:56:28 2009 +0200
@@ -23,7 +23,7 @@
 apply (drule (1) bspec, erule bexE)
 apply (drule (1) bspec, erule bexE)
 apply (erule rev_bexI)
-apply (erule (1) trans_less)
+apply (erule (1) below_trans)
 done
 
 interpretation upper_le: preorder upper_le
@@ -38,7 +38,7 @@
 lemma PDPlus_upper_mono: "\<lbrakk>s \<le>\<sharp> t; u \<le>\<sharp> v\<rbrakk> \<Longrightarrow> PDPlus s u \<le>\<sharp> PDPlus t v"
 unfolding upper_le_def Rep_PDPlus by fast
 
-lemma PDPlus_upper_less: "PDPlus t u \<le>\<sharp> t"
+lemma PDPlus_upper_le: "PDPlus t u \<le>\<sharp> t"
 unfolding upper_le_def Rep_PDPlus by fast
 
 lemma upper_le_PDUnit_PDUnit_iff [simp]:
@@ -97,7 +97,7 @@
   "{S::'a pd_basis set. upper_le.ideal S}"
 by (fast intro: upper_le.ideal_principal)
 
-instantiation upper_pd :: (profinite) sq_ord
+instantiation upper_pd :: (profinite) below
 begin
 
 definition
@@ -108,16 +108,16 @@
 
 instance upper_pd :: (profinite) po
 by (rule upper_le.typedef_ideal_po
-    [OF type_definition_upper_pd sq_le_upper_pd_def])
+    [OF type_definition_upper_pd below_upper_pd_def])
 
 instance upper_pd :: (profinite) cpo
 by (rule upper_le.typedef_ideal_cpo
-    [OF type_definition_upper_pd sq_le_upper_pd_def])
+    [OF type_definition_upper_pd below_upper_pd_def])
 
 lemma Rep_upper_pd_lub:
   "chain Y \<Longrightarrow> Rep_upper_pd (\<Squnion>i. Y i) = (\<Union>i. Rep_upper_pd (Y i))"
 by (rule upper_le.typedef_ideal_rep_contlub
-    [OF type_definition_upper_pd sq_le_upper_pd_def])
+    [OF type_definition_upper_pd below_upper_pd_def])
 
 lemma ideal_Rep_upper_pd: "upper_le.ideal (Rep_upper_pd xs)"
 by (rule Rep_upper_pd [unfolded mem_Collect_eq])
@@ -143,7 +143,7 @@
 apply (rule ideal_Rep_upper_pd)
 apply (erule Rep_upper_pd_lub)
 apply (rule Rep_upper_principal)
-apply (simp only: sq_le_upper_pd_def)
+apply (simp only: below_upper_pd_def)
 done
 
 text {* Upper powerdomain is pointed *}
@@ -262,28 +262,28 @@
 lemmas upper_plus_aci =
   upper_plus_ac upper_plus_absorb upper_plus_left_absorb
 
-lemma upper_plus_less1: "xs +\<sharp> ys \<sqsubseteq> xs"
+lemma upper_plus_below1: "xs +\<sharp> ys \<sqsubseteq> xs"
 apply (induct xs ys rule: upper_pd.principal_induct2, simp, simp)
-apply (simp add: PDPlus_upper_less)
+apply (simp add: PDPlus_upper_le)
 done
 
-lemma upper_plus_less2: "xs +\<sharp> ys \<sqsubseteq> ys"
-by (subst upper_plus_commute, rule upper_plus_less1)
+lemma upper_plus_below2: "xs +\<sharp> ys \<sqsubseteq> ys"
+by (subst upper_plus_commute, rule upper_plus_below1)
 
 lemma upper_plus_greatest: "\<lbrakk>xs \<sqsubseteq> ys; xs \<sqsubseteq> zs\<rbrakk> \<Longrightarrow> xs \<sqsubseteq> ys +\<sharp> zs"
 apply (subst upper_plus_absorb [of xs, symmetric])
 apply (erule (1) monofun_cfun [OF monofun_cfun_arg])
 done
 
-lemma upper_less_plus_iff:
+lemma upper_below_plus_iff:
   "xs \<sqsubseteq> ys +\<sharp> zs \<longleftrightarrow> xs \<sqsubseteq> ys \<and> xs \<sqsubseteq> zs"
 apply safe
-apply (erule trans_less [OF _ upper_plus_less1])
-apply (erule trans_less [OF _ upper_plus_less2])
+apply (erule below_trans [OF _ upper_plus_below1])
+apply (erule below_trans [OF _ upper_plus_below2])
 apply (erule (1) upper_plus_greatest)
 done
 
-lemma upper_plus_less_unit_iff:
+lemma upper_plus_below_unit_iff:
   "xs +\<sharp> ys \<sqsubseteq> {z}\<sharp> \<longleftrightarrow> xs \<sqsubseteq> {z}\<sharp> \<or> ys \<sqsubseteq> {z}\<sharp>"
  apply (rule iffI)
   apply (subgoal_tac
@@ -297,13 +297,13 @@
    apply simp
   apply simp
  apply (erule disjE)
-  apply (erule trans_less [OF upper_plus_less1])
- apply (erule trans_less [OF upper_plus_less2])
+  apply (erule below_trans [OF upper_plus_below1])
+ apply (erule below_trans [OF upper_plus_below2])
 done
 
-lemma upper_unit_less_iff [simp]: "{x}\<sharp> \<sqsubseteq> {y}\<sharp> \<longleftrightarrow> x \<sqsubseteq> y"
+lemma upper_unit_below_iff [simp]: "{x}\<sharp> \<sqsubseteq> {y}\<sharp> \<longleftrightarrow> x \<sqsubseteq> y"
  apply (rule iffI)
-  apply (rule profinite_less_ext)
+  apply (rule profinite_below_ext)
   apply (drule_tac f="approx i" in monofun_cfun_arg, simp)
   apply (cut_tac x="approx i\<cdot>x" in compact_basis.compact_imp_principal, simp)
   apply (cut_tac x="approx i\<cdot>y" in compact_basis.compact_imp_principal, simp)
@@ -311,10 +311,10 @@
  apply (erule monofun_cfun_arg)
 done
 
-lemmas upper_pd_less_simps =
-  upper_unit_less_iff
-  upper_less_plus_iff
-  upper_plus_less_unit_iff
+lemmas upper_pd_below_simps =
+  upper_unit_below_iff
+  upper_below_plus_iff
+  upper_plus_below_unit_iff
 
 lemma upper_unit_eq_iff [simp]: "{x}\<sharp> = {y}\<sharp> \<longleftrightarrow> x = y"
 unfolding po_eq_conv by simp
@@ -323,10 +323,10 @@
 unfolding inst_upper_pd_pcpo Rep_compact_bot [symmetric] by simp
 
 lemma upper_plus_strict1 [simp]: "\<bottom> +\<sharp> ys = \<bottom>"
-by (rule UU_I, rule upper_plus_less1)
+by (rule UU_I, rule upper_plus_below1)
 
 lemma upper_plus_strict2 [simp]: "xs +\<sharp> \<bottom> = \<bottom>"
-by (rule UU_I, rule upper_plus_less2)
+by (rule UU_I, rule upper_plus_below2)
 
 lemma upper_unit_strict_iff [simp]: "{x}\<sharp> = \<bottom> \<longleftrightarrow> x = \<bottom>"
 unfolding upper_unit_strict [symmetric] by (rule upper_unit_eq_iff)
@@ -407,11 +407,11 @@
 
 lemma upper_bind_basis_mono:
   "t \<le>\<sharp> u \<Longrightarrow> upper_bind_basis t \<sqsubseteq> upper_bind_basis u"
-unfolding expand_cfun_less
+unfolding expand_cfun_below
 apply (erule upper_le_induct, safe)
 apply (simp add: monofun_cfun)
-apply (simp add: trans_less [OF upper_plus_less1])
-apply (simp add: upper_less_plus_iff)
+apply (simp add: below_trans [OF upper_plus_below1])
+apply (simp add: upper_below_plus_iff)
 done
 
 definition

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOLCF/ex/Domain_ex.thy	Fri May 15 15:56:28 2009 +0200
@@ -0,0 +1,221 @@
+(*  Title:      HOLCF/ex/Domain_ex.thy
+    Author:     Brian Huffman
+*)
+
+header {* Domain package examples *}
+
+theory Domain_ex
+imports HOLCF
+begin
+
+text {* Domain constructors are strict by default. *}
+
+domain d1 = d1a | d1b "d1" "d1"
+
+lemma "d1b\<cdot>\<bottom>\<cdot>y = \<bottom>" by simp
+
+text {* Constructors can be made lazy using the @{text "lazy"} keyword. *}
+
+domain d2 = d2a | d2b (lazy "d2")
+
+lemma "d2b\<cdot>x \<noteq> \<bottom>" by simp
+
+text {* Strict and lazy arguments may be mixed arbitrarily. *}
+
+domain d3 = d3a | d3b (lazy "d2") "d2"
+
+lemma "P (d3b\<cdot>x\<cdot>y = \<bottom>) \<longleftrightarrow> P (y = \<bottom>)" by simp
+
+text {* Selectors can be used with strict or lazy constructor arguments. *}
+
+domain d4 = d4a | d4b (lazy d4b_left :: "d2") (d4b_right :: "d2")
+
+lemma "y \<noteq> \<bottom> \<Longrightarrow> d4b_left\<cdot>(d4b\<cdot>x\<cdot>y) = x" by simp
+
+text {* Mixfix declarations can be given for data constructors. *}
+
+domain d5 = d5a | d5b (lazy "d5") "d5" (infixl ":#:" 70)
+
+lemma "d5a \<noteq> x :#: y :#: z" by simp
+
+text {* Mixfix declarations can also be given for type constructors. *}
+
+domain ('a, 'b) lazypair (infixl ":*:" 25) =
+  lpair (lazy lfst :: 'a) (lazy lsnd :: 'b) (infixl ":*:" 75)
+
+lemma "\<forall>p::('a :*: 'b). p \<sqsubseteq> lfst\<cdot>p :*: lsnd\<cdot>p"
+by (rule allI, case_tac p, simp_all)
+
+text {* Non-recursive constructor arguments can have arbitrary types. *}
+
+domain ('a, 'b) d6 = d6 "int lift" "'a \<oplus> 'b u" (lazy "('a :*: 'b) \<times> ('b \<rightarrow> 'a)")
+
+text {*
+  Indirect recusion is allowed for sums, products, lifting, and the
+  continuous function space.  However, the domain package currently
+  generates induction rules that are too weak.  A fix is planned for
+  the next release.
+*}
+
+domain 'a d7 = d7a "'a d7 \<oplus> int lift" | d7b "'a \<otimes> 'a d7" | d7c "'a d7 \<rightarrow> 'a"
+
+thm d7.ind -- "note the lack of inductive hypotheses"
+
+text {*
+  Indirect recursion using previously-defined datatypes is currently
+  not allowed.  This restriction should go away by the next release.
+*}
+(*
+domain 'a slist = SNil | SCons 'a "'a slist"
+domain 'a stree = STip | SBranch "'a stree slist" -- "illegal indirect recursion"
+*)
+
+text {* Mutually-recursive datatypes can be defined using the @{text "and"} keyword. *}
+
+domain d8 = d8a | d8b "d9" and d9 = d9a | d9b (lazy "d8")
+
+text {* Non-regular recursion is not allowed. *}
+(*
+domain ('a, 'b) altlist = ANil | ACons 'a "('b, 'a) altlist"
+  -- "illegal direct recursion with different arguments"
+domain 'a nest = Nest1 'a | Nest2 "'a nest nest"
+  -- "illegal direct recursion with different arguments"
+*)
+
+text {*
+  Mutually-recursive datatypes must have all the same type arguments,
+  not necessarily in the same order.
+*}
+
+domain ('a, 'b) list1 = Nil1 | Cons1 'a "('b, 'a) list2"
+   and ('b, 'a) list2 = Nil2 | Cons2 'b "('a, 'b) list1"
+
+text {* Induction rules for flat datatypes have no admissibility side-condition. *}
+
+domain 'a flattree = Tip | Branch "'a flattree" "'a flattree"
+
+lemma "\<lbrakk>P \<bottom>; P Tip; \<And>x y. \<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>; P x; P y\<rbrakk> \<Longrightarrow> P (Branch\<cdot>x\<cdot>y)\<rbrakk> \<Longrightarrow> P x"
+by (rule flattree.ind) -- "no admissibility requirement"
+
+text {* Trivial datatypes will produce a warning message. *}
+
+domain triv = triv1 triv triv
+  -- "domain Domain_ex.triv is empty!"
+
+lemma "(x::triv) = \<bottom>" by (induct x, simp_all)
+
+
+subsection {* Generated constants and theorems *}
+
+domain 'a tree = Leaf (lazy 'a) | Node (left :: "'a tree") (lazy right :: "'a tree")
+
+lemmas tree_abs_defined_iff =
+  iso.abs_defined_iff [OF iso.intro [OF tree.abs_iso tree.rep_iso]]
+
+text {* Rules about ismorphism *}
+term tree_rep
+term tree_abs
+thm tree.rep_iso
+thm tree.abs_iso
+thm tree.iso_rews
+
+text {* Rules about constructors *}
+term Leaf
+term Node
+thm tree.Leaf_def tree.Node_def
+thm tree.exhaust
+thm tree.casedist
+thm tree.compacts
+thm tree.con_rews
+thm tree.dist_les
+thm tree.dist_eqs
+thm tree.inverts
+thm tree.injects
+
+text {* Rules about case combinator *}
+term tree_when
+thm tree.when_def
+thm tree.when_rews
+
+text {* Rules about selectors *}
+term left
+term right
+thm tree.sel_rews
+
+text {* Rules about discriminators *}
+term is_Leaf
+term is_Node
+thm tree.dis_rews
+
+text {* Rules about pattern match combinators *}
+term Leaf_pat
+term Node_pat
+thm tree.pat_rews
+
+text {* Rules about monadic pattern match combinators *}
+term match_Leaf
+term match_Node
+thm tree.match_rews
+
+text {* Rules about copy function *}
+term tree_copy
+thm tree.copy_def
+thm tree.copy_rews
+
+text {* Rules about take function *}
+term tree_take
+thm tree.take_def
+thm tree.take_rews
+thm tree.take_lemmas
+thm tree.finite_ind
+
+text {* Rules about finiteness predicate *}
+term tree_finite
+thm tree.finite_def
+thm tree.finites
+
+text {* Rules about bisimulation predicate *}
+term tree_bisim
+thm tree.bisim_def
+thm tree.coind
+
+text {* Induction rule *}
+thm tree.ind
+
+
+subsection {* Known bugs *}
+
+text {* Declaring a mixfix with spaces causes some strange parse errors. *}
+(*
+domain xx = xx ("x y")
+  -- "Inner syntax error: unexpected end of input"
+
+domain 'a foo = foo (sel::"'a") ("a b")
+  -- {* Inner syntax error at "= UU" *}
+*)
+
+text {*
+  I don't know what is going on here.  The failed proof has to do with
+  the finiteness predicate.
+*}
+(*
+domain foo = Foo (lazy "bar") and bar = Bar
+  -- "Tactic failed."
+*)
+
+text {* Declaring class constraints on the LHS is currently broken. *}
+(*
+domain ('a::cpo) box = Box (lazy 'a)
+  -- "Malformed YXML encoding: multiple results"
+*)
+
+text {*
+  Class constraints on the RHS are not supported yet.  This feature is
+  planned to replace the old-style LHS class constraints.
+*}
+(*
+domain 'a box = Box (lazy "'a::cpo")
+  -- {* Inconsistent sort constraint for type variable "'a" *}
+*)
+
+end

--- a/src/HOLCF/ex/Fixrec_ex.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/ex/Fixrec_ex.thy	Fri May 15 15:56:28 2009 +0200
@@ -8,7 +8,7 @@
 imports HOLCF
 begin
 
-subsection {* basic fixrec examples *}
+subsection {* Basic @{text fixrec} examples *}
 
 text {*
   Fixrec patterns can mention any constructor defined by the domain
@@ -16,31 +16,31 @@
   cpair, spair, sinl, sinr, up, ONE, TT, FF.
 *}
 
-text {* typical usage is with lazy constructors *}
+text {* Typical usage is with lazy constructors. *}
 
 fixrec down :: "'a u \<rightarrow> 'a"
 where "down\<cdot>(up\<cdot>x) = x"
 
-text {* with strict constructors, rewrite rules may require side conditions *}
+text {* With strict constructors, rewrite rules may require side conditions. *}
 
 fixrec from_sinl :: "'a \<oplus> 'b \<rightarrow> 'a"
 where "x \<noteq> \<bottom> \<Longrightarrow> from_sinl\<cdot>(sinl\<cdot>x) = x"
 
-text {* lifting can turn a strict constructor into a lazy one *}
+text {* Lifting can turn a strict constructor into a lazy one. *}
 
 fixrec from_sinl_up :: "'a u \<oplus> 'b \<rightarrow> 'a"
 where "from_sinl_up\<cdot>(sinl\<cdot>(up\<cdot>x)) = x"
 
 
-subsection {* fixpat examples *}
+subsection {* Examples using @{text fixpat} *}
 
-text {* a type of lazy lists *}
+text {* A type of lazy lists. *}
 
 domain 'a llist = lNil | lCons (lazy 'a) (lazy "'a llist")
 
-text {* zip function for lazy lists *}
+text {* A zip function for lazy lists. *}
 
-text {* notice that the patterns are not exhaustive *}
+text {* Notice that the patterns are not exhaustive. *}
 
 fixrec
   lzip :: "'a llist \<rightarrow> 'b llist \<rightarrow> ('a \<times> 'b) llist"
@@ -48,24 +48,59 @@
   "lzip\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>(lCons\<cdot>y\<cdot>ys) = lCons\<cdot><x,y>\<cdot>(lzip\<cdot>xs\<cdot>ys)"
 | "lzip\<cdot>lNil\<cdot>lNil = lNil"
 
-text {* fixpat is useful for producing strictness theorems *}
-text {* note that pattern matching is done in left-to-right order *}
+text {* @{text fixpat} is useful for producing strictness theorems. *}
+text {* Note that pattern matching is done in left-to-right order. *}
 
 fixpat lzip_stricts [simp]:
   "lzip\<cdot>\<bottom>\<cdot>ys"
   "lzip\<cdot>lNil\<cdot>\<bottom>"
   "lzip\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>\<bottom>"
 
-text {* fixpat can also produce rules for missing cases *}
+text {* @{text fixpat} can also produce rules for missing cases. *}
 
 fixpat lzip_undefs [simp]:
   "lzip\<cdot>lNil\<cdot>(lCons\<cdot>y\<cdot>ys)"
   "lzip\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>lNil"
 
 
-subsection {* skipping proofs of rewrite rules *}
+subsection {* Pattern matching with bottoms *}
+
+text {*
+  As an alternative to using @{text fixpat}, it is also possible to
+  use bottom as a constructor pattern.  When using a bottom pattern,
+  the right-hand-side must also be bottom; otherwise, @{text fixrec}
+  will not be able to prove the equation.
+*}
+
+fixrec
+  from_sinr_up :: "'a \<oplus> 'b\<^sub>\<bottom> \<rightarrow> 'b"
+where
+  "from_sinr_up\<cdot>\<bottom> = \<bottom>"
+| "from_sinr_up\<cdot>(sinr\<cdot>(up\<cdot>x)) = x"
 
-text {* another zip function for lazy lists *}
+text {*
+  If the function is already strict in that argument, then the bottom
+  pattern does not change the meaning of the function.  For example,
+  in the definition of @{term from_sinr_up}, the first equation is
+  actually redundant, and could have been proven separately by
+  @{text fixpat}.
+*}
+
+text {*
+  A bottom pattern can also be used to make a function strict in a
+  certain argument, similar to a bang-pattern in Haskell.
+*}
+
+fixrec
+  seq :: "'a \<rightarrow> 'b \<rightarrow> 'b"
+where
+  "seq\<cdot>\<bottom>\<cdot>y = \<bottom>"
+| "x \<noteq> \<bottom> \<Longrightarrow> seq\<cdot>x\<cdot>y = y"
+
+
+subsection {* Skipping proofs of rewrite rules *}
+
+text {* Another zip function for lazy lists. *}
 
 text {*
   Notice that this version has overlapping patterns.
@@ -85,7 +120,7 @@
   does not produce any simp rules.
 *}
 
-text {* simp rules can be generated later using fixpat *}
+text {* Simp rules can be generated later using @{text fixpat}. *}
 
 fixpat lzip2_simps [simp]:
   "lzip2\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>(lCons\<cdot>y\<cdot>ys)"
@@ -97,16 +132,17 @@
   "lzip2\<cdot>\<bottom>\<cdot>ys"
   "lzip2\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>\<bottom>"
 
-subsection {* mutual recursion with fixrec *}
 
-text {* tree and forest types *}
+subsection {* Mutual recursion with @{text fixrec} *}
+
+text {* Tree and forest types. *}
 
 domain 'a tree = Leaf (lazy 'a) | Branch (lazy "'a forest")
 and    'a forest = Empty | Trees (lazy "'a tree") "'a forest"
 
 text {*
   To define mutually recursive functions, separate the equations
-  for each function using the keyword "and".
+  for each function using the keyword @{text "and"}.
 *}
 
 fixrec
@@ -125,10 +161,13 @@
 
 text {*
   Theorems generated:
-  map_tree_def map_forest_def
-  map_tree_unfold map_forest_unfold
-  map_tree_simps map_forest_simps
-  map_tree_map_forest_induct
+  @{text map_tree_def}
+  @{text map_forest_def}
+  @{text map_tree_unfold}
+  @{text map_forest_unfold}
+  @{text map_tree_simps}
+  @{text map_forest_simps}
+  @{text map_tree_map_forest_induct}
 *}
 
 end

--- a/src/HOLCF/ex/ROOT.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/ex/ROOT.ML	Fri May 15 15:56:28 2009 +0200
@@ -4,4 +4,4 @@
 *)
 
 use_thys ["Dnat", "Stream", "Dagstuhl", "Focus_ex", "Fix2", "Hoare",
-  "Loop", "Fixrec_ex", "Powerdomain_ex"];
+  "Loop", "Fixrec_ex", "Powerdomain_ex", "Domain_ex"];

--- a/src/HOLCF/ex/Stream.thy	Fri May 15 15:29:34 2009 +0200
+++ b/src/HOLCF/ex/Stream.thy	Fri May 15 15:56:28 2009 +0200
@@ -64,10 +64,10 @@
 section "scons"
 
 lemma scons_eq_UU: "(a && s = UU) = (a = UU)"
-by (auto, erule contrapos_pp, simp)
+by simp
 
 lemma scons_not_empty: "[| a && x = UU; a ~= UU |] ==> R"
-by auto
+by simp
 
 lemma stream_exhaust_eq: "(x ~= UU) = (EX a y. a ~= UU &  x = a && y)"
 by (auto,insert stream.exhaust [of x],auto)
@@ -382,7 +382,6 @@
 
 lemma slen_scons_eq_rev: "(#x < Fin (Suc (Suc n))) = (!a y. x ~= a && y |  a = \<bottom> |  #y < Fin (Suc n))"
  apply (rule stream.casedist [of x], auto)
-    apply ((*drule sym,*) drule scons_eq_UU [THEN iffD1],auto)
    apply (simp add: zero_inat_def)
   apply (case_tac "#s") apply (simp_all add: iSuc_Fin)
  apply (case_tac "#s") apply (simp_all add: iSuc_Fin)
@@ -874,7 +873,6 @@
 lemma slen_sconc_finite1:
   "[| #(x ooo y) = Infty; Fin n = #x |] ==> #y = Infty"
 apply (case_tac "#y ~= Infty",auto)
-apply (simp only: slen_infinite [symmetric])
 apply (drule_tac y=y in rt_sconc1)
 apply (insert stream_finite_i_rt [of n "x ooo y"])
 by (simp add: slen_infinite)
@@ -889,16 +887,15 @@
   apply (drule ex_sconc,auto)
  apply (erule contrapos_pp)
  apply (insert stream_finite_i_rt)
- apply (simp add: slen_infinite,auto)
+ apply (fastsimp simp add: slen_infinite,auto)
 by (simp add: sconc_def)
 
 lemma sconc_finite: "(#x~=Infty & #y~=Infty) = (#(x ooo y)~=Infty)"
 apply auto
-  apply (case_tac "#x",auto)
-  apply (erule contrapos_pp,simp)
-  apply (erule slen_sconc_finite1,simp)
- apply (drule slen_sconc_infinite1 [of _ y],simp)
-by (drule slen_sconc_infinite2 [of _ x],simp)
+  apply (metis not_Infty_eq slen_sconc_finite1)
+ apply (metis not_Infty_eq slen_sconc_infinite1)
+apply (metis not_Infty_eq slen_sconc_infinite2)
+done
 
 (* ----------------------------------------------------------------------- *)
 

--- a/src/Provers/Arith/cancel_div_mod.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/Provers/Arith/cancel_div_mod.ML	Fri May 15 15:56:28 2009 +0200
@@ -69,7 +69,7 @@
 
 fun cancel ss t pq =
   let val teqt' = Data.prove_eq_sums ss (t, rearrange t pq)
-  in hd(Data.div_mod_eqs RL [teqt' RS transitive_thm]) end;
+  in hd (Data.div_mod_eqs RL [teqt' RS transitive_thm]) end;
 
 fun proc ss t =
   let val (divs,mods) = coll_div_mod t ([],[])

--- a/src/Provers/Arith/fast_lin_arith.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/Provers/Arith/fast_lin_arith.ML	Fri May 15 15:56:28 2009 +0200
@@ -56,7 +56,7 @@
 
   (*preprocessing, performed on the goal -- must do the same as 'pre_decomp':*)
   val pre_tac: Proof.context -> int -> tactic
-  val number_of: int * typ -> term
+  val mk_number: typ -> int -> term
 
   (*the limit on the number of ~= allowed; because each ~= is split
     into two cases, this can lead to an explosion*)
@@ -86,6 +86,9 @@
 
 signature FAST_LIN_ARITH =
 sig
+  val cut_lin_arith_tac: simpset -> int -> tactic
+  val lin_arith_tac: Proof.context -> bool -> int -> tactic
+  val lin_arith_simproc: simpset -> term -> thm option
   val map_data: ({add_mono_thms: thm list, mult_mono_thms: thm list, inj_thms: thm list,
                  lessD: thm list, neqE: thm list, simpset: Simplifier.simpset}
                  -> {add_mono_thms: thm list, mult_mono_thms: thm list, inj_thms: thm list,
@@ -93,9 +96,6 @@
                 -> Context.generic -> Context.generic
   val trace: bool ref
   val warning_count: int ref;
-  val cut_lin_arith_tac: simpset -> int -> tactic
-  val lin_arith_tac: Proof.context -> bool -> int -> tactic
-  val lin_arith_simproc: simpset -> term -> thm option
 end;
 
 functor Fast_Lin_Arith
@@ -429,7 +429,7 @@
 
 (* FIXME OPTIMIZE!!!! (partly done already)
    Addition/Multiplication need i*t representation rather than t+t+...
-   Get rid of Mulitplied(2). For Nat LA_Data.number_of should return Suc^n
+   Get rid of Mulitplied(2). For Nat LA_Data.mk_number should return Suc^n
    because Numerals are not known early enough.
 
 Simplification may detect a contradiction 'prematurely' due to type
@@ -480,7 +480,7 @@
               get_first (fn th => SOME(thm RS th) handle THM _ => NONE) mult_mono_thms
             fun cvar(th,_ $ (_ $ _ $ var)) = cterm_of (Thm.theory_of_thm th) var;
             val cv = cvar(mth, hd(prems_of mth));
-            val ct = cterm_of thy (LA_Data.number_of(n,#T(rep_cterm cv)))
+            val ct = cterm_of thy (LA_Data.mk_number (#T (rep_cterm cv)) n)
         in instantiate ([],[(cv,ct)]) mth end
 
       fun simp thm =

--- a/src/Pure/General/symbol.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/Pure/General/symbol.ML	Fri May 15 15:56:28 2009 +0200
@@ -18,6 +18,7 @@
   val is_symbolic: symbol -> bool
   val is_printable: symbol -> bool
   val is_utf8_trailer: symbol -> bool
+  val name_of: symbol -> string
   val eof: symbol
   val is_eof: symbol -> bool
   val not_eof: symbol -> bool
@@ -135,6 +136,10 @@
 fun is_regular s =
   not_eof s andalso s <> sync andalso s <> malformed andalso s <> end_malformed;
 
+fun name_of s = if is_symbolic s
+  then (unsuffix ">" o unprefix "\\<") s
+  else error (malformed_msg s);
+
 
 (* ascii symbols *)
 

--- a/src/Pure/IsaMakefile	Fri May 15 15:29:34 2009 +0200
+++ b/src/Pure/IsaMakefile	Fri May 15 15:56:28 2009 +0200
@@ -40,9 +40,8 @@
 
 Pure: $(OUT)/Pure
 
-$(OUT)/Pure: $(BOOTSTRAP_FILES) ../Tools/auto_solve.ML			\
-  ../Tools/quickcheck.ML Concurrent/ROOT.ML Concurrent/future.ML	\
-  Concurrent/mailbox.ML Concurrent/par_list.ML				\
+$(OUT)/Pure: $(BOOTSTRAP_FILES) Concurrent/ROOT.ML			\
+  Concurrent/future.ML Concurrent/mailbox.ML Concurrent/par_list.ML	\
   Concurrent/par_list_dummy.ML Concurrent/simple_thread.ML		\
   Concurrent/synchronized.ML Concurrent/task_queue.ML General/ROOT.ML	\
   General/alist.ML General/antiquote.ML General/balanced_tree.ML	\
@@ -57,7 +56,7 @@
   General/table.ML General/url.ML General/xml.ML General/yxml.ML	\
   Isar/ROOT.ML Isar/args.ML Isar/attrib.ML Isar/auto_bind.ML		\
   Isar/calculation.ML Isar/class.ML Isar/class_target.ML Isar/code.ML	\
-  Isar/code_unit.ML Isar/constdefs.ML Isar/context_rules.ML		\
+  Isar/constdefs.ML Isar/context_rules.ML		\
   Isar/element.ML Isar/expression.ML Isar/isar_cmd.ML			\
   Isar/isar_document.ML Isar/isar_syn.ML Isar/local_defs.ML		\
   Isar/local_syntax.ML Isar/local_theory.ML Isar/locale.ML		\

--- a/src/Pure/Isar/ROOT.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/Pure/Isar/ROOT.ML	Fri May 15 15:56:28 2009 +0200
@@ -61,7 +61,6 @@
 use "../simplifier.ML";
 
 (*executable theory content*)
-use "code_unit.ML";
 use "code.ML";
 
 (*specifications*)

--- a/src/Pure/Isar/class_target.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/Pure/Isar/class_target.ML	Fri May 15 15:56:28 2009 +0200
@@ -278,7 +278,8 @@
     val classrel = Goal.prove_global thy [] [] (Logic.mk_classrel (sub, sup))
       (K tac);
     val diff_sort = Sign.complete_sort thy [sup]
-      |> subtract (op =) (Sign.complete_sort thy [sub]);
+      |> subtract (op =) (Sign.complete_sort thy [sub])
+      |> filter (is_class thy);
   in
     thy
     |> AxClass.add_classrel classrel

--- a/src/Pure/Isar/code.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/Pure/Isar/code.ML	Fri May 15 15:56:28 2009 +0200
@@ -7,45 +7,73 @@
 
 signature CODE =
 sig
+  (*constructor sets*)
+  val constrset_of_consts: theory -> (string * typ) list
+    -> string * ((string * sort) list * (string * typ list) list)
+
+  (*typ instantiations*)
+  val typscheme: theory -> string * typ -> (string * sort) list * typ
+  val inst_thm: theory -> sort Vartab.table -> thm -> thm
+
+  (*constants*)
+  val string_of_typ: theory -> typ -> string
+  val string_of_const: theory -> string -> string
+  val no_args: theory -> string -> int
+  val check_const: theory -> term -> string
+  val read_bare_const: theory -> string -> string * typ
+  val read_const: theory -> string -> string
+
+  (*constant aliasses*)
+  val add_const_alias: thm -> theory -> theory
+  val triv_classes: theory -> class list
+  val resubst_alias: theory -> string -> string
+
+  (*code equations*)
+  val mk_eqn: theory -> (string -> bool) -> thm * bool -> thm * bool
+  val mk_eqn_liberal: theory -> (string -> bool) -> thm -> (thm * bool) option
+  val assert_eqn: theory -> thm * bool -> thm * bool
+  val assert_eqns_const: theory -> string
+    -> (thm * bool) list -> (thm * bool) list
+  val const_typ_eqn: thm -> string * typ
+  val const_eqn: theory -> thm -> string
+  val typscheme_eqn: theory -> thm -> (string * sort) list * typ
+  val expand_eta: theory -> int -> thm -> thm
+  val rewrite_eqn: simpset -> thm -> thm
+  val rewrite_head: thm list -> thm -> thm
+  val norm_args: theory -> thm list -> thm list 
+  val norm_varnames: theory -> thm list -> thm list
+
+  (*case certificates*)
+  val case_cert: thm -> string * (int * string list)
+
+  (*infrastructure*)
+  val add_attribute: string * attribute parser -> theory -> theory
+  val purge_data: theory -> theory
+
+  (*executable content*)
+  val add_datatype: (string * typ) list -> theory -> theory
+  val add_datatype_cmd: string list -> theory -> theory
+  val type_interpretation:
+    (string * ((string * sort) list * (string * typ list) list)
+      -> theory -> theory) -> theory -> theory
   val add_eqn: thm -> theory -> theory
-  val add_nonlinear_eqn: thm -> theory -> theory
+  val add_nbe_eqn: thm -> theory -> theory
   val add_default_eqn: thm -> theory -> theory
   val add_default_eqn_attribute: attribute
   val add_default_eqn_attrib: Attrib.src
   val del_eqn: thm -> theory -> theory
   val del_eqns: string -> theory -> theory
   val add_eqnl: string * (thm * bool) list lazy -> theory -> theory
-  val map_pre: (simpset -> simpset) -> theory -> theory
-  val map_post: (simpset -> simpset) -> theory -> theory
-  val add_inline: thm -> theory -> theory
-  val add_functrans: string * (theory -> (thm * bool) list -> (thm * bool) list option) -> theory -> theory
-  val del_functrans: string -> theory -> theory
-  val add_datatype: (string * typ) list -> theory -> theory
-  val add_datatype_cmd: string list -> theory -> theory
-  val type_interpretation:
-    (string * ((string * sort) list * (string * typ list) list)
-      -> theory -> theory) -> theory -> theory
   val add_case: thm -> theory -> theory
   val add_undefined: string -> theory -> theory
-  val purge_data: theory -> theory
 
-  val coregular_algebra: theory -> Sorts.algebra
-  val operational_algebra: theory -> (sort -> sort) * Sorts.algebra
-  val these_eqns: theory -> string -> (thm * bool) list
-  val these_raw_eqns: theory -> string -> (thm * bool) list
+  (*data retrieval*)
   val get_datatype: theory -> string -> ((string * sort) list * (string * typ list) list)
   val get_datatype_of_constr: theory -> string -> string option
+  val default_typscheme: theory -> string -> (string * sort) list * typ
+  val these_eqns: theory -> string -> (thm * bool) list
   val get_case_scheme: theory -> string -> (int * (int * string list)) option
   val is_undefined: theory -> string -> bool
-  val default_typscheme: theory -> string -> (string * sort) list * typ
-
-  val preprocess_conv: theory -> cterm -> thm
-  val preprocess_term: theory -> term -> term
-  val postprocess_conv: theory -> cterm -> thm
-  val postprocess_term: theory -> term -> term
-
-  val add_attribute: string * attribute parser -> theory -> theory
-
   val print_codesetup: theory -> unit
 end;
 
@@ -80,6 +108,400 @@
 structure Code : PRIVATE_CODE =
 struct
 
+(* auxiliary *)
+
+fun string_of_typ thy = setmp show_sorts true (Syntax.string_of_typ_global thy);
+fun string_of_const thy c = case AxClass.inst_of_param thy c
+ of SOME (c, tyco) => Sign.extern_const thy c ^ " " ^ enclose "[" "]" (Sign.extern_type thy tyco)
+  | NONE => Sign.extern_const thy c;
+
+fun no_args thy = length o fst o strip_type o Sign.the_const_type thy;
+
+
+(* utilities *)
+
+fun typscheme thy (c, ty) =
+  let
+    val ty' = Logic.unvarifyT ty;
+    fun dest (TFree (v, sort)) = (v, sort)
+      | dest ty = error ("Illegal type parameter in type scheme: " ^ Syntax.string_of_typ_global thy ty);
+    val vs = map dest (Sign.const_typargs thy (c, ty'));
+  in (vs, Type.strip_sorts ty') end;
+
+fun inst_thm thy tvars' thm =
+  let
+    val tvars = (Term.add_tvars o Thm.prop_of) thm [];
+    val inter_sort = Sorts.inter_sort (Sign.classes_of thy);
+    fun mk_inst (tvar as (v, sort)) = case Vartab.lookup tvars' v
+     of SOME sort' => SOME (pairself (Thm.ctyp_of thy o TVar)
+          (tvar, (v, inter_sort (sort, sort'))))
+      | NONE => NONE;
+    val insts = map_filter mk_inst tvars;
+  in Thm.instantiate (insts, []) thm end;
+
+fun expand_eta thy k thm =
+  let
+    val (lhs, rhs) = (Logic.dest_equals o Thm.plain_prop_of) thm;
+    val (head, args) = strip_comb lhs;
+    val l = if k = ~1
+      then (length o fst o strip_abs) rhs
+      else Int.max (0, k - length args);
+    val used = Name.make_context (map (fst o fst) (Term.add_vars lhs []));
+    fun get_name _ 0 = pair []
+      | get_name (Abs (v, ty, t)) k =
+          Name.variants [v]
+          ##>> get_name t (k - 1)
+          #>> (fn ([v'], vs') => (v', ty) :: vs')
+      | get_name t k = 
+          let
+            val (tys, _) = (strip_type o fastype_of) t
+          in case tys
+           of [] => raise TERM ("expand_eta", [t])
+            | ty :: _ =>
+                Name.variants [""]
+                #-> (fn [v] => get_name (t $ Var ((v, 0), ty)) (k - 1)
+                #>> (fn vs' => (v, ty) :: vs'))
+          end;
+    val (vs, _) = get_name rhs l used;
+    fun expand (v, ty) thm = Drule.fun_cong_rule thm
+      (Thm.cterm_of thy (Var ((v, 0), ty)));
+  in
+    thm
+    |> fold expand vs
+    |> Conv.fconv_rule Drule.beta_eta_conversion
+  end;
+
+fun eqn_conv conv =
+  let
+    fun lhs_conv ct = if can Thm.dest_comb ct
+      then (Conv.combination_conv lhs_conv conv) ct
+      else Conv.all_conv ct;
+  in Conv.combination_conv (Conv.arg_conv lhs_conv) conv end;
+
+fun head_conv conv =
+  let
+    fun lhs_conv ct = if can Thm.dest_comb ct
+      then (Conv.fun_conv lhs_conv) ct
+      else conv ct;
+  in Conv.fun_conv (Conv.arg_conv lhs_conv) end;
+
+val rewrite_eqn = Conv.fconv_rule o eqn_conv o Simplifier.rewrite;
+val rewrite_head = Conv.fconv_rule o head_conv o MetaSimplifier.rewrite false;
+
+fun norm_args thy thms =
+  let
+    val num_args_of = length o snd o strip_comb o fst o Logic.dest_equals;
+    val k = fold (curry Int.max o num_args_of o Thm.prop_of) thms 0;
+  in
+    thms
+    |> map (expand_eta thy k)
+    |> map (Conv.fconv_rule Drule.beta_eta_conversion)
+  end;
+
+fun canonical_tvars thy thm =
+  let
+    val ctyp = Thm.ctyp_of thy;
+    val purify_tvar = unprefix "'" #> Name.desymbolize false #> prefix "'";
+    fun tvars_subst_for thm = (fold_types o fold_atyps)
+      (fn TVar (v_i as (v, _), sort) => let
+            val v' = purify_tvar v
+          in if v = v' then I
+          else insert (op =) (v_i, (v', sort)) end
+        | _ => I) (prop_of thm) [];
+    fun mk_inst (v_i, (v', sort)) (maxidx, acc) =
+      let
+        val ty = TVar (v_i, sort)
+      in
+        (maxidx + 1, (ctyp ty, ctyp (TVar ((v', maxidx), sort))) :: acc)
+      end;
+    val maxidx = Thm.maxidx_of thm + 1;
+    val (_, inst) = fold mk_inst (tvars_subst_for thm) (maxidx + 1, []);
+  in Thm.instantiate (inst, []) thm end;
+
+fun canonical_vars thy thm =
+  let
+    val cterm = Thm.cterm_of thy;
+    val purify_var = Name.desymbolize false;
+    fun vars_subst_for thm = fold_aterms
+      (fn Var (v_i as (v, _), ty) => let
+            val v' = purify_var v
+          in if v = v' then I
+          else insert (op =) (v_i, (v', ty)) end
+        | _ => I) (prop_of thm) [];
+    fun mk_inst (v_i as (v, i), (v', ty)) (maxidx, acc) =
+      let
+        val t = Var (v_i, ty)
+      in
+        (maxidx + 1, (cterm t, cterm (Var ((v', maxidx), ty))) :: acc)
+      end;
+    val maxidx = Thm.maxidx_of thm + 1;
+    val (_, inst) = fold mk_inst (vars_subst_for thm) (maxidx + 1, []);
+  in Thm.instantiate ([], inst) thm end;
+
+fun canonical_absvars thm =
+  let
+    val t = Thm.plain_prop_of thm;
+    val purify_var = Name.desymbolize false;
+    val t' = Term.map_abs_vars purify_var t;
+  in Thm.rename_boundvars t t' thm end;
+
+fun norm_varnames thy thms =
+  let
+    fun burrow_thms f [] = []
+      | burrow_thms f thms =
+          thms
+          |> Conjunction.intr_balanced
+          |> f
+          |> Conjunction.elim_balanced (length thms)
+  in
+    thms
+    |> map (canonical_vars thy)
+    |> map canonical_absvars
+    |> map Drule.zero_var_indexes
+    |> burrow_thms (canonical_tvars thy)
+    |> Drule.zero_var_indexes_list
+  end;
+
+
+(* const aliasses *)
+
+structure ConstAlias = TheoryDataFun
+(
+  type T = ((string * string) * thm) list * class list;
+  val empty = ([], []);
+  val copy = I;
+  val extend = I;
+  fun merge _ ((alias1, classes1), (alias2, classes2)) : T =
+    (Library.merge (eq_snd Thm.eq_thm_prop) (alias1, alias2),
+      Library.merge (op =) (classes1, classes2));
+);
+
+fun add_const_alias thm thy =
+  let
+    val lhs_rhs = case try Logic.dest_equals (Thm.prop_of thm)
+     of SOME lhs_rhs => lhs_rhs
+      | _ => error ("Not an equation: " ^ Display.string_of_thm thm);
+    val c_c' = case try (pairself (AxClass.unoverload_const thy o dest_Const)) lhs_rhs
+     of SOME c_c' => c_c'
+      | _ => error ("Not an equation with two constants: " ^ Display.string_of_thm thm);
+    val some_class = the_list (AxClass.class_of_param thy (snd c_c'));
+  in thy |>
+    ConstAlias.map (fn (alias, classes) =>
+      ((c_c', thm) :: alias, fold (insert (op =)) some_class classes))
+  end;
+
+fun resubst_alias thy =
+  let
+    val alias = fst (ConstAlias.get thy);
+    val subst_inst_param = Option.map fst o AxClass.inst_of_param thy;
+    fun subst_alias c =
+      get_first (fn ((c', c''), _) => if c = c'' then SOME c' else NONE) alias;
+  in
+    perhaps subst_inst_param
+    #> perhaps subst_alias
+  end;
+
+val triv_classes = snd o ConstAlias.get;
+
+
+(* reading constants as terms *)
+
+fun check_bare_const thy t = case try dest_Const t
+ of SOME c_ty => c_ty
+  | NONE => error ("Not a constant: " ^ Syntax.string_of_term_global thy t);
+
+fun check_const thy = AxClass.unoverload_const thy o check_bare_const thy;
+
+fun read_bare_const thy = check_bare_const thy o Syntax.read_term_global thy;
+
+fun read_const thy = AxClass.unoverload_const thy o read_bare_const thy;
+
+
+(* constructor sets *)
+
+fun constrset_of_consts thy cs =
+  let
+    val _ = map (fn (c, _) => if (is_some o AxClass.class_of_param thy) c
+      then error ("Is a class parameter: " ^ string_of_const thy c) else ()) cs;
+    fun no_constr (c, ty) = error ("Not a datatype constructor: " ^ string_of_const thy c
+      ^ " :: " ^ string_of_typ thy ty);
+    fun last_typ c_ty ty =
+      let
+        val frees = OldTerm.typ_tfrees ty;
+        val (tyco, vs) = ((apsnd o map) (dest_TFree) o dest_Type o snd o strip_type) ty
+          handle TYPE _ => no_constr c_ty
+        val _ = if has_duplicates (eq_fst (op =)) vs then no_constr c_ty else ();
+        val _ = if length frees <> length vs then no_constr c_ty else ();
+      in (tyco, vs) end;
+    fun ty_sorts (c, ty) =
+      let
+        val ty_decl = (Logic.unvarifyT o Sign.the_const_type thy) c;
+        val (tyco, _) = last_typ (c, ty) ty_decl;
+        val (_, vs) = last_typ (c, ty) ty;
+      in ((tyco, map snd vs), (c, (map fst vs, ty))) end;
+    fun add ((tyco', sorts'), c) ((tyco, sorts), cs) =
+      let
+        val _ = if tyco' <> tyco
+          then error "Different type constructors in constructor set"
+          else ();
+        val sorts'' = map2 (curry (Sorts.inter_sort (Sign.classes_of thy))) sorts' sorts
+      in ((tyco, sorts), c :: cs) end;
+    fun inst vs' (c, (vs, ty)) =
+      let
+        val the_v = the o AList.lookup (op =) (vs ~~ vs');
+        val ty' = map_atyps (fn TFree (v, _) => TFree (the_v v)) ty;
+      in (c, (fst o strip_type) ty') end;
+    val c' :: cs' = map ty_sorts cs;
+    val ((tyco, sorts), cs'') = fold add cs' (apsnd single c');
+    val vs = Name.names Name.context Name.aT sorts;
+    val cs''' = map (inst vs) cs'';
+  in (tyco, (vs, rev cs''')) end;
+
+
+(* code equations *)
+
+exception BAD_THM of string;
+fun bad_thm msg = raise BAD_THM msg;
+fun error_thm f thm = f thm handle BAD_THM msg => error msg;
+fun try_thm f thm = SOME (f thm) handle BAD_THM _ => NONE;
+
+fun is_linear thm =
+  let val (_, args) = (strip_comb o fst o Logic.dest_equals o Thm.plain_prop_of) thm
+  in not (has_duplicates (op =) ((fold o fold_aterms)
+    (fn Var (v, _) => cons v | _ => I) args [])) end;
+
+fun gen_assert_eqn thy is_constr_head is_constr_pat (thm, proper) =
+  let
+    val (lhs, rhs) = (Logic.dest_equals o Thm.plain_prop_of) thm
+      handle TERM _ => bad_thm ("Not an equation: " ^ Display.string_of_thm thm)
+           | THM _ => bad_thm ("Not an equation: " ^ Display.string_of_thm thm);
+    fun vars_of t = fold_aterms (fn Var (v, _) => insert (op =) v
+      | Free _ => bad_thm ("Illegal free variable in equation\n"
+          ^ Display.string_of_thm thm)
+      | _ => I) t [];
+    fun tvars_of t = fold_term_types (fn _ =>
+      fold_atyps (fn TVar (v, _) => insert (op =) v
+        | TFree _ => bad_thm 
+      ("Illegal free type variable in equation\n" ^ Display.string_of_thm thm))) t [];
+    val lhs_vs = vars_of lhs;
+    val rhs_vs = vars_of rhs;
+    val lhs_tvs = tvars_of lhs;
+    val rhs_tvs = tvars_of rhs;
+    val _ = if null (subtract (op =) lhs_vs rhs_vs)
+      then ()
+      else bad_thm ("Free variables on right hand side of equation\n"
+        ^ Display.string_of_thm thm);
+    val _ = if null (subtract (op =) lhs_tvs rhs_tvs)
+      then ()
+      else bad_thm ("Free type variables on right hand side of equation\n"
+        ^ Display.string_of_thm thm)    val (head, args) = (strip_comb o fst o Logic.dest_equals o Thm.plain_prop_of) thm;
+    val (c, ty) = case head
+     of Const (c_ty as (_, ty)) => (AxClass.unoverload_const thy c_ty, ty)
+      | _ => bad_thm ("Equation not headed by constant\n" ^ Display.string_of_thm thm);
+    fun check _ (Abs _) = bad_thm
+          ("Abstraction on left hand side of equation\n"
+            ^ Display.string_of_thm thm)
+      | check 0 (Var _) = ()
+      | check _ (Var _) = bad_thm
+          ("Variable with application on left hand side of equation\n"
+            ^ Display.string_of_thm thm)
+      | check n (t1 $ t2) = (check (n+1) t1; check 0 t2)
+      | check n (Const (c_ty as (c, ty))) = if n = (length o fst o strip_type) ty
+          then if not proper orelse is_constr_pat (AxClass.unoverload_const thy c_ty)
+            then ()
+            else bad_thm (quote c ^ " is not a constructor, on left hand side of equation\n"
+              ^ Display.string_of_thm thm)
+          else bad_thm
+            ("Partially applied constant " ^ quote c ^ " on left hand side of equation\n"
+               ^ Display.string_of_thm thm);
+    val _ = map (check 0) args;
+    val _ = if not proper orelse is_linear thm then ()
+      else bad_thm ("Duplicate variables on left hand side of equation\n"
+        ^ Display.string_of_thm thm);
+    val _ = if (is_none o AxClass.class_of_param thy) c
+      then ()
+      else bad_thm ("Polymorphic constant as head in equation\n"
+        ^ Display.string_of_thm thm)
+    val _ = if not (is_constr_head c)
+      then ()
+      else bad_thm ("Constructor as head in equation\n"
+        ^ Display.string_of_thm thm)
+    val ty_decl = Sign.the_const_type thy c;
+    val _ = if Sign.typ_equiv thy (Type.strip_sorts ty_decl, Type.strip_sorts ty)
+      then () else bad_thm ("Type\n" ^ string_of_typ thy ty
+           ^ "\nof equation\n"
+           ^ Display.string_of_thm thm
+           ^ "\nis incompatible with declared function type\n"
+           ^ string_of_typ thy ty_decl)
+  in (thm, proper) end;
+
+fun assert_eqn thy is_constr = error_thm (gen_assert_eqn thy is_constr is_constr);
+
+val const_typ_eqn = dest_Const o fst o strip_comb o fst o Logic.dest_equals o Thm.plain_prop_of;
+
+
+(*those following are permissive wrt. to overloaded constants!*)
+
+fun mk_eqn thy is_constr_head = error_thm (gen_assert_eqn thy is_constr_head (K true)) o
+  apfst (LocalDefs.meta_rewrite_rule (ProofContext.init thy));
+
+fun mk_eqn_liberal thy is_constr_head = Option.map (fn (thm, _) => (thm, is_linear thm))
+  o try_thm (gen_assert_eqn thy is_constr_head (K true))
+  o rpair false o LocalDefs.meta_rewrite_rule (ProofContext.init thy);
+
+fun const_typ_eqn_unoverload thy thm =
+  let
+    val (c, ty) = const_typ_eqn thm;
+    val c' = AxClass.unoverload_const thy (c, ty);
+  in (c', ty) end;
+
+fun typscheme_eqn thy = typscheme thy o const_typ_eqn_unoverload thy;
+fun const_eqn thy = fst o const_typ_eqn_unoverload thy;
+
+
+(* case cerificates *)
+
+fun case_certificate thm =
+  let
+    val ((head, raw_case_expr), cases) = (apfst Logic.dest_equals
+      o apsnd Logic.dest_conjunctions o Logic.dest_implies o Thm.prop_of) thm;
+    val _ = case head of Free _ => true
+      | Var _ => true
+      | _ => raise TERM ("case_cert", []);
+    val ([(case_var, _)], case_expr) = Term.strip_abs_eta 1 raw_case_expr;
+    val (Const (case_const, _), raw_params) = strip_comb case_expr;
+    val n = find_index (fn Free (v, _) => v = case_var | _ => false) raw_params;
+    val _ = if n = ~1 then raise TERM ("case_cert", []) else ();
+    val params = map (fst o dest_Var) (nth_drop n raw_params);
+    fun dest_case t =
+      let
+        val (head' $ t_co, rhs) = Logic.dest_equals t;
+        val _ = if head' = head then () else raise TERM ("case_cert", []);
+        val (Const (co, _), args) = strip_comb t_co;
+        val (Var (param, _), args') = strip_comb rhs;
+        val _ = if args' = args then () else raise TERM ("case_cert", []);
+      in (param, co) end;
+    fun analyze_cases cases =
+      let
+        val co_list = fold (AList.update (op =) o dest_case) cases [];
+      in map (the o AList.lookup (op =) co_list) params end;
+    fun analyze_let t =
+      let
+        val (head' $ arg, Var (param', _) $ arg') = Logic.dest_equals t;
+        val _ = if head' = head then () else raise TERM ("case_cert", []);
+        val _ = if arg' = arg then () else raise TERM ("case_cert", []);
+        val _ = if [param'] = params then () else raise TERM ("case_cert", []);
+      in [] end;
+    fun analyze (cases as [let_case]) =
+          (analyze_cases cases handle Bind => analyze_let let_case)
+      | analyze cases = analyze_cases cases;
+  in (case_const, (n, analyze cases)) end;
+
+fun case_cert thm = case_certificate thm
+  handle Bind => error "bad case certificate"
+       | TERM _ => error "bad case certificate";
+
+
 (** code attributes **)
 
 structure CodeAttr = TheoryDataFun (
@@ -111,7 +533,7 @@
 (* code equations *)
 
 type eqns = bool * (thm * bool) list lazy;
-  (*default flag, theorems with linear flag (perhaps lazy)*)
+  (*default flag, theorems with proper flag (perhaps lazy)*)
 
 fun pretty_lthms ctxt r = case Lazy.peek r
  of SOME thms => map (ProofContext.pretty_thm ctxt o fst) (Exn.release thms)
@@ -124,18 +546,19 @@
         val thy_ref = Theory.check_thy thy;
       in Lazy.lazy (fn () => (f (Theory.deref thy_ref) o Lazy.force) r) end;
 
-fun add_drop_redundant thy (thm, linear) thms =
+fun add_drop_redundant thy (thm, proper) thms =
   let
-    val args_of = snd o strip_comb o fst o Logic.dest_equals o Thm.plain_prop_of;
+    val args_of = snd o strip_comb o map_types Type.strip_sorts
+      o fst o Logic.dest_equals o Thm.plain_prop_of;
     val args = args_of thm;
     val incr_idx = Logic.incr_indexes ([], Thm.maxidx_of thm + 1);
     fun matches_args args' = length args <= length args' andalso
       Pattern.matchess thy (args, (map incr_idx o curry Library.take (length args)) args');
-    fun drop (thm', linear') = if (linear orelse not linear')
+    fun drop (thm', proper') = if (proper orelse not proper')
       andalso matches_args (args_of thm') then 
         (warning ("Code generator: dropping redundant code equation\n" ^ Display.string_of_thm thm'); true)
       else false;
-  in (thm, linear) :: filter_out drop thms end;
+  in (thm, proper) :: filter_out drop thms end;
 
 fun add_thm thy _ thm (false, thms) = (false, Lazy.map_force (add_drop_redundant thy thm) thms)
   | add_thm thy true thm (true, thms) = (true, Lazy.map_force (fn thms => thms @ [thm]) thms)
@@ -159,6 +582,8 @@
 
 fun mk_spec ((concluded_history, eqns), (dtyps, cases)) =
   Spec { concluded_history = concluded_history, eqns = eqns, dtyps = dtyps, cases = cases };
+val empty_spec =
+  mk_spec ((false, Symtab.empty), (Symtab.empty, (Symtab.empty, Symtab.empty)));
 fun map_spec f (Spec { concluded_history = concluded_history, eqns = eqns,
   dtyps = dtyps, cases = cases }) =
   mk_spec (f ((concluded_history, eqns), (dtyps, cases)));
@@ -167,7 +592,8 @@
   let
     fun merge_eqns ((_, history1), (_, history2)) =
       let
-        val raw_history = AList.merge (op =) (K true) (history1, history2)
+        val raw_history = AList.merge (op = : serial * serial -> bool)
+          (K true) (history1, history2)
         val filtered_history = filter_out (fst o snd) raw_history
         val history = if null filtered_history
           then raw_history else filtered_history;
@@ -179,57 +605,16 @@
   in mk_spec ((false, eqns), (dtyps, cases)) end;
 
 
-(* pre- and postprocessor *)
-
-datatype thmproc = Thmproc of {
-  pre: simpset,
-  post: simpset,
-  functrans: (string * (serial * (theory -> (thm * bool) list -> (thm * bool) list option))) list
-};
-
-fun mk_thmproc ((pre, post), functrans) =
-  Thmproc { pre = pre, post = post, functrans = functrans };
-fun map_thmproc f (Thmproc { pre, post, functrans }) =
-  mk_thmproc (f ((pre, post), functrans));
-fun merge_thmproc (Thmproc { pre = pre1, post = post1, functrans = functrans1 },
-  Thmproc { pre = pre2, post = post2, functrans = functrans2 }) =
-    let
-      val pre = Simplifier.merge_ss (pre1, pre2);
-      val post = Simplifier.merge_ss (post1, post2);
-      val functrans = AList.merge (op =) (eq_fst (op =)) (functrans1, functrans2);
-    in mk_thmproc ((pre, post), functrans) end;
-
-datatype exec = Exec of {
-  thmproc: thmproc,
-  spec: spec
-};
-
-
 (* code setup data *)
 
-fun mk_exec (thmproc, spec) =
-  Exec { thmproc = thmproc, spec = spec };
-fun map_exec f (Exec { thmproc = thmproc, spec = spec }) =
-  mk_exec (f (thmproc, spec));
-fun merge_exec (Exec { thmproc = thmproc1, spec = spec1 },
-  Exec { thmproc = thmproc2, spec = spec2 }) =
-  let
-    val thmproc = merge_thmproc (thmproc1, thmproc2);
-    val spec = merge_spec (spec1, spec2);
-  in mk_exec (thmproc, spec) end;
-val empty_exec = mk_exec (mk_thmproc ((Simplifier.empty_ss, Simplifier.empty_ss), []),
-  mk_spec ((false, Symtab.empty), (Symtab.empty, (Symtab.empty, Symtab.empty))));
-
-fun the_thmproc (Exec { thmproc = Thmproc x, ...}) = x;
-fun the_spec (Exec { spec = Spec x, ...}) = x;
+fun the_spec (Spec x) = x;
 val the_eqns = #eqns o the_spec;
 val the_dtyps = #dtyps o the_spec;
 val the_cases = #cases o the_spec;
-val map_thmproc = map_exec o apfst o map_thmproc;
-val map_concluded_history = map_exec o apsnd o map_spec o apfst o apfst;
-val map_eqns = map_exec o apsnd o map_spec o apfst o apsnd;
-val map_dtyps = map_exec o apsnd o map_spec o apsnd o apfst;
-val map_cases = map_exec o apsnd o map_spec o apsnd o apsnd;
+val map_concluded_history = map_spec o apfst o apfst;
+val map_eqns = map_spec o apfst o apsnd;
+val map_dtyps = map_spec o apsnd o apfst;
+val map_cases = map_spec o apsnd o apsnd;
 
 
 (* data slots dependent on executable content *)
@@ -277,17 +662,17 @@
 type data = Object.T Datatab.table;
 val empty_data = Datatab.empty : data;
 
-structure CodeData = TheoryDataFun
+structure Code_Data = TheoryDataFun
 (
-  type T = exec * data ref;
-  val empty = (empty_exec, ref empty_data);
-  fun copy (exec, data) = (exec, ref (! data));
+  type T = spec * data ref;
+  val empty = (empty_spec, ref empty_data);
+  fun copy (spec, data) = (spec, ref (! data));
   val extend = copy;
-  fun merge pp ((exec1, data1), (exec2, data2)) =
-    (merge_exec (exec1, exec2), ref empty_data);
+  fun merge pp ((spec1, data1), (spec2, data2)) =
+    (merge_spec (spec1, spec2), ref empty_data);
 );
 
-fun thy_data f thy = f ((snd o CodeData.get) thy);
+fun thy_data f thy = f ((snd o Code_Data.get) thy);
 
 fun get_ensure_init kind data_ref =
   case Datatab.lookup (! data_ref) kind
@@ -299,7 +684,7 @@
 
 (* access to executable content *)
 
-val the_exec = fst o CodeData.get;
+val the_exec = fst o Code_Data.get;
 
 fun complete_class_params thy cs =
   fold (fn c => case AxClass.inst_of_param thy c
@@ -307,11 +692,11 @@
     | SOME (c', _) => insert (op =) c' #> insert (op =) c) cs [];
 
 fun map_exec_purge touched f thy =
-  CodeData.map (fn (exec, data) => (f exec, ref (case touched
+  Code_Data.map (fn (exec, data) => (f exec, ref (case touched
    of SOME cs => invoke_purge_all thy (complete_class_params thy cs) (! data)
     | NONE => empty_data))) thy;
 
-val purge_data = (CodeData.map o apsnd) (K (ref empty_data));
+val purge_data = (Code_Data.map o apsnd) (K (ref empty_data));
 
 
 (* tackling equation history *)
@@ -323,21 +708,21 @@
 
 fun continue_history thy = if (#concluded_history o the_spec o the_exec) thy
   then thy
-    |> (CodeData.map o apfst o map_concluded_history) (K false)
+    |> (Code_Data.map o apfst o map_concluded_history) (K false)
     |> SOME
   else NONE;
 
 fun conclude_history thy = if (#concluded_history o the_spec o the_exec) thy
   then NONE
   else thy
-    |> (CodeData.map o apfst)
+    |> (Code_Data.map o apfst)
         ((map_eqns o Symtab.map) (fn ((changed, current), history) =>
           ((false, current),
             if changed then (serial (), current) :: history else history))
         #> map_concluded_history (K true))
     |> SOME;
 
-val _ = Context.>> (Context.map_theory (CodeData.init
+val _ = Context.>> (Context.map_theory (Code_Data.init
   #> Theory.at_begin continue_history
   #> Theory.at_end conclude_history));
 
@@ -366,9 +751,6 @@
 
 end; (*local*)
 
-
-(* print executable content *)
-
 fun print_codesetup thy =
   let
     val ctxt = ProofContext.init thy;
@@ -383,19 +765,16 @@
           (Pretty.block o Pretty.breaks) (
             Pretty.str s
             :: Pretty.str "="
-            :: separate (Pretty.str "|") (map (fn (c, []) => Pretty.str (Code_Unit.string_of_const thy c)
+            :: separate (Pretty.str "|") (map (fn (c, []) => Pretty.str (string_of_const thy c)
                  | (c, tys) =>
                      (Pretty.block o Pretty.breaks)
-                        (Pretty.str (Code_Unit.string_of_const thy c)
+                        (Pretty.str (string_of_const thy c)
                           :: Pretty.str "of"
                           :: map (Pretty.quote o Syntax.pretty_typ_global thy) tys)) cos)
           );
-    val pre = (#pre o the_thmproc) exec;
-    val post = (#post o the_thmproc) exec;
-    val functrans = (map fst o #functrans o the_thmproc) exec;
     val eqns = the_eqns exec
       |> Symtab.dest
-      |> (map o apfst) (Code_Unit.string_of_const thy)
+      |> (map o apfst) (string_of_const thy)
       |> (map o apsnd) (snd o fst)
       |> sort (string_ord o pairself fst);
     val dtyps = the_dtyps exec
@@ -410,21 +789,6 @@
         :: Pretty.fbrk
         :: (Pretty.fbreaks o map pretty_eqn) eqns
       ),
-      Pretty.block [
-        Pretty.str "preprocessing simpset:",
-        Pretty.fbrk,
-        Simplifier.pretty_ss ctxt pre
-      ],
-      Pretty.block [
-        Pretty.str "postprocessing simpset:",
-        Pretty.fbrk,
-        Simplifier.pretty_ss ctxt post
-      ],
-      Pretty.block (
-        Pretty.str "function transformers:"
-        :: Pretty.fbrk
-        :: (Pretty.fbreaks o map Pretty.str) functrans
-      ),
       Pretty.block (
         Pretty.str "datatypes:"
         :: Pretty.fbrk
@@ -446,68 +810,21 @@
             val max' = Thm.maxidx_of thm' + 1;
           in (thm', max') end;
         val (thms', maxidx) = fold_map incr_thm thms 0;
-        val ty1 :: tys = map (snd o Code_Unit.const_typ_eqn) thms';
+        val ty1 :: tys = map (snd o const_typ_eqn) thms';
         fun unify ty env = Sign.typ_unify thy (ty1, ty) env
           handle Type.TUNIFY =>
             error ("Type unificaton failed, while unifying code equations\n"
             ^ (cat_lines o map Display.string_of_thm) thms
             ^ "\nwith types\n"
-            ^ (cat_lines o map (Code_Unit.string_of_typ thy)) (ty1 :: tys));
+            ^ (cat_lines o map (string_of_typ thy)) (ty1 :: tys));
         val (env, _) = fold unify tys (Vartab.empty, maxidx)
         val instT = Vartab.fold (fn (x_i, (sort, ty)) =>
           cons (Thm.ctyp_of thy (TVar (x_i, sort)), Thm.ctyp_of thy ty)) env [];
       in map (Thm.instantiate (instT, [])) thms' end;
 
-fun check_linear (eqn as (thm, linear)) =
-  if linear then eqn else Code_Unit.bad_thm
-    ("Duplicate variables on left hand side of code equation:\n"
-      ^ Display.string_of_thm thm);
-
-fun mk_eqn thy linear =
-  Code_Unit.error_thm ((if linear then check_linear else I) o Code_Unit.mk_eqn thy);
-fun mk_syntactic_eqn thy = Code_Unit.warning_thm (Code_Unit.mk_eqn thy);
-fun mk_default_eqn thy = Code_Unit.try_thm (check_linear o Code_Unit.mk_eqn thy);
-
-
-(** operational sort algebra and class discipline **)
-
-local
-
-fun arity_constraints thy algebra (class, tyco) =
-  let
-    val base_constraints = Sorts.mg_domain algebra tyco [class];
-    val classparam_constraints = Sorts.complete_sort algebra [class]
-      |> maps (map fst o these o try (#params o AxClass.get_info thy))
-      |> map_filter (fn c => try (AxClass.param_of_inst thy) (c, tyco))
-      |> maps (map fst o get_eqns thy)
-      |> map (map (snd o dest_TVar) o Sign.const_typargs thy o Code_Unit.const_typ_eqn);
-    val inter_sorts = map2 (curry (Sorts.inter_sort algebra));
-  in fold inter_sorts classparam_constraints base_constraints end;
-
-fun retrieve_algebra thy operational =
-  Sorts.subalgebra (Syntax.pp_global thy) operational
-    (SOME o arity_constraints thy (Sign.classes_of thy))
-    (Sign.classes_of thy);
-
-in
-
-fun coregular_algebra thy = retrieve_algebra thy (K true) |> snd;
-fun operational_algebra thy =
-  let
-    fun add_iff_operational class =
-      can (AxClass.get_info thy) class ? cons class;
-    val operational_classes = fold add_iff_operational (Sign.all_classes thy) []
-  in retrieve_algebra thy (member (op =) operational_classes) end;
-
-end; (*local*)
-
 
 (** interfaces and attributes **)
 
-fun delete_force msg key xs =
-  if AList.defined (op =) xs key then AList.delete (op =) key xs
-  else error ("No such " ^ msg ^ ": " ^ quote key);
-
 fun get_datatype thy tyco =
   case these (Symtab.lookup ((the_dtyps o the_exec) thy) tyco)
    of (_, spec) :: _ => spec
@@ -522,51 +839,47 @@
        then SOME tyco else NONE
     | _ => NONE;
 
-fun recheck_eqn thy = Code_Unit.error_thm
-  (Code_Unit.assert_linear (is_some o get_datatype_of_constr thy) o apfst (Code_Unit.assert_eqn thy));
+fun is_constr thy = is_some o get_datatype_of_constr thy;
 
-fun recheck_eqns_const thy c eqns =
+val assert_eqn = fn thy => assert_eqn thy (is_constr thy);
+
+fun assert_eqns_const thy c eqns =
   let
-    fun cert (eqn as (thm, _)) = if c = Code_Unit.const_eqn thm
+    fun cert (eqn as (thm, _)) = if c = const_eqn thy thm
       then eqn else error ("Wrong head of code equation,\nexpected constant "
-        ^ Code_Unit.string_of_const thy c ^ "\n" ^ Display.string_of_thm thm)
-  in map (cert o recheck_eqn thy) eqns end;
+        ^ string_of_const thy c ^ "\n" ^ Display.string_of_thm thm)
+  in map (cert o assert_eqn thy) eqns end;
 
 fun change_eqns delete c f = (map_exec_purge (SOME [c]) o map_eqns
   o (if delete then Symtab.map_entry c else Symtab.map_default (c, ((false, (true, Lazy.value [])), [])))
     o apfst) (fn (_, eqns) => (true, f eqns));
 
-fun gen_add_eqn linear default thm thy =
-  case (if default then mk_default_eqn thy else SOME o mk_eqn thy linear) thm
-   of SOME (thm, _) =>
-        let
-          val c = Code_Unit.const_eqn thm;
-          val _ = if not default andalso (is_some o AxClass.class_of_param thy) c
-            then error ("Rejected polymorphic code equation for overloaded constant:\n"
-              ^ Display.string_of_thm thm)
-            else ();
-          val _ = if not default andalso (is_some o get_datatype_of_constr thy) c
-            then error ("Rejected code equation for datatype constructor:\n"
-              ^ Display.string_of_thm thm)
-            else ();
-        in change_eqns false c (add_thm thy default (thm, linear)) thy end
+fun gen_add_eqn default (eqn as (thm, _)) thy =
+  let val c = const_eqn thy thm
+  in change_eqns false c (add_thm thy default eqn) thy end;
+
+fun add_eqn thm thy =
+  gen_add_eqn false (mk_eqn thy (is_constr thy) (thm, true)) thy;
+
+fun add_default_eqn thm thy =
+  case mk_eqn_liberal thy (is_constr thy) thm
+   of SOME eqn => gen_add_eqn true eqn thy
     | NONE => thy;
 
-val add_eqn = gen_add_eqn true false;
-val add_default_eqn = gen_add_eqn true true;
-val add_nonlinear_eqn = gen_add_eqn false false;
+fun add_nbe_eqn thm thy =
+  gen_add_eqn false (mk_eqn thy (is_constr thy) (thm, false)) thy;
 
 fun add_eqnl (c, lthms) thy =
   let
-    val lthms' = certificate thy (fn thy => recheck_eqns_const thy c) lthms;
+    val lthms' = certificate thy (fn thy => assert_eqns_const thy c) lthms;
   in change_eqns false c (add_lthms lthms') thy end;
 
 val add_default_eqn_attribute = Thm.declaration_attribute
   (fn thm => Context.mapping (add_default_eqn thm) I);
 val add_default_eqn_attrib = Attrib.internal (K add_default_eqn_attribute);
 
-fun del_eqn thm thy = case mk_syntactic_eqn thy thm
- of SOME (thm, _) => change_eqns true (Code_Unit.const_eqn thm) (del_thm thm) thy
+fun del_eqn thm thy = case mk_eqn_liberal thy (is_constr thy) thm
+ of SOME (thm, _) => change_eqns true (const_eqn thy thm) (del_thm thm) thy
   | NONE => thy;
 
 fun del_eqns c = change_eqns true c (K (false, Lazy.value []));
@@ -580,7 +893,7 @@
 fun add_datatype raw_cs thy =
   let
     val cs = map (fn c_ty as (_, ty) => (AxClass.unoverload_const thy c_ty, ty)) raw_cs;
-    val (tyco, vs_cos) = Code_Unit.constrset_of_consts thy cs;
+    val (tyco, vs_cos) = constrset_of_consts thy cs;
     val old_cs = (map fst o snd o get_datatype thy) tyco;
     fun drop_outdated_cases cases = fold Symtab.delete_safe
       (Symtab.fold (fn (c, (_, (_, cos))) =>
@@ -588,9 +901,9 @@
           then insert (op =) c else I) cases []) cases;
   in
     thy
+    |> fold (del_eqns o fst) cs
     |> map_exec_purge NONE
         ((map_dtyps o Symtab.map_default (tyco, [])) (cons (serial (), vs_cos))
-        #> map_eqns (fold (Symtab.delete_safe o fst) cs)
         #> (map_cases o apfst) drop_outdated_cases)
     |> TypeInterpretation.data (tyco, serial ())
   end;
@@ -600,13 +913,13 @@
 
 fun add_datatype_cmd raw_cs thy =
   let
-    val cs = map (Code_Unit.read_bare_const thy) raw_cs;
+    val cs = map (read_bare_const thy) raw_cs;
   in add_datatype cs thy end;
 
 fun add_case thm thy =
   let
-    val (c, (k, case_pats)) = Code_Unit.case_cert thm;
-    val _ = case filter (is_none o get_datatype_of_constr thy) case_pats
+    val (c, (k, case_pats)) = case_cert thm;
+    val _ = case filter_out (is_constr thy) case_pats
      of [] => ()
       | cs => error ("Non-constructor(s) in case certificate: " ^ commas (map quote cs));
     val entry = (1 + Int.max (1, length case_pats), (k, case_pats))
@@ -615,22 +928,6 @@
 fun add_undefined c thy =
   (map_exec_purge (SOME [c]) o map_cases o apsnd) (Symtab.update (c, ())) thy;
 
-val map_pre = map_exec_purge NONE o map_thmproc o apfst o apfst;
-val map_post = map_exec_purge NONE o map_thmproc o apfst o apsnd;
-
-val add_inline = map_pre o MetaSimplifier.add_simp;
-val del_inline = map_pre o MetaSimplifier.del_simp;
-val add_post = map_post o MetaSimplifier.add_simp;
-val del_post = map_post o MetaSimplifier.del_simp;
-  
-fun add_functrans (name, f) =
-  (map_exec_purge NONE o map_thmproc o apsnd)
-    (AList.update (op =) (name, (serial (), f)));
-
-fun del_functrans name =
-  (map_exec_purge NONE o map_thmproc o apsnd)
-    (delete_force "function transformer" name);
-
 val _ = Context.>> (Context.map_theory
   (let
     fun mk_attribute f = Thm.declaration_attribute (fn thm => Context.mapping (f thm) I);
@@ -642,100 +939,27 @@
   in
     TypeInterpretation.init
     #> add_del_attribute ("", (add_eqn, del_eqn))
-    #> add_simple_attribute ("nbe", add_nonlinear_eqn)
-    #> add_del_attribute ("inline", (add_inline, del_inline))
-    #> add_del_attribute ("post", (add_post, del_post))
+    #> add_simple_attribute ("nbe", add_nbe_eqn)
   end));
 
-
-(** post- and preprocessing **)
-
-local
-
-fun apply_functrans thy c _ [] = []
-  | apply_functrans thy c [] eqns = eqns
-  | apply_functrans thy c functrans eqns = eqns
-      |> perhaps (perhaps_loop (perhaps_apply functrans))
-      |> (map o apfst) (AxClass.unoverload thy)
-      |> recheck_eqns_const thy c
-      |> (map o apfst) (AxClass.overload thy);
-
-fun rhs_conv conv thm = Thm.transitive thm ((conv o Thm.rhs_of) thm);
-
-fun term_of_conv thy f =
-  Thm.cterm_of thy
-  #> f
-  #> Thm.prop_of
-  #> Logic.dest_equals
-  #> snd;
-
-fun preprocess thy functrans c eqns =
-  let
-    val pre = (Simplifier.theory_context thy o #pre o the_thmproc o the_exec) thy;
-  in
-    eqns
-    |> (map o apfst) (AxClass.overload thy)
-    |> apply_functrans thy c functrans
-    |> (map o apfst) (Code_Unit.rewrite_eqn pre)
-    |> (map o apfst) (AxClass.unoverload thy)
-    |> map (recheck_eqn thy)
-    |> burrow_fst (common_typ_eqns thy)
-  end;
-
-in
-
-fun preprocess_conv thy ct =
-  let
-    val pre = (Simplifier.theory_context thy o #pre o the_thmproc o the_exec) thy;
-  in
-    ct
-    |> Simplifier.rewrite pre
-    |> rhs_conv (AxClass.unoverload_conv thy)
-  end;
-
-fun preprocess_term thy = term_of_conv thy (preprocess_conv thy);
-
-fun postprocess_conv thy ct =
-  let
-    val post = (Simplifier.theory_context thy o #post o the_thmproc o the_exec) thy;
-  in
-    ct
-    |> AxClass.overload_conv thy
-    |> rhs_conv (Simplifier.rewrite post)
-  end;
-
-fun postprocess_term thy = term_of_conv thy (postprocess_conv thy);
-
-fun these_raw_eqns thy c =
+fun these_eqns thy c =
   get_eqns thy c
   |> (map o apfst) (Thm.transfer thy)
   |> burrow_fst (common_typ_eqns thy);
 
-fun these_eqns thy c =
-  let
-    val functrans = (map (fn (_, (_, f)) => f thy) o #functrans
-      o the_thmproc o the_exec) thy;
-  in
-    get_eqns thy c
-    |> (map o apfst) (Thm.transfer thy)
-    |> preprocess thy functrans c
-  end;
-
 fun default_typscheme thy c =
   let
-    fun the_const_typscheme c = (curry (Code_Unit.typscheme thy) c o snd o dest_Const
+    fun the_const_typscheme c = (curry (typscheme thy) c o snd o dest_Const
       o TermSubst.zero_var_indexes o curry Const "" o Sign.the_const_type thy) c;
     fun strip_sorts (vs, ty) = (map (fn (v, _) => (v, [])) vs, ty);
   in case AxClass.class_of_param thy c
    of SOME class => ([(Name.aT, [class])], snd (the_const_typscheme c))
-    | NONE => if is_some (get_datatype_of_constr thy c)
+    | NONE => if is_constr thy c
         then strip_sorts (the_const_typscheme c)
         else case get_eqns thy c
-         of (thm, _) :: _ => snd (Code_Unit.head_eqn thy (Drule.zero_var_indexes thm))
+         of (thm, _) :: _ => (typscheme_eqn thy o Drule.zero_var_indexes) thm
           | [] => strip_sorts (the_const_typscheme c) end;
 
-end; (*local*)
-
 end; (*struct*)
 
 

--- a/src/Pure/Isar/code_unit.ML	Fri May 15 15:29:34 2009 +0200
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,446 +0,0 @@
-(*  Title:      Pure/Isar/code_unit.ML
-    Author:     Florian Haftmann, TU Muenchen
-
-Basic notions of code generation.  Auxiliary.
-*)
-
-signature CODE_UNIT =
-sig
-  (*generic non-sense*)
-  val bad_thm: string -> 'a
-  val error_thm: ('a -> 'b) -> 'a -> 'b
-  val warning_thm: ('a -> 'b) -> 'a -> 'b option
-  val try_thm: ('a -> 'b) -> 'a -> 'b option
-
-  (*typ instantiations*)
-  val typscheme: theory -> string * typ -> (string * sort) list * typ
-  val inst_thm: theory -> sort Vartab.table -> thm -> thm
-  val constrain_thm: theory -> sort -> thm -> thm
-
-  (*constant aliasses*)
-  val add_const_alias: thm -> theory -> theory
-  val triv_classes: theory -> class list
-  val resubst_alias: theory -> string -> string
-
-  (*constants*)
-  val string_of_typ: theory -> typ -> string
-  val string_of_const: theory -> string -> string
-  val no_args: theory -> string -> int
-  val check_const: theory -> term -> string
-  val read_bare_const: theory -> string -> string * typ
-  val read_const: theory -> string -> string
-
-  (*constructor sets*)
-  val constrset_of_consts: theory -> (string * typ) list
-    -> string * ((string * sort) list * (string * typ list) list)
-
-  (*code equations*)
-  val assert_eqn: theory -> thm -> thm
-  val mk_eqn: theory -> thm -> thm * bool
-  val assert_linear: (string -> bool) -> thm * bool -> thm * bool
-  val const_eqn: thm -> string
-  val const_typ_eqn: thm -> string * typ
-  val head_eqn: theory -> thm -> string * ((string * sort) list * typ)
-  val expand_eta: theory -> int -> thm -> thm
-  val rewrite_eqn: simpset -> thm -> thm
-  val rewrite_head: thm list -> thm -> thm
-  val norm_args: theory -> thm list -> thm list 
-  val norm_varnames: theory -> (string -> string) -> (string -> string) -> thm list -> thm list
-
-  (*case certificates*)
-  val case_cert: thm -> string * (int * string list)
-end;
-
-structure Code_Unit: CODE_UNIT =
-struct
-
-
-(* auxiliary *)
-
-exception BAD_THM of string;
-fun bad_thm msg = raise BAD_THM msg;
-fun error_thm f thm = f thm handle BAD_THM msg => error msg;
-fun warning_thm f thm = SOME (f thm) handle BAD_THM msg
-  => (warning ("code generator: " ^ msg); NONE);
-fun try_thm f thm = SOME (f thm) handle BAD_THM _ => NONE;
-
-fun string_of_typ thy = setmp show_sorts true (Syntax.string_of_typ_global thy);
-fun string_of_const thy c = case AxClass.inst_of_param thy c
- of SOME (c, tyco) => Sign.extern_const thy c ^ " " ^ enclose "[" "]" (Sign.extern_type thy tyco)
-  | NONE => Sign.extern_const thy c;
-
-fun no_args thy = length o fst o strip_type o Sign.the_const_type thy;
-
-
-(* utilities *)
-
-fun typscheme thy (c, ty) =
-  let
-    val ty' = Logic.unvarifyT ty;
-    fun dest (TFree (v, sort)) = (v, sort)
-      | dest ty = error ("Illegal type parameter in type scheme: " ^ Syntax.string_of_typ_global thy ty);
-    val vs = map dest (Sign.const_typargs thy (c, ty'));
-  in (vs, Type.strip_sorts ty') end;
-
-fun inst_thm thy tvars' thm =
-  let
-    val tvars = (Term.add_tvars o Thm.prop_of) thm [];
-    val inter_sort = Sorts.inter_sort (Sign.classes_of thy);
-    fun mk_inst (tvar as (v, sort)) = case Vartab.lookup tvars' v
-     of SOME sort' => SOME (pairself (Thm.ctyp_of thy o TVar)
-          (tvar, (v, inter_sort (sort, sort'))))
-      | NONE => NONE;
-    val insts = map_filter mk_inst tvars;
-  in Thm.instantiate (insts, []) thm end;
-
-fun constrain_thm thy sort thm =
-  let
-    val constrain = curry (Sorts.inter_sort (Sign.classes_of thy)) sort
-    val tvars = (Term.add_tvars o Thm.prop_of) thm [];
-    fun mk_inst (tvar as (v, sort)) = pairself (Thm.ctyp_of thy o TVar o pair v)
-      (sort, constrain sort)
-    val insts = map mk_inst tvars;
-  in Thm.instantiate (insts, []) thm end;
-
-fun expand_eta thy k thm =
-  let
-    val (lhs, rhs) = (Logic.dest_equals o Thm.plain_prop_of) thm;
-    val (head, args) = strip_comb lhs;
-    val l = if k = ~1
-      then (length o fst o strip_abs) rhs
-      else Int.max (0, k - length args);
-    val used = Name.make_context (map (fst o fst) (Term.add_vars lhs []));
-    fun get_name _ 0 = pair []
-      | get_name (Abs (v, ty, t)) k =
-          Name.variants [v]
-          ##>> get_name t (k - 1)
-          #>> (fn ([v'], vs') => (v', ty) :: vs')
-      | get_name t k = 
-          let
-            val (tys, _) = (strip_type o fastype_of) t
-          in case tys
-           of [] => raise TERM ("expand_eta", [t])
-            | ty :: _ =>
-                Name.variants [""]
-                #-> (fn [v] => get_name (t $ Var ((v, 0), ty)) (k - 1)
-                #>> (fn vs' => (v, ty) :: vs'))
-          end;
-    val (vs, _) = get_name rhs l used;
-    fun expand (v, ty) thm = Drule.fun_cong_rule thm
-      (Thm.cterm_of thy (Var ((v, 0), ty)));
-  in
-    thm
-    |> fold expand vs
-    |> Conv.fconv_rule Drule.beta_eta_conversion
-  end;
-
-fun eqn_conv conv =
-  let
-    fun lhs_conv ct = if can Thm.dest_comb ct
-      then (Conv.combination_conv lhs_conv conv) ct
-      else Conv.all_conv ct;
-  in Conv.combination_conv (Conv.arg_conv lhs_conv) conv end;
-
-fun head_conv conv =
-  let
-    fun lhs_conv ct = if can Thm.dest_comb ct
-      then (Conv.fun_conv lhs_conv) ct
-      else conv ct;
-  in Conv.fun_conv (Conv.arg_conv lhs_conv) end;
-
-val rewrite_eqn = Conv.fconv_rule o eqn_conv o Simplifier.rewrite;
-val rewrite_head = Conv.fconv_rule o head_conv o MetaSimplifier.rewrite false;
-
-fun norm_args thy thms =
-  let
-    val num_args_of = length o snd o strip_comb o fst o Logic.dest_equals;
-    val k = fold (curry Int.max o num_args_of o Thm.prop_of) thms 0;
-  in
-    thms
-    |> map (expand_eta thy k)
-    |> map (Conv.fconv_rule Drule.beta_eta_conversion)
-  end;
-
-fun canonical_tvars thy purify_tvar thm =
-  let
-    val ctyp = Thm.ctyp_of thy;
-    fun tvars_subst_for thm = (fold_types o fold_atyps)
-      (fn TVar (v_i as (v, _), sort) => let
-            val v' = purify_tvar v
-          in if v = v' then I
-          else insert (op =) (v_i, (v', sort)) end
-        | _ => I) (prop_of thm) [];
-    fun mk_inst (v_i, (v', sort)) (maxidx, acc) =
-      let
-        val ty = TVar (v_i, sort)
-      in
-        (maxidx + 1, (ctyp ty, ctyp (TVar ((v', maxidx), sort))) :: acc)
-      end;
-    val maxidx = Thm.maxidx_of thm + 1;
-    val (_, inst) = fold mk_inst (tvars_subst_for thm) (maxidx + 1, []);
-  in Thm.instantiate (inst, []) thm end;
-
-fun canonical_vars thy purify_var thm =
-  let
-    val cterm = Thm.cterm_of thy;
-    fun vars_subst_for thm = fold_aterms
-      (fn Var (v_i as (v, _), ty) => let
-            val v' = purify_var v
-          in if v = v' then I
-          else insert (op =) (v_i, (v', ty)) end
-        | _ => I) (prop_of thm) [];
-    fun mk_inst (v_i as (v, i), (v', ty)) (maxidx, acc) =
-      let
-        val t = Var (v_i, ty)
-      in
-        (maxidx + 1, (cterm t, cterm (Var ((v', maxidx), ty))) :: acc)
-      end;
-    val maxidx = Thm.maxidx_of thm + 1;
-    val (_, inst) = fold mk_inst (vars_subst_for thm) (maxidx + 1, []);
-  in Thm.instantiate ([], inst) thm end;
-
-fun canonical_absvars purify_var thm =
-  let
-    val t = Thm.plain_prop_of thm;
-    val t' = Term.map_abs_vars purify_var t;
-  in Thm.rename_boundvars t t' thm end;
-
-fun norm_varnames thy purify_tvar purify_var thms =
-  let
-    fun burrow_thms f [] = []
-      | burrow_thms f thms =
-          thms
-          |> Conjunction.intr_balanced
-          |> f
-          |> Conjunction.elim_balanced (length thms)
-  in
-    thms
-    |> map (canonical_vars thy purify_var)
-    |> map (canonical_absvars purify_var)
-    |> map Drule.zero_var_indexes
-    |> burrow_thms (canonical_tvars thy purify_tvar)
-    |> Drule.zero_var_indexes_list
-  end;
-
-
-(* const aliasses *)
-
-structure ConstAlias = TheoryDataFun
-(
-  type T = ((string * string) * thm) list * class list;
-  val empty = ([], []);
-  val copy = I;
-  val extend = I;
-  fun merge _ ((alias1, classes1), (alias2, classes2)) : T =
-    (Library.merge (eq_snd Thm.eq_thm_prop) (alias1, alias2),
-      Library.merge (op =) (classes1, classes2));
-);
-
-fun add_const_alias thm thy =
-  let
-    val lhs_rhs = case try Logic.dest_equals (Thm.prop_of thm)
-     of SOME lhs_rhs => lhs_rhs
-      | _ => error ("Not an equation: " ^ Display.string_of_thm thm);
-    val c_c' = case try (pairself (AxClass.unoverload_const thy o dest_Const)) lhs_rhs
-     of SOME c_c' => c_c'
-      | _ => error ("Not an equation with two constants: " ^ Display.string_of_thm thm);
-    val some_class = the_list (AxClass.class_of_param thy (snd c_c'));
-  in thy |>
-    ConstAlias.map (fn (alias, classes) =>
-      ((c_c', thm) :: alias, fold (insert (op =)) some_class classes))
-  end;
-
-fun resubst_alias thy =
-  let
-    val alias = fst (ConstAlias.get thy);
-    val subst_inst_param = Option.map fst o AxClass.inst_of_param thy;
-    fun subst_alias c =
-      get_first (fn ((c', c''), _) => if c = c'' then SOME c' else NONE) alias;
-  in
-    perhaps subst_inst_param
-    #> perhaps subst_alias
-  end;
-
-val triv_classes = snd o ConstAlias.get;
-
-
-(* reading constants as terms *)
-
-fun check_bare_const thy t = case try dest_Const t
- of SOME c_ty => c_ty
-  | NONE => error ("Not a constant: " ^ Syntax.string_of_term_global thy t);
-
-fun check_const thy = AxClass.unoverload_const thy o check_bare_const thy;
-
-fun read_bare_const thy = check_bare_const thy o Syntax.read_term_global thy;
-
-fun read_const thy = AxClass.unoverload_const thy o read_bare_const thy;
-
-
-(* constructor sets *)
-
-fun constrset_of_consts thy cs =
-  let
-    val _ = map (fn (c, _) => if (is_some o AxClass.class_of_param thy) c
-      then error ("Is a class parameter: " ^ string_of_const thy c) else ()) cs;
-    fun no_constr (c, ty) = error ("Not a datatype constructor: " ^ string_of_const thy c
-      ^ " :: " ^ string_of_typ thy ty);
-    fun last_typ c_ty ty =
-      let
-        val frees = OldTerm.typ_tfrees ty;
-        val (tyco, vs) = ((apsnd o map) (dest_TFree) o dest_Type o snd o strip_type) ty
-          handle TYPE _ => no_constr c_ty
-        val _ = if has_duplicates (eq_fst (op =)) vs then no_constr c_ty else ();
-        val _ = if length frees <> length vs then no_constr c_ty else ();
-      in (tyco, vs) end;
-    fun ty_sorts (c, ty) =
-      let
-        val ty_decl = (Logic.unvarifyT o Sign.the_const_type thy) c;
-        val (tyco, _) = last_typ (c, ty) ty_decl;
-        val (_, vs) = last_typ (c, ty) ty;
-      in ((tyco, map snd vs), (c, (map fst vs, ty))) end;
-    fun add ((tyco', sorts'), c) ((tyco, sorts), cs) =
-      let
-        val _ = if tyco' <> tyco
-          then error "Different type constructors in constructor set"
-          else ();
-        val sorts'' = map2 (curry (Sorts.inter_sort (Sign.classes_of thy))) sorts' sorts
-      in ((tyco, sorts), c :: cs) end;
-    fun inst vs' (c, (vs, ty)) =
-      let
-        val the_v = the o AList.lookup (op =) (vs ~~ vs');
-        val ty' = map_atyps (fn TFree (v, _) => TFree (the_v v)) ty;
-      in (c, (fst o strip_type) ty') end;
-    val c' :: cs' = map ty_sorts cs;
-    val ((tyco, sorts), cs'') = fold add cs' (apsnd single c');
-    val vs = Name.names Name.context Name.aT sorts;
-    val cs''' = map (inst vs) cs'';
-  in (tyco, (vs, rev cs''')) end;
-
-
-(* code equations *)
-
-fun assert_eqn thy thm =
-  let
-    val (lhs, rhs) = (Logic.dest_equals o Thm.plain_prop_of) thm
-      handle TERM _ => bad_thm ("Not an equation: " ^ Display.string_of_thm thm)
-          | THM _ => bad_thm ("Not an equation: " ^ Display.string_of_thm thm);
-    fun vars_of t = fold_aterms (fn Var (v, _) => insert (op =) v
-      | Free _ => bad_thm ("Illegal free variable in rewrite theorem\n"
-          ^ Display.string_of_thm thm)
-      | _ => I) t [];
-    fun tvars_of t = fold_term_types (fn _ =>
-      fold_atyps (fn TVar (v, _) => insert (op =) v
-        | TFree _ => bad_thm 
-      ("Illegal free type variable in rewrite theorem\n" ^ Display.string_of_thm thm))) t [];
-    val lhs_vs = vars_of lhs;
-    val rhs_vs = vars_of rhs;
-    val lhs_tvs = tvars_of lhs;
-    val rhs_tvs = tvars_of rhs;
-    val _ = if null (subtract (op =) lhs_vs rhs_vs)
-      then ()
-      else bad_thm ("Free variables on right hand side of rewrite theorem\n"
-        ^ Display.string_of_thm thm);
-    val _ = if null (subtract (op =) lhs_tvs rhs_tvs)
-      then ()
-      else bad_thm ("Free type variables on right hand side of rewrite theorem\n"
-        ^ Display.string_of_thm thm)    val (head, args) = (strip_comb o fst o Logic.dest_equals o Thm.plain_prop_of) thm;
-    val (c, ty) = case head of Const c_ty => c_ty | _ =>
-      bad_thm ("Equation not headed by constant\n" ^ Display.string_of_thm thm);
-    fun check _ (Abs _) = bad_thm
-          ("Abstraction on left hand side of equation\n"
-            ^ Display.string_of_thm thm)
-      | check 0 (Var _) = ()
-      | check _ (Var _) = bad_thm
-          ("Variable with application on left hand side of code equation\n"
-            ^ Display.string_of_thm thm)
-      | check n (t1 $ t2) = (check (n+1) t1; check 0 t2)
-      | check n (Const (_, ty)) = if n <> (length o fst o strip_type) ty
-          then bad_thm
-            ("Partially applied constant on left hand side of equation\n"
-               ^ Display.string_of_thm thm)
-          else ();
-    val _ = map (check 0) args;
-    val ty_decl = Sign.the_const_type thy c;
-    val _ = if Sign.typ_equiv thy (Type.strip_sorts ty_decl, Type.strip_sorts ty)
-      then () else bad_thm ("Type\n" ^ string_of_typ thy ty
-           ^ "\nof code equation\n"
-           ^ Display.string_of_thm thm
-           ^ "\nis incompatible with declared function type\n"
-           ^ string_of_typ thy ty_decl)
-  in thm end;
-
-fun add_linear thm =
-  let
-    val (_, args) = (strip_comb o fst o Logic.dest_equals o Thm.plain_prop_of) thm;
-    val linear = not (has_duplicates (op =)
-      ((fold o fold_aterms) (fn Var (v, _) => cons v | _ => I) args []))
-  in (thm, linear) end;
-
-fun assert_pat is_cons thm =
-  let
-    val args = (snd o strip_comb o fst o Logic.dest_equals o Thm.plain_prop_of) thm;
-    val _ = (map o map_aterms) (fn t as Const (c, _) => if is_cons c then t
-          else bad_thm ("Not a constructor on left hand side of equation: "
-            ^ quote c ^ ",\n in equation\n" ^ Display.string_of_thm thm)
-      | t => t) args;
-  in thm end;
-
-fun assert_linear is_cons (thm, false) = (thm, false)
-  | assert_linear is_cons (thm, true) = if snd (add_linear (assert_pat is_cons thm)) then (thm, true)
-      else bad_thm
-        ("Duplicate variables on left hand side of code equation:\n"
-          ^ Display.string_of_thm thm);
-
-
-fun mk_eqn thy = add_linear o assert_eqn thy o AxClass.unoverload thy
-  o LocalDefs.meta_rewrite_rule (ProofContext.init thy);
-
-val const_typ_eqn = dest_Const o fst o strip_comb o fst o Logic.dest_equals o Thm.plain_prop_of;
-val const_eqn = fst o const_typ_eqn;
-fun head_eqn thy thm = let val (c, ty) = const_typ_eqn thm in (c, typscheme thy (c, ty)) end;
-
-
-(* case cerificates *)
-
-fun case_certificate thm =
-  let
-    val ((head, raw_case_expr), cases) = (apfst Logic.dest_equals
-      o apsnd Logic.dest_conjunctions o Logic.dest_implies o Thm.prop_of) thm;
-    val _ = case head of Free _ => true
-      | Var _ => true
-      | _ => raise TERM ("case_cert", []);
-    val ([(case_var, _)], case_expr) = Term.strip_abs_eta 1 raw_case_expr;
-    val (Const (case_const, _), raw_params) = strip_comb case_expr;
-    val n = find_index (fn Free (v, _) => v = case_var | _ => false) raw_params;
-    val _ = if n = ~1 then raise TERM ("case_cert", []) else ();
-    val params = map (fst o dest_Var) (nth_drop n raw_params);
-    fun dest_case t =
-      let
-        val (head' $ t_co, rhs) = Logic.dest_equals t;
-        val _ = if head' = head then () else raise TERM ("case_cert", []);
-        val (Const (co, _), args) = strip_comb t_co;
-        val (Var (param, _), args') = strip_comb rhs;
-        val _ = if args' = args then () else raise TERM ("case_cert", []);
-      in (param, co) end;
-    fun analyze_cases cases =
-      let
-        val co_list = fold (AList.update (op =) o dest_case) cases [];
-      in map (the o AList.lookup (op =) co_list) params end;
-    fun analyze_let t =
-      let
-        val (head' $ arg, Var (param', _) $ arg') = Logic.dest_equals t;
-        val _ = if head' = head then () else raise TERM ("case_cert", []);
-        val _ = if arg' = arg then () else raise TERM ("case_cert", []);
-        val _ = if [param'] = params then () else raise TERM ("case_cert", []);
-      in [] end;
-    fun analyze (cases as [let_case]) =
-          (analyze_cases cases handle Bind => analyze_let let_case)
-      | analyze cases = analyze_cases cases;
-  in (case_const, (n, analyze cases)) end;
-
-fun case_cert thm = case_certificate thm
-  handle Bind => error "bad case certificate"
-       | TERM _ => error "bad case certificate";
-
-end;

--- a/src/Pure/Isar/isar_syn.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/Pure/Isar/isar_syn.ML	Fri May 15 15:56:28 2009 +0200
@@ -881,7 +881,7 @@
     (opt_modes -- P.typ >> (Toplevel.no_timing oo IsarCmd.print_type));
 
 val _ =
-  OuterSyntax.improper_command "print_codesetup" "print code generator setup of this theory" K.diag
+  OuterSyntax.improper_command "print_codesetup" "print code generator setup" K.diag
     (Scan.succeed
       (Toplevel.no_timing o Toplevel.unknown_theory o Toplevel.keep
         (Code.print_codesetup o Toplevel.theory_of)));

--- a/src/Pure/ProofGeneral/ROOT.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/Pure/ProofGeneral/ROOT.ML	Fri May 15 15:56:28 2009 +0200
@@ -14,11 +14,7 @@
 
 use "pgip_isabelle.ML";
 
-(use
-  |> setmp Proofterm.proofs 1
-  |> setmp quick_and_dirty true
-  |> setmp auto_quickcheck true
-  |> setmp auto_solve true) "preferences.ML";
+use "preferences.ML";
 
 use "pgip_parser.ML";
 

--- a/src/Pure/ProofGeneral/preferences.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/Pure/ProofGeneral/preferences.ML	Fri May 15 15:56:28 2009 +0200
@@ -6,6 +6,10 @@
 
 signature PREFERENCES =
 sig
+  val category_display: string
+  val category_advanced_display: string
+  val category_tracing: string
+  val category_proof: string
   type preference =
    {name: string,
     descr: string,
@@ -29,6 +33,14 @@
 structure Preferences: PREFERENCES =
 struct
 
+(* categories *)
+
+val category_display = "Display";
+val category_advanced_display = "Advanced Display";
+val category_tracing = "Tracing";
+val category_proof = "Proof"
+
+
 (* preferences and preference tables *)
 
 type preference =
@@ -66,11 +78,11 @@
 
 (* preferences of Pure *)
 
-val proof_pref =
+val proof_pref = setmp Proofterm.proofs 1 (fn () =>
   let
     fun get () = PgipTypes.bool_to_pgstring (! Proofterm.proofs >= 2);
     fun set s = Proofterm.proofs := (if PgipTypes.read_pgipbool s then 2 else 1);
-  in mkpref get set PgipTypes.Pgipbool "full-proofs" "Record full proof objects internally" end;
+  in mkpref get set PgipTypes.Pgipbool "full-proofs" "Record full proof objects internally" end) ();
 
 val thm_depsN = "thm_deps";
 val thm_deps_pref =
@@ -145,24 +157,13 @@
   bool_pref Toplevel.debug
     "debugging"
     "Whether to enable debugging.",
-  bool_pref Quickcheck.auto
-    "auto-quickcheck"
-    "Whether to enable quickcheck automatically.",
-  nat_pref Quickcheck.auto_time_limit
-    "auto-quickcheck-time-limit"
-    "Time limit for automatic quickcheck (in milliseconds).",
-  bool_pref AutoSolve.auto
-    "auto-solve"
-    "Try to solve newly declared lemmas with existing theorems.",
-  nat_pref AutoSolve.auto_time_limit
-    "auto-solve-time-limit"
-    "Time limit for seeking automatic solutions (in milliseconds).",
   thm_deps_pref];
 
 val proof_preferences =
- [bool_pref quick_and_dirty
-    "quick-and-dirty"
-    "Take a few short cuts",
+ [setmp quick_and_dirty true (fn () =>
+    bool_pref quick_and_dirty
+      "quick-and-dirty"
+      "Take a few short cuts") (),
   bool_pref Toplevel.skip_proofs
     "skip-proofs"
     "Skip over proofs (interactive-only)",
@@ -175,10 +176,10 @@
     "Check proofs in parallel"];
 
 val pure_preferences =
- [("Display", display_preferences),
-  ("Advanced Display", advanced_display_preferences),
-  ("Tracing", tracing_preferences),
-  ("Proof", proof_preferences)];
+ [(category_display, display_preferences),
+  (category_advanced_display, advanced_display_preferences),
+  (category_tracing, tracing_preferences),
+  (category_proof, proof_preferences)];
 
 
 (* table of categories and preferences; names must be unique *)
@@ -203,6 +204,6 @@
     else
       if exists (fn {name, ...} => name = #name pref) prefs
       then (warning ("Preference already exists: " ^ quote (#name pref)); (cat, prefs))
-      else (cat, pref :: prefs));
+      else (cat, prefs @ [pref]));
 
 end;

--- a/src/Pure/Tools/ROOT.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/Pure/Tools/ROOT.ML	Fri May 15 15:56:28 2009 +0200
@@ -1,16 +1,9 @@
-(*  Title:      Pure/Tools/ROOT.ML
-
-Miscellaneous tools and packages for Pure Isabelle.
-*)
+(* Miscellaneous tools and packages for Pure Isabelle *)
 
 use "named_thms.ML";
 
-(*basic XML support*)
 use "xml_syntax.ML";
 
 use "find_theorems.ML";
 use "find_consts.ML";
 
-(*quickcheck/autosolve needed here because of pg preferences*)
-use "../../Tools/quickcheck.ML";
-use "../../Tools/auto_solve.ML";

--- a/src/Pure/Tools/find_theorems.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/Pure/Tools/find_theorems.ML	Fri May 15 15:56:28 2009 +0200
@@ -7,7 +7,7 @@
 signature FIND_THEOREMS =
 sig
   datatype 'term criterion =
-    Name of string | Intro | Elim | Dest | Solves | Simp of 'term |
+    Name of string | Intro | IntroIff | Elim | Dest | Solves | Simp of 'term |
     Pattern of 'term
   val tac_limit: int ref
   val limit: int ref
@@ -24,11 +24,12 @@
 (** search criteria **)
 
 datatype 'term criterion =
-  Name of string | Intro | Elim | Dest | Solves | Simp of 'term |
+  Name of string | Intro | IntroIff | Elim | Dest | Solves | Simp of 'term |
   Pattern of 'term;
 
 fun read_criterion _ (Name name) = Name name
   | read_criterion _ Intro = Intro
+  | read_criterion _ IntroIff = IntroIff
   | read_criterion _ Elim = Elim
   | read_criterion _ Dest = Dest
   | read_criterion _ Solves = Solves
@@ -42,6 +43,7 @@
     (case c of
       Name name => Pretty.str (prfx "name: " ^ quote name)
     | Intro => Pretty.str (prfx "intro")
+    | IntroIff => Pretty.str (prfx "introiff")
     | Elim => Pretty.str (prfx "elim")
     | Dest => Pretty.str (prfx "dest")
     | Solves => Pretty.str (prfx "solves")
@@ -74,17 +76,40 @@
 
 fun is_nontrivial thy = Term.is_Const o Term.head_of o ObjectLogic.drop_judgment thy;
 
+(* Note: ("op =" : "bool --> bool --> bool") does not exist in Pure. *)
+fun is_Iff c =
+  (case dest_Const c of
+     ("op =", ty) =>
+       (ty
+        |> strip_type
+        |> swap
+        |> (op ::)
+        |> map (fst o dest_Type)
+        |> forall (curry (op =) "bool")
+        handle TYPE _ => false)
+   | _ => false);
+
 (*extract terms from term_src, refine them to the parts that concern us,
   if po try match them against obj else vice versa.
   trivial matches are ignored.
   returns: smallest substitution size*)
-fun is_matching_thm (extract_terms, refine_term) ctxt po obj term_src =
+fun is_matching_thm doiff (extract_terms, refine_term) ctxt po obj term_src =
   let
     val thy = ProofContext.theory_of ctxt;
 
+    val chkmatch = obj |> (if po then rpair else pair) #> Pattern.matches thy;
     fun matches pat =
-      is_nontrivial thy pat andalso
-      Pattern.matches thy (if po then (pat, obj) else (obj, pat));
+      let
+        val jpat = ObjectLogic.drop_judgment thy pat;
+        val c = Term.head_of jpat;
+        val pats =
+          if Term.is_Const c
+          then if doiff andalso is_Iff c
+               then pat :: map (ObjectLogic.ensure_propT thy) ((snd o strip_comb) jpat)
+                    |> filter (is_nontrivial thy)
+               else [pat]
+          else [];
+      in filter chkmatch pats end;
 
     fun substsize pat =
       let val (_, subst) =
@@ -96,7 +121,9 @@
 
     val match_thm = matches o refine_term;
   in
-    map (substsize o refine_term) (filter match_thm (extract_terms term_src))
+    map match_thm (extract_terms term_src)
+    |> flat
+    |> map substsize
     |> bestmatch
   end;
 
@@ -117,7 +144,7 @@
       hd o Logic.strip_imp_prems);
     val prems = Logic.prems_of_goal goal 1;
 
-    fun try_subst prem = is_matching_thm extract_dest ctxt true prem thm;
+    fun try_subst prem = is_matching_thm false extract_dest ctxt true prem thm;
     val successful = prems |> map_filter try_subst;
   in
     (*if possible, keep best substitution (one with smallest size)*)
@@ -127,11 +154,11 @@
     then SOME (Thm.nprems_of thm - 1, foldr1 Int.min successful) else NONE
   end;
 
-fun filter_intro ctxt goal (_, thm) =
+fun filter_intro doiff ctxt goal (_, thm) =
   let
     val extract_intro = (single o Thm.full_prop_of, Logic.strip_imp_concl);
     val concl = Logic.concl_of_goal goal 1;
-    val ss = is_matching_thm extract_intro ctxt true concl thm;
+    val ss = is_matching_thm doiff extract_intro ctxt true concl thm;
   in
     if is_some ss then SOME (Thm.nprems_of thm, the ss) else NONE
   end;
@@ -148,7 +175,7 @@
       val rule_tree = combine rule_mp rule_concl;
       fun goal_tree prem = combine prem goal_concl;
       fun try_subst prem =
-        is_matching_thm (single, I) ctxt true (goal_tree prem) rule_tree;
+        is_matching_thm false (single, I) ctxt true (goal_tree prem) rule_tree;
       val successful = prems |> map_filter try_subst;
     in
     (*elim rules always have assumptions, so an elim with one
@@ -183,7 +210,7 @@
     val mksimps = Simplifier.mksimps (Simplifier.local_simpset_of ctxt);
     val extract_simp =
       (map Thm.full_prop_of o mksimps, #1 o Logic.dest_equals o Logic.strip_imp_concl);
-    val ss = is_matching_thm extract_simp ctxt false t thm;
+    val ss = is_matching_thm false extract_simp ctxt false t thm;
   in
     if is_some ss then SOME (Thm.nprems_of thm, the ss) else NONE
   end;
@@ -233,7 +260,8 @@
   | filter_crit _ NONE Elim = err_no_goal "elim"
   | filter_crit _ NONE Dest = err_no_goal "dest"
   | filter_crit _ NONE Solves = err_no_goal "solves"
-  | filter_crit ctxt (SOME goal) Intro = apfst (filter_intro ctxt (fix_goal goal))
+  | filter_crit ctxt (SOME goal) Intro = apfst (filter_intro false ctxt (fix_goal goal))
+  | filter_crit ctxt (SOME goal) IntroIff = apfst (filter_intro true ctxt (fix_goal goal))
   | filter_crit ctxt (SOME goal) Elim = apfst (filter_elim ctxt (fix_goal goal))
   | filter_crit ctxt (SOME goal) Dest = apfst (filter_dest ctxt (fix_goal goal))
   | filter_crit ctxt (SOME goal) Solves = apfst (filter_solves ctxt goal)
@@ -428,6 +456,7 @@
 val criterion =
   P.reserved "name" |-- P.!!! (P.$$$ ":" |-- P.xname) >> Name ||
   P.reserved "intro" >> K Intro ||
+  P.reserved "introiff" >> K IntroIff ||
   P.reserved "elim" >> K Elim ||
   P.reserved "dest" >> K Dest ||
   P.reserved "solves" >> K Solves ||

--- a/src/Pure/axclass.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/Pure/axclass.ML	Fri May 15 15:56:28 2009 +0200
@@ -286,74 +286,6 @@
     handle TYPE (msg, _, _) => error msg;
 
 
-(* primitive rules *)
-
-fun add_classrel th thy =
-  let
-    fun err () = raise THM ("add_classrel: malformed class relation", 0, [th]);
-    val prop = Thm.plain_prop_of (Thm.transfer thy th);
-    val rel = Logic.dest_classrel prop handle TERM _ => err ();
-    val (c1, c2) = cert_classrel thy rel handle TYPE _ => err ();
-  in
-    thy
-    |> Sign.primitive_classrel (c1, c2)
-    |> put_classrel ((c1, c2), Thm.close_derivation (Drule.unconstrainTs th))
-    |> perhaps complete_arities
-  end;
-
-fun add_arity th thy =
-  let
-    fun err () = raise THM ("add_arity: malformed type arity", 0, [th]);
-    val prop = Thm.plain_prop_of (Thm.transfer thy th);
-    val (t, Ss, c) = Logic.dest_arity prop handle TERM _ => err ();
-    val _ = map (Sign.certify_sort thy) Ss = Ss orelse err ();
-    val _ = case filter_out (fn c => can (get_inst_param thy) (c, t)) (params_of thy c)
-     of [] => ()
-      | cs => Output.legacy_feature
-          ("Missing specifications for overloaded parameters " ^ commas_quote cs)
-    val th' = Drule.unconstrainTs th;
-  in
-    thy
-    |> Sign.primitive_arity (t, Ss, [c])
-    |> put_arity ((t, Ss, c), th')
-  end;
-
-
-(* tactical proofs *)
-
-fun prove_classrel raw_rel tac thy =
-  let
-    val ctxt = ProofContext.init thy;
-    val (c1, c2) = cert_classrel thy raw_rel;
-    val th = Goal.prove ctxt [] [] (Logic.mk_classrel (c1, c2)) (K tac) handle ERROR msg =>
-      cat_error msg ("The error(s) above occurred while trying to prove class relation " ^
-        quote (Syntax.string_of_classrel ctxt [c1, c2]));
-  in
-    thy
-    |> PureThy.add_thms [((Binding.name
-        (prefix classrel_prefix (Logic.name_classrel (c1, c2))), th), [])]
-    |-> (fn [th'] => add_classrel th')
-  end;
-
-fun prove_arity raw_arity tac thy =
-  let
-    val ctxt = ProofContext.init thy;
-    val arity = Sign.cert_arity thy raw_arity;
-    val names = map (prefix arity_prefix) (Logic.name_arities arity);
-    val props = Logic.mk_arities arity;
-    val ths = Goal.prove_multi ctxt [] [] props
-      (fn _ => Goal.precise_conjunction_tac (length props) 1 THEN tac) handle ERROR msg =>
-        cat_error msg ("The error(s) above occurred while trying to prove type arity " ^
-          quote (Syntax.string_of_arity ctxt arity));
-  in
-    thy
-    |> PureThy.add_thms (map (rpair []) (map Binding.name names ~~ ths))
-    |-> fold add_arity
-  end;
-
-
-(* instance parameters and overloaded definitions *)
-
 (* declaration and definition of instances of overloaded constants *)
 
 fun declare_overloaded (c, T) thy =
@@ -398,6 +330,74 @@
   end;
 
 
+(* primitive rules *)
+
+fun add_classrel th thy =
+  let
+    fun err () = raise THM ("add_classrel: malformed class relation", 0, [th]);
+    val prop = Thm.plain_prop_of (Thm.transfer thy th);
+    val rel = Logic.dest_classrel prop handle TERM _ => err ();
+    val (c1, c2) = cert_classrel thy rel handle TYPE _ => err ();
+  in
+    thy
+    |> Sign.primitive_classrel (c1, c2)
+    |> put_classrel ((c1, c2), Thm.close_derivation (Drule.unconstrainTs th))
+    |> perhaps complete_arities
+  end;
+
+fun add_arity th thy =
+  let
+    fun err () = raise THM ("add_arity: malformed type arity", 0, [th]);
+    val prop = Thm.plain_prop_of (Thm.transfer thy th);
+    val (t, Ss, c) = Logic.dest_arity prop handle TERM _ => err ();
+    val T = Type (t, map TFree (Name.names Name.context Name.aT Ss));
+    val missing_params = Sign.complete_sort thy [c]
+      |> maps (these o Option.map #params o try (get_info thy))
+      |> filter_out (fn (const, _) => can (get_inst_param thy) (const, t))
+      |> (map o apsnd o map_atyps) (K T);
+    val _ = map (Sign.certify_sort thy) Ss = Ss orelse err ();
+    val th' = Drule.unconstrainTs th;
+  in
+    thy
+    |> fold (snd oo declare_overloaded) missing_params
+    |> Sign.primitive_arity (t, Ss, [c])
+    |> put_arity ((t, Ss, c), th')
+  end;
+
+
+(* tactical proofs *)
+
+fun prove_classrel raw_rel tac thy =
+  let
+    val ctxt = ProofContext.init thy;
+    val (c1, c2) = cert_classrel thy raw_rel;
+    val th = Goal.prove ctxt [] [] (Logic.mk_classrel (c1, c2)) (K tac) handle ERROR msg =>
+      cat_error msg ("The error(s) above occurred while trying to prove class relation " ^
+        quote (Syntax.string_of_classrel ctxt [c1, c2]));
+  in
+    thy
+    |> PureThy.add_thms [((Binding.name
+        (prefix classrel_prefix (Logic.name_classrel (c1, c2))), th), [])]
+    |-> (fn [th'] => add_classrel th')
+  end;
+
+fun prove_arity raw_arity tac thy =
+  let
+    val ctxt = ProofContext.init thy;
+    val arity = Sign.cert_arity thy raw_arity;
+    val names = map (prefix arity_prefix) (Logic.name_arities arity);
+    val props = Logic.mk_arities arity;
+    val ths = Goal.prove_multi ctxt [] [] props
+      (fn _ => Goal.precise_conjunction_tac (length props) 1 THEN tac) handle ERROR msg =>
+        cat_error msg ("The error(s) above occurred while trying to prove type arity " ^
+          quote (Syntax.string_of_arity ctxt arity));
+  in
+    thy
+    |> PureThy.add_thms (map (rpair []) (map Binding.name names ~~ ths))
+    |-> fold add_arity
+  end;
+
+
 
 (** class definitions **)
 

--- a/src/Pure/codegen.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/Pure/codegen.ML	Fri May 15 15:56:28 2009 +0200
@@ -75,7 +75,7 @@
   val mk_type: bool -> typ -> Pretty.T
   val mk_term_of: codegr -> string -> bool -> typ -> Pretty.T
   val mk_gen: codegr -> string -> bool -> string list -> string -> typ -> Pretty.T
-  val test_fn: (int -> (string * term) list option) ref
+  val test_fn: (int -> term list option) ref
   val test_term: Proof.context -> term -> int -> term list option
   val eval_result: (unit -> term) ref
   val eval_term: theory -> term -> term
@@ -329,7 +329,7 @@
   end;
 
 val assoc_const_i = gen_assoc_const (K I);
-val assoc_const = gen_assoc_const Code_Unit.read_bare_const;
+val assoc_const = gen_assoc_const Code.read_bare_const;
 
 
 (**** associate types with target language types ****)
@@ -871,39 +871,35 @@
               [mk_gen gr module true xs a T, mk_type true T]) Ts) @
          (if member (op =) xs s then [str a] else []))));
 
-val test_fn : (int -> (string * term) list option) ref = ref (fn _ => NONE);
+val test_fn : (int -> term list option) ref = ref (fn _ => NONE);
 
 fun test_term ctxt t =
   let
     val thy = ProofContext.theory_of ctxt;
     val (code, gr) = setmp mode ["term_of", "test"]
       (generate_code_i thy [] "Generated") [("testf", t)];
-    val frees = Name.names Name.context "a" ((map snd o fst o strip_abs) t);
-    val frees' = frees ~~
-      map (fn i => "arg" ^ string_of_int i) (1 upto length frees);
+    val Ts = map snd (fst (strip_abs t));
+    val args = map_index (fn (i, T) => ("arg" ^ string_of_int i, T)) Ts;
     val s = "structure TestTerm =\nstruct\n\n" ^
       cat_lines (map snd code) ^
       "\nopen Generated;\n\n" ^ string_of
         (Pretty.block [str "val () = Codegen.test_fn :=",
           Pretty.brk 1, str ("(fn i =>"), Pretty.brk 1,
-          mk_let (map (fn ((s, T), s') =>
-              (mk_tuple [str s', str (s' ^ "_t")],
+          mk_let (map (fn (s, T) =>
+              (mk_tuple [str s, str (s ^ "_t")],
                Pretty.block [mk_gen gr "Generated" false [] "" T, Pretty.brk 1,
-                 str "(i + 1)"])) frees')
+                 str "i"])) args)
             (Pretty.block [str "if ",
-              mk_app false (str "testf") (map (str o snd) frees'),
+              mk_app false (str "testf") (map (str o fst) args),
               Pretty.brk 1, str "then NONE",
               Pretty.brk 1, str "else ",
               Pretty.block [str "SOME ", Pretty.block (str "[" ::
-                flat (separate [str ",", Pretty.brk 1]
-                  (map (fn ((s, T), s') => [Pretty.block
-                    [str ("(" ^ quote (Symbol.escape s) ^ ","), Pretty.brk 1,
-                     str (s' ^ "_t ())")]]) frees')) @
+                Pretty.commas (map (fn (s, _) => str (s ^ "_t ()")) args) @
                   [str "]"])]]),
           str ");"]) ^
       "\n\nend;\n";
     val _ = ML_Context.eval_in (SOME ctxt) false Position.none s;
-  in ! test_fn #> (Option.map o map) snd end;
+  in ! test_fn end;
 
 
 
@@ -1024,8 +1020,6 @@
 
 val setup = add_codegen "default" default_codegen
   #> add_tycodegen "default" default_tycodegen
-  #> Code.add_attribute ("unfold", Scan.succeed (Thm.declaration_attribute
-       (fn thm => Context.mapping (add_unfold thm #> Code.add_inline thm) I)))
   #> add_preprocessor unfold_preprocessor;
 
 val _ =

--- a/src/Pure/name.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/Pure/name.ML	Fri May 15 15:56:28 2009 +0200
@@ -28,6 +28,7 @@
   val variants: string list -> context -> string list * context
   val variant_list: string list -> string list -> string list
   val variant: string list -> string -> string
+  val desymbolize: bool -> string -> string
 end;
 
 structure Name: NAME =
@@ -144,4 +145,31 @@
 fun variant_list used names = #1 (make_context used |> variants names);
 fun variant used = singleton (variant_list used);
 
+
+(* names conforming to typical requirements of identifiers in the world outside *)
+
+fun desymbolize upper "" = if upper then "X" else "x"
+  | desymbolize upper s =
+      let
+        val xs as (x :: _) = Symbol.explode s;
+        val ys = if Symbol.is_ascii_letter x orelse Symbol.is_symbolic x then xs
+          else "x" :: xs;
+        fun is_valid x =
+          Symbol.is_ascii_letter x orelse Symbol.is_ascii_digit x orelse x = "'";
+        fun sep [] = []
+          | sep (xs as "_" :: _) = xs
+          | sep xs = "_" :: xs;
+        fun desep ("_" :: xs) = xs
+          | desep xs = xs;
+        fun desymb x xs = if is_valid x
+            then x :: xs
+          else if Symbol.is_symbolic x
+            then "_" :: explode (Symbol.name_of x) @ sep xs
+          else
+            sep xs
+        fun upper_lower cs = if upper then nth_map 0 Symbol.to_ascii_upper cs
+          else (if forall Symbol.is_ascii_upper cs
+            then map else nth_map 0) Symbol.to_ascii_lower cs;
+      in fold_rev desymb ys [] |> desep |> upper_lower |> implode end;
+
 end;

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/Tools/Code_Generator.thy	Fri May 15 15:56:28 2009 +0200
@@ -0,0 +1,28 @@
+(*  Title:   Tools/Code_Generator.thy
+    Author:  Florian Haftmann, TU Muenchen
+*)
+
+header {* Loading the code generator modules *}
+
+theory Code_Generator
+imports Pure
+uses
+  "~~/src/Tools/value.ML"
+  "~~/src/Tools/quickcheck.ML"
+  "~~/src/Tools/code/code_preproc.ML" 
+  "~~/src/Tools/code/code_thingol.ML"
+  "~~/src/Tools/code/code_printer.ML"
+  "~~/src/Tools/code/code_target.ML"
+  "~~/src/Tools/code/code_ml.ML"
+  "~~/src/Tools/code/code_haskell.ML"
+  "~~/src/Tools/nbe.ML"
+begin
+
+setup {*
+  Code_Preproc.setup
+  #> Code_ML.setup
+  #> Code_Haskell.setup
+  #> Nbe.setup
+*}
+
+end
\ No newline at end of file

--- a/src/Tools/auto_solve.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/Tools/auto_solve.ML	Fri May 15 15:56:28 2009 +0200
@@ -14,18 +14,34 @@
   val auto : bool ref
   val auto_time_limit : int ref
   val limit : int ref
-
-  val seek_solution : bool -> Proof.state -> Proof.state
 end;
 
 structure AutoSolve : AUTO_SOLVE =
 struct
 
+(* preferences *)
+
 val auto = ref false;
 val auto_time_limit = ref 2500;
 val limit = ref 5;
 
-fun seek_solution int state =
+val _ =
+  ProofGeneralPgip.add_preference Preferences.category_tracing
+  (setmp auto true (fn () =>
+    Preferences.bool_pref auto
+      "auto-solve"
+      "Try to solve newly declared lemmas with existing theorems.") ());
+
+val _ =
+  ProofGeneralPgip.add_preference Preferences.category_tracing
+    (Preferences.nat_pref auto_time_limit
+      "auto-solve-time-limit"
+      "Time limit for seeking automatic solutions (in milliseconds).");
+
+
+(* hook *)
+
+val _ = Context.>> (Specification.add_theorem_hook (fn int => fn state =>
   let
     val ctxt = Proof.context_of state;
 
@@ -76,12 +92,10 @@
     if int andalso ! auto andalso not (! Toplevel.quiet)
     then go ()
     else state
-  end;
+  end));
 
 end;
 
-val _ = Context.>> (Specification.add_theorem_hook AutoSolve.seek_solution);
-
 val auto_solve = AutoSolve.auto;
 val auto_solve_time_limit = AutoSolve.auto_time_limit;
 

--- a/src/Tools/code/code_funcgr.ML	Fri May 15 15:29:34 2009 +0200
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,335 +0,0 @@
-(*  Title:      Tools/code/code_funcgr.ML
-    Author:     Florian Haftmann, TU Muenchen
-
-Retrieving, normalizing and structuring code equations in graph
-with explicit dependencies.
-
-Legacy.  To be replaced by Tools/code/code_wellsorted.ML
-*)
-
-signature CODE_WELLSORTED =
-sig
-  type T
-  val eqns: T -> string -> (thm * bool) list
-  val typ: T -> string -> (string * sort) list * typ
-  val all: T -> string list
-  val pretty: theory -> T -> Pretty.T
-  val make: theory -> string list
-    -> ((sort -> sort) * Sorts.algebra) * T
-  val eval_conv: theory
-    -> (term -> term * (((sort -> sort) * Sorts.algebra) -> T -> thm)) -> cterm -> thm
-  val eval_term: theory
-    -> (term -> term * (((sort -> sort) * Sorts.algebra) -> T -> 'a)) -> term -> 'a
-  val timing: bool ref
-end
-
-structure Code_Wellsorted : CODE_WELLSORTED =
-struct
-
-(** the graph type **)
-
-type T = (((string * sort) list * typ) * (thm * bool) list) Graph.T;
-
-fun eqns funcgr =
-  these o Option.map snd o try (Graph.get_node funcgr);
-
-fun typ funcgr =
-  fst o Graph.get_node funcgr;
-
-fun all funcgr = Graph.keys funcgr;
-
-fun pretty thy funcgr =
-  AList.make (snd o Graph.get_node funcgr) (Graph.keys funcgr)
-  |> (map o apfst) (Code_Unit.string_of_const thy)
-  |> sort (string_ord o pairself fst)
-  |> map (fn (s, thms) =>
-       (Pretty.block o Pretty.fbreaks) (
-         Pretty.str s
-         :: map (Display.pretty_thm o fst) thms
-       ))
-  |> Pretty.chunks;
-
-
-(** generic combinators **)
-
-fun fold_consts f thms =
-  thms
-  |> maps (op :: o swap o apfst (snd o strip_comb) o Logic.dest_equals o Thm.plain_prop_of)
-  |> (fold o fold_aterms) (fn Const c => f c | _ => I);
-
-fun consts_of (const, []) = []
-  | consts_of (const, thms as _ :: _) = 
-      let
-        fun the_const (c, _) = if c = const then I else insert (op =) c
-      in fold_consts the_const (map fst thms) [] end;
-
-fun insts_of thy algebra tys sorts =
-  let
-    fun class_relation (x, _) _ = x;
-    fun type_constructor tyco xs class =
-      (tyco, class) :: (maps o maps) fst xs;
-    fun type_variable (TVar (_, sort)) = map (pair []) sort
-      | type_variable (TFree (_, sort)) = map (pair []) sort;
-    fun of_sort_deriv ty sort =
-      Sorts.of_sort_derivation (Syntax.pp_global thy) algebra
-        { class_relation = class_relation, type_constructor = type_constructor,
-          type_variable = type_variable }
-        (ty, sort) handle Sorts.CLASS_ERROR _ => [] (*permissive!*)
-  in (flat o flat) (map2 of_sort_deriv tys sorts) end;
-
-fun meets_of thy algebra =
-  let
-    fun meet_of ty sort tab =
-      Sorts.meet_sort algebra (ty, sort) tab
-        handle Sorts.CLASS_ERROR _ => tab (*permissive!*);
-  in fold2 meet_of end;
-
-
-(** graph algorithm **)
-
-val timing = ref false;
-
-local
-
-fun resort_thms thy algebra typ_of thms =
-  let
-    val cs = fold_consts (insert (op =)) thms [];
-    fun meets (c, ty) = case typ_of c
-       of SOME (vs, _) =>
-            meets_of thy algebra (Sign.const_typargs thy (c, ty)) (map snd vs)
-        | NONE => I;
-    val tab = fold meets cs Vartab.empty;
-  in map (Code_Unit.inst_thm thy tab) thms end;
-
-fun resort_eqnss thy algebra funcgr =
-  let
-    val typ_funcgr = try (fst o Graph.get_node funcgr);
-    val resort_dep = (apsnd o burrow_fst) (resort_thms thy algebra typ_funcgr);
-    fun resort_rec typ_of (c, []) = (true, (c, []))
-      | resort_rec typ_of (c, thms as (thm, _) :: _) = if is_some (AxClass.inst_of_param thy c)
-          then (true, (c, thms))
-          else let
-            val (_, (vs, ty)) = Code_Unit.head_eqn thy thm;
-            val thms' as (thm', _) :: _ = burrow_fst (resort_thms thy algebra typ_of) thms
-            val (_, (vs', ty')) = Code_Unit.head_eqn thy thm'; (*FIXME simplify check*)
-          in (Sign.typ_equiv thy (ty, ty'), (c, thms')) end;
-    fun resort_recs eqnss =
-      let
-        fun typ_of c = case these (AList.lookup (op =) eqnss c)
-         of (thm, _) :: _ => (SOME o snd o Code_Unit.head_eqn thy) thm
-          | [] => NONE;
-        val (unchangeds, eqnss') = split_list (map (resort_rec typ_of) eqnss);
-        val unchanged = fold (fn x => fn y => x andalso y) unchangeds true;
-      in (unchanged, eqnss') end;
-    fun resort_rec_until eqnss =
-      let
-        val (unchanged, eqnss') = resort_recs eqnss;
-      in if unchanged then eqnss' else resort_rec_until eqnss' end;
-  in map resort_dep #> resort_rec_until end;
-
-fun instances_of thy algebra insts =
-  let
-    val thy_classes = (#classes o Sorts.rep_algebra o Sign.classes_of) thy;
-    fun all_classparams tyco class =
-      these (try (#params o AxClass.get_info thy) class)
-      |> map_filter (fn (c, _) => try (AxClass.param_of_inst thy) (c, tyco))
-  in
-    Symtab.empty
-    |> fold (fn (tyco, class) =>
-        Symtab.map_default (tyco, []) (insert (op =) class)) insts
-    |> (fn tab => Symtab.fold (fn (tyco, classes) => append (maps (all_classparams tyco)
-         (Graph.all_succs thy_classes classes))) tab [])
-  end;
-
-fun instances_of_consts thy algebra funcgr consts =
-  let
-    fun inst (cexpr as (c, ty)) = insts_of thy algebra
-      (Sign.const_typargs thy (c, ty)) ((map snd o fst) (typ funcgr c));
-  in
-    []
-    |> fold (fold (insert (op =)) o inst) consts
-    |> instances_of thy algebra
-  end;
-
-fun ensure_const' thy algebra funcgr const auxgr =
-  if can (Graph.get_node funcgr) const
-    then (NONE, auxgr)
-  else if can (Graph.get_node auxgr) const
-    then (SOME const, auxgr)
-  else if is_some (Code.get_datatype_of_constr thy const) then
-    auxgr
-    |> Graph.new_node (const, [])
-    |> pair (SOME const)
-  else let
-    val thms = Code.these_eqns thy const
-      |> burrow_fst (Code_Unit.norm_args thy)
-      |> burrow_fst (Code_Unit.norm_varnames thy Code_Name.purify_tvar Code_Name.purify_var);
-    val rhs = consts_of (const, thms);
-  in
-    auxgr
-    |> Graph.new_node (const, thms)
-    |> fold_map (ensure_const thy algebra funcgr) rhs
-    |-> (fn rhs' => fold (fn SOME const' => Graph.add_edge (const, const')
-                           | NONE => I) rhs')
-    |> pair (SOME const)
-  end
-and ensure_const thy algebra funcgr const =
-  let
-    val timeap = if !timing
-      then Output.timeap_msg ("time for " ^ Code_Unit.string_of_const thy const)
-      else I;
-  in timeap (ensure_const' thy algebra funcgr const) end;
-
-fun merge_eqnss thy algebra raw_eqnss funcgr =
-  let
-    val eqnss = raw_eqnss
-      |> resort_eqnss thy algebra funcgr
-      |> filter_out (can (Graph.get_node funcgr) o fst);
-    fun typ_eqn c [] = Code.default_typscheme thy c
-      | typ_eqn c (thms as (thm, _) :: _) = (snd o Code_Unit.head_eqn thy) thm;
-    fun add_eqns (const, thms) =
-      Graph.new_node (const, (typ_eqn const thms, thms));
-    fun add_deps (eqns as (const, thms)) funcgr =
-      let
-        val deps = consts_of eqns;
-        val insts = instances_of_consts thy algebra funcgr
-          (fold_consts (insert (op =)) (map fst thms) []);
-      in
-        funcgr
-        |> ensure_consts thy algebra insts
-        |> fold (curry Graph.add_edge const) deps
-        |> fold (curry Graph.add_edge const) insts
-       end;
-  in
-    funcgr
-    |> fold add_eqns eqnss
-    |> fold add_deps eqnss
-  end
-and ensure_consts thy algebra cs funcgr =
-  let
-    val auxgr = Graph.empty
-      |> fold (snd oo ensure_const thy algebra funcgr) cs;
-  in
-    funcgr
-    |> fold (merge_eqnss thy algebra)
-         (map (AList.make (Graph.get_node auxgr))
-         (rev (Graph.strong_conn auxgr)))
-  end;
-
-in
-
-(** retrieval interfaces **)
-
-val ensure_consts = ensure_consts;
-
-fun proto_eval thy cterm_of evaluator_lift evaluator proto_ct funcgr =
-  let
-    val ct = cterm_of proto_ct;
-    val _ = Sign.no_vars (Syntax.pp_global thy) (Thm.term_of ct);
-    val _ = Term.fold_types (Type.no_tvars #> K I) (Thm.term_of ct) ();
-    fun consts_of t =
-      fold_aterms (fn Const c_ty => cons c_ty | _ => I) t [];
-    val algebra = Code.coregular_algebra thy;
-    val thm = Code.preprocess_conv thy ct;
-    val ct' = Thm.rhs_of thm;
-    val t' = Thm.term_of ct';
-    val consts = map fst (consts_of t');
-    val funcgr' = ensure_consts thy algebra consts funcgr;
-    val (t'', evaluator_funcgr) = evaluator t';
-    val consts' = consts_of t'';
-    val dicts = instances_of_consts thy algebra funcgr' consts';
-    val funcgr'' = ensure_consts thy algebra dicts funcgr';
-  in (evaluator_lift (evaluator_funcgr (Code.operational_algebra thy)) thm funcgr'', funcgr'') end;
-
-fun proto_eval_conv thy =
-  let
-    fun evaluator_lift evaluator thm1 funcgr =
-      let
-        val thm2 = evaluator funcgr;
-        val thm3 = Code.postprocess_conv thy (Thm.rhs_of thm2);
-      in
-        Thm.transitive thm1 (Thm.transitive thm2 thm3) handle THM _ =>
-          error ("could not construct evaluation proof:\n"
-          ^ (cat_lines o map Display.string_of_thm) [thm1, thm2, thm3])
-      end;
-  in proto_eval thy I evaluator_lift end;
-
-fun proto_eval_term thy =
-  let
-    fun evaluator_lift evaluator _ funcgr = evaluator funcgr;
-  in proto_eval thy (Thm.cterm_of thy) evaluator_lift end;
-
-end; (*local*)
-
-structure Funcgr = CodeDataFun
-(
-  type T = T;
-  val empty = Graph.empty;
-  fun purge _ cs funcgr =
-    Graph.del_nodes ((Graph.all_preds funcgr 
-      o filter (can (Graph.get_node funcgr))) cs) funcgr;
-);
-
-fun make thy =
-  pair (Code.operational_algebra thy)
-  o Funcgr.change thy o ensure_consts thy (Code.coregular_algebra thy);
-
-fun eval_conv thy f =
-  fst o Funcgr.change_yield thy o proto_eval_conv thy f;
-
-fun eval_term thy f =
-  fst o Funcgr.change_yield thy o proto_eval_term thy f;
-
-
-(** diagnostic commands **)
-
-fun code_depgr thy consts =
-  let
-    val (_, gr) = make thy consts;
-    val select = Graph.all_succs gr consts;
-  in
-    gr
-    |> not (null consts) ? Graph.subgraph (member (op =) select) 
-    |> Graph.map_nodes ((apsnd o map o apfst) (AxClass.overload thy))
-  end;
-
-fun code_thms thy = Pretty.writeln o pretty thy o code_depgr thy;
-
-fun code_deps thy consts =
-  let
-    val gr = code_depgr thy consts;
-    fun mk_entry (const, (_, (_, parents))) =
-      let
-        val name = Code_Unit.string_of_const thy const;
-        val nameparents = map (Code_Unit.string_of_const thy) parents;
-      in { name = name, ID = name, dir = "", unfold = true,
-        path = "", parents = nameparents }
-      end;
-    val prgr = Graph.fold ((fn x => fn xs => xs @ [x]) o mk_entry) gr [];
-  in Present.display_graph prgr end;
-
-local
-
-structure P = OuterParse
-and K = OuterKeyword
-
-fun code_thms_cmd thy = code_thms thy o op @ o Code_Name.read_const_exprs thy;
-fun code_deps_cmd thy = code_deps thy o op @ o Code_Name.read_const_exprs thy;
-
-in
-
-val _ =
-  OuterSyntax.improper_command "code_thms" "print system of code equations for code" OuterKeyword.diag
-    (Scan.repeat P.term_group
-      >> (fn cs => Toplevel.no_timing o Toplevel.unknown_theory
-        o Toplevel.keep ((fn thy => code_thms_cmd thy cs) o Toplevel.theory_of)));
-
-val _ =
-  OuterSyntax.improper_command "code_deps" "visualize dependencies of code equations for code" OuterKeyword.diag
-    (Scan.repeat P.term_group
-      >> (fn cs => Toplevel.no_timing o Toplevel.unknown_theory
-        o Toplevel.keep ((fn thy => code_deps_cmd thy cs) o Toplevel.theory_of)));
-
-end;
-
-end; (*struct*)

--- a/src/Tools/code/code_haskell.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/Tools/code/code_haskell.ML	Fri May 15 15:56:28 2009 +0200
@@ -31,7 +31,7 @@
       | pr_bind ((SOME v, SOME p), _) = brackets [str v, str "@", p];
   in gen_pr_bind pr_bind pr_term end;
 
-fun pr_haskell_stmt naming labelled_name syntax_class syntax_tyco syntax_const
+fun pr_haskell_stmt labelled_name syntax_class syntax_tyco syntax_const
     init_syms deresolve is_cons contr_classparam_typs deriving_show =
   let
     val deresolve_base = Long_Name.base_name o deresolve;
@@ -96,7 +96,7 @@
             (str o deresolve) c :: map2 pr_term_anno ts_fingerprint (curry Library.take (length ts) tys)
           else (str o deresolve) c :: map (pr_term tyvars thm vars BR) ts
         end
-    and pr_app tyvars = gen_pr_app (pr_app' tyvars) (pr_term tyvars) syntax_const naming
+    and pr_app tyvars = gen_pr_app (pr_app' tyvars) (pr_term tyvars) syntax_const
     and pr_bind tyvars = pr_haskell_bind (pr_term tyvars)
     and pr_case tyvars thm vars fxy (cases as ((_, [_]), _)) =
           let
@@ -261,7 +261,7 @@
                     val vars = init_syms
                       |> Code_Printer.intro_vars (the_list const)
                       |> Code_Printer.intro_vars vs;
-                    val lhs = IConst (classparam, ([], tys)) `$$ map IVar vs;
+                    val lhs = IConst (classparam, (([], []), tys)) `$$ map IVar vs;
                       (*dictionaries are not relevant at this late stage*)
                   in
                     semicolon [
@@ -336,7 +336,7 @@
 
 fun serialize_haskell module_prefix raw_module_name string_classes labelled_name
     raw_reserved_names includes raw_module_alias
-    syntax_class syntax_tyco syntax_const naming program cs destination =
+    syntax_class syntax_tyco syntax_const program cs destination =
   let
     val stmt_names = Code_Target.stmt_names_of_destination destination;
     val module_name = if null stmt_names then raw_module_name else SOME "Code";
@@ -358,7 +358,7 @@
           | deriv' _ (ITyVar _) = true
       in deriv [] tyco end;
     val reserved_names = Code_Printer.make_vars reserved_names;
-    fun pr_stmt qualified = pr_haskell_stmt naming labelled_name
+    fun pr_stmt qualified = pr_haskell_stmt labelled_name
       syntax_class syntax_tyco syntax_const reserved_names
       (if qualified then deresolver else Long_Name.base_name o deresolver)
       is_cons contr_classparam_typs
@@ -469,18 +469,18 @@
       | pr_monad pr_bind pr (SOME (bind, false), t) vars = vars
           |> pr_bind NOBR bind
           |>> (fn p => semicolon [str "let", p, str "=", pr vars NOBR t]);
-    fun pretty pr naming thm vars fxy [(t1, _), (t2, _)] = case dest_bind t1 t2
+    fun pretty _ [c_bind'] pr thm vars fxy [(t1, _), (t2, _)] = case dest_bind t1 t2
      of SOME (bind, t') => let
-          val (binds, t'') = implode_monad ((the o Code_Thingol.lookup_const naming) c_bind) t'
+          val (binds, t'') = implode_monad c_bind' t'
           val (ps, vars') = fold_map (pr_monad (pr_haskell_bind (K pr) thm) pr) (bind :: binds) vars;
         in (brackify fxy o single o Pretty.enclose "do {" "}" o Pretty.breaks) (ps @| pr vars' NOBR t'') end
       | NONE => brackify_infix (1, L) fxy
           [pr vars (INFX (1, L)) t1, str ">>=", pr vars (INFX (1, X)) t2]
-  in (2, pretty) end;
+  in (2, ([c_bind], pretty)) end;
 
 fun add_monad target' raw_c_bind thy =
   let
-    val c_bind = Code_Unit.read_const thy raw_c_bind;
+    val c_bind = Code.read_const thy raw_c_bind;
   in if target = target' then
     thy
     |> Code_Target.add_syntax_const target c_bind

--- a/src/Tools/code/code_ml.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/Tools/code/code_ml.ML	Fri May 15 15:56:28 2009 +0200
@@ -6,8 +6,9 @@
 
 signature CODE_ML =
 sig
-  val eval_term: string * (unit -> 'a) option ref
-    -> theory -> term -> string list -> 'a
+  val eval: string option -> string * (unit -> 'a) option ref
+    -> ((term -> term) -> 'a -> 'a) -> theory -> term -> string list -> 'a
+  val target_Eval: string
   val setup: theory -> theory
 end;
 
@@ -22,6 +23,7 @@
 
 val target_SML = "SML";
 val target_OCaml = "OCaml";
+val target_Eval = "Eval";
 
 datatype ml_stmt =
     MLExc of string * int
@@ -43,7 +45,7 @@
 
 (** SML serailizer **)
 
-fun pr_sml_stmt naming labelled_name syntax_tyco syntax_const reserved_names deresolve is_cons =
+fun pr_sml_stmt labelled_name syntax_tyco syntax_const reserved_names deresolve is_cons =
   let
     val pr_label_classrel = translate_string (fn "." => "__" | c => c)
       o Long_Name.qualifier;
@@ -107,7 +109,7 @@
                 then pr_case is_closure thm vars fxy cases
                 else pr_app is_closure thm vars fxy c_ts
             | NONE => pr_case is_closure thm vars fxy cases)
-    and pr_app' is_closure thm vars (app as ((c, (iss, tys)), ts)) =
+    and pr_app' is_closure thm vars (app as ((c, ((_, iss), tys)), ts)) =
       if is_cons c then
         let
           val k = length tys
@@ -122,7 +124,7 @@
         (str o deresolve) c
           :: (map (pr_dicts BR) o filter_out null) iss @ map (pr_term is_closure thm vars BR) ts
     and pr_app is_closure thm vars = gen_pr_app (pr_app' is_closure) (pr_term is_closure)
-      syntax_const naming thm vars
+      syntax_const thm vars
     and pr_bind' ((NONE, NONE), _) = str "_"
       | pr_bind' ((SOME v, NONE), _) = str v
       | pr_bind' ((NONE, SOME p), _) = p
@@ -159,20 +161,21 @@
               :: map (pr "|") clauses
             )
           end
-      | pr_case is_closure thm vars fxy ((_, []), _) = str "raise Fail \"empty case\"";
+      | pr_case is_closure thm vars fxy ((_, []), _) =
+          (concat o map str) ["raise", "Fail", "\"empty case\""];
     fun pr_stmt (MLExc (name, n)) =
           let
             val exc_str =
               (ML_Syntax.print_string o Long_Name.base_name o Long_Name.qualifier) name;
           in
-            concat (
-              str (if n = 0 then "val" else "fun")
-              :: (str o deresolve) name
-              :: map str (replicate n "_")
-              @ str "="
-              :: str "raise"
-              :: str "(Fail"
-              @@ str (exc_str ^ ")")
+            (concat o map str) (
+              (if n = 0 then "val" else "fun")
+              :: deresolve name
+              :: replicate n "_"
+              @ "="
+              :: "raise"
+              :: "Fail"
+              @@ exc_str
             )
           end
       | pr_stmt (MLVal (name, (((vs, ty), t), (thm, _)))) =
@@ -358,7 +361,7 @@
 
 (** OCaml serializer **)
 
-fun pr_ocaml_stmt naming labelled_name syntax_tyco syntax_const reserved_names deresolve is_cons =
+fun pr_ocaml_stmt labelled_name syntax_tyco syntax_const reserved_names deresolve is_cons =
   let
     fun pr_dicts fxy ds =
       let
@@ -412,7 +415,7 @@
                 then pr_case is_closure thm vars fxy cases
                 else pr_app is_closure thm vars fxy c_ts
             | NONE => pr_case is_closure thm vars fxy cases)
-    and pr_app' is_closure thm vars (app as ((c, (iss, tys)), ts)) =
+    and pr_app' is_closure thm vars (app as ((c, ((_, iss), tys)), ts)) =
       if is_cons c then
         if length tys = length ts
         then case ts
@@ -426,7 +429,7 @@
       else (str o deresolve) c
         :: ((map (pr_dicts BR) o filter_out null) iss @ map (pr_term is_closure thm vars BR) ts)
     and pr_app is_closure = gen_pr_app (pr_app' is_closure) (pr_term is_closure)
-      syntax_const naming
+      syntax_const
     and pr_bind' ((NONE, NONE), _) = str "_"
       | pr_bind' ((SOME v, NONE), _) = str v
       | pr_bind' ((NONE, SOME p), _) = p
@@ -456,7 +459,8 @@
               :: map (pr "|") clauses
             )
           end
-      | pr_case is_closure thm vars fxy ((_, []), _) = str "failwith \"empty case\"";
+      | pr_case is_closure thm vars fxy ((_, []), _) =
+          (concat o map str) ["failwith", "\"empty case\""];
     fun fish_params vars eqs =
       let
         fun fish_param _ (w as SOME _) = w
@@ -475,13 +479,13 @@
             val exc_str =
               (ML_Syntax.print_string o Long_Name.base_name o Long_Name.qualifier) name;
           in
-            concat (
-              str "let"
-              :: (str o deresolve) name
-              :: map str (replicate n "_")
-              @ str "="
-              :: str "failwith"
-              @@ str exc_str
+            (concat o map str) (
+              "let"
+              :: deresolve name
+              :: replicate n "_"
+              @ "="
+              :: "failwith"
+              @@ exc_str
             )
           end
       | pr_stmt (MLVal (name, (((vs, ty), t), (thm, _)))) =
@@ -907,36 +911,38 @@
   in (deresolver, nodes) end;
 
 fun serialize_ml target compile pr_module pr_stmt raw_module_name labelled_name reserved_names includes raw_module_alias
-  _ syntax_tyco syntax_const naming program cs destination =
+  _ syntax_tyco syntax_const program stmt_names destination =
   let
     val is_cons = Code_Thingol.is_cons program;
-    val stmt_names = Code_Target.stmt_names_of_destination destination;
-    val module_name = if null stmt_names then raw_module_name else SOME "Code";
+    val present_stmt_names = Code_Target.stmt_names_of_destination destination;
+    val is_present = not (null present_stmt_names);
+    val module_name = if is_present then SOME "Code" else raw_module_name;
     val (deresolver, nodes) = ml_node_of_program labelled_name module_name
       reserved_names raw_module_alias program;
     val reserved_names = Code_Printer.make_vars reserved_names;
     fun pr_node prefix (Dummy _) =
           NONE
-      | pr_node prefix (Stmt (_, stmt)) = if null stmt_names orelse
-          (not o null o filter (member (op =) stmt_names) o stmt_names_of) stmt then SOME
-            (pr_stmt naming labelled_name syntax_tyco syntax_const reserved_names
+      | pr_node prefix (Stmt (_, stmt)) = if is_present andalso
+          (null o filter (member (op =) present_stmt_names) o stmt_names_of) stmt
+          then NONE
+          else SOME
+            (pr_stmt labelled_name syntax_tyco syntax_const reserved_names
               (deresolver prefix) is_cons stmt)
-          else NONE
       | pr_node prefix (Module (module_name, (_, nodes))) =
           separate (str "")
             ((map_filter (pr_node (prefix @ [module_name]) o Graph.get_node nodes)
               o rev o flat o Graph.strong_conn) nodes)
-          |> (if null stmt_names then pr_module module_name else Pretty.chunks)
+          |> (if is_present then Pretty.chunks else pr_module module_name)
           |> SOME;
-    val cs' = (map o try)
-      (deresolver (if is_some module_name then the_list module_name else [])) cs;
+    val stmt_names' = (map o try)
+      (deresolver (if is_some module_name then the_list module_name else [])) stmt_names;
     val p = Pretty.chunks (separate (str "") (map snd includes @ (map_filter
       (pr_node [] o Graph.get_node nodes) o rev o flat o Graph.strong_conn) nodes));
   in
     Code_Target.mk_serialization target
       (case compile of SOME compile => SOME (compile o Code_Target.code_of_pretty) | NONE => NONE)
       (fn NONE => Code_Target.code_writeln | SOME file => File.write file o Code_Target.code_of_pretty)
-      (rpair cs' o Code_Target.code_of_pretty) p destination
+      (rpair stmt_names' o Code_Target.code_of_pretty) p destination
   end;
 
 end; (*local*)
@@ -944,20 +950,17 @@
 
 (** ML (system language) code for evaluation and instrumentalization **)
 
-fun ml_code_of thy = Code_Target.serialize_custom thy (target_SML,
+fun eval_code_of some_target thy = Code_Target.serialize_custom thy (the_default target_Eval some_target,
     (fn _ => fn [] => serialize_ml target_SML (SOME (K ())) (K Pretty.chunks) pr_sml_stmt (SOME ""),
   literals_sml));
 
 
 (* evaluation *)
 
-fun eval eval'' term_of reff thy ct args =
+fun eval some_target reff postproc thy t args =
   let
     val ctxt = ProofContext.init thy;
-    val _ = if null (Term.add_frees (term_of ct) []) then () else error ("Term "
-      ^ quote (Syntax.string_of_term_global thy (term_of ct))
-      ^ " to be evaluated contains free variables");
-    fun eval' naming program ((vs, ty), t) deps =
+    fun evaluator naming program ((_, (_, ty)), t) deps =
       let
         val _ = if Code_Thingol.contains_dictvar t then
           error "Term to be evaluated contains free dictionaries" else ();
@@ -966,13 +969,11 @@
           |> Graph.new_node (value_name,
               Code_Thingol.Fun (Term.dummy_patternN, (([], ty), [(([], t), (Drule.dummy_thm, true))])))
           |> fold (curry Graph.add_edge value_name) deps;
-        val (value_code, [SOME value_name']) = ml_code_of thy naming program' [value_name];
+        val (value_code, [SOME value_name']) = eval_code_of some_target thy naming program' [value_name];
         val sml_code = "let\n" ^ value_code ^ "\nin " ^ value_name'
           ^ space_implode " " (map (enclose "(" ")") args) ^ " end";
       in ML_Context.evaluate ctxt false reff sml_code end;
-  in eval'' thy (rpair eval') ct end;
-
-fun eval_term reff = eval Code_Thingol.eval_term I reff;
+  in Code_Thingol.eval thy I postproc evaluator t end;
 
 
 (* instrumentalization by antiquotation *)
@@ -981,51 +982,90 @@
 
 structure CodeAntiqData = ProofDataFun
 (
-  type T = string list * (bool * (string * (string * (string * string) list) lazy));
-  fun init _ = ([], (true, ("", Lazy.value ("", []))));
+  type T = (string list * string list) * (bool * (string
+    * (string * ((string * string) list * (string * string) list)) lazy));
+  fun init _ = (([], []), (true, ("", Lazy.value ("", ([], [])))));
 );
 
 val is_first_occ = fst o snd o CodeAntiqData.get;
 
-fun delayed_code thy consts () =
+fun delayed_code thy tycos consts () =
   let
     val (consts', (naming, program)) = Code_Thingol.consts_program thy consts;
-    val (ml_code, consts'') = ml_code_of thy naming program consts';
-    val const_tab = map2 (fn const => fn NONE =>
-      error ("Constant " ^ (quote o Code_Unit.string_of_const thy) const
-        ^ "\nhas a user-defined serialization")
-      | SOME const' => (const, const')) consts consts''
-  in (ml_code, const_tab) end;
+    val tycos' = map (the o Code_Thingol.lookup_tyco naming) tycos;
+    val (ml_code, target_names) = eval_code_of NONE thy naming program (consts' @ tycos');
+    val (consts'', tycos'') = chop (length consts') target_names;
+    val consts_map = map2 (fn const => fn NONE =>
+        error ("Constant " ^ (quote o Code.string_of_const thy) const
+          ^ "\nhas a user-defined serialization")
+      | SOME const'' => (const, const'')) consts consts''
+    val tycos_map = map2 (fn tyco => fn NONE =>
+        error ("Type " ^ (quote o Sign.extern_type thy) tyco
+          ^ "\nhas a user-defined serialization")
+      | SOME tyco'' => (tyco, tyco'')) tycos tycos'';
+  in (ml_code, (tycos_map, consts_map)) end;
 
-fun register_const const ctxt =
+fun register_code new_tycos new_consts ctxt =
   let
-    val (consts, (_, (struct_name, _))) = CodeAntiqData.get ctxt;
-    val consts' = insert (op =) const consts;
+    val ((tycos, consts), (_, (struct_name, _))) = CodeAntiqData.get ctxt;
+    val tycos' = fold (insert (op =)) new_tycos tycos;
+    val consts' = fold (insert (op =)) new_consts consts;
     val (struct_name', ctxt') = if struct_name = ""
       then ML_Antiquote.variant "Code" ctxt
       else (struct_name, ctxt);
-    val acc_code = Lazy.lazy (delayed_code (ProofContext.theory_of ctxt) consts');
-  in CodeAntiqData.put (consts', (false, (struct_name', acc_code))) ctxt' end;
+    val acc_code = Lazy.lazy (delayed_code (ProofContext.theory_of ctxt) tycos' consts');
+  in CodeAntiqData.put ((tycos', consts'), (false, (struct_name', acc_code))) ctxt' end;
+
+fun register_const const = register_code [] [const];
 
-fun print_code struct_name is_first const ctxt =
+fun register_datatype tyco constrs = register_code [tyco] constrs;
+
+fun print_const const all_struct_name tycos_map consts_map =
+  (Long_Name.append all_struct_name o the o AList.lookup (op =) consts_map) const;
+
+fun print_datatype tyco constrs all_struct_name tycos_map consts_map =
   let
-    val (consts, (_, (struct_code_name, acc_code))) = CodeAntiqData.get ctxt;
-    val (raw_ml_code, consts_map) = Lazy.force acc_code;
-    val const'' = Long_Name.append (Long_Name.append struct_name struct_code_name)
-      ((the o AList.lookup (op =) consts_map) const);
+    val upperize = implode o nth_map 0 Symbol.to_ascii_upper o explode;
+    fun check_base name name'' =
+      if upperize (Long_Name.base_name name) = upperize name''
+      then () else error ("Name as printed " ^ quote name''
+        ^ "\ndiffers from logical base name " ^ quote (Long_Name.base_name name) ^ "; sorry.");
+    val tyco'' = (the o AList.lookup (op =) tycos_map) tyco;
+    val constrs'' = map (the o AList.lookup (op =) consts_map) constrs;
+    val _ = check_base tyco tyco'';
+    val _ = map2 check_base constrs constrs'';
+  in "datatype " ^ tyco'' ^ " = datatype " ^ Long_Name.append all_struct_name tyco'' end;
+
+fun print_code struct_name is_first print_it ctxt =
+  let
+    val (_, (_, (struct_code_name, acc_code))) = CodeAntiqData.get ctxt;
+    val (raw_ml_code, (tycos_map, consts_map)) = Lazy.force acc_code;
     val ml_code = if is_first then "\nstructure " ^ struct_code_name
         ^ " =\nstruct\n\n" ^ raw_ml_code ^ "\nend;\n\n"
       else "";
-  in (ml_code, const'') end;
+    val all_struct_name = Long_Name.append struct_name struct_code_name;
+  in (ml_code, print_it all_struct_name tycos_map consts_map) end;
 
 in
 
 fun ml_code_antiq raw_const {struct_name, background} =
   let
-    val const = Code_Unit.check_const (ProofContext.theory_of background) raw_const;
+    val const = Code.check_const (ProofContext.theory_of background) raw_const;
     val is_first = is_first_occ background;
     val background' = register_const const background;
-  in (print_code struct_name is_first const, background') end;
+  in (print_code struct_name is_first (print_const const), background') end;
+
+fun ml_code_datatype_antiq (raw_tyco, raw_constrs) {struct_name, background} =
+  let
+    val thy = ProofContext.theory_of background;
+    val tyco = Sign.intern_type thy raw_tyco;
+    val constrs = map (Code.check_const thy) raw_constrs;
+    val constrs' = (map fst o snd o Code.get_datatype thy) tyco;
+    val _ = if gen_eq_set (op =) (constrs, constrs') then ()
+      else error ("Type " ^ quote tyco ^ ": given constructors diverge from real constructors")
+    val is_first = is_first_occ background;
+    val background' = register_datatype tyco constrs background;
+  in (print_code struct_name is_first (print_datatype tyco constrs), background') end;
 
 end; (*local*)
 
@@ -1033,6 +1073,10 @@
 (** Isar setup **)
 
 val _ = ML_Context.add_antiq "code" (fn _ => Args.term >> ml_code_antiq);
+val _ = ML_Context.add_antiq "code_datatype" (fn _ =>
+  (Args.tyname --| Scan.lift (Args.$$$ "=")
+    -- (Args.term ::: Scan.repeat (Scan.lift (Args.$$$ "|") |-- Args.term)))
+      >> ml_code_datatype_antiq);
 
 fun isar_seri_sml module_name =
   Code_Target.parse_args (Scan.succeed ())
@@ -1048,6 +1092,7 @@
 val setup =
   Code_Target.add_target (target_SML, (isar_seri_sml, literals_sml))
   #> Code_Target.add_target (target_OCaml, (isar_seri_ocaml, literals_ocaml))
+  #> Code_Target.extend_target (target_Eval, (target_SML, K I))
   #> Code_Target.add_syntax_tyco target_SML "fun" (SOME (2, fn pr_typ => fn fxy => fn [ty1, ty2] =>
       brackify_infix (1, R) fxy [
         pr_typ (INFX (1, X)) ty1,

--- a/src/Tools/code/code_name.ML	Fri May 15 15:29:34 2009 +0200
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,104 +0,0 @@
-(*  Title:      Tools/code/code_name.ML
-    Author:     Florian Haftmann, TU Muenchen
-
-Some code generator infrastructure concerning names.
-*)
-
-signature CODE_NAME =
-sig
-  val purify_var: string -> string
-  val purify_tvar: string -> string
-  val purify_base: string -> string
-  val check_modulename: string -> string
-
-  val read_const_exprs: theory -> string list -> string list * string list
-end;
-
-structure Code_Name: CODE_NAME =
-struct
-
-(** purification **)
-
-fun purify_name upper =
-  let
-    fun is_valid s = Symbol.is_ascii_letter s orelse Symbol.is_ascii_digit s orelse s = "'";
-    val is_junk = not o is_valid andf Symbol.is_regular;
-    val junk = Scan.many is_junk;
-    val scan_valids = Symbol.scanner "Malformed input"
-      ((junk |--
-        (Scan.optional (Scan.one Symbol.is_ascii_letter) "x" ^^ (Scan.many is_valid >> implode)
-        --| junk))
-      ::: Scan.repeat ((Scan.many1 is_valid >> implode) --| junk));
-    fun upper_lower cs = if upper then nth_map 0 Symbol.to_ascii_upper cs
-      else (if forall Symbol.is_ascii_upper cs
-        then map else nth_map 0) Symbol.to_ascii_lower cs;
-  in
-    explode
-    #> scan_valids
-    #> space_implode "_"
-    #> explode
-    #> upper_lower
-    #> implode
-  end;
-
-fun purify_var "" = "x"
-  | purify_var v = purify_name false v;
-
-fun purify_tvar "" = "'a"
-  | purify_tvar v =
-      (unprefix "'" #> explode #> filter Symbol.is_ascii_letter #> cons "'" #> implode) v;
-
-val purify_prefix =
-  explode
-  (*FIMXE should disappear as soon as hierarchical theory name spaces are available*)
-  #> Symbol.scanner "Malformed name"
-      (Scan.repeat ($$ "_" |-- $$ "_" >> (fn _ => ".") || Scan.one Symbol.is_regular))
-  #> implode
-  #> Long_Name.explode
-  #> map (purify_name true);
-
-(*FIMXE non-canonical function treating non-canonical names*)
-fun purify_base "op &" = "and"
-  | purify_base "op |" = "or"
-  | purify_base "op -->" = "implies"
-  | purify_base "op :" = "member"
-  | purify_base "*" = "product"
-  | purify_base "+" = "sum"
-  | purify_base s = if String.isPrefix "op =" s
-      then "eq" ^ purify_name false s
-      else purify_name false s;
-
-fun check_modulename mn =
-  let
-    val mns = Long_Name.explode mn;
-    val mns' = map (purify_name true) mns;
-  in
-    if mns' = mns then mn else error ("Invalid module name: " ^ quote mn ^ "\n"
-      ^ "perhaps try " ^ quote (Long_Name.implode mns'))
-  end;
-
-
-(** misc **)
-
-fun read_const_exprs thy =
-  let
-    fun consts_of some_thyname =
-      let
-        val thy' = case some_thyname
-         of SOME thyname => ThyInfo.the_theory thyname thy
-          | NONE => thy;
-        val cs = Symtab.fold (fn (c, (_, NONE)) => cons c | _ => I)
-          ((snd o #constants o Consts.dest o #consts o Sign.rep_sg) thy') [];
-        fun belongs_here c =
-          not (exists (fn thy'' => Sign.declared_const thy'' c) (Theory.parents_of thy'))
-      in case some_thyname
-       of NONE => cs
-        | SOME thyname => filter belongs_here cs
-      end;
-    fun read_const_expr "*" = ([], consts_of NONE)
-      | read_const_expr s = if String.isSuffix ".*" s
-          then ([], consts_of (SOME (unsuffix ".*" s)))
-          else ([Code_Unit.read_const thy s], []);
-  in pairself flat o split_list o map read_const_expr end;
-
-end;

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/Tools/code/code_preproc.ML	Fri May 15 15:56:28 2009 +0200
@@ -0,0 +1,515 @@
+(*  Title:      Tools/code/code_preproc.ML
+    Author:     Florian Haftmann, TU Muenchen
+
+Preprocessing code equations into a well-sorted system
+in a graph with explicit dependencies.
+*)
+
+signature CODE_PREPROC =
+sig
+  val map_pre: (simpset -> simpset) -> theory -> theory
+  val map_post: (simpset -> simpset) -> theory -> theory
+  val add_inline: thm -> theory -> theory
+  val add_functrans: string * (theory -> (thm * bool) list -> (thm * bool) list option) -> theory -> theory
+  val del_functrans: string -> theory -> theory
+  val simple_functrans: (theory -> thm list -> thm list option)
+    -> theory -> (thm * bool) list -> (thm * bool) list option
+  val print_codeproc: theory -> unit
+
+  type code_algebra
+  type code_graph
+  val eqns: code_graph -> string -> (thm * bool) list
+  val typ: code_graph -> string -> (string * sort) list * typ
+  val all: code_graph -> string list
+  val pretty: theory -> code_graph -> Pretty.T
+  val obtain: theory -> string list -> term list -> code_algebra * code_graph
+  val eval_conv: theory -> (sort -> sort)
+    -> (code_algebra -> code_graph -> (string * sort) list -> term -> cterm -> thm) -> cterm -> thm
+  val eval: theory -> (sort -> sort) -> ((term -> term) -> 'a -> 'a)
+    -> (code_algebra -> code_graph -> (string * sort) list -> term -> 'a) -> term -> 'a
+
+  val setup: theory -> theory
+end
+
+structure Code_Preproc : CODE_PREPROC =
+struct
+
+(** preprocessor administration **)
+
+(* theory data *)
+
+datatype thmproc = Thmproc of {
+  pre: simpset,
+  post: simpset,
+  functrans: (string * (serial * (theory -> (thm * bool) list -> (thm * bool) list option))) list
+};
+
+fun mk_thmproc ((pre, post), functrans) =
+  Thmproc { pre = pre, post = post, functrans = functrans };
+fun map_thmproc f (Thmproc { pre, post, functrans }) =
+  mk_thmproc (f ((pre, post), functrans));
+fun merge_thmproc (Thmproc { pre = pre1, post = post1, functrans = functrans1 },
+  Thmproc { pre = pre2, post = post2, functrans = functrans2 }) =
+    let
+      val pre = Simplifier.merge_ss (pre1, pre2);
+      val post = Simplifier.merge_ss (post1, post2);
+      val functrans = AList.merge (op =) (eq_fst (op =)) (functrans1, functrans2);
+    in mk_thmproc ((pre, post), functrans) end;
+
+structure Code_Preproc_Data = TheoryDataFun
+(
+  type T = thmproc;
+  val empty = mk_thmproc ((Simplifier.empty_ss, Simplifier.empty_ss), []);
+  fun copy spec = spec;
+  val extend = copy;
+  fun merge pp = merge_thmproc;
+);
+
+fun the_thmproc thy = case Code_Preproc_Data.get thy
+ of Thmproc x => x;
+
+fun delete_force msg key xs =
+  if AList.defined (op =) xs key then AList.delete (op =) key xs
+  else error ("No such " ^ msg ^ ": " ^ quote key);
+
+fun map_data f thy =
+  thy
+  |> Code.purge_data
+  |> (Code_Preproc_Data.map o map_thmproc) f;
+
+val map_pre = map_data o apfst o apfst;
+val map_post = map_data o apfst o apsnd;
+
+val add_inline = map_pre o MetaSimplifier.add_simp;
+val del_inline = map_pre o MetaSimplifier.del_simp;
+val add_post = map_post o MetaSimplifier.add_simp;
+val del_post = map_post o MetaSimplifier.del_simp;
+  
+fun add_functrans (name, f) = (map_data o apsnd)
+  (AList.update (op =) (name, (serial (), f)));
+
+fun del_functrans name = (map_data o apsnd)
+  (delete_force "function transformer" name);
+
+
+(* post- and preprocessing *)
+
+fun apply_functrans thy c _ [] = []
+  | apply_functrans thy c [] eqns = eqns
+  | apply_functrans thy c functrans eqns = eqns
+      |> perhaps (perhaps_loop (perhaps_apply functrans))
+      |> Code.assert_eqns_const thy c;
+
+fun rhs_conv conv thm = Thm.transitive thm ((conv o Thm.rhs_of) thm);
+
+fun term_of_conv thy f =
+  Thm.cterm_of thy
+  #> f
+  #> Thm.prop_of
+  #> Logic.dest_equals
+  #> snd;
+
+fun preprocess thy c eqns =
+  let
+    val pre = (Simplifier.theory_context thy o #pre o the_thmproc) thy;
+    val functrans = (map (fn (_, (_, f)) => f thy) o #functrans
+      o the_thmproc) thy;
+  in
+    eqns
+    |> apply_functrans thy c functrans
+    |> (map o apfst) (Code.rewrite_eqn pre)
+    |> (map o apfst) (AxClass.unoverload thy)
+    |> map (Code.assert_eqn thy)
+    |> burrow_fst (Code.norm_args thy)
+    |> burrow_fst (Code.norm_varnames thy)
+  end;
+
+fun preprocess_conv thy ct =
+  let
+    val pre = (Simplifier.theory_context thy o #pre o the_thmproc) thy;
+  in
+    ct
+    |> Simplifier.rewrite pre
+    |> rhs_conv (AxClass.unoverload_conv thy)
+  end;
+
+fun postprocess_conv thy ct =
+  let
+    val post = (Simplifier.theory_context thy o #post o the_thmproc) thy;
+  in
+    ct
+    |> AxClass.overload_conv thy
+    |> rhs_conv (Simplifier.rewrite post)
+  end;
+
+fun postprocess_term thy = term_of_conv thy (postprocess_conv thy);
+
+fun print_codeproc thy =
+  let
+    val ctxt = ProofContext.init thy;
+    val pre = (#pre o the_thmproc) thy;
+    val post = (#post o the_thmproc) thy;
+    val functrans = (map fst o #functrans o the_thmproc) thy;
+  in
+    (Pretty.writeln o Pretty.chunks) [
+      Pretty.block [
+        Pretty.str "preprocessing simpset:",
+        Pretty.fbrk,
+        Simplifier.pretty_ss ctxt pre
+      ],
+      Pretty.block [
+        Pretty.str "postprocessing simpset:",
+        Pretty.fbrk,
+        Simplifier.pretty_ss ctxt post
+      ],
+      Pretty.block (
+        Pretty.str "function transformers:"
+        :: Pretty.fbrk
+        :: (Pretty.fbreaks o map Pretty.str) functrans
+      )
+    ]
+  end;
+
+fun simple_functrans f thy eqns = case f thy (map fst eqns)
+ of SOME thms' => SOME (map (rpair (forall snd eqns)) thms')
+  | NONE => NONE;
+
+
+(** sort algebra and code equation graph types **)
+
+type code_algebra = (sort -> sort) * Sorts.algebra;
+type code_graph = (((string * sort) list * typ) * (thm * bool) list) Graph.T;
+
+fun eqns eqngr = these o Option.map snd o try (Graph.get_node eqngr);
+fun typ eqngr = fst o Graph.get_node eqngr;
+fun all eqngr = Graph.keys eqngr;
+
+fun pretty thy eqngr =
+  AList.make (snd o Graph.get_node eqngr) (Graph.keys eqngr)
+  |> (map o apfst) (Code.string_of_const thy)
+  |> sort (string_ord o pairself fst)
+  |> map (fn (s, thms) =>
+       (Pretty.block o Pretty.fbreaks) (
+         Pretty.str s
+         :: map (Display.pretty_thm o fst) thms
+       ))
+  |> Pretty.chunks;
+
+
+(** the Waisenhaus algorithm **)
+
+(* auxiliary *)
+
+fun is_proper_class thy = can (AxClass.get_info thy);
+
+fun complete_proper_sort thy =
+  Sign.complete_sort thy #> filter (is_proper_class thy);
+
+fun inst_params thy tyco =
+  map (fn (c, _) => AxClass.param_of_inst thy (c, tyco))
+    o maps (#params o AxClass.get_info thy);
+
+fun consts_of thy eqns = [] |> (fold o fold o fold_aterms)
+  (fn Const (c, ty) => insert (op =) (c, Sign.const_typargs thy (c, Logic.unvarifyT ty)) | _ => I)
+    (map (op :: o swap o apfst (snd o strip_comb) o Logic.dest_equals o Thm.plain_prop_of o fst) eqns);
+
+fun tyscm_rhss_of thy c eqns =
+  let
+    val tyscm = case eqns of [] => Code.default_typscheme thy c
+      | ((thm, _) :: _) => Code.typscheme_eqn thy thm;
+    val rhss = consts_of thy eqns;
+  in (tyscm, rhss) end;
+
+
+(* data structures *)
+
+datatype const = Fun of string | Inst of class * string;
+
+fun const_ord (Fun c1, Fun c2) = fast_string_ord (c1, c2)
+  | const_ord (Inst class_tyco1, Inst class_tyco2) =
+      prod_ord fast_string_ord fast_string_ord (class_tyco1, class_tyco2)
+  | const_ord (Fun _, Inst _) = LESS
+  | const_ord (Inst _, Fun _) = GREATER;
+
+type var = const * int;
+
+structure Vargraph =
+  GraphFun(type key = var val ord = prod_ord const_ord int_ord);
+
+datatype styp = Tyco of string * styp list | Var of var | Free;
+
+fun styp_of c_lhs (Type (tyco, tys)) = Tyco (tyco, map (styp_of c_lhs) tys)
+  | styp_of c_lhs (TFree (v, _)) = case c_lhs
+     of SOME (c, lhs) => Var (Fun c, find_index (fn (v', _) => v = v') lhs)
+      | NONE => Free;
+
+type vardeps_data = ((string * styp list) list * class list) Vargraph.T
+  * (((string * sort) list * (thm * bool) list) Symtab.table
+    * (class * string) list);
+
+val empty_vardeps_data : vardeps_data =
+  (Vargraph.empty, (Symtab.empty, []));
+
+
+(* retrieving equations and instances from the background context *)
+
+fun obtain_eqns thy eqngr c =
+  case try (Graph.get_node eqngr) c
+   of SOME ((lhs, _), eqns) => ((lhs, []), [])
+    | NONE => let
+        val eqns = Code.these_eqns thy c
+          |> preprocess thy c;
+        val ((lhs, _), rhss) = tyscm_rhss_of thy c eqns;
+      in ((lhs, rhss), eqns) end;
+
+fun obtain_instance thy arities (inst as (class, tyco)) =
+  case AList.lookup (op =) arities inst
+   of SOME classess => (classess, ([], []))
+    | NONE => let
+        val all_classes = complete_proper_sort thy [class];
+        val superclasses = remove (op =) class all_classes
+        val classess = map (complete_proper_sort thy)
+          (Sign.arity_sorts thy tyco [class]);
+        val inst_params = inst_params thy tyco all_classes;
+      in (classess, (superclasses, inst_params)) end;
+
+
+(* computing instantiations *)
+
+fun add_classes thy arities eqngr c_k new_classes vardeps_data =
+  let
+    val (styps, old_classes) = Vargraph.get_node (fst vardeps_data) c_k;
+    val diff_classes = new_classes |> subtract (op =) old_classes;
+  in if null diff_classes then vardeps_data
+  else let
+    val c_ks = Vargraph.imm_succs (fst vardeps_data) c_k |> insert (op =) c_k;
+  in
+    vardeps_data
+    |> (apfst o Vargraph.map_node c_k o apsnd) (append diff_classes)
+    |> fold (fn styp => fold (ensure_typmatch_inst thy arities eqngr styp) new_classes) styps
+    |> fold (fn c_k => add_classes thy arities eqngr c_k diff_classes) c_ks
+  end end
+and add_styp thy arities eqngr c_k tyco_styps vardeps_data =
+  let
+    val (old_styps, classes) = Vargraph.get_node (fst vardeps_data) c_k;
+  in if member (op =) old_styps tyco_styps then vardeps_data
+  else
+    vardeps_data
+    |> (apfst o Vargraph.map_node c_k o apfst) (cons tyco_styps)
+    |> fold (ensure_typmatch_inst thy arities eqngr tyco_styps) classes
+  end
+and add_dep thy arities eqngr c_k c_k' vardeps_data =
+  let
+    val (_, classes) = Vargraph.get_node (fst vardeps_data) c_k;
+  in
+    vardeps_data
+    |> add_classes thy arities eqngr c_k' classes
+    |> apfst (Vargraph.add_edge (c_k, c_k'))
+  end
+and ensure_typmatch_inst thy arities eqngr (tyco, styps) class vardeps_data =
+  if can (Sign.arity_sorts thy tyco) [class]
+  then vardeps_data
+    |> ensure_inst thy arities eqngr (class, tyco)
+    |> fold_index (fn (k, styp) =>
+         ensure_typmatch thy arities eqngr styp (Inst (class, tyco), k)) styps
+  else vardeps_data (*permissive!*)
+and ensure_inst thy arities eqngr (inst as (class, tyco)) (vardeps_data as (_, (_, insts))) =
+  if member (op =) insts inst then vardeps_data
+  else let
+    val (classess, (superclasses, inst_params)) =
+      obtain_instance thy arities inst;
+  in
+    vardeps_data
+    |> (apsnd o apsnd) (insert (op =) inst)
+    |> fold_index (fn (k, _) =>
+         apfst (Vargraph.new_node ((Inst (class, tyco), k), ([] ,[])))) classess
+    |> fold (fn superclass => ensure_inst thy arities eqngr (superclass, tyco)) superclasses
+    |> fold (ensure_fun thy arities eqngr) inst_params
+    |> fold_index (fn (k, classes) =>
+         add_classes thy arities eqngr (Inst (class, tyco), k) classes
+         #> fold (fn superclass =>
+             add_dep thy arities eqngr (Inst (superclass, tyco), k)
+             (Inst (class, tyco), k)) superclasses
+         #> fold (fn inst_param =>
+             add_dep thy arities eqngr (Fun inst_param, k)
+             (Inst (class, tyco), k)
+             ) inst_params
+         ) classess
+  end
+and ensure_typmatch thy arities eqngr (Tyco tyco_styps) c_k vardeps_data =
+      vardeps_data
+      |> add_styp thy arities eqngr c_k tyco_styps
+  | ensure_typmatch thy arities eqngr (Var c_k') c_k vardeps_data =
+      vardeps_data
+      |> add_dep thy arities eqngr c_k c_k'
+  | ensure_typmatch thy arities eqngr Free c_k vardeps_data =
+      vardeps_data
+and ensure_rhs thy arities eqngr (c', styps) vardeps_data =
+  vardeps_data
+  |> ensure_fun thy arities eqngr c'
+  |> fold_index (fn (k, styp) =>
+       ensure_typmatch thy arities eqngr styp (Fun c', k)) styps
+and ensure_fun thy arities eqngr c (vardeps_data as (_, (eqntab, _))) =
+  if Symtab.defined eqntab c then vardeps_data
+  else let
+    val ((lhs, rhss), eqns) = obtain_eqns thy eqngr c;
+    val rhss' = (map o apsnd o map) (styp_of (SOME (c, lhs))) rhss;
+  in
+    vardeps_data
+    |> (apsnd o apfst) (Symtab.update_new (c, (lhs, eqns)))
+    |> fold_index (fn (k, _) =>
+         apfst (Vargraph.new_node ((Fun c, k), ([] ,[])))) lhs
+    |> fold_index (fn (k, (_, sort)) =>
+         add_classes thy arities eqngr (Fun c, k) (complete_proper_sort thy sort)) lhs
+    |> fold (ensure_rhs thy arities eqngr) rhss'
+  end;
+
+
+(* applying instantiations *)
+
+fun dicts_of thy (proj_sort, algebra) (T, sort) =
+  let
+    fun class_relation (x, _) _ = x;
+    fun type_constructor tyco xs class =
+      inst_params thy tyco (Sorts.complete_sort algebra [class])
+        @ (maps o maps) fst xs;
+    fun type_variable (TFree (_, sort)) = map (pair []) (proj_sort sort);
+  in
+    flat (Sorts.of_sort_derivation (Syntax.pp_global thy) algebra
+      { class_relation = class_relation, type_constructor = type_constructor,
+        type_variable = type_variable } (T, proj_sort sort)
+       handle Sorts.CLASS_ERROR _ => [] (*permissive!*))
+  end;
+
+fun add_arity thy vardeps (class, tyco) =
+  AList.default (op =)
+    ((class, tyco), map (fn k => (snd o Vargraph.get_node vardeps) (Inst (class, tyco), k))
+      (0 upto Sign.arity_number thy tyco - 1));
+
+fun add_eqs thy vardeps (c, (proto_lhs, proto_eqns)) (rhss, eqngr) =
+  if can (Graph.get_node eqngr) c then (rhss, eqngr)
+  else let
+    val lhs = map_index (fn (k, (v, _)) =>
+      (v, snd (Vargraph.get_node vardeps (Fun c, k)))) proto_lhs;
+    val inst_tab = Vartab.empty |> fold (fn (v, sort) =>
+      Vartab.update ((v, 0), sort)) lhs;
+    val eqns = proto_eqns
+      |> (map o apfst) (Code.inst_thm thy inst_tab);
+    val (tyscm, rhss') = tyscm_rhss_of thy c eqns;
+    val eqngr' = Graph.new_node (c, (tyscm, eqns)) eqngr;
+  in (map (pair c) rhss' @ rhss, eqngr') end;
+
+fun extend_arities_eqngr thy cs ts (arities, eqngr) =
+  let
+    val cs_rhss = (fold o fold_aterms) (fn Const (c_ty as (c, _)) =>
+      insert (op =) (c, (map (styp_of NONE) o Sign.const_typargs thy) c_ty) | _ => I) ts [];
+    val (vardeps, (eqntab, insts)) = empty_vardeps_data
+      |> fold (ensure_fun thy arities eqngr) cs
+      |> fold (ensure_rhs thy arities eqngr) cs_rhss;
+    val arities' = fold (add_arity thy vardeps) insts arities;
+    val pp = Syntax.pp_global thy;
+    val algebra = Sorts.subalgebra pp (is_proper_class thy)
+      (AList.lookup (op =) arities') (Sign.classes_of thy);
+    val (rhss, eqngr') = Symtab.fold (add_eqs thy vardeps) eqntab ([], eqngr);
+    fun deps_of (c, rhs) = c :: maps (dicts_of thy algebra)
+      (rhs ~~ (map snd o fst o fst o Graph.get_node eqngr') c);
+    val eqngr'' = fold (fn (c, rhs) => fold
+      (curry Graph.add_edge c) (deps_of rhs)) rhss eqngr';
+  in (algebra, (arities', eqngr'')) end;
+
+
+(** store for preprocessed arities and code equations **)
+
+structure Wellsorted = CodeDataFun
+(
+  type T = ((string * class) * sort list) list * code_graph;
+  val empty = ([], Graph.empty);
+  fun purge thy cs (arities, eqngr) =
+    let
+      val del_cs = ((Graph.all_preds eqngr
+        o filter (can (Graph.get_node eqngr))) cs);
+      val del_arities = del_cs
+        |> map_filter (AxClass.inst_of_param thy)
+        |> maps (fn (c, tyco) =>
+             (map (rpair tyco) o Sign.complete_sort thy o the_list
+               o AxClass.class_of_param thy) c);
+      val arities' = fold (AList.delete (op =)) del_arities arities;
+      val eqngr' = Graph.del_nodes del_cs eqngr;
+    in (arities', eqngr') end;
+);
+
+
+(** retrieval and evaluation interfaces **)
+
+fun obtain thy cs ts = apsnd snd
+  (Wellsorted.change_yield thy (extend_arities_eqngr thy cs ts));
+
+fun prepare_sorts_typ prep_sort
+  = map_type_tfree (fn (v, sort) => TFree (v, prep_sort sort));
+
+fun prepare_sorts prep_sort (Const (c, ty)) =
+      Const (c, prepare_sorts_typ prep_sort ty)
+  | prepare_sorts prep_sort (t1 $ t2) =
+      prepare_sorts prep_sort t1 $ prepare_sorts prep_sort t2
+  | prepare_sorts prep_sort (Abs (v, ty, t)) =
+      Abs (v, prepare_sorts_typ prep_sort ty, prepare_sorts prep_sort t)
+  | prepare_sorts _ (t as Bound _) = t;
+
+fun gen_eval thy cterm_of conclude_evaluation prep_sort evaluator proto_ct =
+  let
+    val pp = Syntax.pp_global thy;
+    val ct = cterm_of proto_ct;
+    val _ = (Sign.no_frees pp o map_types (K dummyT) o Sign.no_vars pp)
+      (Thm.term_of ct);
+    val thm = preprocess_conv thy ct;
+    val ct' = Thm.rhs_of thm;
+    val t' = Thm.term_of ct';
+    val vs = Term.add_tfrees t' [];
+    val consts = fold_aterms
+      (fn Const (c, _) => insert (op =) c | _ => I) t' [];
+ 
+    val t'' = prepare_sorts prep_sort t';
+    val (algebra', eqngr') = obtain thy consts [t''];
+  in conclude_evaluation (evaluator algebra' eqngr' vs t'' ct') thm end;
+
+fun simple_evaluator evaluator algebra eqngr vs t ct =
+  evaluator algebra eqngr vs t;
+
+fun eval_conv thy =
+  let
+    fun conclude_evaluation thm2 thm1 =
+      let
+        val thm3 = postprocess_conv thy (Thm.rhs_of thm2);
+      in
+        Thm.transitive thm1 (Thm.transitive thm2 thm3) handle THM _ =>
+          error ("could not construct evaluation proof:\n"
+          ^ (cat_lines o map Display.string_of_thm) [thm1, thm2, thm3])
+      end;
+  in gen_eval thy I conclude_evaluation end;
+
+fun eval thy prep_sort postproc evaluator = gen_eval thy (Thm.cterm_of thy)
+  (K o postproc (postprocess_term thy)) prep_sort (simple_evaluator evaluator);
+
+
+(** setup **)
+
+val setup = 
+  let
+    fun mk_attribute f = Thm.declaration_attribute (fn thm => Context.mapping (f thm) I);
+    fun add_del_attribute (name, (add, del)) =
+      Code.add_attribute (name, Args.del |-- Scan.succeed (mk_attribute del)
+        || Scan.succeed (mk_attribute add))
+  in
+    add_del_attribute ("inline", (add_inline, del_inline))
+    #> add_del_attribute ("post", (add_post, del_post))
+    #> Code.add_attribute ("unfold", Scan.succeed (Thm.declaration_attribute
+       (fn thm => Context.mapping (Codegen.add_unfold thm #> add_inline thm) I)))
+  end;
+
+val _ =
+  OuterSyntax.improper_command "print_codeproc" "print code preprocessor setup"
+  OuterKeyword.diag (Scan.succeed
+      (Toplevel.no_timing o Toplevel.unknown_theory o Toplevel.keep
+        (print_codeproc o Toplevel.theory_of)));
+
+end; (*struct*)

--- a/src/Tools/code/code_printer.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/Tools/code/code_printer.ML	Fri May 15 15:56:28 2009 +0200
@@ -23,6 +23,17 @@
   val intro_vars: string list -> var_ctxt -> var_ctxt
   val lookup_var: var_ctxt -> string -> string
 
+  type literals
+  val Literals: { literal_char: string -> string, literal_string: string -> string,
+        literal_numeral: bool -> int -> string,
+        literal_list: Pretty.T list -> Pretty.T, infix_cons: int * string }
+    -> literals
+  val literal_char: literals -> string -> string
+  val literal_string: literals -> string -> string
+  val literal_numeral: literals -> bool -> int -> string
+  val literal_list: literals -> Pretty.T list -> Pretty.T
+  val infix_cons: literals -> int * string
+
   type lrx
   val L: lrx
   val R: lrx
@@ -41,6 +52,7 @@
   type dict = Code_Thingol.dict
   type tyco_syntax
   type const_syntax
+  type proto_const_syntax
   val parse_infix: ('a -> 'b) -> lrx * int -> string
     -> int * ((fixity -> 'b -> Pretty.T)
     -> fixity -> 'a list -> Pretty.T)
@@ -48,26 +60,18 @@
     -> (int * ((fixity -> 'b -> Pretty.T)
     -> fixity -> 'a list -> Pretty.T)) option * OuterParse.token list
   val simple_const_syntax: (int * ((fixity -> iterm -> Pretty.T)
-    -> fixity -> (iterm * itype) list -> Pretty.T)) option -> const_syntax option
+    -> fixity -> (iterm * itype) list -> Pretty.T)) option -> proto_const_syntax option
+  val activate_const_syntax: theory -> literals
+    -> proto_const_syntax -> Code_Thingol.naming -> const_syntax * Code_Thingol.naming
   val gen_pr_app: (thm -> var_ctxt -> const * iterm list -> Pretty.T list)
     -> (thm -> var_ctxt -> fixity -> iterm -> Pretty.T)
-    -> (string -> const_syntax option) -> Code_Thingol.naming
+    -> (string -> const_syntax option)
     -> thm -> var_ctxt -> fixity -> const * iterm list -> Pretty.T
   val gen_pr_bind: ((string option * Pretty.T option) * itype -> Pretty.T)
     -> (thm -> var_ctxt -> fixity -> iterm -> Pretty.T)
     -> thm -> fixity
     -> (string option * iterm option) * itype -> var_ctxt -> Pretty.T * var_ctxt
 
-  type literals
-  val Literals: { literal_char: string -> string, literal_string: string -> string,
-        literal_numeral: bool -> int -> string, literal_list: Pretty.T list -> Pretty.T, infix_cons: int * string }
-    -> literals
-  val literal_char: literals -> string -> string
-  val literal_string: literals -> string -> string
-  val literal_numeral: literals -> bool -> int -> string
-  val literal_list: literals -> Pretty.T list -> Pretty.T
-  val infix_cons: literals -> int * string
-
   val mk_name_module: Name.context -> string option -> (string -> string option)
     -> 'a Graph.T -> string -> string
   val dest_name: string -> string * string
@@ -115,6 +119,25 @@
 val first_lower = implode o nth_map 0 Symbol.to_ascii_lower o explode;
 
 
+(** pretty literals **)
+
+datatype literals = Literals of {
+  literal_char: string -> string,
+  literal_string: string -> string,
+  literal_numeral: bool -> int -> string,
+  literal_list: Pretty.T list -> Pretty.T,
+  infix_cons: int * string
+};
+
+fun dest_Literals (Literals lits) = lits;
+
+val literal_char = #literal_char o dest_Literals;
+val literal_string = #literal_string o dest_Literals;
+val literal_numeral = #literal_numeral o dest_Literals;
+val literal_list = #literal_list o dest_Literals;
+val infix_cons = #infix_cons o dest_Literals;
+
+
 (** syntax printer **)
 
 (* binding priorities *)
@@ -158,17 +181,25 @@
 type tyco_syntax = int * ((fixity -> itype -> Pretty.T)
   -> fixity -> itype list -> Pretty.T);
 type const_syntax = int * ((var_ctxt -> fixity -> iterm -> Pretty.T)
-  -> Code_Thingol.naming -> thm -> var_ctxt -> fixity -> (iterm * itype) list -> Pretty.T);
+  -> thm -> var_ctxt -> fixity -> (iterm * itype) list -> Pretty.T);
+type proto_const_syntax = int * (string list * (literals -> string list
+  -> (var_ctxt -> fixity -> iterm -> Pretty.T)
+    -> thm -> var_ctxt -> fixity -> (iterm * itype) list -> Pretty.T));
 
-fun simple_const_syntax x = (Option.map o apsnd)
-  (fn pretty => fn pr => fn naming => fn thm => fn vars => pretty (pr vars)) x;
+fun simple_const_syntax (SOME (n, f)) = SOME (n,
+      ([], (fn _ => fn _ => fn pr => fn thm => fn vars => f (pr vars))))
+  | simple_const_syntax NONE = NONE;
 
-fun gen_pr_app pr_app pr_term syntax_const naming thm vars fxy (app as ((c, (_, tys)), ts)) =
+fun activate_const_syntax thy literals (n, (cs, f)) naming =
+  fold_map (Code_Thingol.ensure_declared_const thy) cs naming
+  |-> (fn cs' => pair (n, f literals cs'));
+
+fun gen_pr_app pr_app pr_term syntax_const thm vars fxy (app as ((c, (_, tys)), ts)) =
   case syntax_const c
    of NONE => brackify fxy (pr_app thm vars app)
     | SOME (k, pr) =>
         let
-          fun pr' fxy ts = pr (pr_term thm) naming thm vars fxy (ts ~~ curry Library.take k tys);
+          fun pr' fxy ts = pr (pr_term thm) thm vars fxy (ts ~~ curry Library.take k tys);
         in if k = length ts
           then pr' fxy ts
         else if k < length ts
@@ -253,25 +284,6 @@
 val _ = List.app OuterKeyword.keyword [infixK, infixlK, infixrK];
 
 
-(** pretty literals **)
-
-datatype literals = Literals of {
-  literal_char: string -> string,
-  literal_string: string -> string,
-  literal_numeral: bool -> int -> string,
-  literal_list: Pretty.T list -> Pretty.T,
-  infix_cons: int * string
-};
-
-fun dest_Literals (Literals lits) = lits;
-
-val literal_char = #literal_char o dest_Literals;
-val literal_string = #literal_string o dest_Literals;
-val literal_numeral = #literal_numeral o dest_Literals;
-val literal_list = #literal_list o dest_Literals;
-val infix_cons = #infix_cons o dest_Literals;
-
-
 (** module name spaces **)
 
 val dest_name =

--- a/src/Tools/code/code_target.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/Tools/code/code_target.ML	Fri May 15 15:56:28 2009 +0200
@@ -44,7 +44,7 @@
   val add_syntax_class: string -> class -> string option -> theory -> theory
   val add_syntax_inst: string -> string * class -> bool -> theory -> theory
   val add_syntax_tyco: string -> string -> tyco_syntax option -> theory -> theory
-  val add_syntax_const: string -> string -> const_syntax option -> theory -> theory
+  val add_syntax_const: string -> string -> proto_const_syntax option -> theory -> theory
   val add_reserved: string -> string -> theory -> theory
 end;
 
@@ -68,7 +68,7 @@
 fun compile f = (code_setmp f Compile; ());
 fun export f = (code_setmp f Export; ());
 fun file p f = (code_setmp f (File p); ());
-fun string cs f = fst (the (code_setmp f (String cs)));
+fun string stmts f = fst (the (code_setmp f (String stmts)));
 
 fun stmt_names_of_destination (String stmts) = stmts
   | stmt_names_of_destination _ = [];
@@ -86,7 +86,7 @@
   class: string Symtab.table,
   instance: unit Symreltab.table,
   tyco: tyco_syntax Symtab.table,
-  const: const_syntax Symtab.table
+  const: proto_const_syntax Symtab.table
 };
 
 fun mk_name_syntax_table ((class, instance), (tyco, const)) =
@@ -112,7 +112,6 @@
   -> (string -> string option)          (*class syntax*)
   -> (string -> tyco_syntax option)
   -> (string -> const_syntax option)
-  -> Code_Thingol.naming
   -> Code_Thingol.program
   -> string list                        (*selected statements*)
   -> serialization;
@@ -287,7 +286,7 @@
 fun gen_add_syntax_const prep_const target raw_c raw_syn thy =
   let
     val c = prep_const thy raw_c;
-    fun check_args (syntax as (n, _)) = if n > Code_Unit.no_args thy c
+    fun check_args (syntax as (n, _)) = if n > Code.no_args thy c
       then error ("Too many arguments in syntax for constant " ^ quote c)
       else syntax;
   in case raw_syn
@@ -320,11 +319,18 @@
       | add (name, NONE) incls = Symtab.delete name incls;
   in map_includes target (add args) thy end;
 
-val add_include = gen_add_include Code_Unit.check_const;
-val add_include_cmd = gen_add_include Code_Unit.read_const;
+val add_include = gen_add_include Code.check_const;
+val add_include_cmd = gen_add_include Code.read_const;
 
-fun add_module_alias target =
-  map_module_alias target o Symtab.update o apsnd Code_Name.check_modulename;
+fun add_module_alias target (thyname, modlname) =
+  let
+    val xs = Long_Name.explode modlname;
+    val xs' = map (Name.desymbolize true) xs;
+  in if xs' = xs
+    then map_module_alias target (Symtab.update (thyname, modlname))
+    else error ("Invalid module name: " ^ quote modlname ^ "\n"
+      ^ "perhaps try " ^ quote (Long_Name.implode xs'))
+  end;
 
 fun gen_allow_abort prep_const raw_c thy =
   let
@@ -357,11 +363,11 @@
 val allow_abort = gen_allow_abort (K I);
 val add_reserved = add_reserved;
 
-val add_syntax_class_cmd = gen_add_syntax_class read_class Code_Unit.read_const;
+val add_syntax_class_cmd = gen_add_syntax_class read_class Code.read_const;
 val add_syntax_inst_cmd = gen_add_syntax_inst read_class read_tyco;
 val add_syntax_tyco_cmd = gen_add_syntax_tyco read_tyco;
-val add_syntax_const_cmd = gen_add_syntax_const Code_Unit.read_const;
-val allow_abort_cmd = gen_allow_abort Code_Unit.read_const;
+val add_syntax_const_cmd = gen_add_syntax_const Code.read_const;
+val allow_abort_cmd = gen_allow_abort Code.read_const;
 
 fun the_literals thy =
   let
@@ -381,33 +387,48 @@
 local
 
 fun labelled_name thy program name = case Graph.get_node program name
- of Code_Thingol.Fun (c, _) => quote (Code_Unit.string_of_const thy c)
+ of Code_Thingol.Fun (c, _) => quote (Code.string_of_const thy c)
   | Code_Thingol.Datatype (tyco, _) => "type " ^ quote (Sign.extern_type thy tyco)
-  | Code_Thingol.Datatypecons (c, _) => quote (Code_Unit.string_of_const thy c)
+  | Code_Thingol.Datatypecons (c, _) => quote (Code.string_of_const thy c)
   | Code_Thingol.Class (class, _) => "class " ^ quote (Sign.extern_class thy class)
   | Code_Thingol.Classrel (sub, super) => let
         val Code_Thingol.Class (sub, _) = Graph.get_node program sub
         val Code_Thingol.Class (super, _) = Graph.get_node program super
       in quote (Sign.extern_class thy sub ^ " < " ^ Sign.extern_class thy super) end
-  | Code_Thingol.Classparam (c, _) => quote (Code_Unit.string_of_const thy c)
+  | Code_Thingol.Classparam (c, _) => quote (Code.string_of_const thy c)
   | Code_Thingol.Classinst ((class, (tyco, _)), _) => let
         val Code_Thingol.Class (class, _) = Graph.get_node program class
         val Code_Thingol.Datatype (tyco, _) = Graph.get_node program tyco
       in quote (Sign.extern_type thy tyco ^ " :: " ^ Sign.extern_class thy class) end
 
-fun invoke_serializer thy abortable serializer reserved abs_includes 
+fun activate_syntax lookup_name src_tab = Symtab.empty
+  |> fold_map (fn thing_identifier => fn tab => case lookup_name thing_identifier
+       of SOME name => (SOME name,
+            Symtab.update_new (name, the (Symtab.lookup src_tab thing_identifier)) tab)
+        | NONE => (NONE, tab)) (Symtab.keys src_tab)
+  |>> map_filter I;
+
+fun activate_const_syntax thy literals src_tab naming = (Symtab.empty, naming)
+  |> fold_map (fn thing_identifier => fn (tab, naming) =>
+      case Code_Thingol.lookup_const naming thing_identifier
+       of SOME name => let
+              val (syn, naming') = Code_Printer.activate_const_syntax thy
+                literals (the (Symtab.lookup src_tab thing_identifier)) naming
+            in (SOME name, (Symtab.update_new (name, syn) tab, naming')) end
+        | NONE => (NONE, (tab, naming))) (Symtab.keys src_tab)
+  |>> map_filter I;
+
+fun invoke_serializer thy abortable serializer literals reserved abs_includes 
     module_alias class instance tyco const module args naming program2 names1 =
   let
-    fun distill_names lookup_name src_tab = Symtab.empty
-      |> fold_map (fn thing_identifier => fn tab => case lookup_name naming thing_identifier
-           of SOME name => (SOME name, Symtab.update_new (name, the (Symtab.lookup src_tab thing_identifier)) tab)
-            | NONE => (NONE, tab)) (Symtab.keys src_tab)
-      |>> map_filter I;
-    val (names_class, class') = distill_names Code_Thingol.lookup_class class;
+    val (names_class, class') =
+      activate_syntax (Code_Thingol.lookup_class naming) class;
     val names_inst = map_filter (Code_Thingol.lookup_instance naming)
       (Symreltab.keys instance);
-    val (names_tyco, tyco') = distill_names Code_Thingol.lookup_tyco tyco;
-    val (names_const, const') = distill_names Code_Thingol.lookup_const const;
+    val (names_tyco, tyco') =
+      activate_syntax (Code_Thingol.lookup_tyco naming) tyco;
+    val (names_const, (const', _)) =
+      activate_const_syntax thy literals const naming;
     val names_hidden = names_class @ names_inst @ names_tyco @ names_const;
     val names2 = subtract (op =) names_hidden names1;
     val program3 = Graph.subgraph (not o member (op =) names_hidden) program2;
@@ -422,7 +443,7 @@
     serializer module args (labelled_name thy program2) reserved includes
       (Symtab.lookup module_alias) (Symtab.lookup class')
       (Symtab.lookup tyco') (Symtab.lookup const')
-      naming program4 names2
+      program4 names2
   end;
 
 fun mount_serializer thy alt_serializer target module args naming program names =
@@ -453,8 +474,9 @@
       ((Symtab.dest o the_includes) data);
     val module_alias = the_module_alias data;
     val { class, instance, tyco, const } = the_name_syntax data;
+    val literals = the_literals thy target;
   in
-    invoke_serializer thy abortable serializer reserved
+    invoke_serializer thy abortable serializer literals reserved
       includes module_alias class instance tyco const module args naming (modify program) names
   end;
 
@@ -495,7 +517,7 @@
 
 fun read_const_exprs thy cs =
   let
-    val (cs1, cs2) = Code_Name.read_const_exprs thy cs;
+    val (cs1, cs2) = Code_Thingol.read_const_exprs thy cs;
     val (names3, (naming, program)) = Code_Thingol.consts_program thy cs2;
     val names4 = transitivly_non_empty_funs thy naming program;
     val cs5 = map_filter

--- a/src/Tools/code/code_thingol.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/Tools/code/code_thingol.ML	Fri May 15 15:56:28 2009 +0200
@@ -20,7 +20,7 @@
   datatype itype =
       `%% of string * itype list
     | ITyVar of vname;
-  type const = string * (dict list list * itype list (*types of arguments*))
+  type const = string * ((itype list * dict list list) * itype list (*types of arguments*))
   datatype iterm =
       IConst of const
     | IVar of vname
@@ -44,11 +44,10 @@
   val unfold_abs: iterm -> ((vname * iterm option) * itype) list * iterm
   val split_let: iterm -> (((iterm * itype) * iterm) * iterm) option
   val unfold_let: iterm -> ((iterm * itype) * iterm) list * iterm
-  val unfold_const_app: iterm ->
-    ((string * (dict list list * itype list)) * iterm list) option
+  val unfold_const_app: iterm -> (const * iterm list) option
   val collapse_let: ((vname * itype) * iterm) * iterm
     -> (iterm * itype) * (iterm * iterm) list
-  val eta_expand: int -> (string * (dict list list * itype list)) * iterm list -> iterm
+  val eta_expand: int -> const * iterm list -> iterm
   val contains_dictvar: iterm -> bool
   val locally_monomorphic: iterm -> bool
   val fold_constnames: (string -> 'a -> 'a) -> iterm -> 'a -> 'a
@@ -62,6 +61,7 @@
   val lookup_tyco: naming -> string -> string option
   val lookup_instance: naming -> class * string -> string option
   val lookup_const: naming -> string -> string option
+  val ensure_declared_const: theory -> string -> naming -> string * naming
 
   datatype stmt =
       NoStmt
@@ -81,13 +81,14 @@
   val is_cons: program -> string -> bool
   val contr_classparam_typs: program -> string -> itype option list
 
+  val read_const_exprs: theory -> string list -> string list * string list
   val consts_program: theory -> string list -> string list * (naming * program)
   val cached_program: theory -> naming * program
-  val eval_conv: theory
-    -> (term -> term * (naming -> program -> typscheme * iterm -> string list -> thm))
+  val eval_conv: theory -> (sort -> sort)
+    -> (naming -> program -> ((string * sort) list * typscheme) * iterm -> string list -> cterm -> thm)
     -> cterm -> thm
-  val eval_term: theory
-    -> (term -> term * (naming -> program -> typscheme * iterm -> string list -> 'a))
+  val eval: theory -> (sort -> sort) -> ((term -> term) -> 'a -> 'a)
+    -> (naming -> program -> ((string * sort) list * typscheme) * iterm -> string list -> 'a)
     -> term -> 'a
 end;
 
@@ -121,7 +122,7 @@
     `%% of string * itype list
   | ITyVar of vname;
 
-type const = string * (dict list list * itype list (*types of arguments*))
+type const = string * ((itype list * dict list list) * itype list (*types of arguments*))
 
 datatype iterm =
     IConst of const
@@ -211,7 +212,7 @@
       | contains (DictVar _) = K true;
   in
     fold_aiterms
-      (fn IConst (_, (dss, _)) => (fold o fold) contains dss | _ => I) t false
+      (fn IConst (_, ((_, dss), _)) => (fold o fold) contains dss | _ => I) t false
   end;
   
 fun locally_monomorphic (IConst _) = false
@@ -239,10 +240,18 @@
     | NONE => (case Code.get_datatype_of_constr thy c
        of SOME dtco => thyname_of_tyco thy dtco
         | NONE => thyname_of thy (Consts.the_tags (Sign.consts_of thy)) c);
+  fun purify_base "op &" = "and"
+    | purify_base "op |" = "or"
+    | purify_base "op -->" = "implies"
+    | purify_base "op :" = "member"
+    | purify_base "op =" = "eq"
+    | purify_base "*" = "product"
+    | purify_base "+" = "sum"
+    | purify_base s = Name.desymbolize false s;
   fun namify thy get_basename get_thyname name =
     let
       val prefix = get_thyname thy name;
-      val base = (Code_Name.purify_base o get_basename) name;
+      val base = (purify_base o get_basename) name;
     in Long_Name.append prefix base end;
 in
 
@@ -351,6 +360,11 @@
 fun declare_const thy = declare thy map_const
   lookup_const Symtab.update_new namify_const;
 
+fun ensure_declared_const thy const naming =
+  case lookup_const naming const
+   of SOME const' => (const', naming)
+    | NONE => declare_const thy const naming;
+
 val unfold_fun = unfoldr
   (fn "Pure.fun.tyco" `%% [ty1, ty2] => SOME (ty1, ty2)
     | _ => NONE); (*depends on suffix_tyco and namify_tyco!*)
@@ -459,7 +473,45 @@
 
 (* translation *)
 
-fun ensure_class thy (algbr as (_, algebra)) funcgr class =
+fun ensure_tyco thy algbr funcgr tyco =
+  let
+    val stmt_datatype =
+      let
+        val (vs, cos) = Code.get_datatype thy tyco;
+      in
+        fold_map (translate_tyvar_sort thy algbr funcgr) vs
+        ##>> fold_map (fn (c, tys) =>
+          ensure_const thy algbr funcgr c
+          ##>> fold_map (translate_typ thy algbr funcgr) tys) cos
+        #>> (fn info => Datatype (tyco, info))
+      end;
+  in ensure_stmt lookup_tyco (declare_tyco thy) stmt_datatype tyco end
+and ensure_const thy algbr funcgr c =
+  let
+    fun stmt_datatypecons tyco =
+      ensure_tyco thy algbr funcgr tyco
+      #>> (fn tyco => Datatypecons (c, tyco));
+    fun stmt_classparam class =
+      ensure_class thy algbr funcgr class
+      #>> (fn class => Classparam (c, class));
+    fun stmt_fun ((vs, ty), raw_thms) =
+      let
+        val thms = if null (Term.add_tfreesT ty []) orelse (null o fst o strip_type) ty
+          then raw_thms
+          else (map o apfst) (Code.expand_eta thy 1) raw_thms;
+      in
+        fold_map (translate_tyvar_sort thy algbr funcgr) vs
+        ##>> translate_typ thy algbr funcgr ty
+        ##>> fold_map (translate_eq thy algbr funcgr) thms
+        #>> (fn info => Fun (c, info))
+      end;
+    val stmt_const = case Code.get_datatype_of_constr thy c
+     of SOME tyco => stmt_datatypecons tyco
+      | NONE => (case AxClass.class_of_param thy c
+         of SOME class => stmt_classparam class
+          | NONE => stmt_fun (Code_Preproc.typ funcgr c, Code_Preproc.eqns funcgr c))
+  in ensure_stmt lookup_const (declare_const thy) stmt_const c end
+and ensure_class thy (algbr as (_, algebra)) funcgr class =
   let
     val superclasses = (Sorts.minimize_sort algebra o Sorts.super_classes algebra) class;
     val cs = #params (AxClass.get_info thy class);
@@ -477,65 +529,6 @@
       ##>> ensure_class thy algbr funcgr superclass
       #>> Classrel;
   in ensure_stmt lookup_classrel (declare_classrel thy) stmt_classrel (subclass, superclass) end
-and ensure_tyco thy algbr funcgr tyco =
-  let
-    val stmt_datatype =
-      let
-        val (vs, cos) = Code.get_datatype thy tyco;
-      in
-        fold_map (translate_tyvar_sort thy algbr funcgr) vs
-        ##>> fold_map (fn (c, tys) =>
-          ensure_const thy algbr funcgr c
-          ##>> fold_map (translate_typ thy algbr funcgr) tys) cos
-        #>> (fn info => Datatype (tyco, info))
-      end;
-  in ensure_stmt lookup_tyco (declare_tyco thy) stmt_datatype tyco end
-and translate_tyvar_sort thy (algbr as (proj_sort, _)) funcgr (v, sort) =
-  fold_map (ensure_class thy algbr funcgr) (proj_sort sort)
-  #>> (fn sort => (unprefix "'" v, sort))
-and translate_typ thy algbr funcgr (TFree (v, _)) =
-      pair (ITyVar (unprefix "'" v))
-  | translate_typ thy algbr funcgr (Type (tyco, tys)) =
-      ensure_tyco thy algbr funcgr tyco
-      ##>> fold_map (translate_typ thy algbr funcgr) tys
-      #>> (fn (tyco, tys) => tyco `%% tys)
-and translate_dicts thy (algbr as (proj_sort, algebra)) funcgr thm (ty, sort) =
-  let
-    val pp = Syntax.pp_global thy;
-    datatype typarg =
-        Global of (class * string) * typarg list list
-      | Local of (class * class) list * (string * (int * sort));
-    fun class_relation (Global ((_, tyco), yss), _) class =
-          Global ((class, tyco), yss)
-      | class_relation (Local (classrels, v), subclass) superclass =
-          Local ((subclass, superclass) :: classrels, v);
-    fun type_constructor tyco yss class =
-      Global ((class, tyco), (map o map) fst yss);
-    fun type_variable (TFree (v, sort)) =
-      let
-        val sort' = proj_sort sort;
-      in map_index (fn (n, class) => (Local ([], (v, (n, sort'))), class)) sort' end;
-    val typargs = Sorts.of_sort_derivation pp algebra
-      {class_relation = class_relation, type_constructor = type_constructor,
-       type_variable = type_variable} (ty, proj_sort sort)
-      handle Sorts.CLASS_ERROR e => not_wellsorted thy thm ty sort e;
-    fun mk_dict (Global (inst, yss)) =
-          ensure_inst thy algbr funcgr inst
-          ##>> (fold_map o fold_map) mk_dict yss
-          #>> (fn (inst, dss) => DictConst (inst, dss))
-      | mk_dict (Local (classrels, (v, (k, sort)))) =
-          fold_map (ensure_classrel thy algbr funcgr) classrels
-          #>> (fn classrels => DictVar (classrels, (unprefix "'" v, (k, length sort))))
-  in fold_map mk_dict typargs end
-and translate_eq thy algbr funcgr (thm, linear) =
-  let
-    val (args, rhs) = (apfst (snd o strip_comb) o Logic.dest_equals
-      o Logic.unvarify o prop_of) thm;
-  in
-    fold_map (translate_term thy algbr funcgr (SOME thm)) args
-    ##>> translate_term thy algbr funcgr (SOME thm) rhs
-    #>> rpair (thm, linear)
-  end
 and ensure_inst thy (algbr as (_, algebra)) funcgr (class, tyco) =
   let
     val superclasses = (Sorts.minimize_sort algebra o Sorts.super_classes algebra) class;
@@ -572,31 +565,12 @@
       #>> (fn ((((class, tyco), arity), superarities), classparams) =>
              Classinst ((class, (tyco, arity)), (superarities, classparams)));
   in ensure_stmt lookup_instance (declare_instance thy) stmt_inst (class, tyco) end
-and ensure_const thy algbr funcgr c =
-  let
-    fun stmt_datatypecons tyco =
+and translate_typ thy algbr funcgr (TFree (v, _)) =
+      pair (ITyVar (unprefix "'" v))
+  | translate_typ thy algbr funcgr (Type (tyco, tys)) =
       ensure_tyco thy algbr funcgr tyco
-      #>> (fn tyco => Datatypecons (c, tyco));
-    fun stmt_classparam class =
-      ensure_class thy algbr funcgr class
-      #>> (fn class => Classparam (c, class));
-    fun stmt_fun ((vs, ty), raw_thms) =
-      let
-        val thms = if null (Term.add_tfreesT ty []) orelse (null o fst o strip_type) ty
-          then raw_thms
-          else (map o apfst) (Code_Unit.expand_eta thy 1) raw_thms;
-      in
-        fold_map (translate_tyvar_sort thy algbr funcgr) vs
-        ##>> translate_typ thy algbr funcgr ty
-        ##>> fold_map (translate_eq thy algbr funcgr) thms
-        #>> (fn info => Fun (c, info))
-      end;
-    val stmt_const = case Code.get_datatype_of_constr thy c
-     of SOME tyco => stmt_datatypecons tyco
-      | NONE => (case AxClass.class_of_param thy c
-         of SOME class => stmt_classparam class
-          | NONE => stmt_fun (Code_Wellsorted.typ funcgr c, Code_Wellsorted.eqns funcgr c))
-  in ensure_stmt lookup_const (declare_const thy) stmt_const c end
+      ##>> fold_map (translate_typ thy algbr funcgr) tys
+      #>> (fn (tyco, tys) => tyco `%% tys)
 and translate_term thy algbr funcgr thm (Const (c, ty)) =
       translate_app thy algbr funcgr thm ((c, ty), [])
   | translate_term thy algbr funcgr thm (Free (v, _)) =
@@ -617,16 +591,26 @@
             translate_term thy algbr funcgr thm t'
             ##>> fold_map (translate_term thy algbr funcgr thm) ts
             #>> (fn (t, ts) => t `$$ ts)
+and translate_eq thy algbr funcgr (thm, proper) =
+  let
+    val (args, rhs) = (apfst (snd o strip_comb) o Logic.dest_equals
+      o Logic.unvarify o prop_of) thm;
+  in
+    fold_map (translate_term thy algbr funcgr (SOME thm)) args
+    ##>> translate_term thy algbr funcgr (SOME thm) rhs
+    #>> rpair (thm, proper)
+  end
 and translate_const thy algbr funcgr thm (c, ty) =
   let
     val tys = Sign.const_typargs thy (c, ty);
-    val sorts = (map snd o fst o Code_Wellsorted.typ funcgr) c;
+    val sorts = (map snd o fst o Code_Preproc.typ funcgr) c;
     val tys_args = (fst o Term.strip_type) ty;
   in
     ensure_const thy algbr funcgr c
+    ##>> fold_map (translate_typ thy algbr funcgr) tys
     ##>> fold_map (translate_dicts thy algbr funcgr thm) (tys ~~ sorts)
     ##>> fold_map (translate_typ thy algbr funcgr) tys_args
-    #>> (fn ((c, iss), tys) => IConst (c, (iss, tys)))
+    #>> (fn (((c, tys), iss), tys_args) => IConst (c, ((tys, iss), tys_args)))
   end
 and translate_app_const thy algbr funcgr thm (c_ty, ts) =
   translate_const thy algbr funcgr thm c_ty
@@ -650,7 +634,7 @@
         Term.strip_abs_eta 1 (the_single ts_clause)
       in [(true, (Free v_ty, body))] end
       else map (uncurry mk_clause)
-        (AList.make (Code_Unit.no_args thy) case_pats ~~ ts_clause);
+        (AList.make (Code.no_args thy) case_pats ~~ ts_clause);
     fun retermify ty (_, (IVar x, body)) =
           (x, ty) `|-> body
       | retermify _ (_, (pat, body)) =
@@ -695,7 +679,38 @@
 and translate_app thy algbr funcgr thm (c_ty_ts as ((c, _), _)) =
   case Code.get_case_scheme thy c
    of SOME case_scheme => translate_app_case thy algbr funcgr thm case_scheme c_ty_ts
-    | NONE => translate_app_const thy algbr funcgr thm c_ty_ts;
+    | NONE => translate_app_const thy algbr funcgr thm c_ty_ts
+and translate_tyvar_sort thy (algbr as (proj_sort, _)) funcgr (v, sort) =
+  fold_map (ensure_class thy algbr funcgr) (proj_sort sort)
+  #>> (fn sort => (unprefix "'" v, sort))
+and translate_dicts thy (algbr as (proj_sort, algebra)) funcgr thm (ty, sort) =
+  let
+    val pp = Syntax.pp_global thy;
+    datatype typarg =
+        Global of (class * string) * typarg list list
+      | Local of (class * class) list * (string * (int * sort));
+    fun class_relation (Global ((_, tyco), yss), _) class =
+          Global ((class, tyco), yss)
+      | class_relation (Local (classrels, v), subclass) superclass =
+          Local ((subclass, superclass) :: classrels, v);
+    fun type_constructor tyco yss class =
+      Global ((class, tyco), (map o map) fst yss);
+    fun type_variable (TFree (v, sort)) =
+      let
+        val sort' = proj_sort sort;
+      in map_index (fn (n, class) => (Local ([], (v, (n, sort'))), class)) sort' end;
+    val typargs = Sorts.of_sort_derivation pp algebra
+      {class_relation = class_relation, type_constructor = type_constructor,
+       type_variable = type_variable} (ty, proj_sort sort)
+      handle Sorts.CLASS_ERROR e => not_wellsorted thy thm ty sort e;
+    fun mk_dict (Global (inst, yss)) =
+          ensure_inst thy algbr funcgr inst
+          ##>> (fold_map o fold_map) mk_dict yss
+          #>> (fn (inst, dss) => DictConst (inst, dss))
+      | mk_dict (Local (classrels, (v, (k, sort)))) =
+          fold_map (ensure_classrel thy algbr funcgr) classrels
+          #>> (fn classrels => DictVar (classrels, (unprefix "'" v, (k, length sort))))
+  in fold_map mk_dict typargs end;
 
 
 (* store *)
@@ -733,14 +748,14 @@
     fun generate_consts thy algebra funcgr =
       fold_map (ensure_const thy algebra funcgr);
   in
-    invoke_generation thy (Code_Wellsorted.make thy cs) generate_consts cs
+    invoke_generation thy (Code_Preproc.obtain thy cs []) generate_consts cs
     |-> project_consts
   end;
 
 
 (* value evaluation *)
 
-fun ensure_value thy algbr funcgr t = 
+fun ensure_value thy algbr funcgr t =
   let
     val ty = fastype_of t;
     val vs = fold_term_types (K (fold_atyps (insert (eq_fst op =)
@@ -753,31 +768,107 @@
         (Term.dummy_patternN, ((vs, ty), [(([], t), (Drule.dummy_thm, true))])));
     fun term_value (dep, (naming, program1)) =
       let
-        val Fun (_, ((vs, ty), [(([], t), _)])) =
+        val Fun (_, (vs_ty, [(([], t), _)])) =
           Graph.get_node program1 Term.dummy_patternN;
         val deps = Graph.imm_succs program1 Term.dummy_patternN;
         val program2 = Graph.del_nodes [Term.dummy_patternN] program1;
         val deps_all = Graph.all_succs program2 deps;
         val program3 = Graph.subgraph (member (op =) deps_all) program2;
-      in (((naming, program3), (((vs, ty), t), deps)), (dep, (naming, program2))) end;
+      in (((naming, program3), ((vs_ty, t), deps)), (dep, (naming, program2))) end;
   in
     ensure_stmt ((K o K) NONE) pair stmt_value Term.dummy_patternN
     #> snd
     #> term_value
   end;
 
-fun eval thy evaluator t =
+fun base_evaluator thy evaluator algebra funcgr vs t =
   let
-    val (t', evaluator'') = evaluator t;
-    fun evaluator' algebra funcgr =
+    val (((naming, program), (((vs', ty'), t'), deps)), _) =
+      invoke_generation thy (algebra, funcgr) ensure_value t;
+    val vs'' = map (fn (v, _) => (v, (the o AList.lookup (op =) vs o prefix "'") v)) vs';
+  in evaluator naming program ((vs'', (vs', ty')), t') deps end;
+
+fun eval_conv thy prep_sort = Code_Preproc.eval_conv thy prep_sort o base_evaluator thy;
+fun eval thy prep_sort postproc = Code_Preproc.eval thy prep_sort postproc o base_evaluator thy;
+
+
+(** diagnostic commands **)
+
+fun read_const_exprs thy =
+  let
+    fun consts_of some_thyname =
       let
-        val (((naming, program), (vs_ty_t, deps)), _) =
-          invoke_generation thy (algebra, funcgr) ensure_value t';
-      in evaluator'' naming program vs_ty_t deps end;
-  in (t', evaluator') end
+        val thy' = case some_thyname
+         of SOME thyname => ThyInfo.the_theory thyname thy
+          | NONE => thy;
+        val cs = Symtab.fold (fn (c, (_, NONE)) => cons c | _ => I)
+          ((snd o #constants o Consts.dest o #consts o Sign.rep_sg) thy') [];
+        fun belongs_here c =
+          not (exists (fn thy'' => Sign.declared_const thy'' c) (Theory.parents_of thy'))
+      in case some_thyname
+       of NONE => cs
+        | SOME thyname => filter belongs_here cs
+      end;
+    fun read_const_expr "*" = ([], consts_of NONE)
+      | read_const_expr s = if String.isSuffix ".*" s
+          then ([], consts_of (SOME (unsuffix ".*" s)))
+          else ([Code.read_const thy s], []);
+  in pairself flat o split_list o map read_const_expr end;
+
+fun code_depgr thy consts =
+  let
+    val (_, eqngr) = Code_Preproc.obtain thy consts [];
+    val select = Graph.all_succs eqngr consts;
+  in
+    eqngr
+    |> not (null consts) ? Graph.subgraph (member (op =) select) 
+    |> Graph.map_nodes ((apsnd o map o apfst) (AxClass.overload thy))
+  end;
+
+fun code_thms thy = Pretty.writeln o Code_Preproc.pretty thy o code_depgr thy;
 
-fun eval_conv thy = Code_Wellsorted.eval_conv thy o eval thy;
-fun eval_term thy = Code_Wellsorted.eval_term thy o eval thy;
+fun code_deps thy consts =
+  let
+    val eqngr = code_depgr thy consts;
+    val constss = Graph.strong_conn eqngr;
+    val mapping = Symtab.empty |> fold (fn consts => fold (fn const =>
+      Symtab.update (const, consts)) consts) constss;
+    fun succs consts = consts
+      |> maps (Graph.imm_succs eqngr)
+      |> subtract (op =) consts
+      |> map (the o Symtab.lookup mapping)
+      |> distinct (op =);
+    val conn = [] |> fold (fn consts => cons (consts, succs consts)) constss;
+    fun namify consts = map (Code.string_of_const thy) consts
+      |> commas;
+    val prgr = map (fn (consts, constss) =>
+      { name = namify consts, ID = namify consts, dir = "", unfold = true,
+        path = "", parents = map namify constss }) conn;
+  in Present.display_graph prgr end;
+
+local
+
+structure P = OuterParse
+and K = OuterKeyword
+
+fun code_thms_cmd thy = code_thms thy o op @ o read_const_exprs thy;
+fun code_deps_cmd thy = code_deps thy o op @ o read_const_exprs thy;
+
+in
+
+val _ =
+  OuterSyntax.improper_command "code_thms" "print system of code equations for code" OuterKeyword.diag
+    (Scan.repeat P.term_group
+      >> (fn cs => Toplevel.no_timing o Toplevel.unknown_theory
+        o Toplevel.keep ((fn thy => code_thms_cmd thy cs) o Toplevel.theory_of)));
+
+val _ =
+  OuterSyntax.improper_command "code_deps" "visualize dependencies of code equations for code" OuterKeyword.diag
+    (Scan.repeat P.term_group
+      >> (fn cs => Toplevel.no_timing o Toplevel.unknown_theory
+        o Toplevel.keep ((fn thy => code_deps_cmd thy cs) o Toplevel.theory_of)));
+
+end;
 
 end; (*struct*)
 

--- a/src/Tools/code/code_wellsorted.ML	Fri May 15 15:29:34 2009 +0200
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,397 +0,0 @@
-(*  Title:      Tools/code/code_wellsorted.ML
-    Author:     Florian Haftmann, TU Muenchen
-
-Producing well-sorted systems of code equations in a graph
-with explicit dependencies -- the Waisenhaus algorithm.
-*)
-
-signature CODE_WELLSORTED =
-sig
-  type T
-  val eqns: T -> string -> (thm * bool) list
-  val typ: T -> string -> (string * sort) list * typ
-  val all: T -> string list
-  val pretty: theory -> T -> Pretty.T
-  val make: theory -> string list
-    -> ((sort -> sort) * Sorts.algebra) * T
-  val eval_conv: theory
-    -> (term -> term * (((sort -> sort) * Sorts.algebra) -> T -> thm)) -> cterm -> thm
-  val eval_term: theory
-    -> (term -> term * (((sort -> sort) * Sorts.algebra) -> T -> 'a)) -> term -> 'a
-end
-
-structure Code_Wellsorted : CODE_WELLSORTED =
-struct
-
-(** the equation graph type **)
-
-type T = (((string * sort) list * typ) * (thm * bool) list) Graph.T;
-
-fun eqns eqngr = these o Option.map snd o try (Graph.get_node eqngr);
-fun typ eqngr = fst o Graph.get_node eqngr;
-fun all eqngr = Graph.keys eqngr;
-
-fun pretty thy eqngr =
-  AList.make (snd o Graph.get_node eqngr) (Graph.keys eqngr)
-  |> (map o apfst) (Code_Unit.string_of_const thy)
-  |> sort (string_ord o pairself fst)
-  |> map (fn (s, thms) =>
-       (Pretty.block o Pretty.fbreaks) (
-         Pretty.str s
-         :: map (Display.pretty_thm o fst) thms
-       ))
-  |> Pretty.chunks;
-
-
-(** the Waisenhaus algorithm **)
-
-(* auxiliary *)
-
-fun complete_proper_sort thy =
-  Sign.complete_sort thy #> filter (can (AxClass.get_info thy));
-
-fun inst_params thy tyco =
-  map (fn (c, _) => AxClass.param_of_inst thy (c, tyco))
-    o maps (#params o AxClass.get_info thy);
-
-fun consts_of thy eqns = [] |> (fold o fold o fold_aterms)
-  (fn Const (c, ty) => insert (op =) (c, Sign.const_typargs thy (c, Logic.unvarifyT ty)) | _ => I)
-    (map (op :: o swap o apfst (snd o strip_comb) o Logic.dest_equals o Thm.plain_prop_of o fst) eqns);
-
-fun tyscm_rhss_of thy c eqns =
-  let
-    val tyscm = case eqns of [] => Code.default_typscheme thy c
-      | ((thm, _) :: _) => (snd o Code_Unit.head_eqn thy) thm;
-    val rhss = consts_of thy eqns;
-  in (tyscm, rhss) end;
-
-
-(* data structures *)
-
-datatype const = Fun of string | Inst of class * string;
-
-fun const_ord (Fun c1, Fun c2) = fast_string_ord (c1, c2)
-  | const_ord (Inst class_tyco1, Inst class_tyco2) =
-      prod_ord fast_string_ord fast_string_ord (class_tyco1, class_tyco2)
-  | const_ord (Fun _, Inst _) = LESS
-  | const_ord (Inst _, Fun _) = GREATER;
-
-type var = const * int;
-
-structure Vargraph =
-  GraphFun(type key = var val ord = prod_ord const_ord int_ord);
-
-datatype styp = Tyco of string * styp list | Var of var | Free;
-
-fun styp_of c_lhs (Type (tyco, tys)) = Tyco (tyco, map (styp_of c_lhs) tys)
-  | styp_of c_lhs (TFree (v, _)) = case c_lhs
-     of SOME (c, lhs) => Var (Fun c, find_index (fn (v', _) => v = v') lhs)
-      | NONE => Free;
-
-type vardeps_data = ((string * styp list) list * class list) Vargraph.T
-  * (((string * sort) list * (thm * bool) list) Symtab.table
-    * (class * string) list);
-
-val empty_vardeps_data : vardeps_data =
-  (Vargraph.empty, (Symtab.empty, []));
-
-
-(* retrieving equations and instances from the background context *)
-
-fun obtain_eqns thy eqngr c =
-  case try (Graph.get_node eqngr) c
-   of SOME ((lhs, _), eqns) => ((lhs, []), [])
-    | NONE => let
-        val eqns = Code.these_eqns thy c
-          |> burrow_fst (Code_Unit.norm_args thy)
-          |> burrow_fst (Code_Unit.norm_varnames thy Code_Name.purify_tvar Code_Name.purify_var);
-        val ((lhs, _), rhss) = tyscm_rhss_of thy c eqns;
-      in ((lhs, rhss), eqns) end;
-
-fun obtain_instance thy arities (inst as (class, tyco)) =
-  case AList.lookup (op =) arities inst
-   of SOME classess => (classess, ([], []))
-    | NONE => let
-        val all_classes = complete_proper_sort thy [class];
-        val superclasses = remove (op =) class all_classes
-        val classess = map (complete_proper_sort thy)
-          (Sign.arity_sorts thy tyco [class]);
-        val inst_params = inst_params thy tyco all_classes;
-      in (classess, (superclasses, inst_params)) end;
-
-
-(* computing instantiations *)
-
-fun add_classes thy arities eqngr c_k new_classes vardeps_data =
-  let
-    val (styps, old_classes) = Vargraph.get_node (fst vardeps_data) c_k;
-    val diff_classes = new_classes |> subtract (op =) old_classes;
-  in if null diff_classes then vardeps_data
-  else let
-    val c_ks = Vargraph.imm_succs (fst vardeps_data) c_k |> insert (op =) c_k;
-  in
-    vardeps_data
-    |> (apfst o Vargraph.map_node c_k o apsnd) (append diff_classes)
-    |> fold (fn styp => fold (assert_typmatch_inst thy arities eqngr styp) new_classes) styps
-    |> fold (fn c_k => add_classes thy arities eqngr c_k diff_classes) c_ks
-  end end
-and add_styp thy arities eqngr c_k tyco_styps vardeps_data =
-  let
-    val (old_styps, classes) = Vargraph.get_node (fst vardeps_data) c_k;
-  in if member (op =) old_styps tyco_styps then vardeps_data
-  else
-    vardeps_data
-    |> (apfst o Vargraph.map_node c_k o apfst) (cons tyco_styps)
-    |> fold (assert_typmatch_inst thy arities eqngr tyco_styps) classes
-  end
-and add_dep thy arities eqngr c_k c_k' vardeps_data =
-  let
-    val (_, classes) = Vargraph.get_node (fst vardeps_data) c_k;
-  in
-    vardeps_data
-    |> add_classes thy arities eqngr c_k' classes
-    |> apfst (Vargraph.add_edge (c_k, c_k'))
-  end
-and assert_typmatch_inst thy arities eqngr (tyco, styps) class vardeps_data =
-  if can (Sign.arity_sorts thy tyco) [class]
-  then vardeps_data
-    |> assert_inst thy arities eqngr (class, tyco)
-    |> fold_index (fn (k, styp) =>
-         assert_typmatch thy arities eqngr styp (Inst (class, tyco), k)) styps
-  else vardeps_data (*permissive!*)
-and assert_inst thy arities eqngr (inst as (class, tyco)) (vardeps_data as (_, (_, insts))) =
-  if member (op =) insts inst then vardeps_data
-  else let
-    val (classess, (superclasses, inst_params)) =
-      obtain_instance thy arities inst;
-  in
-    vardeps_data
-    |> (apsnd o apsnd) (insert (op =) inst)
-    |> fold_index (fn (k, _) =>
-         apfst (Vargraph.new_node ((Inst (class, tyco), k), ([] ,[])))) classess
-    |> fold (fn superclass => assert_inst thy arities eqngr (superclass, tyco)) superclasses
-    |> fold (assert_fun thy arities eqngr) inst_params
-    |> fold_index (fn (k, classes) =>
-         add_classes thy arities eqngr (Inst (class, tyco), k) classes
-         #> fold (fn superclass =>
-             add_dep thy arities eqngr (Inst (superclass, tyco), k)
-             (Inst (class, tyco), k)) superclasses
-         #> fold (fn inst_param =>
-             add_dep thy arities eqngr (Fun inst_param, k)
-             (Inst (class, tyco), k)
-             ) inst_params
-         ) classess
-  end
-and assert_typmatch thy arities eqngr (Tyco tyco_styps) c_k vardeps_data =
-      vardeps_data
-      |> add_styp thy arities eqngr c_k tyco_styps
-  | assert_typmatch thy arities eqngr (Var c_k') c_k vardeps_data =
-      vardeps_data
-      |> add_dep thy arities eqngr c_k c_k'
-  | assert_typmatch thy arities eqngr Free c_k vardeps_data =
-      vardeps_data
-and assert_rhs thy arities eqngr (c', styps) vardeps_data =
-  vardeps_data
-  |> assert_fun thy arities eqngr c'
-  |> fold_index (fn (k, styp) =>
-       assert_typmatch thy arities eqngr styp (Fun c', k)) styps
-and assert_fun thy arities eqngr c (vardeps_data as (_, (eqntab, _))) =
-  if Symtab.defined eqntab c then vardeps_data
-  else let
-    val ((lhs, rhss), eqns) = obtain_eqns thy eqngr c;
-    val rhss' = (map o apsnd o map) (styp_of (SOME (c, lhs))) rhss;
-  in
-    vardeps_data
-    |> (apsnd o apfst) (Symtab.update_new (c, (lhs, eqns)))
-    |> fold_index (fn (k, _) =>
-         apfst (Vargraph.new_node ((Fun c, k), ([] ,[])))) lhs
-    |> fold_index (fn (k, (_, sort)) =>
-         add_classes thy arities eqngr (Fun c, k) (complete_proper_sort thy sort)) lhs
-    |> fold (assert_rhs thy arities eqngr) rhss'
-  end;
-
-
-(* applying instantiations *)
-
-fun dicts_of thy (proj_sort, algebra) (T, sort) =
-  let
-    fun class_relation (x, _) _ = x;
-    fun type_constructor tyco xs class =
-      inst_params thy tyco (Sorts.complete_sort algebra [class])
-        @ (maps o maps) fst xs;
-    fun type_variable (TFree (_, sort)) = map (pair []) (proj_sort sort);
-  in
-    flat (Sorts.of_sort_derivation (Syntax.pp_global thy) algebra
-      { class_relation = class_relation, type_constructor = type_constructor,
-        type_variable = type_variable } (T, proj_sort sort)
-       handle Sorts.CLASS_ERROR _ => [] (*permissive!*))
-  end;
-
-fun add_arity thy vardeps (class, tyco) =
-  AList.default (op =)
-    ((class, tyco), map (fn k => (snd o Vargraph.get_node vardeps) (Inst (class, tyco), k))
-      (0 upto Sign.arity_number thy tyco - 1));
-
-fun add_eqs thy (proj_sort, algebra) vardeps
-    (c, (proto_lhs, proto_eqns)) (rhss, eqngr) =
-  if can (Graph.get_node eqngr) c then (rhss, eqngr)
-  else let
-    val lhs = map_index (fn (k, (v, _)) =>
-      (v, snd (Vargraph.get_node vardeps (Fun c, k)))) proto_lhs;
-    val inst_tab = Vartab.empty |> fold (fn (v, sort) =>
-      Vartab.update ((v, 0), sort)) lhs;
-    val eqns = proto_eqns
-      |> (map o apfst) (Code_Unit.inst_thm thy inst_tab);
-    val (tyscm, rhss') = tyscm_rhss_of thy c eqns;
-    val eqngr' = Graph.new_node (c, (tyscm, eqns)) eqngr;
-  in (map (pair c) rhss' @ rhss, eqngr') end;
-
-fun extend_arities_eqngr thy cs cs_rhss (arities, eqngr) =
-  let
-    val cs_rhss' = (map o apsnd o map) (styp_of NONE) cs_rhss;
-    val (vardeps, (eqntab, insts)) = empty_vardeps_data
-      |> fold (assert_fun thy arities eqngr) cs
-      |> fold (assert_rhs thy arities eqngr) cs_rhss';
-    val arities' = fold (add_arity thy vardeps) insts arities;
-    val pp = Syntax.pp_global thy;
-    val is_proper_class = can (AxClass.get_info thy);
-    val (proj_sort, algebra) = Sorts.subalgebra pp is_proper_class
-      (AList.lookup (op =) arities') (Sign.classes_of thy);
-    val (rhss, eqngr') = Symtab.fold
-      (add_eqs thy (proj_sort, algebra) vardeps) eqntab ([], eqngr);
-    fun deps_of (c, rhs) = c ::
-      maps (dicts_of thy (proj_sort, algebra))
-        (rhs ~~ (map snd o fst o fst o Graph.get_node eqngr') c);
-    val eqngr'' = fold (fn (c, rhs) => fold
-      (curry Graph.add_edge c) (deps_of rhs)) rhss eqngr';
-  in ((proj_sort, algebra), (arities', eqngr'')) end;
-
-
-(** retrieval interfaces **)
-
-fun proto_eval thy cterm_of evaluator_lift evaluator proto_ct arities_eqngr =
-  let
-    val ct = cterm_of proto_ct;
-    val _ = Sign.no_vars (Syntax.pp_global thy) (Thm.term_of ct);
-    val _ = Term.fold_types (Type.no_tvars #> K I) (Thm.term_of ct) ();
-    fun consts_of t =
-      fold_aterms (fn Const c_ty => cons c_ty | _ => I) t [];
-    val thm = Code.preprocess_conv thy ct;
-    val ct' = Thm.rhs_of thm;
-    val t' = Thm.term_of ct';
-    val (t'', evaluator_eqngr) = evaluator t';
-    val consts = map fst (consts_of t');
-    val consts' = consts_of t'';
-    val const_matches' = fold (fn (c, ty) =>
-      insert (op =) (c, Sign.const_typargs thy (c, ty))) consts' [];
-    val (algebra', arities_eqngr') =
-      extend_arities_eqngr thy consts const_matches' arities_eqngr;
-  in
-    (evaluator_lift (evaluator_eqngr algebra') thm (snd arities_eqngr'),
-      arities_eqngr')
-  end;
-
-fun proto_eval_conv thy =
-  let
-    fun evaluator_lift evaluator thm1 eqngr =
-      let
-        val thm2 = evaluator eqngr;
-        val thm3 = Code.postprocess_conv thy (Thm.rhs_of thm2);
-      in
-        Thm.transitive thm1 (Thm.transitive thm2 thm3) handle THM _ =>
-          error ("could not construct evaluation proof:\n"
-          ^ (cat_lines o map Display.string_of_thm) [thm1, thm2, thm3])
-      end;
-  in proto_eval thy I evaluator_lift end;
-
-fun proto_eval_term thy =
-  let
-    fun evaluator_lift evaluator _ eqngr = evaluator eqngr;
-  in proto_eval thy (Thm.cterm_of thy) evaluator_lift end;
-
-structure Wellsorted = CodeDataFun
-(
-  type T = ((string * class) * sort list) list * T;
-  val empty = ([], Graph.empty);
-  fun purge thy cs (arities, eqngr) =
-    let
-      val del_cs = ((Graph.all_preds eqngr
-        o filter (can (Graph.get_node eqngr))) cs);
-      val del_arities = del_cs
-        |> map_filter (AxClass.inst_of_param thy)
-        |> maps (fn (c, tyco) =>
-             (map (rpair tyco) o Sign.complete_sort thy o the_list
-               o AxClass.class_of_param thy) c);
-      val arities' = fold (AList.delete (op =)) del_arities arities;
-      val eqngr' = Graph.del_nodes del_cs eqngr;
-    in (arities', eqngr') end;
-);
-
-fun make thy cs = apsnd snd
-  (Wellsorted.change_yield thy (extend_arities_eqngr thy cs []));
-
-fun eval_conv thy f =
-  fst o Wellsorted.change_yield thy o proto_eval_conv thy f;
-
-fun eval_term thy f =
-  fst o Wellsorted.change_yield thy o proto_eval_term thy f;
-
-
-(** diagnostic commands **)
-
-fun code_depgr thy consts =
-  let
-    val (_, eqngr) = make thy consts;
-    val select = Graph.all_succs eqngr consts;
-  in
-    eqngr
-    |> not (null consts) ? Graph.subgraph (member (op =) select) 
-    |> Graph.map_nodes ((apsnd o map o apfst) (AxClass.overload thy))
-  end;
-
-fun code_thms thy = Pretty.writeln o pretty thy o code_depgr thy;
-
-fun code_deps thy consts =
-  let
-    val eqngr = code_depgr thy consts;
-    val constss = Graph.strong_conn eqngr;
-    val mapping = Symtab.empty |> fold (fn consts => fold (fn const =>
-      Symtab.update (const, consts)) consts) constss;
-    fun succs consts = consts
-      |> maps (Graph.imm_succs eqngr)
-      |> subtract (op =) consts
-      |> map (the o Symtab.lookup mapping)
-      |> distinct (op =);
-    val conn = [] |> fold (fn consts => cons (consts, succs consts)) constss;
-    fun namify consts = map (Code_Unit.string_of_const thy) consts
-      |> commas;
-    val prgr = map (fn (consts, constss) =>
-      { name = namify consts, ID = namify consts, dir = "", unfold = true,
-        path = "", parents = map namify constss }) conn;
-  in Present.display_graph prgr end;
-
-local
-
-structure P = OuterParse
-and K = OuterKeyword
-
-fun code_thms_cmd thy = code_thms thy o op @ o Code_Name.read_const_exprs thy;
-fun code_deps_cmd thy = code_deps thy o op @ o Code_Name.read_const_exprs thy;
-
-in
-
-val _ =
-  OuterSyntax.improper_command "code_thms" "print system of code equations for code" OuterKeyword.diag
-    (Scan.repeat P.term_group
-      >> (fn cs => Toplevel.no_timing o Toplevel.unknown_theory
-        o Toplevel.keep ((fn thy => code_thms_cmd thy cs) o Toplevel.theory_of)));
-
-val _ =
-  OuterSyntax.improper_command "code_deps" "visualize dependencies of code equations for code" OuterKeyword.diag
-    (Scan.repeat P.term_group
-      >> (fn cs => Toplevel.no_timing o Toplevel.unknown_theory
-        o Toplevel.keep ((fn thy => code_deps_cmd thy cs) o Toplevel.theory_of)));
-
-end;
-
-end; (*struct*)

--- a/src/Tools/nbe.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/Tools/nbe.ML	Fri May 15 15:56:28 2009 +0200
@@ -7,11 +7,10 @@
 signature NBE =
 sig
   val norm_conv: cterm -> thm
-  val norm_term: theory -> term -> term
+  val norm: theory -> term -> term
 
   datatype Univ =
       Const of int * Univ list               (*named (uninterpreted) constants*)
-    | Free of string * Univ list             (*free (uninterpreted) variables*)
     | DFree of string * int                  (*free (uninterpreted) dictionary parameters*)
     | BVar of int * Univ list
     | Abs of (int * (Univ list -> Univ)) * Univ list
@@ -57,14 +56,12 @@
 
 datatype Univ =
     Const of int * Univ list           (*named (uninterpreted) constants*)
-  | Free of string * Univ list         (*free variables*)
   | DFree of string * int              (*free (uninterpreted) dictionary parameters*)
   | BVar of int * Univ list            (*bound variables, named*)
   | Abs of (int * (Univ list -> Univ)) * Univ list
                                        (*abstractions as closures*);
 
 fun same (Const (k, xs)) (Const (l, ys)) = k = l andalso sames xs ys
-  | same (Free (s, xs)) (Free (t, ys)) = s = t andalso sames xs ys
   | same (DFree (s, k)) (DFree (t, l)) = s = t andalso k = l
   | same (BVar (k, xs)) (BVar (l, ys)) = k = l andalso sames xs ys
   | same _ _ = false
@@ -80,7 +77,6 @@
         | GREATER => Abs ((k, f), ys @ xs) (*note: reverse convention also for apps!*)
       end
   | apps (Const (name, xs)) ys = Const (name, ys @ xs)
-  | apps (Free (name, xs)) ys = Free (name, ys @ xs)
   | apps (BVar (n, xs)) ys = BVar (n, ys @ xs);
 
 
@@ -194,7 +190,7 @@
           let
             val (t', ts) = Code_Thingol.unfold_app t
           in of_iapp match_cont t' (fold_rev (cons o of_iterm NONE) ts []) end
-        and of_iapp match_cont (IConst (c, (dss, _))) ts = constapp c dss ts
+        and of_iapp match_cont (IConst (c, ((_, dss), _))) ts = constapp c dss ts
           | of_iapp match_cont (IVar v) ts = nbe_apps (nbe_bound v) ts
           | of_iapp match_cont ((v, _) `|-> t) ts =
               nbe_apps (nbe_abss 1 (ml_abs (ml_list [nbe_bound v]) (of_iterm NONE t))) ts
@@ -299,15 +295,15 @@
         val params = Name.invent_list [] "d" (length names);
         fun mk (k, name) =
           (name, ([(v, [])],
-            [([IConst (class, ([], [])) `$$ map IVar params], IVar (nth params k))]));
+            [([IConst (class, (([], []), [])) `$$ map IVar params], IVar (nth params k))]));
       in map_index mk names end
   | eqns_of_stmt (_, Code_Thingol.Classrel _) =
       []
   | eqns_of_stmt (_, Code_Thingol.Classparam _) =
       []
   | eqns_of_stmt (inst, Code_Thingol.Classinst ((class, (_, arities)), (superinsts, instops))) =
-      [(inst, (arities, [([], IConst (class, ([], [])) `$$
-        map (fn (_, (_, (inst, dicts))) => IConst (inst, (dicts, []))) superinsts
+      [(inst, (arities, [([], IConst (class, (([], []), [])) `$$
+        map (fn (_, (_, (inst, dicts))) => IConst (inst, (([], dicts), []))) superinsts
         @ map (IConst o snd o fst) instops)]))];
 
 fun compile_stmts ctxt stmts_deps =
@@ -350,20 +346,27 @@
 
 (* term evaluation *)
 
-fun eval_term ctxt gr deps ((vs, ty) : typscheme, t) =
+fun eval_term ctxt gr deps (vs : (string * sort) list, t) =
   let 
-    val frees = Code_Thingol.fold_unbound_varnames (insert (op =)) t []
-    val frees' = map (fn v => Free (v, [])) frees;
     val dict_frees = maps (fn (v, sort) => map_index (curry DFree v o fst) sort) vs;
   in
-    ("", (vs, [(map IVar frees, t)]))
+    ("", (vs, [([], t)]))
     |> singleton (compile_eqnss ctxt gr deps)
     |> snd
-    |> (fn t => apps t (rev (dict_frees @ frees')))
+    |> (fn t => apps t (rev dict_frees))
   end;
 
 (* reification *)
 
+fun typ_of_itype program vs (ityco `%% itys) =
+      let
+        val Code_Thingol.Datatype (tyco, _) = Graph.get_node program ityco;
+      in Type (tyco, map (typ_of_itype program vs) itys) end
+  | typ_of_itype program vs (ITyVar v) =
+      let
+        val sort = (the o AList.lookup (op =) vs) v;
+      in TFree ("'" ^ v, sort) end;
+
 fun term_of_univ thy program idx_tab t =
   let
     fun take_until f [] = []
@@ -390,8 +393,6 @@
             val T' = map_type_tfree (fn (v, _) => TypeInfer.param typidx (v, [])) T;
             val typidx' = typidx + 1;
           in of_apps bounds (Term.Const (c, T'), ts') typidx' end
-      | of_univ bounds (Free (name, ts)) typidx =
-          of_apps bounds (Term.Free (name, dummyT), ts) typidx
       | of_univ bounds (BVar (n, ts)) typidx =
           of_apps bounds (Bound (bounds - n - 1), ts) typidx
       | of_univ bounds (t as Abs _) typidx =
@@ -418,43 +419,37 @@
 
 (* compilation, evaluation and reification *)
 
-fun compile_eval thy naming program vs_ty_t deps =
+fun compile_eval thy naming program vs_t deps =
   let
     val ctxt = ProofContext.init thy;
     val (_, (gr, (_, idx_tab))) =
       Nbe_Functions.change thy (ensure_stmts ctxt naming program o snd);
   in
-    vs_ty_t
+    vs_t
     |> eval_term ctxt gr deps
     |> term_of_univ thy program idx_tab
   end;
 
 (* evaluation with type reconstruction *)
 
-fun eval thy t naming program vs_ty_t deps =
+fun normalize thy naming program ((vs0, (vs, ty)), t) deps =
   let
     fun subst_const f = map_aterms (fn t as Term.Const (c, ty) => Term.Const (f c, ty)
       | t => t);
-    val subst_triv_consts = subst_const (Code_Unit.resubst_alias thy);
-    val ty = type_of t;
-    val type_free = AList.lookup (op =)
-      (map (fn (s, T) => (s, Term.Free (s, T))) (Term.add_frees t []));
-    val type_frees = Term.map_aterms
-      (fn (t as Term.Free (s, _)) => the_default t (type_free s) | t => t);
+    val resubst_triv_consts = subst_const (Code.resubst_alias thy);
+    val ty' = typ_of_itype program vs0 ty;
     fun type_infer t =
       singleton (TypeInfer.infer_types (Syntax.pp_global thy) (Sign.tsig_of thy) I
         (try (Type.strip_sorts o Sign.the_const_type thy)) (K NONE) Name.context 0)
-      (TypeInfer.constrain ty t);
+      (TypeInfer.constrain ty' t);
     fun check_tvars t = if null (Term.add_tvars t []) then t else
       error ("Illegal schematic type variables in normalized term: "
         ^ setmp show_types true (Syntax.string_of_term_global thy) t);
     val string_of_term = setmp show_types true (Syntax.string_of_term_global thy);
   in
-    compile_eval thy naming program vs_ty_t deps
+    compile_eval thy naming program (vs, t) deps
     |> tracing (fn t => "Normalized:\n" ^ string_of_term t)
-    |> subst_triv_consts
-    |> type_frees
-    |> tracing (fn t => "Vars typed:\n" ^ string_of_term t)
+    |> resubst_triv_consts
     |> type_infer
     |> tracing (fn t => "Types inferred:\n" ^ string_of_term t)
     |> check_tvars
@@ -463,39 +458,59 @@
 
 (* evaluation oracle *)
 
-val (_, norm_oracle) = Context.>>> (Context.map_theory_result
-  (Thm.add_oracle (Binding.name "norm", fn (thy, t, naming, program, vs_ty_t, deps) =>
-    Thm.cterm_of thy (Logic.mk_equals (t, eval thy t naming program vs_ty_t deps)))));
+fun add_triv_classes thy = curry (Sorts.inter_sort (Sign.classes_of thy))
+  (Code.triv_classes thy);
 
-fun add_triv_classes thy =
+fun mk_equals thy lhs raw_rhs =
+  let
+    val ty = Thm.typ_of (Thm.ctyp_of_term lhs);
+    val eq = Thm.cterm_of thy (Term.Const ("==", ty --> ty --> propT));
+    val rhs = Thm.cterm_of thy raw_rhs;
+  in Thm.mk_binop eq lhs rhs end;
+
+val (_, raw_norm_oracle) = Context.>>> (Context.map_theory_result
+  (Thm.add_oracle (Binding.name "norm", fn (thy, naming, program, vsp_ty_t, deps, ct) =>
+    mk_equals thy ct (normalize thy naming program vsp_ty_t deps))));
+
+fun norm_oracle thy naming program vsp_ty_t deps ct =
+  raw_norm_oracle (thy, naming, program, vsp_ty_t, deps, ct);
+
+fun no_frees_conv conv ct =
   let
-    val inters = curry (Sorts.inter_sort (Sign.classes_of thy))
-      (Code_Unit.triv_classes thy);
-    fun map_sorts f = (map_types o map_atyps)
-      (fn TVar (v, sort) => TVar (v, f sort)
-        | TFree (v, sort) => TFree (v, f sort));
-  in map_sorts inters end;
+    val frees = Thm.add_cterm_frees ct [];
+    fun apply_beta free thm = Thm.combination thm (Thm.reflexive free)
+      |> Conv.fconv_rule (Conv.arg_conv (Conv.try_conv (Thm.beta_conversion false)))
+      |> Conv.fconv_rule (Conv.arg1_conv (Thm.beta_conversion false));
+  in
+    ct
+    |> fold_rev Thm.cabs frees
+    |> conv
+    |> fold apply_beta frees
+  end;
 
-fun norm_conv ct =
+fun no_frees_rew rew t =
+  let
+    val frees = map Free (Term.add_frees t []);
+  in
+    t
+    |> fold_rev lambda frees
+    |> rew
+    |> (fn t' => Term.betapplys (t', frees))
+  end;
+
+val norm_conv = no_frees_conv (fn ct =>
   let
     val thy = Thm.theory_of_cterm ct;
-    fun evaluator' t naming program vs_ty_t deps =
-      norm_oracle (thy, t, naming, program, vs_ty_t, deps);
-    fun evaluator t = (add_triv_classes thy t, evaluator' t);
-  in Code_Thingol.eval_conv thy evaluator ct end;
+  in Code_Thingol.eval_conv thy (add_triv_classes thy) (norm_oracle thy) ct end);
 
-fun norm_term thy t =
-  let
-    fun evaluator' t naming program vs_ty_t deps = eval thy t naming program vs_ty_t deps;
-    fun evaluator t = (add_triv_classes thy t, evaluator' t);
-  in (Code.postprocess_term thy o Code_Thingol.eval_term thy evaluator) t end;
+fun norm thy = no_frees_rew (Code_Thingol.eval thy (add_triv_classes thy) I (normalize thy));
 
 (* evaluation command *)
 
 fun norm_print_term ctxt modes t =
   let
     val thy = ProofContext.theory_of ctxt;
-    val t' = norm_term thy t;
+    val t' = norm thy t;
     val ty' = Term.type_of t';
     val ctxt' = Variable.auto_fixes t ctxt;
     val p = PrintMode.with_modes modes (fn () =>
@@ -510,8 +525,7 @@
   let val ctxt = Toplevel.context_of state
   in norm_print_term ctxt modes (Syntax.read_term ctxt s) end;
 
-val setup =
-  Value.add_evaluator ("nbe", norm_term o ProofContext.theory_of);
+val setup = Value.add_evaluator ("nbe", norm o ProofContext.theory_of);
 
 local structure P = OuterParse and K = OuterKeyword in
 

--- a/src/Tools/quickcheck.ML	Fri May 15 15:29:34 2009 +0200
+++ b/src/Tools/quickcheck.ML	Fri May 15 15:56:28 2009 +0200
@@ -6,28 +6,48 @@
 
 signature QUICKCHECK =
 sig
-  val test_term: Proof.context -> bool -> string option -> int -> int -> term -> (string * term) list option;
-  val add_generator: string * (Proof.context -> term -> int -> term list option) -> theory -> theory
   val auto: bool ref
   val auto_time_limit: int ref
+  val test_term: Proof.context -> bool -> string option -> int -> int -> term ->
+    (string * term) list option
+  val add_generator: string * (Proof.context -> term -> int -> term list option) -> theory -> theory
 end;
 
 structure Quickcheck : QUICKCHECK =
 struct
 
+(* preferences *)
+
+val auto = ref false;
+val auto_time_limit = ref 2500;
+
+val _ =
+  ProofGeneralPgip.add_preference Preferences.category_tracing
+  (setmp auto true (fn () =>
+    Preferences.bool_pref auto
+      "auto-quickcheck"
+      "Whether to enable quickcheck automatically.") ());
+
+val _ =
+  ProofGeneralPgip.add_preference Preferences.category_tracing
+    (Preferences.nat_pref auto_time_limit
+      "auto-quickcheck-time-limit"
+      "Time limit for automatic quickcheck (in milliseconds).");
+
+
 (* quickcheck configuration -- default parameters, test generators *)
 
 datatype test_params = Test_Params of
   { size: int, iterations: int, default_type: typ option };
 
-fun dest_test_params (Test_Params { size, iterations, default_type}) =
+fun dest_test_params (Test_Params { size, iterations, default_type }) =
   ((size, iterations), default_type);
 fun mk_test_params ((size, iterations), default_type) =
   Test_Params { size = size, iterations = iterations, default_type = default_type };
 fun map_test_params f (Test_Params { size, iterations, default_type}) =
   mk_test_params (f ((size, iterations), default_type));
-fun merge_test_params (Test_Params {size = size1, iterations = iterations1, default_type = default_type1},
-  Test_Params {size = size2, iterations = iterations2, default_type = default_type2}) =
+fun merge_test_params (Test_Params { size = size1, iterations = iterations1, default_type = default_type1 },
+  Test_Params { size = size2, iterations = iterations2, default_type = default_type2 }) =
   mk_test_params ((Int.max (size1, size2), Int.max (iterations1, iterations2)),
     case default_type1 of NONE => default_type2 | _ => default_type1);
 
@@ -74,7 +94,7 @@
       error "Term to be tested contains type variables";
     val _ = null (Term.add_vars t []) orelse
       error "Term to be tested contains schematic variables";
-    val frees = map dest_Free (OldTerm.term_frees t);
+    val frees = Term.add_frees t [];
   in (map fst frees, list_abs_free (frees, t)) end
 
 fun test_term ctxt quiet generator_name size i t =
@@ -84,12 +104,12 @@
      of NONE => if quiet then mk_testers ctxt t' else mk_testers_strict ctxt t'
       | SOME name => [mk_tester_select name ctxt t'];
     fun iterate f 0 = NONE
-      | iterate f k = case f () handle Match => (if quiet then ()
+      | iterate f j = case f () handle Match => (if quiet then ()
              else warning "Exception Match raised during quickcheck"; NONE)
-          of NONE => iterate f (k - 1) | SOME q => SOME q;
+          of NONE => iterate f (j - 1) | SOME q => SOME q;
     fun with_testers k [] = NONE
       | with_testers k (tester :: testers) =
-          case iterate (fn () => tester k) i
+          case iterate (fn () => tester (k - 1)) i
            of NONE => with_testers k testers
             | SOME q => SOME q;
     fun with_size k = if k > size then NONE
@@ -138,10 +158,7 @@
 
 (* automatic testing *)
 
-val auto = ref false;
-val auto_time_limit = ref 5000;
-
-fun test_goal_auto int state =
+val _ = Context.>> (Specification.add_theorem_hook (fn int => fn state =>
   let
     val ctxt = Proof.context_of state;
     val assms = map term_of (Assumption.all_assms_of ctxt);
@@ -162,12 +179,10 @@
     if int andalso !auto andalso not (!Toplevel.quiet)
     then test ()
     else state
-  end;
-
-val _ = Context.>> (Specification.add_theorem_hook test_goal_auto);
+  end));
 
 
-(* Isar interfaces *)
+(* Isar commands *)
 
 fun read_nat s = case (Library.read_int o Symbol.explode) s
  of (k, []) => if k >= 0 then k