1.1 --- a/Admin/mirror-website Mon May 11 09:39:53 2009 +0200
1.2 +++ b/Admin/mirror-website Mon May 11 17:20:52 2009 +0200
1.3 @@ -12,7 +12,7 @@
1.4 ;;
1.5 *.cl.cam.ac.uk)
1.6 USER=paulson
1.7 - DEST=/anfs/www/html/Research/HVG/Isabelle
1.8 + DEST=/anfs/www/html/research/hvg/Isabelle
1.9 ;;
1.10 *)
1.11 echo "Unknown destination directory for ${HOST}"
2.1 --- a/CONTRIBUTORS Mon May 11 09:39:53 2009 +0200
2.2 +++ b/CONTRIBUTORS Mon May 11 17:20:52 2009 +0200
2.3 @@ -7,6 +7,10 @@
2.4 Contributions to this Isabelle version
2.5 --------------------------------------
2.6
2.7 +
2.8 +Contributions to Isabelle2009
2.9 +-----------------------------
2.10 +
2.11 * March 2009: Robert Himmelmann, TUM and Amine Chaieb, University of
2.12 Cambridge
2.13 Elementary topology in Euclidean space.
3.1 --- a/NEWS Mon May 11 09:39:53 2009 +0200
3.2 +++ b/NEWS Mon May 11 17:20:52 2009 +0200
3.3 @@ -4,6 +4,26 @@
3.4 New in this Isabelle version
3.5 ----------------------------
3.6
3.7 +*** Pure ***
3.8 +
3.9 +* On instantiation of classes, remaining undefined class parameters are
3.10 +formally declared. INCOMPATIBILITY.
3.11 +
3.12 +
3.13 +*** HOL ***
3.14 +
3.15 +* Class semiring_div requires superclass no_zero_divisors and proof of div_mult_mult1;
3.16 +theorems div_mult_mult1, div_mult_mult2, div_mult_mult1_if, div_mult_mult1 and
3.17 +div_mult_mult2 have been generalized to class semiring_div, subsuming former
3.18 +theorems zdiv_zmult_zmult1, zdiv_zmult_zmult1_if, zdiv_zmult_zmult1 and zdiv_zmult_zmult2.
3.19 +div_mult_mult1 is now [simp] by default. INCOMPATIBILITY.
3.20 +
3.21 +* Power operations on relations and functions are now one dedicate constant compow with
3.22 +infix syntax "^^". Power operations on multiplicative monoids retains syntax "^"
3.23 +and is now defined generic in class power. INCOMPATIBILITY.
3.24 +
3.25 +* ML antiquotation @{code_datatype} inserts definition of a datatype generated
3.26 +by the code generator; see Predicate.thy for an example.
3.27
3.28
3.29 New in Isabelle2009 (April 2009)
3.30 @@ -187,7 +207,7 @@
3.31
3.32 * Keyword 'code_exception' now named 'code_abort'. INCOMPATIBILITY.
3.33
3.34 -* Unified theorem tables for both code code generators. Thus [code
3.35 +* Unified theorem tables for both code generators. Thus [code
3.36 func] has disappeared and only [code] remains. INCOMPATIBILITY.
3.37
3.38 * Command 'find_consts' searches for constants based on type and name
4.1 --- a/contrib/SystemOnTPTP/remote Mon May 11 09:39:53 2009 +0200
4.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
4.3 @@ -1,120 +0,0 @@
4.4 -#!/usr/bin/env perl
4.5 -#
4.6 -# Wrapper for custom remote provers on SystemOnTPTP
4.7 -# Author: Fabian Immler, TU Muenchen
4.8 -#
4.9 -
4.10 -use warnings;
4.11 -use strict;
4.12 -use Getopt::Std;
4.13 -use HTTP::Request::Common;
4.14 -use LWP;
4.15 -
4.16 -my $SystemOnTPTPFormReplyURL = "http://www.cs.miami.edu/~tptp/cgi-bin/SystemOnTPTPFormReply";
4.17 -
4.18 -# default parameters
4.19 -my %URLParameters = (
4.20 - "NoHTML" => 1,
4.21 - "QuietFlag" => "-q01",
4.22 - "X2TPTP" => "-S",
4.23 - "SubmitButton" => "RunSelectedSystems",
4.24 - "ProblemSource" => "UPLOAD",
4.25 - );
4.26 -
4.27 -#----Get format and transform options if specified
4.28 -my %Options;
4.29 -getopts("hws:t:c:",\%Options);
4.30 -
4.31 -#----Usage
4.32 -sub usage() {
4.33 - print("Usage: remote [<options>] <File name>\n");
4.34 - print(" <options> are ...\n");
4.35 - print(" -h - print this help\n");
4.36 - print(" -w - list available ATP systems\n");
4.37 - print(" -s<system> - specified system to use\n");
4.38 - print(" -t<timelimit> - CPU time limit for system\n");
4.39 - print(" -c<command> - custom command for system\n");
4.40 - print(" <File name> - TPTP problem file\n");
4.41 - exit(0);
4.42 -}
4.43 -if (exists($Options{'h'})) {
4.44 - usage();
4.45 -}
4.46 -#----What systems flag
4.47 -if (exists($Options{'w'})) {
4.48 - $URLParameters{"SubmitButton"} = "ListSystems";
4.49 - delete($URLParameters{"ProblemSource"});
4.50 -}
4.51 -#----Selected system
4.52 -my $System;
4.53 -if (exists($Options{'s'})) {
4.54 - $System = $Options{'s'};
4.55 -} else {
4.56 - # use Vampire as default
4.57 - $System = "Vampire---9.0";
4.58 -}
4.59 -$URLParameters{"System___$System"} = $System;
4.60 -
4.61 -#----Time limit
4.62 -if (exists($Options{'t'})) {
4.63 - $URLParameters{"TimeLimit___$System"} = $Options{'t'};
4.64 -}
4.65 -#----Custom command
4.66 -if (exists($Options{'c'})) {
4.67 - $URLParameters{"Command___$System"} = $Options{'c'};
4.68 -}
4.69 -
4.70 -#----Get single file name
4.71 -if (exists($URLParameters{"ProblemSource"})) {
4.72 - if (scalar(@ARGV) >= 1) {
4.73 - $URLParameters{"UPLOADProblem"} = [shift(@ARGV)];
4.74 - } else {
4.75 - print("Missing problem file\n");
4.76 - usage();
4.77 - die;
4.78 - }
4.79 -}
4.80 -
4.81 -# Query Server
4.82 -my $Agent = LWP::UserAgent->new;
4.83 -if (exists($Options{'t'})) {
4.84 - # give server more time to respond
4.85 - $Agent->timeout($Options{'t'} + 10);
4.86 -}
4.87 -my $Request = POST($SystemOnTPTPFormReplyURL,
4.88 - Content_Type => 'form-data',Content => \%URLParameters);
4.89 -my $Response = $Agent->request($Request);
4.90 -
4.91 -#catch errors / failure
4.92 -if(! $Response->is_success){
4.93 - print "HTTP-Error: " . $Response->message . "\n";
4.94 - exit(-1);
4.95 -} elsif (exists($Options{'w'})) {
4.96 - print $Response->content;
4.97 - exit (0);
4.98 -} elsif ($Response->content =~ /WARNING: (\S*) does not exist/) {
4.99 - print "Specified System $1 does not exist\n";
4.100 - exit(-1);
4.101 -} elsif ($Response->content =~ /%\s*Result\s*:\s*Unsatisfiable.*\n%\s*Output\s*:\s*(CNF)?Refutation.*\n%/) {
4.102 - my @lines = split( /\n/, $Response->content);
4.103 - my $extract = "";
4.104 - foreach my $line (@lines){
4.105 - #ignore comments
4.106 - if ($line !~ /^%/ && !($line eq "")) {
4.107 - $extract .= "$line";
4.108 - }
4.109 - }
4.110 - # insert newlines after ').'
4.111 - $extract =~ s/\s//g;
4.112 - $extract =~ s/\)\.cnf/\)\.\ncnf/g;
4.113 -
4.114 - # orientation for res_reconstruct.ML
4.115 - print "# SZS output start CNFRefutation.\n";
4.116 - print "$extract\n";
4.117 - print "# SZS output end CNFRefutation.\n";
4.118 - exit(0);
4.119 -} else {
4.120 - print "Remote-script could not extract proof:\n".$Response->content;
4.121 - exit(-1);
4.122 -}
4.123 -
5.1 --- a/doc-src/Codegen/Makefile Mon May 11 09:39:53 2009 +0200
5.2 +++ b/doc-src/Codegen/Makefile Mon May 11 17:20:52 2009 +0200
5.3 @@ -17,7 +17,7 @@
5.4
5.5 dvi: $(NAME).dvi
5.6
5.7 -$(NAME).dvi: $(FILES) isabelle_isar.eps architecture.eps adaption.eps
5.8 +$(NAME).dvi: $(FILES) isabelle_isar.eps architecture.eps adaptation.eps
5.9 $(LATEX) $(NAME)
5.10 $(BIBTEX) $(NAME)
5.11 $(LATEX) $(NAME)
5.12 @@ -25,7 +25,7 @@
5.13
5.14 pdf: $(NAME).pdf
5.15
5.16 -$(NAME).pdf: $(FILES) isabelle_isar.pdf architecture.pdf adaption.pdf
5.17 +$(NAME).pdf: $(FILES) isabelle_isar.pdf architecture.pdf adaptation.pdf
5.18 $(PDFLATEX) $(NAME)
5.19 $(BIBTEX) $(NAME)
5.20 $(PDFLATEX) $(NAME)
5.21 @@ -37,17 +37,17 @@
5.22 architecture.dvi: Thy/pictures/architecture.tex
5.23 latex -output-directory=$(dir $@) $<
5.24
5.25 -adaption.dvi: Thy/pictures/adaption.tex
5.26 +adaptation.dvi: Thy/pictures/adaptation.tex
5.27 latex -output-directory=$(dir $@) $<
5.28
5.29 architecture.eps: architecture.dvi
5.30 dvips -E -o $@ $<
5.31
5.32 -adaption.eps: adaption.dvi
5.33 +adaptation.eps: adaptation.dvi
5.34 dvips -E -o $@ $<
5.35
5.36 architecture.pdf: architecture.eps
5.37 epstopdf --outfile=$@ $<
5.38
5.39 -adaption.pdf: adaption.eps
5.40 +adaptation.pdf: adaptation.eps
5.41 epstopdf --outfile=$@ $<
6.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
6.2 +++ b/doc-src/Codegen/Thy/Adaptation.thy Mon May 11 17:20:52 2009 +0200
6.3 @@ -0,0 +1,326 @@
6.4 +theory Adaptation
6.5 +imports Setup
6.6 +begin
6.7 +
6.8 +setup %invisible {* Code_Target.extend_target ("\<SML>", ("SML", K I)) *}
6.9 +
6.10 +section {* Adaptation to target languages \label{sec:adaptation} *}
6.11 +
6.12 +subsection {* Adapting code generation *}
6.13 +
6.14 +text {*
6.15 + The aspects of code generation introduced so far have two aspects
6.16 + in common:
6.17 +
6.18 + \begin{itemize}
6.19 + \item They act uniformly, without reference to a specific
6.20 + target language.
6.21 + \item They are \emph{safe} in the sense that as long as you trust
6.22 + the code generator meta theory and implementation, you cannot
6.23 + produce programs that yield results which are not derivable
6.24 + in the logic.
6.25 + \end{itemize}
6.26 +
6.27 + \noindent In this section we will introduce means to \emph{adapt} the serialiser
6.28 + to a specific target language, i.e.~to print program fragments
6.29 + in a way which accommodates \qt{already existing} ingredients of
6.30 + a target language environment, for three reasons:
6.31 +
6.32 + \begin{itemize}
6.33 + \item improving readability and aesthetics of generated code
6.34 + \item gaining efficiency
6.35 + \item interface with language parts which have no direct counterpart
6.36 + in @{text "HOL"} (say, imperative data structures)
6.37 + \end{itemize}
6.38 +
6.39 + \noindent Generally, you should avoid using those features yourself
6.40 + \emph{at any cost}:
6.41 +
6.42 + \begin{itemize}
6.43 + \item The safe configuration methods act uniformly on every target language,
6.44 + whereas for adaptation you have to treat each target language separate.
6.45 + \item Application is extremely tedious since there is no abstraction
6.46 + which would allow for a static check, making it easy to produce garbage.
6.47 + \item More or less subtle errors can be introduced unconsciously.
6.48 + \end{itemize}
6.49 +
6.50 + \noindent However, even if you ought refrain from setting up adaptation
6.51 + yourself, already the @{text "HOL"} comes with some reasonable default
6.52 + adaptations (say, using target language list syntax). There also some
6.53 + common adaptation cases which you can setup by importing particular
6.54 + library theories. In order to understand these, we provide some clues here;
6.55 + these however are not supposed to replace a careful study of the sources.
6.56 +*}
6.57 +
6.58 +subsection {* The adaptation principle *}
6.59 +
6.60 +text {*
6.61 + Figure \ref{fig:adaptation} illustrates what \qt{adaptation} is conceptually
6.62 + supposed to be:
6.63 +
6.64 + \begin{figure}[here]
6.65 + \includegraphics{adaptation}
6.66 + \caption{The adaptation principle}
6.67 + \label{fig:adaptation}
6.68 + \end{figure}
6.69 +
6.70 + \noindent In the tame view, code generation acts as broker between
6.71 + @{text logic}, @{text "intermediate language"} and
6.72 + @{text "target language"} by means of @{text translation} and
6.73 + @{text serialisation}; for the latter, the serialiser has to observe
6.74 + the structure of the @{text language} itself plus some @{text reserved}
6.75 + keywords which have to be avoided for generated code.
6.76 + However, if you consider @{text adaptation} mechanisms, the code generated
6.77 + by the serializer is just the tip of the iceberg:
6.78 +
6.79 + \begin{itemize}
6.80 + \item @{text serialisation} can be \emph{parametrised} such that
6.81 + logical entities are mapped to target-specific ones
6.82 + (e.g. target-specific list syntax,
6.83 + see also \secref{sec:adaptation_mechanisms})
6.84 + \item Such parametrisations can involve references to a
6.85 + target-specific standard @{text library} (e.g. using
6.86 + the @{text Haskell} @{verbatim Maybe} type instead
6.87 + of the @{text HOL} @{type "option"} type);
6.88 + if such are used, the corresponding identifiers
6.89 + (in our example, @{verbatim Maybe}, @{verbatim Nothing}
6.90 + and @{verbatim Just}) also have to be considered @{text reserved}.
6.91 + \item Even more, the user can enrich the library of the
6.92 + target-language by providing code snippets
6.93 + (\qt{@{text "includes"}}) which are prepended to
6.94 + any generated code (see \secref{sec:include}); this typically
6.95 + also involves further @{text reserved} identifiers.
6.96 + \end{itemize}
6.97 +
6.98 + \noindent As figure \ref{fig:adaptation} illustrates, all these adaptation mechanisms
6.99 + have to act consistently; it is at the discretion of the user
6.100 + to take care for this.
6.101 +*}
6.102 +
6.103 +subsection {* Common adaptation patterns *}
6.104 +
6.105 +text {*
6.106 + The @{theory HOL} @{theory Main} theory already provides a code
6.107 + generator setup
6.108 + which should be suitable for most applications. Common extensions
6.109 + and modifications are available by certain theories of the @{text HOL}
6.110 + library; beside being useful in applications, they may serve
6.111 + as a tutorial for customising the code generator setup (see below
6.112 + \secref{sec:adaptation_mechanisms}).
6.113 +
6.114 + \begin{description}
6.115 +
6.116 + \item[@{theory "Code_Integer"}] represents @{text HOL} integers by big
6.117 + integer literals in target languages.
6.118 + \item[@{theory "Code_Char"}] represents @{text HOL} characters by
6.119 + character literals in target languages.
6.120 + \item[@{theory "Code_Char_chr"}] like @{text "Code_Char"},
6.121 + but also offers treatment of character codes; includes
6.122 + @{theory "Code_Char"}.
6.123 + \item[@{theory "Efficient_Nat"}] \label{eff_nat} implements natural numbers by integers,
6.124 + which in general will result in higher efficiency; pattern
6.125 + matching with @{term "0\<Colon>nat"} / @{const "Suc"}
6.126 + is eliminated; includes @{theory "Code_Integer"}
6.127 + and @{theory "Code_Index"}.
6.128 + \item[@{theory "Code_Index"}] provides an additional datatype
6.129 + @{typ index} which is mapped to target-language built-in integers.
6.130 + Useful for code setups which involve e.g. indexing of
6.131 + target-language arrays.
6.132 + \item[@{theory "String"}] provides an additional datatype
6.133 + @{typ message_string} which is isomorphic to strings;
6.134 + @{typ message_string}s are mapped to target-language strings.
6.135 + Useful for code setups which involve e.g. printing (error) messages.
6.136 +
6.137 + \end{description}
6.138 +
6.139 + \begin{warn}
6.140 + When importing any of these theories, they should form the last
6.141 + items in an import list. Since these theories adapt the
6.142 + code generator setup in a non-conservative fashion,
6.143 + strange effects may occur otherwise.
6.144 + \end{warn}
6.145 +*}
6.146 +
6.147 +
6.148 +subsection {* Parametrising serialisation \label{sec:adaptation_mechanisms} *}
6.149 +
6.150 +text {*
6.151 + Consider the following function and its corresponding
6.152 + SML code:
6.153 +*}
6.154 +
6.155 +primrec %quote in_interval :: "nat \<times> nat \<Rightarrow> nat \<Rightarrow> bool" where
6.156 + "in_interval (k, l) n \<longleftrightarrow> k \<le> n \<and> n \<le> l"
6.157 +(*<*)
6.158 +code_type %invisible bool
6.159 + (SML)
6.160 +code_const %invisible True and False and "op \<and>" and Not
6.161 + (SML and and and)
6.162 +(*>*)
6.163 +text %quote {*@{code_stmts in_interval (SML)}*}
6.164 +
6.165 +text {*
6.166 + \noindent Though this is correct code, it is a little bit unsatisfactory:
6.167 + boolean values and operators are materialised as distinguished
6.168 + entities with have nothing to do with the SML-built-in notion
6.169 + of \qt{bool}. This results in less readable code;
6.170 + additionally, eager evaluation may cause programs to
6.171 + loop or break which would perfectly terminate when
6.172 + the existing SML @{verbatim "bool"} would be used. To map
6.173 + the HOL @{typ bool} on SML @{verbatim "bool"}, we may use
6.174 + \qn{custom serialisations}:
6.175 +*}
6.176 +
6.177 +code_type %quotett bool
6.178 + (SML "bool")
6.179 +code_const %quotett True and False and "op \<and>"
6.180 + (SML "true" and "false" and "_ andalso _")
6.181 +
6.182 +text {*
6.183 + \noindent The @{command code_type} command takes a type constructor
6.184 + as arguments together with a list of custom serialisations.
6.185 + Each custom serialisation starts with a target language
6.186 + identifier followed by an expression, which during
6.187 + code serialisation is inserted whenever the type constructor
6.188 + would occur. For constants, @{command code_const} implements
6.189 + the corresponding mechanism. Each ``@{verbatim "_"}'' in
6.190 + a serialisation expression is treated as a placeholder
6.191 + for the type constructor's (the constant's) arguments.
6.192 +*}
6.193 +
6.194 +text %quote {*@{code_stmts in_interval (SML)}*}
6.195 +
6.196 +text {*
6.197 + \noindent This still is not perfect: the parentheses
6.198 + around the \qt{andalso} expression are superfluous.
6.199 + Though the serialiser
6.200 + by no means attempts to imitate the rich Isabelle syntax
6.201 + framework, it provides some common idioms, notably
6.202 + associative infixes with precedences which may be used here:
6.203 +*}
6.204 +
6.205 +code_const %quotett "op \<and>"
6.206 + (SML infixl 1 "andalso")
6.207 +
6.208 +text %quote {*@{code_stmts in_interval (SML)}*}
6.209 +
6.210 +text {*
6.211 + \noindent The attentive reader may ask how we assert that no generated
6.212 + code will accidentally overwrite. For this reason the serialiser has
6.213 + an internal table of identifiers which have to be avoided to be used
6.214 + for new declarations. Initially, this table typically contains the
6.215 + keywords of the target language. It can be extended manually, thus avoiding
6.216 + accidental overwrites, using the @{command "code_reserved"} command:
6.217 +*}
6.218 +
6.219 +code_reserved %quote "\<SML>" bool true false andalso
6.220 +
6.221 +text {*
6.222 + \noindent Next, we try to map HOL pairs to SML pairs, using the
6.223 + infix ``@{verbatim "*"}'' type constructor and parentheses:
6.224 +*}
6.225 +(*<*)
6.226 +code_type %invisible *
6.227 + (SML)
6.228 +code_const %invisible Pair
6.229 + (SML)
6.230 +(*>*)
6.231 +code_type %quotett *
6.232 + (SML infix 2 "*")
6.233 +code_const %quotett Pair
6.234 + (SML "!((_),/ (_))")
6.235 +
6.236 +text {*
6.237 + \noindent The initial bang ``@{verbatim "!"}'' tells the serialiser
6.238 + never to put
6.239 + parentheses around the whole expression (they are already present),
6.240 + while the parentheses around argument place holders
6.241 + tell not to put parentheses around the arguments.
6.242 + The slash ``@{verbatim "/"}'' (followed by arbitrary white space)
6.243 + inserts a space which may be used as a break if necessary
6.244 + during pretty printing.
6.245 +
6.246 + These examples give a glimpse what mechanisms
6.247 + custom serialisations provide; however their usage
6.248 + requires careful thinking in order not to introduce
6.249 + inconsistencies -- or, in other words:
6.250 + custom serialisations are completely axiomatic.
6.251 +
6.252 + A further noteworthy details is that any special
6.253 + character in a custom serialisation may be quoted
6.254 + using ``@{verbatim "'"}''; thus, in
6.255 + ``@{verbatim "fn '_ => _"}'' the first
6.256 + ``@{verbatim "_"}'' is a proper underscore while the
6.257 + second ``@{verbatim "_"}'' is a placeholder.
6.258 +*}
6.259 +
6.260 +
6.261 +subsection {* @{text Haskell} serialisation *}
6.262 +
6.263 +text {*
6.264 + For convenience, the default
6.265 + @{text HOL} setup for @{text Haskell} maps the @{class eq} class to
6.266 + its counterpart in @{text Haskell}, giving custom serialisations
6.267 + for the class @{class eq} (by command @{command code_class}) and its operation
6.268 + @{const HOL.eq}
6.269 +*}
6.270 +
6.271 +code_class %quotett eq
6.272 + (Haskell "Eq")
6.273 +
6.274 +code_const %quotett "op ="
6.275 + (Haskell infixl 4 "==")
6.276 +
6.277 +text {*
6.278 + \noindent A problem now occurs whenever a type which
6.279 + is an instance of @{class eq} in @{text HOL} is mapped
6.280 + on a @{text Haskell}-built-in type which is also an instance
6.281 + of @{text Haskell} @{text Eq}:
6.282 +*}
6.283 +
6.284 +typedecl %quote bar
6.285 +
6.286 +instantiation %quote bar :: eq
6.287 +begin
6.288 +
6.289 +definition %quote "eq_class.eq (x\<Colon>bar) y \<longleftrightarrow> x = y"
6.290 +
6.291 +instance %quote by default (simp add: eq_bar_def)
6.292 +
6.293 +end %quote (*<*)
6.294 +
6.295 +(*>*) code_type %quotett bar
6.296 + (Haskell "Integer")
6.297 +
6.298 +text {*
6.299 + \noindent The code generator would produce
6.300 + an additional instance, which of course is rejected by the @{text Haskell}
6.301 + compiler.
6.302 + To suppress this additional instance, use
6.303 + @{text "code_instance"}:
6.304 +*}
6.305 +
6.306 +code_instance %quotett bar :: eq
6.307 + (Haskell -)
6.308 +
6.309 +
6.310 +subsection {* Enhancing the target language context \label{sec:include} *}
6.311 +
6.312 +text {*
6.313 + In rare cases it is necessary to \emph{enrich} the context of a
6.314 + target language; this is accomplished using the @{command "code_include"}
6.315 + command:
6.316 +*}
6.317 +
6.318 +code_include %quotett Haskell "Errno"
6.319 +{*errno i = error ("Error number: " ++ show i)*}
6.320 +
6.321 +code_reserved %quotett Haskell Errno
6.322 +
6.323 +text {*
6.324 + \noindent Such named @{text include}s are then prepended to every generated code.
6.325 + Inspect such code in order to find out how @{command "code_include"} behaves
6.326 + with respect to a particular target language.
6.327 +*}
6.328 +
6.329 +end
7.1 --- a/doc-src/Codegen/Thy/Adaption.thy Mon May 11 09:39:53 2009 +0200
7.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
7.3 @@ -1,326 +0,0 @@
7.4 -theory Adaption
7.5 -imports Setup
7.6 -begin
7.7 -
7.8 -setup %invisible {* Code_Target.extend_target ("\<SML>", ("SML", K I)) *}
7.9 -
7.10 -section {* Adaption to target languages \label{sec:adaption} *}
7.11 -
7.12 -subsection {* Adapting code generation *}
7.13 -
7.14 -text {*
7.15 - The aspects of code generation introduced so far have two aspects
7.16 - in common:
7.17 -
7.18 - \begin{itemize}
7.19 - \item They act uniformly, without reference to a specific
7.20 - target language.
7.21 - \item They are \emph{safe} in the sense that as long as you trust
7.22 - the code generator meta theory and implementation, you cannot
7.23 - produce programs that yield results which are not derivable
7.24 - in the logic.
7.25 - \end{itemize}
7.26 -
7.27 - \noindent In this section we will introduce means to \emph{adapt} the serialiser
7.28 - to a specific target language, i.e.~to print program fragments
7.29 - in a way which accommodates \qt{already existing} ingredients of
7.30 - a target language environment, for three reasons:
7.31 -
7.32 - \begin{itemize}
7.33 - \item improving readability and aesthetics of generated code
7.34 - \item gaining efficiency
7.35 - \item interface with language parts which have no direct counterpart
7.36 - in @{text "HOL"} (say, imperative data structures)
7.37 - \end{itemize}
7.38 -
7.39 - \noindent Generally, you should avoid using those features yourself
7.40 - \emph{at any cost}:
7.41 -
7.42 - \begin{itemize}
7.43 - \item The safe configuration methods act uniformly on every target language,
7.44 - whereas for adaption you have to treat each target language separate.
7.45 - \item Application is extremely tedious since there is no abstraction
7.46 - which would allow for a static check, making it easy to produce garbage.
7.47 - \item More or less subtle errors can be introduced unconsciously.
7.48 - \end{itemize}
7.49 -
7.50 - \noindent However, even if you ought refrain from setting up adaption
7.51 - yourself, already the @{text "HOL"} comes with some reasonable default
7.52 - adaptions (say, using target language list syntax). There also some
7.53 - common adaption cases which you can setup by importing particular
7.54 - library theories. In order to understand these, we provide some clues here;
7.55 - these however are not supposed to replace a careful study of the sources.
7.56 -*}
7.57 -
7.58 -subsection {* The adaption principle *}
7.59 -
7.60 -text {*
7.61 - Figure \ref{fig:adaption} illustrates what \qt{adaption} is conceptually
7.62 - supposed to be:
7.63 -
7.64 - \begin{figure}[here]
7.65 - \includegraphics{adaption}
7.66 - \caption{The adaption principle}
7.67 - \label{fig:adaption}
7.68 - \end{figure}
7.69 -
7.70 - \noindent In the tame view, code generation acts as broker between
7.71 - @{text logic}, @{text "intermediate language"} and
7.72 - @{text "target language"} by means of @{text translation} and
7.73 - @{text serialisation}; for the latter, the serialiser has to observe
7.74 - the structure of the @{text language} itself plus some @{text reserved}
7.75 - keywords which have to be avoided for generated code.
7.76 - However, if you consider @{text adaption} mechanisms, the code generated
7.77 - by the serializer is just the tip of the iceberg:
7.78 -
7.79 - \begin{itemize}
7.80 - \item @{text serialisation} can be \emph{parametrised} such that
7.81 - logical entities are mapped to target-specific ones
7.82 - (e.g. target-specific list syntax,
7.83 - see also \secref{sec:adaption_mechanisms})
7.84 - \item Such parametrisations can involve references to a
7.85 - target-specific standard @{text library} (e.g. using
7.86 - the @{text Haskell} @{verbatim Maybe} type instead
7.87 - of the @{text HOL} @{type "option"} type);
7.88 - if such are used, the corresponding identifiers
7.89 - (in our example, @{verbatim Maybe}, @{verbatim Nothing}
7.90 - and @{verbatim Just}) also have to be considered @{text reserved}.
7.91 - \item Even more, the user can enrich the library of the
7.92 - target-language by providing code snippets
7.93 - (\qt{@{text "includes"}}) which are prepended to
7.94 - any generated code (see \secref{sec:include}); this typically
7.95 - also involves further @{text reserved} identifiers.
7.96 - \end{itemize}
7.97 -
7.98 - \noindent As figure \ref{fig:adaption} illustrates, all these adaption mechanisms
7.99 - have to act consistently; it is at the discretion of the user
7.100 - to take care for this.
7.101 -*}
7.102 -
7.103 -subsection {* Common adaption patterns *}
7.104 -
7.105 -text {*
7.106 - The @{theory HOL} @{theory Main} theory already provides a code
7.107 - generator setup
7.108 - which should be suitable for most applications. Common extensions
7.109 - and modifications are available by certain theories of the @{text HOL}
7.110 - library; beside being useful in applications, they may serve
7.111 - as a tutorial for customising the code generator setup (see below
7.112 - \secref{sec:adaption_mechanisms}).
7.113 -
7.114 - \begin{description}
7.115 -
7.116 - \item[@{theory "Code_Integer"}] represents @{text HOL} integers by big
7.117 - integer literals in target languages.
7.118 - \item[@{theory "Code_Char"}] represents @{text HOL} characters by
7.119 - character literals in target languages.
7.120 - \item[@{theory "Code_Char_chr"}] like @{text "Code_Char"},
7.121 - but also offers treatment of character codes; includes
7.122 - @{theory "Code_Char"}.
7.123 - \item[@{theory "Efficient_Nat"}] \label{eff_nat} implements natural numbers by integers,
7.124 - which in general will result in higher efficiency; pattern
7.125 - matching with @{term "0\<Colon>nat"} / @{const "Suc"}
7.126 - is eliminated; includes @{theory "Code_Integer"}
7.127 - and @{theory "Code_Index"}.
7.128 - \item[@{theory "Code_Index"}] provides an additional datatype
7.129 - @{typ index} which is mapped to target-language built-in integers.
7.130 - Useful for code setups which involve e.g. indexing of
7.131 - target-language arrays.
7.132 - \item[@{theory "Code_Message"}] provides an additional datatype
7.133 - @{typ message_string} which is isomorphic to strings;
7.134 - @{typ message_string}s are mapped to target-language strings.
7.135 - Useful for code setups which involve e.g. printing (error) messages.
7.136 -
7.137 - \end{description}
7.138 -
7.139 - \begin{warn}
7.140 - When importing any of these theories, they should form the last
7.141 - items in an import list. Since these theories adapt the
7.142 - code generator setup in a non-conservative fashion,
7.143 - strange effects may occur otherwise.
7.144 - \end{warn}
7.145 -*}
7.146 -
7.147 -
7.148 -subsection {* Parametrising serialisation \label{sec:adaption_mechanisms} *}
7.149 -
7.150 -text {*
7.151 - Consider the following function and its corresponding
7.152 - SML code:
7.153 -*}
7.154 -
7.155 -primrec %quote in_interval :: "nat \<times> nat \<Rightarrow> nat \<Rightarrow> bool" where
7.156 - "in_interval (k, l) n \<longleftrightarrow> k \<le> n \<and> n \<le> l"
7.157 -(*<*)
7.158 -code_type %invisible bool
7.159 - (SML)
7.160 -code_const %invisible True and False and "op \<and>" and Not
7.161 - (SML and and and)
7.162 -(*>*)
7.163 -text %quote {*@{code_stmts in_interval (SML)}*}
7.164 -
7.165 -text {*
7.166 - \noindent Though this is correct code, it is a little bit unsatisfactory:
7.167 - boolean values and operators are materialised as distinguished
7.168 - entities with have nothing to do with the SML-built-in notion
7.169 - of \qt{bool}. This results in less readable code;
7.170 - additionally, eager evaluation may cause programs to
7.171 - loop or break which would perfectly terminate when
7.172 - the existing SML @{verbatim "bool"} would be used. To map
7.173 - the HOL @{typ bool} on SML @{verbatim "bool"}, we may use
7.174 - \qn{custom serialisations}:
7.175 -*}
7.176 -
7.177 -code_type %quotett bool
7.178 - (SML "bool")
7.179 -code_const %quotett True and False and "op \<and>"
7.180 - (SML "true" and "false" and "_ andalso _")
7.181 -
7.182 -text {*
7.183 - \noindent The @{command code_type} command takes a type constructor
7.184 - as arguments together with a list of custom serialisations.
7.185 - Each custom serialisation starts with a target language
7.186 - identifier followed by an expression, which during
7.187 - code serialisation is inserted whenever the type constructor
7.188 - would occur. For constants, @{command code_const} implements
7.189 - the corresponding mechanism. Each ``@{verbatim "_"}'' in
7.190 - a serialisation expression is treated as a placeholder
7.191 - for the type constructor's (the constant's) arguments.
7.192 -*}
7.193 -
7.194 -text %quote {*@{code_stmts in_interval (SML)}*}
7.195 -
7.196 -text {*
7.197 - \noindent This still is not perfect: the parentheses
7.198 - around the \qt{andalso} expression are superfluous.
7.199 - Though the serialiser
7.200 - by no means attempts to imitate the rich Isabelle syntax
7.201 - framework, it provides some common idioms, notably
7.202 - associative infixes with precedences which may be used here:
7.203 -*}
7.204 -
7.205 -code_const %quotett "op \<and>"
7.206 - (SML infixl 1 "andalso")
7.207 -
7.208 -text %quote {*@{code_stmts in_interval (SML)}*}
7.209 -
7.210 -text {*
7.211 - \noindent The attentive reader may ask how we assert that no generated
7.212 - code will accidentally overwrite. For this reason the serialiser has
7.213 - an internal table of identifiers which have to be avoided to be used
7.214 - for new declarations. Initially, this table typically contains the
7.215 - keywords of the target language. It can be extended manually, thus avoiding
7.216 - accidental overwrites, using the @{command "code_reserved"} command:
7.217 -*}
7.218 -
7.219 -code_reserved %quote "\<SML>" bool true false andalso
7.220 -
7.221 -text {*
7.222 - \noindent Next, we try to map HOL pairs to SML pairs, using the
7.223 - infix ``@{verbatim "*"}'' type constructor and parentheses:
7.224 -*}
7.225 -(*<*)
7.226 -code_type %invisible *
7.227 - (SML)
7.228 -code_const %invisible Pair
7.229 - (SML)
7.230 -(*>*)
7.231 -code_type %quotett *
7.232 - (SML infix 2 "*")
7.233 -code_const %quotett Pair
7.234 - (SML "!((_),/ (_))")
7.235 -
7.236 -text {*
7.237 - \noindent The initial bang ``@{verbatim "!"}'' tells the serialiser
7.238 - never to put
7.239 - parentheses around the whole expression (they are already present),
7.240 - while the parentheses around argument place holders
7.241 - tell not to put parentheses around the arguments.
7.242 - The slash ``@{verbatim "/"}'' (followed by arbitrary white space)
7.243 - inserts a space which may be used as a break if necessary
7.244 - during pretty printing.
7.245 -
7.246 - These examples give a glimpse what mechanisms
7.247 - custom serialisations provide; however their usage
7.248 - requires careful thinking in order not to introduce
7.249 - inconsistencies -- or, in other words:
7.250 - custom serialisations are completely axiomatic.
7.251 -
7.252 - A further noteworthy details is that any special
7.253 - character in a custom serialisation may be quoted
7.254 - using ``@{verbatim "'"}''; thus, in
7.255 - ``@{verbatim "fn '_ => _"}'' the first
7.256 - ``@{verbatim "_"}'' is a proper underscore while the
7.257 - second ``@{verbatim "_"}'' is a placeholder.
7.258 -*}
7.259 -
7.260 -
7.261 -subsection {* @{text Haskell} serialisation *}
7.262 -
7.263 -text {*
7.264 - For convenience, the default
7.265 - @{text HOL} setup for @{text Haskell} maps the @{class eq} class to
7.266 - its counterpart in @{text Haskell}, giving custom serialisations
7.267 - for the class @{class eq} (by command @{command code_class}) and its operation
7.268 - @{const HOL.eq}
7.269 -*}
7.270 -
7.271 -code_class %quotett eq
7.272 - (Haskell "Eq")
7.273 -
7.274 -code_const %quotett "op ="
7.275 - (Haskell infixl 4 "==")
7.276 -
7.277 -text {*
7.278 - \noindent A problem now occurs whenever a type which
7.279 - is an instance of @{class eq} in @{text HOL} is mapped
7.280 - on a @{text Haskell}-built-in type which is also an instance
7.281 - of @{text Haskell} @{text Eq}:
7.282 -*}
7.283 -
7.284 -typedecl %quote bar
7.285 -
7.286 -instantiation %quote bar :: eq
7.287 -begin
7.288 -
7.289 -definition %quote "eq_class.eq (x\<Colon>bar) y \<longleftrightarrow> x = y"
7.290 -
7.291 -instance %quote by default (simp add: eq_bar_def)
7.292 -
7.293 -end %quote (*<*)
7.294 -
7.295 -(*>*) code_type %quotett bar
7.296 - (Haskell "Integer")
7.297 -
7.298 -text {*
7.299 - \noindent The code generator would produce
7.300 - an additional instance, which of course is rejected by the @{text Haskell}
7.301 - compiler.
7.302 - To suppress this additional instance, use
7.303 - @{text "code_instance"}:
7.304 -*}
7.305 -
7.306 -code_instance %quotett bar :: eq
7.307 - (Haskell -)
7.308 -
7.309 -
7.310 -subsection {* Enhancing the target language context \label{sec:include} *}
7.311 -
7.312 -text {*
7.313 - In rare cases it is necessary to \emph{enrich} the context of a
7.314 - target language; this is accomplished using the @{command "code_include"}
7.315 - command:
7.316 -*}
7.317 -
7.318 -code_include %quotett Haskell "Errno"
7.319 -{*errno i = error ("Error number: " ++ show i)*}
7.320 -
7.321 -code_reserved %quotett Haskell Errno
7.322 -
7.323 -text {*
7.324 - \noindent Such named @{text include}s are then prepended to every generated code.
7.325 - Inspect such code in order to find out how @{command "code_include"} behaves
7.326 - with respect to a particular target language.
7.327 -*}
7.328 -
7.329 -end
8.1 --- a/doc-src/Codegen/Thy/Further.thy Mon May 11 09:39:53 2009 +0200
8.2 +++ b/doc-src/Codegen/Thy/Further.thy Mon May 11 17:20:52 2009 +0200
8.3 @@ -66,7 +66,7 @@
8.4 text {*
8.5 \noindent The soundness of the @{method eval} method depends crucially
8.6 on the correctness of the code generator; this is one of the reasons
8.7 - why you should not use adaption (see \secref{sec:adaption}) frivolously.
8.8 + why you should not use adaptation (see \secref{sec:adaptation}) frivolously.
8.9 *}
8.10
8.11 subsection {* Code antiquotation *}
9.1 --- a/doc-src/Codegen/Thy/Introduction.thy Mon May 11 09:39:53 2009 +0200
9.2 +++ b/doc-src/Codegen/Thy/Introduction.thy Mon May 11 17:20:52 2009 +0200
9.3 @@ -28,8 +28,8 @@
9.4 This manifests in the structure of this tutorial: after a short
9.5 conceptual introduction with an example (\secref{sec:intro}),
9.6 we discuss the generic customisation facilities (\secref{sec:program}).
9.7 - A further section (\secref{sec:adaption}) is dedicated to the matter of
9.8 - \qn{adaption} to specific target language environments. After some
9.9 + A further section (\secref{sec:adaptation}) is dedicated to the matter of
9.10 + \qn{adaptation} to specific target language environments. After some
9.11 further issues (\secref{sec:further}) we conclude with an overview
9.12 of some ML programming interfaces (\secref{sec:ml}).
9.13
10.1 --- a/doc-src/Codegen/Thy/Program.thy Mon May 11 09:39:53 2009 +0200
10.2 +++ b/doc-src/Codegen/Thy/Program.thy Mon May 11 17:20:52 2009 +0200
10.3 @@ -323,7 +323,7 @@
10.4 *}
10.5
10.6
10.7 -subsection {* Equality and wellsortedness *}
10.8 +subsection {* Equality *}
10.9
10.10 text {*
10.11 Surely you have already noticed how equality is treated
10.12 @@ -358,60 +358,7 @@
10.13 manually like any other type class.
10.14
10.15 Though this @{text eq} class is designed to get rarely in
10.16 - the way, a subtlety
10.17 - enters the stage when definitions of overloaded constants
10.18 - are dependent on operational equality. For example, let
10.19 - us define a lexicographic ordering on tuples
10.20 - (also see theory @{theory Product_ord}):
10.21 -*}
10.22 -
10.23 -instantiation %quote "*" :: (order, order) order
10.24 -begin
10.25 -
10.26 -definition %quote [code del]:
10.27 - "x \<le> y \<longleftrightarrow> fst x < fst y \<or> fst x = fst y \<and> snd x \<le> snd y"
10.28 -
10.29 -definition %quote [code del]:
10.30 - "x < y \<longleftrightarrow> fst x < fst y \<or> fst x = fst y \<and> snd x < snd y"
10.31 -
10.32 -instance %quote proof
10.33 -qed (auto simp: less_eq_prod_def less_prod_def intro: order_less_trans)
10.34 -
10.35 -end %quote
10.36 -
10.37 -lemma %quote order_prod [code]:
10.38 - "(x1 \<Colon> 'a\<Colon>order, y1 \<Colon> 'b\<Colon>order) < (x2, y2) \<longleftrightarrow>
10.39 - x1 < x2 \<or> x1 = x2 \<and> y1 < y2"
10.40 - "(x1 \<Colon> 'a\<Colon>order, y1 \<Colon> 'b\<Colon>order) \<le> (x2, y2) \<longleftrightarrow>
10.41 - x1 < x2 \<or> x1 = x2 \<and> y1 \<le> y2"
10.42 - by (simp_all add: less_prod_def less_eq_prod_def)
10.43 -
10.44 -text {*
10.45 - \noindent Then code generation will fail. Why? The definition
10.46 - of @{term "op \<le>"} depends on equality on both arguments,
10.47 - which are polymorphic and impose an additional @{class eq}
10.48 - class constraint, which the preprocessor does not propagate
10.49 - (for technical reasons).
10.50 -
10.51 - The solution is to add @{class eq} explicitly to the first sort arguments in the
10.52 - code theorems:
10.53 -*}
10.54 -
10.55 -lemma %quote order_prod_code [code]:
10.56 - "(x1 \<Colon> 'a\<Colon>{order, eq}, y1 \<Colon> 'b\<Colon>order) < (x2, y2) \<longleftrightarrow>
10.57 - x1 < x2 \<or> x1 = x2 \<and> y1 < y2"
10.58 - "(x1 \<Colon> 'a\<Colon>{order, eq}, y1 \<Colon> 'b\<Colon>order) \<le> (x2, y2) \<longleftrightarrow>
10.59 - x1 < x2 \<or> x1 = x2 \<and> y1 \<le> y2"
10.60 - by (simp_all add: less_prod_def less_eq_prod_def)
10.61 -
10.62 -text {*
10.63 - \noindent Then code generation succeeds:
10.64 -*}
10.65 -
10.66 -text %quote {*@{code_stmts "op \<le> \<Colon> _ \<times> _ \<Rightarrow> _ \<times> _ \<Rightarrow> bool" (SML)}*}
10.67 -
10.68 -text {*
10.69 - In some cases, the automatically derived code equations
10.70 + the way, in some cases the automatically derived code equations
10.71 for equality on a particular type may not be appropriate.
10.72 As example, watch the following datatype representing
10.73 monomorphic parametric types (where type constructors
11.1 --- a/doc-src/Codegen/Thy/ROOT.ML Mon May 11 09:39:53 2009 +0200
11.2 +++ b/doc-src/Codegen/Thy/ROOT.ML Mon May 11 17:20:52 2009 +0200
11.3 @@ -4,6 +4,6 @@
11.4
11.5 use_thy "Introduction";
11.6 use_thy "Program";
11.7 -use_thy "Adaption";
11.8 +use_thy "Adaptation";
11.9 use_thy "Further";
11.10 use_thy "ML";
12.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
12.2 +++ b/doc-src/Codegen/Thy/document/Adaptation.tex Mon May 11 17:20:52 2009 +0200
12.3 @@ -0,0 +1,642 @@
12.4 +%
12.5 +\begin{isabellebody}%
12.6 +\def\isabellecontext{Adaptation}%
12.7 +%
12.8 +\isadelimtheory
12.9 +%
12.10 +\endisadelimtheory
12.11 +%
12.12 +\isatagtheory
12.13 +\isacommand{theory}\isamarkupfalse%
12.14 +\ Adaptation\isanewline
12.15 +\isakeyword{imports}\ Setup\isanewline
12.16 +\isakeyword{begin}%
12.17 +\endisatagtheory
12.18 +{\isafoldtheory}%
12.19 +%
12.20 +\isadelimtheory
12.21 +\isanewline
12.22 +%
12.23 +\endisadelimtheory
12.24 +%
12.25 +\isadeliminvisible
12.26 +\isanewline
12.27 +%
12.28 +\endisadeliminvisible
12.29 +%
12.30 +\isataginvisible
12.31 +\isacommand{setup}\isamarkupfalse%
12.32 +\ {\isacharverbatimopen}\ Code{\isacharunderscore}Target{\isachardot}extend{\isacharunderscore}target\ {\isacharparenleft}{\isachardoublequote}{\isasymSML}{\isachardoublequote}{\isacharcomma}\ {\isacharparenleft}{\isachardoublequote}SML{\isachardoublequote}{\isacharcomma}\ K\ I{\isacharparenright}{\isacharparenright}\ {\isacharverbatimclose}%
12.33 +\endisataginvisible
12.34 +{\isafoldinvisible}%
12.35 +%
12.36 +\isadeliminvisible
12.37 +%
12.38 +\endisadeliminvisible
12.39 +%
12.40 +\isamarkupsection{Adaptation to target languages \label{sec:adaptation}%
12.41 +}
12.42 +\isamarkuptrue%
12.43 +%
12.44 +\isamarkupsubsection{Adapting code generation%
12.45 +}
12.46 +\isamarkuptrue%
12.47 +%
12.48 +\begin{isamarkuptext}%
12.49 +The aspects of code generation introduced so far have two aspects
12.50 + in common:
12.51 +
12.52 + \begin{itemize}
12.53 + \item They act uniformly, without reference to a specific
12.54 + target language.
12.55 + \item They are \emph{safe} in the sense that as long as you trust
12.56 + the code generator meta theory and implementation, you cannot
12.57 + produce programs that yield results which are not derivable
12.58 + in the logic.
12.59 + \end{itemize}
12.60 +
12.61 + \noindent In this section we will introduce means to \emph{adapt} the serialiser
12.62 + to a specific target language, i.e.~to print program fragments
12.63 + in a way which accommodates \qt{already existing} ingredients of
12.64 + a target language environment, for three reasons:
12.65 +
12.66 + \begin{itemize}
12.67 + \item improving readability and aesthetics of generated code
12.68 + \item gaining efficiency
12.69 + \item interface with language parts which have no direct counterpart
12.70 + in \isa{HOL} (say, imperative data structures)
12.71 + \end{itemize}
12.72 +
12.73 + \noindent Generally, you should avoid using those features yourself
12.74 + \emph{at any cost}:
12.75 +
12.76 + \begin{itemize}
12.77 + \item The safe configuration methods act uniformly on every target language,
12.78 + whereas for adaptation you have to treat each target language separate.
12.79 + \item Application is extremely tedious since there is no abstraction
12.80 + which would allow for a static check, making it easy to produce garbage.
12.81 + \item More or less subtle errors can be introduced unconsciously.
12.82 + \end{itemize}
12.83 +
12.84 + \noindent However, even if you ought refrain from setting up adaptation
12.85 + yourself, already the \isa{HOL} comes with some reasonable default
12.86 + adaptations (say, using target language list syntax). There also some
12.87 + common adaptation cases which you can setup by importing particular
12.88 + library theories. In order to understand these, we provide some clues here;
12.89 + these however are not supposed to replace a careful study of the sources.%
12.90 +\end{isamarkuptext}%
12.91 +\isamarkuptrue%
12.92 +%
12.93 +\isamarkupsubsection{The adaptation principle%
12.94 +}
12.95 +\isamarkuptrue%
12.96 +%
12.97 +\begin{isamarkuptext}%
12.98 +Figure \ref{fig:adaptation} illustrates what \qt{adaptation} is conceptually
12.99 + supposed to be:
12.100 +
12.101 + \begin{figure}[here]
12.102 + \includegraphics{adaptation}
12.103 + \caption{The adaptation principle}
12.104 + \label{fig:adaptation}
12.105 + \end{figure}
12.106 +
12.107 + \noindent In the tame view, code generation acts as broker between
12.108 + \isa{logic}, \isa{intermediate\ language} and
12.109 + \isa{target\ language} by means of \isa{translation} and
12.110 + \isa{serialisation}; for the latter, the serialiser has to observe
12.111 + the structure of the \isa{language} itself plus some \isa{reserved}
12.112 + keywords which have to be avoided for generated code.
12.113 + However, if you consider \isa{adaptation} mechanisms, the code generated
12.114 + by the serializer is just the tip of the iceberg:
12.115 +
12.116 + \begin{itemize}
12.117 + \item \isa{serialisation} can be \emph{parametrised} such that
12.118 + logical entities are mapped to target-specific ones
12.119 + (e.g. target-specific list syntax,
12.120 + see also \secref{sec:adaptation_mechanisms})
12.121 + \item Such parametrisations can involve references to a
12.122 + target-specific standard \isa{library} (e.g. using
12.123 + the \isa{Haskell} \verb|Maybe| type instead
12.124 + of the \isa{HOL} \isa{option} type);
12.125 + if such are used, the corresponding identifiers
12.126 + (in our example, \verb|Maybe|, \verb|Nothing|
12.127 + and \verb|Just|) also have to be considered \isa{reserved}.
12.128 + \item Even more, the user can enrich the library of the
12.129 + target-language by providing code snippets
12.130 + (\qt{\isa{includes}}) which are prepended to
12.131 + any generated code (see \secref{sec:include}); this typically
12.132 + also involves further \isa{reserved} identifiers.
12.133 + \end{itemize}
12.134 +
12.135 + \noindent As figure \ref{fig:adaptation} illustrates, all these adaptation mechanisms
12.136 + have to act consistently; it is at the discretion of the user
12.137 + to take care for this.%
12.138 +\end{isamarkuptext}%
12.139 +\isamarkuptrue%
12.140 +%
12.141 +\isamarkupsubsection{Common adaptation patterns%
12.142 +}
12.143 +\isamarkuptrue%
12.144 +%
12.145 +\begin{isamarkuptext}%
12.146 +The \hyperlink{theory.HOL}{\mbox{\isa{HOL}}} \hyperlink{theory.Main}{\mbox{\isa{Main}}} theory already provides a code
12.147 + generator setup
12.148 + which should be suitable for most applications. Common extensions
12.149 + and modifications are available by certain theories of the \isa{HOL}
12.150 + library; beside being useful in applications, they may serve
12.151 + as a tutorial for customising the code generator setup (see below
12.152 + \secref{sec:adaptation_mechanisms}).
12.153 +
12.154 + \begin{description}
12.155 +
12.156 + \item[\hyperlink{theory.Code-Integer}{\mbox{\isa{Code{\isacharunderscore}Integer}}}] represents \isa{HOL} integers by big
12.157 + integer literals in target languages.
12.158 + \item[\hyperlink{theory.Code-Char}{\mbox{\isa{Code{\isacharunderscore}Char}}}] represents \isa{HOL} characters by
12.159 + character literals in target languages.
12.160 + \item[\hyperlink{theory.Code-Char-chr}{\mbox{\isa{Code{\isacharunderscore}Char{\isacharunderscore}chr}}}] like \isa{Code{\isacharunderscore}Char},
12.161 + but also offers treatment of character codes; includes
12.162 + \hyperlink{theory.Code-Char}{\mbox{\isa{Code{\isacharunderscore}Char}}}.
12.163 + \item[\hyperlink{theory.Efficient-Nat}{\mbox{\isa{Efficient{\isacharunderscore}Nat}}}] \label{eff_nat} implements natural numbers by integers,
12.164 + which in general will result in higher efficiency; pattern
12.165 + matching with \isa{{\isadigit{0}}} / \isa{Suc}
12.166 + is eliminated; includes \hyperlink{theory.Code-Integer}{\mbox{\isa{Code{\isacharunderscore}Integer}}}
12.167 + and \hyperlink{theory.Code-Index}{\mbox{\isa{Code{\isacharunderscore}Index}}}.
12.168 + \item[\hyperlink{theory.Code-Index}{\mbox{\isa{Code{\isacharunderscore}Index}}}] provides an additional datatype
12.169 + \isa{index} which is mapped to target-language built-in integers.
12.170 + Useful for code setups which involve e.g. indexing of
12.171 + target-language arrays.
12.172 + \item[\hyperlink{theory.Code-Message}{\mbox{\isa{Code{\isacharunderscore}Message}}}] provides an additional datatype
12.173 + \isa{message{\isacharunderscore}string} which is isomorphic to strings;
12.174 + \isa{message{\isacharunderscore}string}s are mapped to target-language strings.
12.175 + Useful for code setups which involve e.g. printing (error) messages.
12.176 +
12.177 + \end{description}
12.178 +
12.179 + \begin{warn}
12.180 + When importing any of these theories, they should form the last
12.181 + items in an import list. Since these theories adapt the
12.182 + code generator setup in a non-conservative fashion,
12.183 + strange effects may occur otherwise.
12.184 + \end{warn}%
12.185 +\end{isamarkuptext}%
12.186 +\isamarkuptrue%
12.187 +%
12.188 +\isamarkupsubsection{Parametrising serialisation \label{sec:adaptation_mechanisms}%
12.189 +}
12.190 +\isamarkuptrue%
12.191 +%
12.192 +\begin{isamarkuptext}%
12.193 +Consider the following function and its corresponding
12.194 + SML code:%
12.195 +\end{isamarkuptext}%
12.196 +\isamarkuptrue%
12.197 +%
12.198 +\isadelimquote
12.199 +%
12.200 +\endisadelimquote
12.201 +%
12.202 +\isatagquote
12.203 +\isacommand{primrec}\isamarkupfalse%
12.204 +\ in{\isacharunderscore}interval\ {\isacharcolon}{\isacharcolon}\ {\isachardoublequoteopen}nat\ {\isasymtimes}\ nat\ {\isasymRightarrow}\ nat\ {\isasymRightarrow}\ bool{\isachardoublequoteclose}\ \isakeyword{where}\isanewline
12.205 +\ \ {\isachardoublequoteopen}in{\isacharunderscore}interval\ {\isacharparenleft}k{\isacharcomma}\ l{\isacharparenright}\ n\ {\isasymlongleftrightarrow}\ k\ {\isasymle}\ n\ {\isasymand}\ n\ {\isasymle}\ l{\isachardoublequoteclose}%
12.206 +\endisatagquote
12.207 +{\isafoldquote}%
12.208 +%
12.209 +\isadelimquote
12.210 +%
12.211 +\endisadelimquote
12.212 +%
12.213 +\isadeliminvisible
12.214 +%
12.215 +\endisadeliminvisible
12.216 +%
12.217 +\isataginvisible
12.218 +%
12.219 +\endisataginvisible
12.220 +{\isafoldinvisible}%
12.221 +%
12.222 +\isadeliminvisible
12.223 +%
12.224 +\endisadeliminvisible
12.225 +%
12.226 +\isadelimquote
12.227 +%
12.228 +\endisadelimquote
12.229 +%
12.230 +\isatagquote
12.231 +%
12.232 +\begin{isamarkuptext}%
12.233 +\isatypewriter%
12.234 +\noindent%
12.235 +\hspace*{0pt}structure Example = \\
12.236 +\hspace*{0pt}struct\\
12.237 +\hspace*{0pt}\\
12.238 +\hspace*{0pt}datatype nat = Zero{\char95}nat | Suc of nat;\\
12.239 +\hspace*{0pt}\\
12.240 +\hspace*{0pt}datatype boola = True | False;\\
12.241 +\hspace*{0pt}\\
12.242 +\hspace*{0pt}fun anda x True = x\\
12.243 +\hspace*{0pt} ~| anda x False = False\\
12.244 +\hspace*{0pt} ~| anda True x = x\\
12.245 +\hspace*{0pt} ~| anda False x = False;\\
12.246 +\hspace*{0pt}\\
12.247 +\hspace*{0pt}fun less{\char95}nat m (Suc n) = less{\char95}eq{\char95}nat m n\\
12.248 +\hspace*{0pt} ~| less{\char95}nat n Zero{\char95}nat = False\\
12.249 +\hspace*{0pt}and less{\char95}eq{\char95}nat (Suc m) n = less{\char95}nat m n\\
12.250 +\hspace*{0pt} ~| less{\char95}eq{\char95}nat Zero{\char95}nat n = True;\\
12.251 +\hspace*{0pt}\\
12.252 +\hspace*{0pt}fun in{\char95}interval (k,~l) n = anda (less{\char95}eq{\char95}nat k n) (less{\char95}eq{\char95}nat n l);\\
12.253 +\hspace*{0pt}\\
12.254 +\hspace*{0pt}end;~(*struct Example*)%
12.255 +\end{isamarkuptext}%
12.256 +\isamarkuptrue%
12.257 +%
12.258 +\endisatagquote
12.259 +{\isafoldquote}%
12.260 +%
12.261 +\isadelimquote
12.262 +%
12.263 +\endisadelimquote
12.264 +%
12.265 +\begin{isamarkuptext}%
12.266 +\noindent Though this is correct code, it is a little bit unsatisfactory:
12.267 + boolean values and operators are materialised as distinguished
12.268 + entities with have nothing to do with the SML-built-in notion
12.269 + of \qt{bool}. This results in less readable code;
12.270 + additionally, eager evaluation may cause programs to
12.271 + loop or break which would perfectly terminate when
12.272 + the existing SML \verb|bool| would be used. To map
12.273 + the HOL \isa{bool} on SML \verb|bool|, we may use
12.274 + \qn{custom serialisations}:%
12.275 +\end{isamarkuptext}%
12.276 +\isamarkuptrue%
12.277 +%
12.278 +\isadelimquotett
12.279 +%
12.280 +\endisadelimquotett
12.281 +%
12.282 +\isatagquotett
12.283 +\isacommand{code{\isacharunderscore}type}\isamarkupfalse%
12.284 +\ bool\isanewline
12.285 +\ \ {\isacharparenleft}SML\ {\isachardoublequoteopen}bool{\isachardoublequoteclose}{\isacharparenright}\isanewline
12.286 +\isacommand{code{\isacharunderscore}const}\isamarkupfalse%
12.287 +\ True\ \isakeyword{and}\ False\ \isakeyword{and}\ {\isachardoublequoteopen}op\ {\isasymand}{\isachardoublequoteclose}\isanewline
12.288 +\ \ {\isacharparenleft}SML\ {\isachardoublequoteopen}true{\isachardoublequoteclose}\ \isakeyword{and}\ {\isachardoublequoteopen}false{\isachardoublequoteclose}\ \isakeyword{and}\ {\isachardoublequoteopen}{\isacharunderscore}\ andalso\ {\isacharunderscore}{\isachardoublequoteclose}{\isacharparenright}%
12.289 +\endisatagquotett
12.290 +{\isafoldquotett}%
12.291 +%
12.292 +\isadelimquotett
12.293 +%
12.294 +\endisadelimquotett
12.295 +%
12.296 +\begin{isamarkuptext}%
12.297 +\noindent The \hyperlink{command.code-type}{\mbox{\isa{\isacommand{code{\isacharunderscore}type}}}} command takes a type constructor
12.298 + as arguments together with a list of custom serialisations.
12.299 + Each custom serialisation starts with a target language
12.300 + identifier followed by an expression, which during
12.301 + code serialisation is inserted whenever the type constructor
12.302 + would occur. For constants, \hyperlink{command.code-const}{\mbox{\isa{\isacommand{code{\isacharunderscore}const}}}} implements
12.303 + the corresponding mechanism. Each ``\verb|_|'' in
12.304 + a serialisation expression is treated as a placeholder
12.305 + for the type constructor's (the constant's) arguments.%
12.306 +\end{isamarkuptext}%
12.307 +\isamarkuptrue%
12.308 +%
12.309 +\isadelimquote
12.310 +%
12.311 +\endisadelimquote
12.312 +%
12.313 +\isatagquote
12.314 +%
12.315 +\begin{isamarkuptext}%
12.316 +\isatypewriter%
12.317 +\noindent%
12.318 +\hspace*{0pt}structure Example = \\
12.319 +\hspace*{0pt}struct\\
12.320 +\hspace*{0pt}\\
12.321 +\hspace*{0pt}datatype nat = Zero{\char95}nat | Suc of nat;\\
12.322 +\hspace*{0pt}\\
12.323 +\hspace*{0pt}fun less{\char95}nat m (Suc n) = less{\char95}eq{\char95}nat m n\\
12.324 +\hspace*{0pt} ~| less{\char95}nat n Zero{\char95}nat = false\\
12.325 +\hspace*{0pt}and less{\char95}eq{\char95}nat (Suc m) n = less{\char95}nat m n\\
12.326 +\hspace*{0pt} ~| less{\char95}eq{\char95}nat Zero{\char95}nat n = true;\\
12.327 +\hspace*{0pt}\\
12.328 +\hspace*{0pt}fun in{\char95}interval (k,~l) n = (less{\char95}eq{\char95}nat k n) andalso (less{\char95}eq{\char95}nat n l);\\
12.329 +\hspace*{0pt}\\
12.330 +\hspace*{0pt}end;~(*struct Example*)%
12.331 +\end{isamarkuptext}%
12.332 +\isamarkuptrue%
12.333 +%
12.334 +\endisatagquote
12.335 +{\isafoldquote}%
12.336 +%
12.337 +\isadelimquote
12.338 +%
12.339 +\endisadelimquote
12.340 +%
12.341 +\begin{isamarkuptext}%
12.342 +\noindent This still is not perfect: the parentheses
12.343 + around the \qt{andalso} expression are superfluous.
12.344 + Though the serialiser
12.345 + by no means attempts to imitate the rich Isabelle syntax
12.346 + framework, it provides some common idioms, notably
12.347 + associative infixes with precedences which may be used here:%
12.348 +\end{isamarkuptext}%
12.349 +\isamarkuptrue%
12.350 +%
12.351 +\isadelimquotett
12.352 +%
12.353 +\endisadelimquotett
12.354 +%
12.355 +\isatagquotett
12.356 +\isacommand{code{\isacharunderscore}const}\isamarkupfalse%
12.357 +\ {\isachardoublequoteopen}op\ {\isasymand}{\isachardoublequoteclose}\isanewline
12.358 +\ \ {\isacharparenleft}SML\ \isakeyword{infixl}\ {\isadigit{1}}\ {\isachardoublequoteopen}andalso{\isachardoublequoteclose}{\isacharparenright}%
12.359 +\endisatagquotett
12.360 +{\isafoldquotett}%
12.361 +%
12.362 +\isadelimquotett
12.363 +%
12.364 +\endisadelimquotett
12.365 +%
12.366 +\isadelimquote
12.367 +%
12.368 +\endisadelimquote
12.369 +%
12.370 +\isatagquote
12.371 +%
12.372 +\begin{isamarkuptext}%
12.373 +\isatypewriter%
12.374 +\noindent%
12.375 +\hspace*{0pt}structure Example = \\
12.376 +\hspace*{0pt}struct\\
12.377 +\hspace*{0pt}\\
12.378 +\hspace*{0pt}datatype nat = Zero{\char95}nat | Suc of nat;\\
12.379 +\hspace*{0pt}\\
12.380 +\hspace*{0pt}fun less{\char95}nat m (Suc n) = less{\char95}eq{\char95}nat m n\\
12.381 +\hspace*{0pt} ~| less{\char95}nat n Zero{\char95}nat = false\\
12.382 +\hspace*{0pt}and less{\char95}eq{\char95}nat (Suc m) n = less{\char95}nat m n\\
12.383 +\hspace*{0pt} ~| less{\char95}eq{\char95}nat Zero{\char95}nat n = true;\\
12.384 +\hspace*{0pt}\\
12.385 +\hspace*{0pt}fun in{\char95}interval (k,~l) n = less{\char95}eq{\char95}nat k n andalso less{\char95}eq{\char95}nat n l;\\
12.386 +\hspace*{0pt}\\
12.387 +\hspace*{0pt}end;~(*struct Example*)%
12.388 +\end{isamarkuptext}%
12.389 +\isamarkuptrue%
12.390 +%
12.391 +\endisatagquote
12.392 +{\isafoldquote}%
12.393 +%
12.394 +\isadelimquote
12.395 +%
12.396 +\endisadelimquote
12.397 +%
12.398 +\begin{isamarkuptext}%
12.399 +\noindent The attentive reader may ask how we assert that no generated
12.400 + code will accidentally overwrite. For this reason the serialiser has
12.401 + an internal table of identifiers which have to be avoided to be used
12.402 + for new declarations. Initially, this table typically contains the
12.403 + keywords of the target language. It can be extended manually, thus avoiding
12.404 + accidental overwrites, using the \hyperlink{command.code-reserved}{\mbox{\isa{\isacommand{code{\isacharunderscore}reserved}}}} command:%
12.405 +\end{isamarkuptext}%
12.406 +\isamarkuptrue%
12.407 +%
12.408 +\isadelimquote
12.409 +%
12.410 +\endisadelimquote
12.411 +%
12.412 +\isatagquote
12.413 +\isacommand{code{\isacharunderscore}reserved}\isamarkupfalse%
12.414 +\ {\isachardoublequoteopen}{\isasymSML}{\isachardoublequoteclose}\ bool\ true\ false\ andalso%
12.415 +\endisatagquote
12.416 +{\isafoldquote}%
12.417 +%
12.418 +\isadelimquote
12.419 +%
12.420 +\endisadelimquote
12.421 +%
12.422 +\begin{isamarkuptext}%
12.423 +\noindent Next, we try to map HOL pairs to SML pairs, using the
12.424 + infix ``\verb|*|'' type constructor and parentheses:%
12.425 +\end{isamarkuptext}%
12.426 +\isamarkuptrue%
12.427 +%
12.428 +\isadeliminvisible
12.429 +%
12.430 +\endisadeliminvisible
12.431 +%
12.432 +\isataginvisible
12.433 +%
12.434 +\endisataginvisible
12.435 +{\isafoldinvisible}%
12.436 +%
12.437 +\isadeliminvisible
12.438 +%
12.439 +\endisadeliminvisible
12.440 +%
12.441 +\isadelimquotett
12.442 +%
12.443 +\endisadelimquotett
12.444 +%
12.445 +\isatagquotett
12.446 +\isacommand{code{\isacharunderscore}type}\isamarkupfalse%
12.447 +\ {\isacharasterisk}\isanewline
12.448 +\ \ {\isacharparenleft}SML\ \isakeyword{infix}\ {\isadigit{2}}\ {\isachardoublequoteopen}{\isacharasterisk}{\isachardoublequoteclose}{\isacharparenright}\isanewline
12.449 +\isacommand{code{\isacharunderscore}const}\isamarkupfalse%
12.450 +\ Pair\isanewline
12.451 +\ \ {\isacharparenleft}SML\ {\isachardoublequoteopen}{\isacharbang}{\isacharparenleft}{\isacharparenleft}{\isacharunderscore}{\isacharparenright}{\isacharcomma}{\isacharslash}\ {\isacharparenleft}{\isacharunderscore}{\isacharparenright}{\isacharparenright}{\isachardoublequoteclose}{\isacharparenright}%
12.452 +\endisatagquotett
12.453 +{\isafoldquotett}%
12.454 +%
12.455 +\isadelimquotett
12.456 +%
12.457 +\endisadelimquotett
12.458 +%
12.459 +\begin{isamarkuptext}%
12.460 +\noindent The initial bang ``\verb|!|'' tells the serialiser
12.461 + never to put
12.462 + parentheses around the whole expression (they are already present),
12.463 + while the parentheses around argument place holders
12.464 + tell not to put parentheses around the arguments.
12.465 + The slash ``\verb|/|'' (followed by arbitrary white space)
12.466 + inserts a space which may be used as a break if necessary
12.467 + during pretty printing.
12.468 +
12.469 + These examples give a glimpse what mechanisms
12.470 + custom serialisations provide; however their usage
12.471 + requires careful thinking in order not to introduce
12.472 + inconsistencies -- or, in other words:
12.473 + custom serialisations are completely axiomatic.
12.474 +
12.475 + A further noteworthy details is that any special
12.476 + character in a custom serialisation may be quoted
12.477 + using ``\verb|'|''; thus, in
12.478 + ``\verb|fn '_ => _|'' the first
12.479 + ``\verb|_|'' is a proper underscore while the
12.480 + second ``\verb|_|'' is a placeholder.%
12.481 +\end{isamarkuptext}%
12.482 +\isamarkuptrue%
12.483 +%
12.484 +\isamarkupsubsection{\isa{Haskell} serialisation%
12.485 +}
12.486 +\isamarkuptrue%
12.487 +%
12.488 +\begin{isamarkuptext}%
12.489 +For convenience, the default
12.490 + \isa{HOL} setup for \isa{Haskell} maps the \isa{eq} class to
12.491 + its counterpart in \isa{Haskell}, giving custom serialisations
12.492 + for the class \isa{eq} (by command \hyperlink{command.code-class}{\mbox{\isa{\isacommand{code{\isacharunderscore}class}}}}) and its operation
12.493 + \isa{eq{\isacharunderscore}class{\isachardot}eq}%
12.494 +\end{isamarkuptext}%
12.495 +\isamarkuptrue%
12.496 +%
12.497 +\isadelimquotett
12.498 +%
12.499 +\endisadelimquotett
12.500 +%
12.501 +\isatagquotett
12.502 +\isacommand{code{\isacharunderscore}class}\isamarkupfalse%
12.503 +\ eq\isanewline
12.504 +\ \ {\isacharparenleft}Haskell\ {\isachardoublequoteopen}Eq{\isachardoublequoteclose}{\isacharparenright}\isanewline
12.505 +\isanewline
12.506 +\isacommand{code{\isacharunderscore}const}\isamarkupfalse%
12.507 +\ {\isachardoublequoteopen}op\ {\isacharequal}{\isachardoublequoteclose}\isanewline
12.508 +\ \ {\isacharparenleft}Haskell\ \isakeyword{infixl}\ {\isadigit{4}}\ {\isachardoublequoteopen}{\isacharequal}{\isacharequal}{\isachardoublequoteclose}{\isacharparenright}%
12.509 +\endisatagquotett
12.510 +{\isafoldquotett}%
12.511 +%
12.512 +\isadelimquotett
12.513 +%
12.514 +\endisadelimquotett
12.515 +%
12.516 +\begin{isamarkuptext}%
12.517 +\noindent A problem now occurs whenever a type which
12.518 + is an instance of \isa{eq} in \isa{HOL} is mapped
12.519 + on a \isa{Haskell}-built-in type which is also an instance
12.520 + of \isa{Haskell} \isa{Eq}:%
12.521 +\end{isamarkuptext}%
12.522 +\isamarkuptrue%
12.523 +%
12.524 +\isadelimquote
12.525 +%
12.526 +\endisadelimquote
12.527 +%
12.528 +\isatagquote
12.529 +\isacommand{typedecl}\isamarkupfalse%
12.530 +\ bar\isanewline
12.531 +\isanewline
12.532 +\isacommand{instantiation}\isamarkupfalse%
12.533 +\ bar\ {\isacharcolon}{\isacharcolon}\ eq\isanewline
12.534 +\isakeyword{begin}\isanewline
12.535 +\isanewline
12.536 +\isacommand{definition}\isamarkupfalse%
12.537 +\ {\isachardoublequoteopen}eq{\isacharunderscore}class{\isachardot}eq\ {\isacharparenleft}x{\isasymColon}bar{\isacharparenright}\ y\ {\isasymlongleftrightarrow}\ x\ {\isacharequal}\ y{\isachardoublequoteclose}\isanewline
12.538 +\isanewline
12.539 +\isacommand{instance}\isamarkupfalse%
12.540 +\ \isacommand{by}\isamarkupfalse%
12.541 +\ default\ {\isacharparenleft}simp\ add{\isacharcolon}\ eq{\isacharunderscore}bar{\isacharunderscore}def{\isacharparenright}\isanewline
12.542 +\isanewline
12.543 +\isacommand{end}\isamarkupfalse%
12.544 +%
12.545 +\endisatagquote
12.546 +{\isafoldquote}%
12.547 +%
12.548 +\isadelimquote
12.549 +%
12.550 +\endisadelimquote
12.551 +%
12.552 +\isadelimquotett
12.553 +\ %
12.554 +\endisadelimquotett
12.555 +%
12.556 +\isatagquotett
12.557 +\isacommand{code{\isacharunderscore}type}\isamarkupfalse%
12.558 +\ bar\isanewline
12.559 +\ \ {\isacharparenleft}Haskell\ {\isachardoublequoteopen}Integer{\isachardoublequoteclose}{\isacharparenright}%
12.560 +\endisatagquotett
12.561 +{\isafoldquotett}%
12.562 +%
12.563 +\isadelimquotett
12.564 +%
12.565 +\endisadelimquotett
12.566 +%
12.567 +\begin{isamarkuptext}%
12.568 +\noindent The code generator would produce
12.569 + an additional instance, which of course is rejected by the \isa{Haskell}
12.570 + compiler.
12.571 + To suppress this additional instance, use
12.572 + \isa{code{\isacharunderscore}instance}:%
12.573 +\end{isamarkuptext}%
12.574 +\isamarkuptrue%
12.575 +%
12.576 +\isadelimquotett
12.577 +%
12.578 +\endisadelimquotett
12.579 +%
12.580 +\isatagquotett
12.581 +\isacommand{code{\isacharunderscore}instance}\isamarkupfalse%
12.582 +\ bar\ {\isacharcolon}{\isacharcolon}\ eq\isanewline
12.583 +\ \ {\isacharparenleft}Haskell\ {\isacharminus}{\isacharparenright}%
12.584 +\endisatagquotett
12.585 +{\isafoldquotett}%
12.586 +%
12.587 +\isadelimquotett
12.588 +%
12.589 +\endisadelimquotett
12.590 +%
12.591 +\isamarkupsubsection{Enhancing the target language context \label{sec:include}%
12.592 +}
12.593 +\isamarkuptrue%
12.594 +%
12.595 +\begin{isamarkuptext}%
12.596 +In rare cases it is necessary to \emph{enrich} the context of a
12.597 + target language; this is accomplished using the \hyperlink{command.code-include}{\mbox{\isa{\isacommand{code{\isacharunderscore}include}}}}
12.598 + command:%
12.599 +\end{isamarkuptext}%
12.600 +\isamarkuptrue%
12.601 +%
12.602 +\isadelimquotett
12.603 +%
12.604 +\endisadelimquotett
12.605 +%
12.606 +\isatagquotett
12.607 +\isacommand{code{\isacharunderscore}include}\isamarkupfalse%
12.608 +\ Haskell\ {\isachardoublequoteopen}Errno{\isachardoublequoteclose}\isanewline
12.609 +{\isacharverbatimopen}errno\ i\ {\isacharequal}\ error\ {\isacharparenleft}{\isachardoublequote}Error\ number{\isacharcolon}\ {\isachardoublequote}\ {\isacharplus}{\isacharplus}\ show\ i{\isacharparenright}{\isacharverbatimclose}\isanewline
12.610 +\isanewline
12.611 +\isacommand{code{\isacharunderscore}reserved}\isamarkupfalse%
12.612 +\ Haskell\ Errno%
12.613 +\endisatagquotett
12.614 +{\isafoldquotett}%
12.615 +%
12.616 +\isadelimquotett
12.617 +%
12.618 +\endisadelimquotett
12.619 +%
12.620 +\begin{isamarkuptext}%
12.621 +\noindent Such named \isa{include}s are then prepended to every generated code.
12.622 + Inspect such code in order to find out how \hyperlink{command.code-include}{\mbox{\isa{\isacommand{code{\isacharunderscore}include}}}} behaves
12.623 + with respect to a particular target language.%
12.624 +\end{isamarkuptext}%
12.625 +\isamarkuptrue%
12.626 +%
12.627 +\isadelimtheory
12.628 +%
12.629 +\endisadelimtheory
12.630 +%
12.631 +\isatagtheory
12.632 +\isacommand{end}\isamarkupfalse%
12.633 +%
12.634 +\endisatagtheory
12.635 +{\isafoldtheory}%
12.636 +%
12.637 +\isadelimtheory
12.638 +%
12.639 +\endisadelimtheory
12.640 +\isanewline
12.641 +\end{isabellebody}%
12.642 +%%% Local Variables:
12.643 +%%% mode: latex
12.644 +%%% TeX-master: "root"
12.645 +%%% End:
13.1 --- a/doc-src/Codegen/Thy/document/Adaption.tex Mon May 11 09:39:53 2009 +0200
13.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
13.3 @@ -1,642 +0,0 @@
13.4 -%
13.5 -\begin{isabellebody}%
13.6 -\def\isabellecontext{Adaption}%
13.7 -%
13.8 -\isadelimtheory
13.9 -%
13.10 -\endisadelimtheory
13.11 -%
13.12 -\isatagtheory
13.13 -\isacommand{theory}\isamarkupfalse%
13.14 -\ Adaption\isanewline
13.15 -\isakeyword{imports}\ Setup\isanewline
13.16 -\isakeyword{begin}%
13.17 -\endisatagtheory
13.18 -{\isafoldtheory}%
13.19 -%
13.20 -\isadelimtheory
13.21 -\isanewline
13.22 -%
13.23 -\endisadelimtheory
13.24 -%
13.25 -\isadeliminvisible
13.26 -\isanewline
13.27 -%
13.28 -\endisadeliminvisible
13.29 -%
13.30 -\isataginvisible
13.31 -\isacommand{setup}\isamarkupfalse%
13.32 -\ {\isacharverbatimopen}\ Code{\isacharunderscore}Target{\isachardot}extend{\isacharunderscore}target\ {\isacharparenleft}{\isachardoublequote}{\isasymSML}{\isachardoublequote}{\isacharcomma}\ {\isacharparenleft}{\isachardoublequote}SML{\isachardoublequote}{\isacharcomma}\ K\ I{\isacharparenright}{\isacharparenright}\ {\isacharverbatimclose}%
13.33 -\endisataginvisible
13.34 -{\isafoldinvisible}%
13.35 -%
13.36 -\isadeliminvisible
13.37 -%
13.38 -\endisadeliminvisible
13.39 -%
13.40 -\isamarkupsection{Adaption to target languages \label{sec:adaption}%
13.41 -}
13.42 -\isamarkuptrue%
13.43 -%
13.44 -\isamarkupsubsection{Adapting code generation%
13.45 -}
13.46 -\isamarkuptrue%
13.47 -%
13.48 -\begin{isamarkuptext}%
13.49 -The aspects of code generation introduced so far have two aspects
13.50 - in common:
13.51 -
13.52 - \begin{itemize}
13.53 - \item They act uniformly, without reference to a specific
13.54 - target language.
13.55 - \item They are \emph{safe} in the sense that as long as you trust
13.56 - the code generator meta theory and implementation, you cannot
13.57 - produce programs that yield results which are not derivable
13.58 - in the logic.
13.59 - \end{itemize}
13.60 -
13.61 - \noindent In this section we will introduce means to \emph{adapt} the serialiser
13.62 - to a specific target language, i.e.~to print program fragments
13.63 - in a way which accommodates \qt{already existing} ingredients of
13.64 - a target language environment, for three reasons:
13.65 -
13.66 - \begin{itemize}
13.67 - \item improving readability and aesthetics of generated code
13.68 - \item gaining efficiency
13.69 - \item interface with language parts which have no direct counterpart
13.70 - in \isa{HOL} (say, imperative data structures)
13.71 - \end{itemize}
13.72 -
13.73 - \noindent Generally, you should avoid using those features yourself
13.74 - \emph{at any cost}:
13.75 -
13.76 - \begin{itemize}
13.77 - \item The safe configuration methods act uniformly on every target language,
13.78 - whereas for adaption you have to treat each target language separate.
13.79 - \item Application is extremely tedious since there is no abstraction
13.80 - which would allow for a static check, making it easy to produce garbage.
13.81 - \item More or less subtle errors can be introduced unconsciously.
13.82 - \end{itemize}
13.83 -
13.84 - \noindent However, even if you ought refrain from setting up adaption
13.85 - yourself, already the \isa{HOL} comes with some reasonable default
13.86 - adaptions (say, using target language list syntax). There also some
13.87 - common adaption cases which you can setup by importing particular
13.88 - library theories. In order to understand these, we provide some clues here;
13.89 - these however are not supposed to replace a careful study of the sources.%
13.90 -\end{isamarkuptext}%
13.91 -\isamarkuptrue%
13.92 -%
13.93 -\isamarkupsubsection{The adaption principle%
13.94 -}
13.95 -\isamarkuptrue%
13.96 -%
13.97 -\begin{isamarkuptext}%
13.98 -Figure \ref{fig:adaption} illustrates what \qt{adaption} is conceptually
13.99 - supposed to be:
13.100 -
13.101 - \begin{figure}[here]
13.102 - \includegraphics{adaption}
13.103 - \caption{The adaption principle}
13.104 - \label{fig:adaption}
13.105 - \end{figure}
13.106 -
13.107 - \noindent In the tame view, code generation acts as broker between
13.108 - \isa{logic}, \isa{intermediate\ language} and
13.109 - \isa{target\ language} by means of \isa{translation} and
13.110 - \isa{serialisation}; for the latter, the serialiser has to observe
13.111 - the structure of the \isa{language} itself plus some \isa{reserved}
13.112 - keywords which have to be avoided for generated code.
13.113 - However, if you consider \isa{adaption} mechanisms, the code generated
13.114 - by the serializer is just the tip of the iceberg:
13.115 -
13.116 - \begin{itemize}
13.117 - \item \isa{serialisation} can be \emph{parametrised} such that
13.118 - logical entities are mapped to target-specific ones
13.119 - (e.g. target-specific list syntax,
13.120 - see also \secref{sec:adaption_mechanisms})
13.121 - \item Such parametrisations can involve references to a
13.122 - target-specific standard \isa{library} (e.g. using
13.123 - the \isa{Haskell} \verb|Maybe| type instead
13.124 - of the \isa{HOL} \isa{option} type);
13.125 - if such are used, the corresponding identifiers
13.126 - (in our example, \verb|Maybe|, \verb|Nothing|
13.127 - and \verb|Just|) also have to be considered \isa{reserved}.
13.128 - \item Even more, the user can enrich the library of the
13.129 - target-language by providing code snippets
13.130 - (\qt{\isa{includes}}) which are prepended to
13.131 - any generated code (see \secref{sec:include}); this typically
13.132 - also involves further \isa{reserved} identifiers.
13.133 - \end{itemize}
13.134 -
13.135 - \noindent As figure \ref{fig:adaption} illustrates, all these adaption mechanisms
13.136 - have to act consistently; it is at the discretion of the user
13.137 - to take care for this.%
13.138 -\end{isamarkuptext}%
13.139 -\isamarkuptrue%
13.140 -%
13.141 -\isamarkupsubsection{Common adaption patterns%
13.142 -}
13.143 -\isamarkuptrue%
13.144 -%
13.145 -\begin{isamarkuptext}%
13.146 -The \hyperlink{theory.HOL}{\mbox{\isa{HOL}}} \hyperlink{theory.Main}{\mbox{\isa{Main}}} theory already provides a code
13.147 - generator setup
13.148 - which should be suitable for most applications. Common extensions
13.149 - and modifications are available by certain theories of the \isa{HOL}
13.150 - library; beside being useful in applications, they may serve
13.151 - as a tutorial for customising the code generator setup (see below
13.152 - \secref{sec:adaption_mechanisms}).
13.153 -
13.154 - \begin{description}
13.155 -
13.156 - \item[\hyperlink{theory.Code-Integer}{\mbox{\isa{Code{\isacharunderscore}Integer}}}] represents \isa{HOL} integers by big
13.157 - integer literals in target languages.
13.158 - \item[\hyperlink{theory.Code-Char}{\mbox{\isa{Code{\isacharunderscore}Char}}}] represents \isa{HOL} characters by
13.159 - character literals in target languages.
13.160 - \item[\hyperlink{theory.Code-Char-chr}{\mbox{\isa{Code{\isacharunderscore}Char{\isacharunderscore}chr}}}] like \isa{Code{\isacharunderscore}Char},
13.161 - but also offers treatment of character codes; includes
13.162 - \hyperlink{theory.Code-Char}{\mbox{\isa{Code{\isacharunderscore}Char}}}.
13.163 - \item[\hyperlink{theory.Efficient-Nat}{\mbox{\isa{Efficient{\isacharunderscore}Nat}}}] \label{eff_nat} implements natural numbers by integers,
13.164 - which in general will result in higher efficiency; pattern
13.165 - matching with \isa{{\isadigit{0}}} / \isa{Suc}
13.166 - is eliminated; includes \hyperlink{theory.Code-Integer}{\mbox{\isa{Code{\isacharunderscore}Integer}}}
13.167 - and \hyperlink{theory.Code-Index}{\mbox{\isa{Code{\isacharunderscore}Index}}}.
13.168 - \item[\hyperlink{theory.Code-Index}{\mbox{\isa{Code{\isacharunderscore}Index}}}] provides an additional datatype
13.169 - \isa{index} which is mapped to target-language built-in integers.
13.170 - Useful for code setups which involve e.g. indexing of
13.171 - target-language arrays.
13.172 - \item[\hyperlink{theory.Code-Message}{\mbox{\isa{Code{\isacharunderscore}Message}}}] provides an additional datatype
13.173 - \isa{message{\isacharunderscore}string} which is isomorphic to strings;
13.174 - \isa{message{\isacharunderscore}string}s are mapped to target-language strings.
13.175 - Useful for code setups which involve e.g. printing (error) messages.
13.176 -
13.177 - \end{description}
13.178 -
13.179 - \begin{warn}
13.180 - When importing any of these theories, they should form the last
13.181 - items in an import list. Since these theories adapt the
13.182 - code generator setup in a non-conservative fashion,
13.183 - strange effects may occur otherwise.
13.184 - \end{warn}%
13.185 -\end{isamarkuptext}%
13.186 -\isamarkuptrue%
13.187 -%
13.188 -\isamarkupsubsection{Parametrising serialisation \label{sec:adaption_mechanisms}%
13.189 -}
13.190 -\isamarkuptrue%
13.191 -%
13.192 -\begin{isamarkuptext}%
13.193 -Consider the following function and its corresponding
13.194 - SML code:%
13.195 -\end{isamarkuptext}%
13.196 -\isamarkuptrue%
13.197 -%
13.198 -\isadelimquote
13.199 -%
13.200 -\endisadelimquote
13.201 -%
13.202 -\isatagquote
13.203 -\isacommand{primrec}\isamarkupfalse%
13.204 -\ in{\isacharunderscore}interval\ {\isacharcolon}{\isacharcolon}\ {\isachardoublequoteopen}nat\ {\isasymtimes}\ nat\ {\isasymRightarrow}\ nat\ {\isasymRightarrow}\ bool{\isachardoublequoteclose}\ \isakeyword{where}\isanewline
13.205 -\ \ {\isachardoublequoteopen}in{\isacharunderscore}interval\ {\isacharparenleft}k{\isacharcomma}\ l{\isacharparenright}\ n\ {\isasymlongleftrightarrow}\ k\ {\isasymle}\ n\ {\isasymand}\ n\ {\isasymle}\ l{\isachardoublequoteclose}%
13.206 -\endisatagquote
13.207 -{\isafoldquote}%
13.208 -%
13.209 -\isadelimquote
13.210 -%
13.211 -\endisadelimquote
13.212 -%
13.213 -\isadeliminvisible
13.214 -%
13.215 -\endisadeliminvisible
13.216 -%
13.217 -\isataginvisible
13.218 -%
13.219 -\endisataginvisible
13.220 -{\isafoldinvisible}%
13.221 -%
13.222 -\isadeliminvisible
13.223 -%
13.224 -\endisadeliminvisible
13.225 -%
13.226 -\isadelimquote
13.227 -%
13.228 -\endisadelimquote
13.229 -%
13.230 -\isatagquote
13.231 -%
13.232 -\begin{isamarkuptext}%
13.233 -\isatypewriter%
13.234 -\noindent%
13.235 -\hspace*{0pt}structure Example = \\
13.236 -\hspace*{0pt}struct\\
13.237 -\hspace*{0pt}\\
13.238 -\hspace*{0pt}datatype nat = Zero{\char95}nat | Suc of nat;\\
13.239 -\hspace*{0pt}\\
13.240 -\hspace*{0pt}datatype boola = True | False;\\
13.241 -\hspace*{0pt}\\
13.242 -\hspace*{0pt}fun anda x True = x\\
13.243 -\hspace*{0pt} ~| anda x False = False\\
13.244 -\hspace*{0pt} ~| anda True x = x\\
13.245 -\hspace*{0pt} ~| anda False x = False;\\
13.246 -\hspace*{0pt}\\
13.247 -\hspace*{0pt}fun less{\char95}nat m (Suc n) = less{\char95}eq{\char95}nat m n\\
13.248 -\hspace*{0pt} ~| less{\char95}nat n Zero{\char95}nat = False\\
13.249 -\hspace*{0pt}and less{\char95}eq{\char95}nat (Suc m) n = less{\char95}nat m n\\
13.250 -\hspace*{0pt} ~| less{\char95}eq{\char95}nat Zero{\char95}nat n = True;\\
13.251 -\hspace*{0pt}\\
13.252 -\hspace*{0pt}fun in{\char95}interval (k,~l) n = anda (less{\char95}eq{\char95}nat k n) (less{\char95}eq{\char95}nat n l);\\
13.253 -\hspace*{0pt}\\
13.254 -\hspace*{0pt}end;~(*struct Example*)%
13.255 -\end{isamarkuptext}%
13.256 -\isamarkuptrue%
13.257 -%
13.258 -\endisatagquote
13.259 -{\isafoldquote}%
13.260 -%
13.261 -\isadelimquote
13.262 -%
13.263 -\endisadelimquote
13.264 -%
13.265 -\begin{isamarkuptext}%
13.266 -\noindent Though this is correct code, it is a little bit unsatisfactory:
13.267 - boolean values and operators are materialised as distinguished
13.268 - entities with have nothing to do with the SML-built-in notion
13.269 - of \qt{bool}. This results in less readable code;
13.270 - additionally, eager evaluation may cause programs to
13.271 - loop or break which would perfectly terminate when
13.272 - the existing SML \verb|bool| would be used. To map
13.273 - the HOL \isa{bool} on SML \verb|bool|, we may use
13.274 - \qn{custom serialisations}:%
13.275 -\end{isamarkuptext}%
13.276 -\isamarkuptrue%
13.277 -%
13.278 -\isadelimquotett
13.279 -%
13.280 -\endisadelimquotett
13.281 -%
13.282 -\isatagquotett
13.283 -\isacommand{code{\isacharunderscore}type}\isamarkupfalse%
13.284 -\ bool\isanewline
13.285 -\ \ {\isacharparenleft}SML\ {\isachardoublequoteopen}bool{\isachardoublequoteclose}{\isacharparenright}\isanewline
13.286 -\isacommand{code{\isacharunderscore}const}\isamarkupfalse%
13.287 -\ True\ \isakeyword{and}\ False\ \isakeyword{and}\ {\isachardoublequoteopen}op\ {\isasymand}{\isachardoublequoteclose}\isanewline
13.288 -\ \ {\isacharparenleft}SML\ {\isachardoublequoteopen}true{\isachardoublequoteclose}\ \isakeyword{and}\ {\isachardoublequoteopen}false{\isachardoublequoteclose}\ \isakeyword{and}\ {\isachardoublequoteopen}{\isacharunderscore}\ andalso\ {\isacharunderscore}{\isachardoublequoteclose}{\isacharparenright}%
13.289 -\endisatagquotett
13.290 -{\isafoldquotett}%
13.291 -%
13.292 -\isadelimquotett
13.293 -%
13.294 -\endisadelimquotett
13.295 -%
13.296 -\begin{isamarkuptext}%
13.297 -\noindent The \hyperlink{command.code-type}{\mbox{\isa{\isacommand{code{\isacharunderscore}type}}}} command takes a type constructor
13.298 - as arguments together with a list of custom serialisations.
13.299 - Each custom serialisation starts with a target language
13.300 - identifier followed by an expression, which during
13.301 - code serialisation is inserted whenever the type constructor
13.302 - would occur. For constants, \hyperlink{command.code-const}{\mbox{\isa{\isacommand{code{\isacharunderscore}const}}}} implements
13.303 - the corresponding mechanism. Each ``\verb|_|'' in
13.304 - a serialisation expression is treated as a placeholder
13.305 - for the type constructor's (the constant's) arguments.%
13.306 -\end{isamarkuptext}%
13.307 -\isamarkuptrue%
13.308 -%
13.309 -\isadelimquote
13.310 -%
13.311 -\endisadelimquote
13.312 -%
13.313 -\isatagquote
13.314 -%
13.315 -\begin{isamarkuptext}%
13.316 -\isatypewriter%
13.317 -\noindent%
13.318 -\hspace*{0pt}structure Example = \\
13.319 -\hspace*{0pt}struct\\
13.320 -\hspace*{0pt}\\
13.321 -\hspace*{0pt}datatype nat = Zero{\char95}nat | Suc of nat;\\
13.322 -\hspace*{0pt}\\
13.323 -\hspace*{0pt}fun less{\char95}nat m (Suc n) = less{\char95}eq{\char95}nat m n\\
13.324 -\hspace*{0pt} ~| less{\char95}nat n Zero{\char95}nat = false\\
13.325 -\hspace*{0pt}and less{\char95}eq{\char95}nat (Suc m) n = less{\char95}nat m n\\
13.326 -\hspace*{0pt} ~| less{\char95}eq{\char95}nat Zero{\char95}nat n = true;\\
13.327 -\hspace*{0pt}\\
13.328 -\hspace*{0pt}fun in{\char95}interval (k,~l) n = (less{\char95}eq{\char95}nat k n) andalso (less{\char95}eq{\char95}nat n l);\\
13.329 -\hspace*{0pt}\\
13.330 -\hspace*{0pt}end;~(*struct Example*)%
13.331 -\end{isamarkuptext}%
13.332 -\isamarkuptrue%
13.333 -%
13.334 -\endisatagquote
13.335 -{\isafoldquote}%
13.336 -%
13.337 -\isadelimquote
13.338 -%
13.339 -\endisadelimquote
13.340 -%
13.341 -\begin{isamarkuptext}%
13.342 -\noindent This still is not perfect: the parentheses
13.343 - around the \qt{andalso} expression are superfluous.
13.344 - Though the serialiser
13.345 - by no means attempts to imitate the rich Isabelle syntax
13.346 - framework, it provides some common idioms, notably
13.347 - associative infixes with precedences which may be used here:%
13.348 -\end{isamarkuptext}%
13.349 -\isamarkuptrue%
13.350 -%
13.351 -\isadelimquotett
13.352 -%
13.353 -\endisadelimquotett
13.354 -%
13.355 -\isatagquotett
13.356 -\isacommand{code{\isacharunderscore}const}\isamarkupfalse%
13.357 -\ {\isachardoublequoteopen}op\ {\isasymand}{\isachardoublequoteclose}\isanewline
13.358 -\ \ {\isacharparenleft}SML\ \isakeyword{infixl}\ {\isadigit{1}}\ {\isachardoublequoteopen}andalso{\isachardoublequoteclose}{\isacharparenright}%
13.359 -\endisatagquotett
13.360 -{\isafoldquotett}%
13.361 -%
13.362 -\isadelimquotett
13.363 -%
13.364 -\endisadelimquotett
13.365 -%
13.366 -\isadelimquote
13.367 -%
13.368 -\endisadelimquote
13.369 -%
13.370 -\isatagquote
13.371 -%
13.372 -\begin{isamarkuptext}%
13.373 -\isatypewriter%
13.374 -\noindent%
13.375 -\hspace*{0pt}structure Example = \\
13.376 -\hspace*{0pt}struct\\
13.377 -\hspace*{0pt}\\
13.378 -\hspace*{0pt}datatype nat = Zero{\char95}nat | Suc of nat;\\
13.379 -\hspace*{0pt}\\
13.380 -\hspace*{0pt}fun less{\char95}nat m (Suc n) = less{\char95}eq{\char95}nat m n\\
13.381 -\hspace*{0pt} ~| less{\char95}nat n Zero{\char95}nat = false\\
13.382 -\hspace*{0pt}and less{\char95}eq{\char95}nat (Suc m) n = less{\char95}nat m n\\
13.383 -\hspace*{0pt} ~| less{\char95}eq{\char95}nat Zero{\char95}nat n = true;\\
13.384 -\hspace*{0pt}\\
13.385 -\hspace*{0pt}fun in{\char95}interval (k,~l) n = less{\char95}eq{\char95}nat k n andalso less{\char95}eq{\char95}nat n l;\\
13.386 -\hspace*{0pt}\\
13.387 -\hspace*{0pt}end;~(*struct Example*)%
13.388 -\end{isamarkuptext}%
13.389 -\isamarkuptrue%
13.390 -%
13.391 -\endisatagquote
13.392 -{\isafoldquote}%
13.393 -%
13.394 -\isadelimquote
13.395 -%
13.396 -\endisadelimquote
13.397 -%
13.398 -\begin{isamarkuptext}%
13.399 -\noindent The attentive reader may ask how we assert that no generated
13.400 - code will accidentally overwrite. For this reason the serialiser has
13.401 - an internal table of identifiers which have to be avoided to be used
13.402 - for new declarations. Initially, this table typically contains the
13.403 - keywords of the target language. It can be extended manually, thus avoiding
13.404 - accidental overwrites, using the \hyperlink{command.code-reserved}{\mbox{\isa{\isacommand{code{\isacharunderscore}reserved}}}} command:%
13.405 -\end{isamarkuptext}%
13.406 -\isamarkuptrue%
13.407 -%
13.408 -\isadelimquote
13.409 -%
13.410 -\endisadelimquote
13.411 -%
13.412 -\isatagquote
13.413 -\isacommand{code{\isacharunderscore}reserved}\isamarkupfalse%
13.414 -\ {\isachardoublequoteopen}{\isasymSML}{\isachardoublequoteclose}\ bool\ true\ false\ andalso%
13.415 -\endisatagquote
13.416 -{\isafoldquote}%
13.417 -%
13.418 -\isadelimquote
13.419 -%
13.420 -\endisadelimquote
13.421 -%
13.422 -\begin{isamarkuptext}%
13.423 -\noindent Next, we try to map HOL pairs to SML pairs, using the
13.424 - infix ``\verb|*|'' type constructor and parentheses:%
13.425 -\end{isamarkuptext}%
13.426 -\isamarkuptrue%
13.427 -%
13.428 -\isadeliminvisible
13.429 -%
13.430 -\endisadeliminvisible
13.431 -%
13.432 -\isataginvisible
13.433 -%
13.434 -\endisataginvisible
13.435 -{\isafoldinvisible}%
13.436 -%
13.437 -\isadeliminvisible
13.438 -%
13.439 -\endisadeliminvisible
13.440 -%
13.441 -\isadelimquotett
13.442 -%
13.443 -\endisadelimquotett
13.444 -%
13.445 -\isatagquotett
13.446 -\isacommand{code{\isacharunderscore}type}\isamarkupfalse%
13.447 -\ {\isacharasterisk}\isanewline
13.448 -\ \ {\isacharparenleft}SML\ \isakeyword{infix}\ {\isadigit{2}}\ {\isachardoublequoteopen}{\isacharasterisk}{\isachardoublequoteclose}{\isacharparenright}\isanewline
13.449 -\isacommand{code{\isacharunderscore}const}\isamarkupfalse%
13.450 -\ Pair\isanewline
13.451 -\ \ {\isacharparenleft}SML\ {\isachardoublequoteopen}{\isacharbang}{\isacharparenleft}{\isacharparenleft}{\isacharunderscore}{\isacharparenright}{\isacharcomma}{\isacharslash}\ {\isacharparenleft}{\isacharunderscore}{\isacharparenright}{\isacharparenright}{\isachardoublequoteclose}{\isacharparenright}%
13.452 -\endisatagquotett
13.453 -{\isafoldquotett}%
13.454 -%
13.455 -\isadelimquotett
13.456 -%
13.457 -\endisadelimquotett
13.458 -%
13.459 -\begin{isamarkuptext}%
13.460 -\noindent The initial bang ``\verb|!|'' tells the serialiser
13.461 - never to put
13.462 - parentheses around the whole expression (they are already present),
13.463 - while the parentheses around argument place holders
13.464 - tell not to put parentheses around the arguments.
13.465 - The slash ``\verb|/|'' (followed by arbitrary white space)
13.466 - inserts a space which may be used as a break if necessary
13.467 - during pretty printing.
13.468 -
13.469 - These examples give a glimpse what mechanisms
13.470 - custom serialisations provide; however their usage
13.471 - requires careful thinking in order not to introduce
13.472 - inconsistencies -- or, in other words:
13.473 - custom serialisations are completely axiomatic.
13.474 -
13.475 - A further noteworthy details is that any special
13.476 - character in a custom serialisation may be quoted
13.477 - using ``\verb|'|''; thus, in
13.478 - ``\verb|fn '_ => _|'' the first
13.479 - ``\verb|_|'' is a proper underscore while the
13.480 - second ``\verb|_|'' is a placeholder.%
13.481 -\end{isamarkuptext}%
13.482 -\isamarkuptrue%
13.483 -%
13.484 -\isamarkupsubsection{\isa{Haskell} serialisation%
13.485 -}
13.486 -\isamarkuptrue%
13.487 -%
13.488 -\begin{isamarkuptext}%
13.489 -For convenience, the default
13.490 - \isa{HOL} setup for \isa{Haskell} maps the \isa{eq} class to
13.491 - its counterpart in \isa{Haskell}, giving custom serialisations
13.492 - for the class \isa{eq} (by command \hyperlink{command.code-class}{\mbox{\isa{\isacommand{code{\isacharunderscore}class}}}}) and its operation
13.493 - \isa{eq{\isacharunderscore}class{\isachardot}eq}%
13.494 -\end{isamarkuptext}%
13.495 -\isamarkuptrue%
13.496 -%
13.497 -\isadelimquotett
13.498 -%
13.499 -\endisadelimquotett
13.500 -%
13.501 -\isatagquotett
13.502 -\isacommand{code{\isacharunderscore}class}\isamarkupfalse%
13.503 -\ eq\isanewline
13.504 -\ \ {\isacharparenleft}Haskell\ {\isachardoublequoteopen}Eq{\isachardoublequoteclose}{\isacharparenright}\isanewline
13.505 -\isanewline
13.506 -\isacommand{code{\isacharunderscore}const}\isamarkupfalse%
13.507 -\ {\isachardoublequoteopen}op\ {\isacharequal}{\isachardoublequoteclose}\isanewline
13.508 -\ \ {\isacharparenleft}Haskell\ \isakeyword{infixl}\ {\isadigit{4}}\ {\isachardoublequoteopen}{\isacharequal}{\isacharequal}{\isachardoublequoteclose}{\isacharparenright}%
13.509 -\endisatagquotett
13.510 -{\isafoldquotett}%
13.511 -%
13.512 -\isadelimquotett
13.513 -%
13.514 -\endisadelimquotett
13.515 -%
13.516 -\begin{isamarkuptext}%
13.517 -\noindent A problem now occurs whenever a type which
13.518 - is an instance of \isa{eq} in \isa{HOL} is mapped
13.519 - on a \isa{Haskell}-built-in type which is also an instance
13.520 - of \isa{Haskell} \isa{Eq}:%
13.521 -\end{isamarkuptext}%
13.522 -\isamarkuptrue%
13.523 -%
13.524 -\isadelimquote
13.525 -%
13.526 -\endisadelimquote
13.527 -%
13.528 -\isatagquote
13.529 -\isacommand{typedecl}\isamarkupfalse%
13.530 -\ bar\isanewline
13.531 -\isanewline
13.532 -\isacommand{instantiation}\isamarkupfalse%
13.533 -\ bar\ {\isacharcolon}{\isacharcolon}\ eq\isanewline
13.534 -\isakeyword{begin}\isanewline
13.535 -\isanewline
13.536 -\isacommand{definition}\isamarkupfalse%
13.537 -\ {\isachardoublequoteopen}eq{\isacharunderscore}class{\isachardot}eq\ {\isacharparenleft}x{\isasymColon}bar{\isacharparenright}\ y\ {\isasymlongleftrightarrow}\ x\ {\isacharequal}\ y{\isachardoublequoteclose}\isanewline
13.538 -\isanewline
13.539 -\isacommand{instance}\isamarkupfalse%
13.540 -\ \isacommand{by}\isamarkupfalse%
13.541 -\ default\ {\isacharparenleft}simp\ add{\isacharcolon}\ eq{\isacharunderscore}bar{\isacharunderscore}def{\isacharparenright}\isanewline
13.542 -\isanewline
13.543 -\isacommand{end}\isamarkupfalse%
13.544 -%
13.545 -\endisatagquote
13.546 -{\isafoldquote}%
13.547 -%
13.548 -\isadelimquote
13.549 -%
13.550 -\endisadelimquote
13.551 -%
13.552 -\isadelimquotett
13.553 -\ %
13.554 -\endisadelimquotett
13.555 -%
13.556 -\isatagquotett
13.557 -\isacommand{code{\isacharunderscore}type}\isamarkupfalse%
13.558 -\ bar\isanewline
13.559 -\ \ {\isacharparenleft}Haskell\ {\isachardoublequoteopen}Integer{\isachardoublequoteclose}{\isacharparenright}%
13.560 -\endisatagquotett
13.561 -{\isafoldquotett}%
13.562 -%
13.563 -\isadelimquotett
13.564 -%
13.565 -\endisadelimquotett
13.566 -%
13.567 -\begin{isamarkuptext}%
13.568 -\noindent The code generator would produce
13.569 - an additional instance, which of course is rejected by the \isa{Haskell}
13.570 - compiler.
13.571 - To suppress this additional instance, use
13.572 - \isa{code{\isacharunderscore}instance}:%
13.573 -\end{isamarkuptext}%
13.574 -\isamarkuptrue%
13.575 -%
13.576 -\isadelimquotett
13.577 -%
13.578 -\endisadelimquotett
13.579 -%
13.580 -\isatagquotett
13.581 -\isacommand{code{\isacharunderscore}instance}\isamarkupfalse%
13.582 -\ bar\ {\isacharcolon}{\isacharcolon}\ eq\isanewline
13.583 -\ \ {\isacharparenleft}Haskell\ {\isacharminus}{\isacharparenright}%
13.584 -\endisatagquotett
13.585 -{\isafoldquotett}%
13.586 -%
13.587 -\isadelimquotett
13.588 -%
13.589 -\endisadelimquotett
13.590 -%
13.591 -\isamarkupsubsection{Enhancing the target language context \label{sec:include}%
13.592 -}
13.593 -\isamarkuptrue%
13.594 -%
13.595 -\begin{isamarkuptext}%
13.596 -In rare cases it is necessary to \emph{enrich} the context of a
13.597 - target language; this is accomplished using the \hyperlink{command.code-include}{\mbox{\isa{\isacommand{code{\isacharunderscore}include}}}}
13.598 - command:%
13.599 -\end{isamarkuptext}%
13.600 -\isamarkuptrue%
13.601 -%
13.602 -\isadelimquotett
13.603 -%
13.604 -\endisadelimquotett
13.605 -%
13.606 -\isatagquotett
13.607 -\isacommand{code{\isacharunderscore}include}\isamarkupfalse%
13.608 -\ Haskell\ {\isachardoublequoteopen}Errno{\isachardoublequoteclose}\isanewline
13.609 -{\isacharverbatimopen}errno\ i\ {\isacharequal}\ error\ {\isacharparenleft}{\isachardoublequote}Error\ number{\isacharcolon}\ {\isachardoublequote}\ {\isacharplus}{\isacharplus}\ show\ i{\isacharparenright}{\isacharverbatimclose}\isanewline
13.610 -\isanewline
13.611 -\isacommand{code{\isacharunderscore}reserved}\isamarkupfalse%
13.612 -\ Haskell\ Errno%
13.613 -\endisatagquotett
13.614 -{\isafoldquotett}%
13.615 -%
13.616 -\isadelimquotett
13.617 -%
13.618 -\endisadelimquotett
13.619 -%
13.620 -\begin{isamarkuptext}%
13.621 -\noindent Such named \isa{include}s are then prepended to every generated code.
13.622 - Inspect such code in order to find out how \hyperlink{command.code-include}{\mbox{\isa{\isacommand{code{\isacharunderscore}include}}}} behaves
13.623 - with respect to a particular target language.%
13.624 -\end{isamarkuptext}%
13.625 -\isamarkuptrue%
13.626 -%
13.627 -\isadelimtheory
13.628 -%
13.629 -\endisadelimtheory
13.630 -%
13.631 -\isatagtheory
13.632 -\isacommand{end}\isamarkupfalse%
13.633 -%
13.634 -\endisatagtheory
13.635 -{\isafoldtheory}%
13.636 -%
13.637 -\isadelimtheory
13.638 -%
13.639 -\endisadelimtheory
13.640 -\isanewline
13.641 -\end{isabellebody}%
13.642 -%%% Local Variables:
13.643 -%%% mode: latex
13.644 -%%% TeX-master: "root"
13.645 -%%% End:
14.1 --- a/doc-src/Codegen/Thy/document/Further.tex Mon May 11 09:39:53 2009 +0200
14.2 +++ b/doc-src/Codegen/Thy/document/Further.tex Mon May 11 17:20:52 2009 +0200
14.3 @@ -132,7 +132,7 @@
14.4 \begin{isamarkuptext}%
14.5 \noindent The soundness of the \hyperlink{method.eval}{\mbox{\isa{eval}}} method depends crucially
14.6 on the correctness of the code generator; this is one of the reasons
14.7 - why you should not use adaption (see \secref{sec:adaption}) frivolously.%
14.8 + why you should not use adaptation (see \secref{sec:adaptation}) frivolously.%
14.9 \end{isamarkuptext}%
14.10 \isamarkuptrue%
14.11 %
15.1 --- a/doc-src/Codegen/Thy/document/Introduction.tex Mon May 11 09:39:53 2009 +0200
15.2 +++ b/doc-src/Codegen/Thy/document/Introduction.tex Mon May 11 17:20:52 2009 +0200
15.3 @@ -46,8 +46,8 @@
15.4 This manifests in the structure of this tutorial: after a short
15.5 conceptual introduction with an example (\secref{sec:intro}),
15.6 we discuss the generic customisation facilities (\secref{sec:program}).
15.7 - A further section (\secref{sec:adaption}) is dedicated to the matter of
15.8 - \qn{adaption} to specific target language environments. After some
15.9 + A further section (\secref{sec:adaptation}) is dedicated to the matter of
15.10 + \qn{adaptation} to specific target language environments. After some
15.11 further issues (\secref{sec:further}) we conclude with an overview
15.12 of some ML programming interfaces (\secref{sec:ml}).
15.13
15.14 @@ -229,7 +229,7 @@
15.15 \hspace*{0pt}module Example where {\char123}\\
15.16 \hspace*{0pt}\\
15.17 \hspace*{0pt}\\
15.18 -\hspace*{0pt}foldla ::~forall a b.~(a -> b -> a) -> a -> [b] -> a;\\
15.19 +\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;\\
15.20 \hspace*{0pt}foldla f a [] = a;\\
15.21 \hspace*{0pt}foldla f a (x :~xs) = foldla f (f a x) xs;\\
15.22 \hspace*{0pt}\\
16.1 --- a/doc-src/Codegen/Thy/document/Program.tex Mon May 11 09:39:53 2009 +0200
16.2 +++ b/doc-src/Codegen/Thy/document/Program.tex Mon May 11 17:20:52 2009 +0200
16.3 @@ -714,7 +714,7 @@
16.4 \end{isamarkuptext}%
16.5 \isamarkuptrue%
16.6 %
16.7 -\isamarkupsubsection{Equality and wellsortedness%
16.8 +\isamarkupsubsection{Equality%
16.9 }
16.10 \isamarkuptrue%
16.11 %
16.12 @@ -766,10 +766,10 @@
16.13 \hspace*{0pt}type 'a eq = {\char123}eq :~'a -> 'a -> bool{\char125};\\
16.14 \hspace*{0pt}fun eq (A{\char95}:'a eq) = {\char35}eq A{\char95};\\
16.15 \hspace*{0pt}\\
16.16 -\hspace*{0pt}fun eqop A{\char95}~a b = eq A{\char95}~a b;\\
16.17 +\hspace*{0pt}fun eqa A{\char95}~a b = eq A{\char95}~a b;\\
16.18 \hspace*{0pt}\\
16.19 \hspace*{0pt}fun member A{\char95}~x [] = false\\
16.20 -\hspace*{0pt} ~| member A{\char95}~x (y ::~ys) = eqop A{\char95}~x y orelse member A{\char95}~x ys;\\
16.21 +\hspace*{0pt} ~| member A{\char95}~x (y ::~ys) = eqa A{\char95}~x y orelse member A{\char95}~x ys;\\
16.22 \hspace*{0pt}\\
16.23 \hspace*{0pt}fun collect{\char95}duplicates A{\char95}~xs ys [] = xs\\
16.24 \hspace*{0pt} ~| collect{\char95}duplicates A{\char95}~xs ys (z ::~zs) =\\
16.25 @@ -801,141 +801,7 @@
16.26 manually like any other type class.
16.27
16.28 Though this \isa{eq} class is designed to get rarely in
16.29 - the way, a subtlety
16.30 - enters the stage when definitions of overloaded constants
16.31 - are dependent on operational equality. For example, let
16.32 - us define a lexicographic ordering on tuples
16.33 - (also see theory \hyperlink{theory.Product-ord}{\mbox{\isa{Product{\isacharunderscore}ord}}}):%
16.34 -\end{isamarkuptext}%
16.35 -\isamarkuptrue%
16.36 -%
16.37 -\isadelimquote
16.38 -%
16.39 -\endisadelimquote
16.40 -%
16.41 -\isatagquote
16.42 -\isacommand{instantiation}\isamarkupfalse%
16.43 -\ {\isachardoublequoteopen}{\isacharasterisk}{\isachardoublequoteclose}\ {\isacharcolon}{\isacharcolon}\ {\isacharparenleft}order{\isacharcomma}\ order{\isacharparenright}\ order\isanewline
16.44 -\isakeyword{begin}\isanewline
16.45 -\isanewline
16.46 -\isacommand{definition}\isamarkupfalse%
16.47 -\ {\isacharbrackleft}code\ del{\isacharbrackright}{\isacharcolon}\isanewline
16.48 -\ \ {\isachardoublequoteopen}x\ {\isasymle}\ y\ {\isasymlongleftrightarrow}\ fst\ x\ {\isacharless}\ fst\ y\ {\isasymor}\ fst\ x\ {\isacharequal}\ fst\ y\ {\isasymand}\ snd\ x\ {\isasymle}\ snd\ y{\isachardoublequoteclose}\isanewline
16.49 -\isanewline
16.50 -\isacommand{definition}\isamarkupfalse%
16.51 -\ {\isacharbrackleft}code\ del{\isacharbrackright}{\isacharcolon}\isanewline
16.52 -\ \ {\isachardoublequoteopen}x\ {\isacharless}\ y\ {\isasymlongleftrightarrow}\ fst\ x\ {\isacharless}\ fst\ y\ {\isasymor}\ fst\ x\ {\isacharequal}\ fst\ y\ {\isasymand}\ snd\ x\ {\isacharless}\ snd\ y{\isachardoublequoteclose}\isanewline
16.53 -\isanewline
16.54 -\isacommand{instance}\isamarkupfalse%
16.55 -\ \isacommand{proof}\isamarkupfalse%
16.56 -\isanewline
16.57 -\isacommand{qed}\isamarkupfalse%
16.58 -\ {\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
16.59 -\isanewline
16.60 -\isacommand{end}\isamarkupfalse%
16.61 -\isanewline
16.62 -\isanewline
16.63 -\isacommand{lemma}\isamarkupfalse%
16.64 -\ order{\isacharunderscore}prod\ {\isacharbrackleft}code{\isacharbrackright}{\isacharcolon}\isanewline
16.65 -\ \ {\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
16.66 -\ \ \ \ \ 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
16.67 -\ \ {\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
16.68 -\ \ \ \ \ 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
16.69 -\ \ \isacommand{by}\isamarkupfalse%
16.70 -\ {\isacharparenleft}simp{\isacharunderscore}all\ add{\isacharcolon}\ less{\isacharunderscore}prod{\isacharunderscore}def\ less{\isacharunderscore}eq{\isacharunderscore}prod{\isacharunderscore}def{\isacharparenright}%
16.71 -\endisatagquote
16.72 -{\isafoldquote}%
16.73 -%
16.74 -\isadelimquote
16.75 -%
16.76 -\endisadelimquote
16.77 -%
16.78 -\begin{isamarkuptext}%
16.79 -\noindent Then code generation will fail. Why? The definition
16.80 - of \isa{op\ {\isasymle}} depends on equality on both arguments,
16.81 - which are polymorphic and impose an additional \isa{eq}
16.82 - class constraint, which the preprocessor does not propagate
16.83 - (for technical reasons).
16.84 -
16.85 - The solution is to add \isa{eq} explicitly to the first sort arguments in the
16.86 - code theorems:%
16.87 -\end{isamarkuptext}%
16.88 -\isamarkuptrue%
16.89 -%
16.90 -\isadelimquote
16.91 -%
16.92 -\endisadelimquote
16.93 -%
16.94 -\isatagquote
16.95 -\isacommand{lemma}\isamarkupfalse%
16.96 -\ order{\isacharunderscore}prod{\isacharunderscore}code\ {\isacharbrackleft}code{\isacharbrackright}{\isacharcolon}\isanewline
16.97 -\ \ {\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
16.98 -\ \ \ \ \ 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
16.99 -\ \ {\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
16.100 -\ \ \ \ \ 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
16.101 -\ \ \isacommand{by}\isamarkupfalse%
16.102 -\ {\isacharparenleft}simp{\isacharunderscore}all\ add{\isacharcolon}\ less{\isacharunderscore}prod{\isacharunderscore}def\ less{\isacharunderscore}eq{\isacharunderscore}prod{\isacharunderscore}def{\isacharparenright}%
16.103 -\endisatagquote
16.104 -{\isafoldquote}%
16.105 -%
16.106 -\isadelimquote
16.107 -%
16.108 -\endisadelimquote
16.109 -%
16.110 -\begin{isamarkuptext}%
16.111 -\noindent Then code generation succeeds:%
16.112 -\end{isamarkuptext}%
16.113 -\isamarkuptrue%
16.114 -%
16.115 -\isadelimquote
16.116 -%
16.117 -\endisadelimquote
16.118 -%
16.119 -\isatagquote
16.120 -%
16.121 -\begin{isamarkuptext}%
16.122 -\isatypewriter%
16.123 -\noindent%
16.124 -\hspace*{0pt}structure Example = \\
16.125 -\hspace*{0pt}struct\\
16.126 -\hspace*{0pt}\\
16.127 -\hspace*{0pt}type 'a eq = {\char123}eq :~'a -> 'a -> bool{\char125};\\
16.128 -\hspace*{0pt}fun eq (A{\char95}:'a eq) = {\char35}eq A{\char95};\\
16.129 -\hspace*{0pt}\\
16.130 -\hspace*{0pt}type 'a ord = {\char123}less{\char95}eq :~'a -> 'a -> bool,~less :~'a -> 'a -> bool{\char125};\\
16.131 -\hspace*{0pt}fun less{\char95}eq (A{\char95}:'a ord) = {\char35}less{\char95}eq A{\char95};\\
16.132 -\hspace*{0pt}fun less (A{\char95}:'a ord) = {\char35}less A{\char95};\\
16.133 -\hspace*{0pt}\\
16.134 -\hspace*{0pt}fun eqop A{\char95}~a b = eq A{\char95}~a b;\\
16.135 -\hspace*{0pt}\\
16.136 -\hspace*{0pt}type 'a preorder = {\char123}Orderings{\char95}{\char95}ord{\char95}preorder :~'a ord{\char125};\\
16.137 -\hspace*{0pt}fun ord{\char95}preorder (A{\char95}:'a preorder) = {\char35}Orderings{\char95}{\char95}ord{\char95}preorder A{\char95};\\
16.138 -\hspace*{0pt}\\
16.139 -\hspace*{0pt}type 'a order = {\char123}Orderings{\char95}{\char95}preorder{\char95}order :~'a preorder{\char125};\\
16.140 -\hspace*{0pt}fun preorder{\char95}order (A{\char95}:'a order) = {\char35}Orderings{\char95}{\char95}preorder{\char95}order A{\char95};\\
16.141 -\hspace*{0pt}\\
16.142 -\hspace*{0pt}fun less{\char95}eqa (A1{\char95},~A2{\char95}) B{\char95}~(x1,~y1) (x2,~y2) =\\
16.143 -\hspace*{0pt} ~less ((ord{\char95}preorder o preorder{\char95}order) A2{\char95}) x1 x2 orelse\\
16.144 -\hspace*{0pt} ~~~eqop A1{\char95}~x1 x2 andalso\\
16.145 -\hspace*{0pt} ~~~~~less{\char95}eq ((ord{\char95}preorder o preorder{\char95}order) B{\char95}) y1 y2\\
16.146 -\hspace*{0pt} ~| less{\char95}eqa (A1{\char95},~A2{\char95}) B{\char95}~(x1,~y1) (x2,~y2) =\\
16.147 -\hspace*{0pt} ~~~less ((ord{\char95}preorder o preorder{\char95}order) A2{\char95}) x1 x2 orelse\\
16.148 -\hspace*{0pt} ~~~~~eqop A1{\char95}~x1 x2 andalso\\
16.149 -\hspace*{0pt} ~~~~~~~less{\char95}eq ((ord{\char95}preorder o preorder{\char95}order) B{\char95}) y1 y2;\\
16.150 -\hspace*{0pt}\\
16.151 -\hspace*{0pt}end;~(*struct Example*)%
16.152 -\end{isamarkuptext}%
16.153 -\isamarkuptrue%
16.154 -%
16.155 -\endisatagquote
16.156 -{\isafoldquote}%
16.157 -%
16.158 -\isadelimquote
16.159 -%
16.160 -\endisadelimquote
16.161 -%
16.162 -\begin{isamarkuptext}%
16.163 -In some cases, the automatically derived code equations
16.164 + the way, in some cases the automatically derived code equations
16.165 for equality on a particular type may not be appropriate.
16.166 As example, watch the following datatype representing
16.167 monomorphic parametric types (where type constructors
17.1 --- a/doc-src/Codegen/Thy/examples/Example.hs Mon May 11 09:39:53 2009 +0200
17.2 +++ b/doc-src/Codegen/Thy/examples/Example.hs Mon May 11 17:20:52 2009 +0200
17.3 @@ -3,7 +3,7 @@
17.4 module Example where {
17.5
17.6
17.7 -foldla :: forall a b. (a -> b -> a) -> a -> [b] -> a;
17.8 +foldla :: forall a_1 b_1. (a_1 -> b_1 -> a_1) -> a_1 -> [b_1] -> a_1;
17.9 foldla f a [] = a;
17.10 foldla f a (x : xs) = foldla f (f a x) xs;
17.11
18.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
18.2 +++ b/doc-src/Codegen/Thy/pictures/adaptation.tex Mon May 11 17:20:52 2009 +0200
18.3 @@ -0,0 +1,52 @@
18.4 +
18.5 +\documentclass[12pt]{article}
18.6 +\usepackage{tikz}
18.7 +
18.8 +\begin{document}
18.9 +
18.10 +\thispagestyle{empty}
18.11 +\setlength{\fboxrule}{0.01pt}
18.12 +\setlength{\fboxsep}{4pt}
18.13 +
18.14 +\fcolorbox{white}{white}{
18.15 +
18.16 +\begin{tikzpicture}[scale = 0.5]
18.17 + \tikzstyle water=[color = blue, thick]
18.18 + \tikzstyle ice=[color = black, very thick, cap = round, join = round, fill = white]
18.19 + \tikzstyle process=[color = green, semithick, ->]
18.20 + \tikzstyle adaptation=[color = red, semithick, ->]
18.21 + \tikzstyle target=[color = black]
18.22 + \foreach \x in {0, ..., 24}
18.23 + \draw[style=water] (\x, 0.25) sin + (0.25, 0.25) cos + (0.25, -0.25) sin
18.24 + + (0.25, -0.25) cos + (0.25, 0.25);
18.25 + \draw[style=ice] (1, 0) --
18.26 + (3, 6) node[above, fill=white] {logic} -- (5, 0) -- cycle;
18.27 + \draw[style=ice] (9, 0) --
18.28 + (11, 6) node[above, fill=white] {intermediate language} -- (13, 0) -- cycle;
18.29 + \draw[style=ice] (15, -6) --
18.30 + (19, 6) node[above, fill=white] {target language} -- (23, -6) -- cycle;
18.31 + \draw[style=process]
18.32 + (3.5, 3) .. controls (7, 5) .. node[fill=white] {translation} (10.5, 3);
18.33 + \draw[style=process]
18.34 + (11.5, 3) .. controls (15, 5) .. node[fill=white] (serialisation) {serialisation} (18.5, 3);
18.35 + \node (adaptation) at (11, -2) [style=adaptation] {adaptation};
18.36 + \node at (19, 3) [rotate=90] {generated};
18.37 + \node at (19.5, -5) {language};
18.38 + \node at (19.5, -3) {library};
18.39 + \node (includes) at (19.5, -1) {includes};
18.40 + \node (reserved) at (16.5, -3) [rotate=72] {reserved}; % proper 71.57
18.41 + \draw[style=process]
18.42 + (includes) -- (serialisation);
18.43 + \draw[style=process]
18.44 + (reserved) -- (serialisation);
18.45 + \draw[style=adaptation]
18.46 + (adaptation) -- (serialisation);
18.47 + \draw[style=adaptation]
18.48 + (adaptation) -- (includes);
18.49 + \draw[style=adaptation]
18.50 + (adaptation) -- (reserved);
18.51 +\end{tikzpicture}
18.52 +
18.53 +}
18.54 +
18.55 +\end{document}
19.1 --- a/doc-src/Codegen/Thy/pictures/adaption.tex Mon May 11 09:39:53 2009 +0200
19.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
19.3 @@ -1,52 +0,0 @@
19.4 -
19.5 -\documentclass[12pt]{article}
19.6 -\usepackage{tikz}
19.7 -
19.8 -\begin{document}
19.9 -
19.10 -\thispagestyle{empty}
19.11 -\setlength{\fboxrule}{0.01pt}
19.12 -\setlength{\fboxsep}{4pt}
19.13 -
19.14 -\fcolorbox{white}{white}{
19.15 -
19.16 -\begin{tikzpicture}[scale = 0.5]
19.17 - \tikzstyle water=[color = blue, thick]
19.18 - \tikzstyle ice=[color = black, very thick, cap = round, join = round, fill = white]
19.19 - \tikzstyle process=[color = green, semithick, ->]
19.20 - \tikzstyle adaption=[color = red, semithick, ->]
19.21 - \tikzstyle target=[color = black]
19.22 - \foreach \x in {0, ..., 24}
19.23 - \draw[style=water] (\x, 0.25) sin + (0.25, 0.25) cos + (0.25, -0.25) sin
19.24 - + (0.25, -0.25) cos + (0.25, 0.25);
19.25 - \draw[style=ice] (1, 0) --
19.26 - (3, 6) node[above, fill=white] {logic} -- (5, 0) -- cycle;
19.27 - \draw[style=ice] (9, 0) --
19.28 - (11, 6) node[above, fill=white] {intermediate language} -- (13, 0) -- cycle;
19.29 - \draw[style=ice] (15, -6) --
19.30 - (19, 6) node[above, fill=white] {target language} -- (23, -6) -- cycle;
19.31 - \draw[style=process]
19.32 - (3.5, 3) .. controls (7, 5) .. node[fill=white] {translation} (10.5, 3);
19.33 - \draw[style=process]
19.34 - (11.5, 3) .. controls (15, 5) .. node[fill=white] (serialisation) {serialisation} (18.5, 3);
19.35 - \node (adaption) at (11, -2) [style=adaption] {adaption};
19.36 - \node at (19, 3) [rotate=90] {generated};
19.37 - \node at (19.5, -5) {language};
19.38 - \node at (19.5, -3) {library};
19.39 - \node (includes) at (19.5, -1) {includes};
19.40 - \node (reserved) at (16.5, -3) [rotate=72] {reserved}; % proper 71.57
19.41 - \draw[style=process]
19.42 - (includes) -- (serialisation);
19.43 - \draw[style=process]
19.44 - (reserved) -- (serialisation);
19.45 - \draw[style=adaption]
19.46 - (adaption) -- (serialisation);
19.47 - \draw[style=adaption]
19.48 - (adaption) -- (includes);
19.49 - \draw[style=adaption]
19.50 - (adaption) -- (reserved);
19.51 -\end{tikzpicture}
19.52 -
19.53 -}
19.54 -
19.55 -\end{document}
20.1 --- a/doc-src/Codegen/codegen.tex Mon May 11 09:39:53 2009 +0200
20.2 +++ b/doc-src/Codegen/codegen.tex Mon May 11 17:20:52 2009 +0200
20.3 @@ -32,7 +32,7 @@
20.4
20.5 \input{Thy/document/Introduction.tex}
20.6 \input{Thy/document/Program.tex}
20.7 -\input{Thy/document/Adaption.tex}
20.8 +\input{Thy/document/Adaptation.tex}
20.9 \input{Thy/document/Further.tex}
20.10 \input{Thy/document/ML.tex}
20.11
21.1 --- a/doc-src/IsarRef/Thy/Spec.thy Mon May 11 09:39:53 2009 +0200
21.2 +++ b/doc-src/IsarRef/Thy/Spec.thy Mon May 11 17:20:52 2009 +0200
21.3 @@ -752,7 +752,11 @@
21.4
21.5 text {*
21.6 Isabelle/Pure's definitional schemes support certain forms of
21.7 - overloading (see \secref{sec:consts}). At most occassions
21.8 + overloading (see \secref{sec:consts}). Overloading means that a
21.9 + constant being declared as @{text "c :: \<alpha> decl"} may be
21.10 + defined separately on type instances
21.11 + @{text "c :: (\<beta>\<^sub>1, \<dots>, \<beta>\<^sub>n) t decl"}
21.12 + for each type constructor @{text t}. At most occassions
21.13 overloading will be used in a Haskell-like fashion together with
21.14 type classes by means of @{command "instantiation"} (see
21.15 \secref{sec:class}). Sometimes low-level overloading is desirable.
21.16 @@ -782,7 +786,8 @@
21.17
21.18 A @{text "(unchecked)"} option disables global dependency checks for
21.19 the corresponding definition, which is occasionally useful for
21.20 - exotic overloading. It is at the discretion of the user to avoid
21.21 + exotic overloading (see \secref{sec:consts} for a precise description).
21.22 + It is at the discretion of the user to avoid
21.23 malformed theory specifications!
21.24
21.25 \end{description}
21.26 @@ -1065,10 +1070,7 @@
21.27
21.28 \end{itemize}
21.29
21.30 - Overloading means that a constant being declared as @{text "c :: \<alpha>
21.31 - decl"} may be defined separately on type instances @{text "c ::
21.32 - (\<beta>\<^sub>1, \<dots>, \<beta>\<^sub>n) t decl"} for each type constructor @{text
21.33 - t}. The right-hand side may mention overloaded constants
21.34 + The right-hand side of overloaded definitions may mention overloaded constants
21.35 recursively at type instances corresponding to the immediate
21.36 argument types @{text "\<beta>\<^sub>1, \<dots>, \<beta>\<^sub>n"}. Incomplete
21.37 specification patterns impose global constraints on all occurrences,
22.1 --- a/doc-src/IsarRef/Thy/document/Spec.tex Mon May 11 09:39:53 2009 +0200
22.2 +++ b/doc-src/IsarRef/Thy/document/Spec.tex Mon May 11 17:20:52 2009 +0200
22.3 @@ -759,7 +759,11 @@
22.4 %
22.5 \begin{isamarkuptext}%
22.6 Isabelle/Pure's definitional schemes support certain forms of
22.7 - overloading (see \secref{sec:consts}). At most occassions
22.8 + overloading (see \secref{sec:consts}). Overloading means that a
22.9 + constant being declared as \isa{{\isachardoublequote}c\ {\isacharcolon}{\isacharcolon}\ {\isasymalpha}\ decl{\isachardoublequote}} may be
22.10 + defined separately on type instances
22.11 + \isa{{\isachardoublequote}c\ {\isacharcolon}{\isacharcolon}\ {\isacharparenleft}{\isasymbeta}\isactrlsub {\isadigit{1}}{\isacharcomma}\ {\isasymdots}{\isacharcomma}\ {\isasymbeta}\isactrlsub n{\isacharparenright}\ t\ decl{\isachardoublequote}}
22.12 + for each type constructor \isa{t}. At most occassions
22.13 overloading will be used in a Haskell-like fashion together with
22.14 type classes by means of \hyperlink{command.instantiation}{\mbox{\isa{\isacommand{instantiation}}}} (see
22.15 \secref{sec:class}). Sometimes low-level overloading is desirable.
22.16 @@ -788,7 +792,8 @@
22.17
22.18 A \isa{{\isachardoublequote}{\isacharparenleft}unchecked{\isacharparenright}{\isachardoublequote}} option disables global dependency checks for
22.19 the corresponding definition, which is occasionally useful for
22.20 - exotic overloading. It is at the discretion of the user to avoid
22.21 + exotic overloading (see \secref{sec:consts} for a precise description).
22.22 + It is at the discretion of the user to avoid
22.23 malformed theory specifications!
22.24
22.25 \end{description}%
22.26 @@ -1092,7 +1097,7 @@
22.27
22.28 \end{itemize}
22.29
22.30 - 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
22.31 + The right-hand side of overloaded definitions may mention overloaded constants
22.32 recursively at type instances corresponding to the immediate
22.33 argument types \isa{{\isachardoublequote}{\isasymbeta}\isactrlsub {\isadigit{1}}{\isacharcomma}\ {\isasymdots}{\isacharcomma}\ {\isasymbeta}\isactrlsub n{\isachardoublequote}}. Incomplete
22.34 specification patterns impose global constraints on all occurrences,
23.1 --- a/doc-src/Main/Docs/Main_Doc.thy Mon May 11 09:39:53 2009 +0200
23.2 +++ b/doc-src/Main/Docs/Main_Doc.thy Mon May 11 17:20:52 2009 +0200
23.3 @@ -268,6 +268,7 @@
23.4 @{const Transitive_Closure.rtrancl} & @{term_type_only Transitive_Closure.rtrancl "('a*'a)set\<Rightarrow>('a*'a)set"}\\
23.5 @{const Transitive_Closure.trancl} & @{term_type_only Transitive_Closure.trancl "('a*'a)set\<Rightarrow>('a*'a)set"}\\
23.6 @{const Transitive_Closure.reflcl} & @{term_type_only Transitive_Closure.reflcl "('a*'a)set\<Rightarrow>('a*'a)set"}\\
23.7 +@{const compower} & @{term_type_only "op ^^ :: ('a*'a)set\<Rightarrow>nat\<Rightarrow>('a*'a)set" "('a*'a)set\<Rightarrow>nat\<Rightarrow>('a*'a)set"}\\
23.8 \end{tabular}
23.9
23.10 \subsubsection*{Syntax}
23.11 @@ -318,7 +319,6 @@
23.12 @{term "op + :: nat \<Rightarrow> nat \<Rightarrow> nat"} &
23.13 @{term "op - :: nat \<Rightarrow> nat \<Rightarrow> nat"} &
23.14 @{term "op * :: nat \<Rightarrow> nat \<Rightarrow> nat"} &
23.15 -@{term "op ^ :: nat \<Rightarrow> nat \<Rightarrow> nat"} &
23.16 @{term "op div :: nat \<Rightarrow> nat \<Rightarrow> nat"}&
23.17 @{term "op mod :: nat \<Rightarrow> nat \<Rightarrow> nat"}&
23.18 @{term "op dvd :: nat \<Rightarrow> nat \<Rightarrow> bool"}\\
23.19 @@ -331,7 +331,9 @@
23.20 \end{tabular}
23.21
23.22 \begin{tabular}{@ {} l @ {~::~} l @ {}}
23.23 -@{const Nat.of_nat} & @{typeof Nat.of_nat}
23.24 +@{const Nat.of_nat} & @{typeof Nat.of_nat}\\
23.25 +@{term "op ^^ :: ('a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a"} &
23.26 + @{term_type_only "op ^^ :: ('a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a" "('a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a"}
23.27 \end{tabular}
23.28
23.29 \section{Int}
23.30 @@ -450,14 +452,6 @@
23.31 \end{tabular}
23.32
23.33
23.34 -\section{Iterated Functions and Relations}
23.35 -
23.36 -Theory: @{theory Relation_Power}
23.37 -
23.38 -Iterated functions \ @{term[source]"(f::'a\<Rightarrow>'a) ^ n"} \
23.39 -and relations \ @{term[source]"(r::('a\<times>'a)set) ^ n"}.
23.40 -
23.41 -
23.42 \section{Option}
23.43
23.44 @{datatype option}
24.1 --- a/doc-src/Main/Docs/document/Main_Doc.tex Mon May 11 09:39:53 2009 +0200
24.2 +++ b/doc-src/Main/Docs/document/Main_Doc.tex Mon May 11 17:20:52 2009 +0200
24.3 @@ -279,6 +279,7 @@
24.4 \isa{rtrancl} & \isa{{\isacharparenleft}{\isacharprime}a\ {\isasymtimes}\ {\isacharprime}a{\isacharparenright}\ set\ {\isasymRightarrow}\ {\isacharparenleft}{\isacharprime}a\ {\isasymtimes}\ {\isacharprime}a{\isacharparenright}\ set}\\
24.5 \isa{trancl} & \isa{{\isacharparenleft}{\isacharprime}a\ {\isasymtimes}\ {\isacharprime}a{\isacharparenright}\ set\ {\isasymRightarrow}\ {\isacharparenleft}{\isacharprime}a\ {\isasymtimes}\ {\isacharprime}a{\isacharparenright}\ set}\\
24.6 \isa{reflcl} & \isa{{\isacharparenleft}{\isacharprime}a\ {\isasymtimes}\ {\isacharprime}a{\isacharparenright}\ set\ {\isasymRightarrow}\ {\isacharparenleft}{\isacharprime}a\ {\isasymtimes}\ {\isacharprime}a{\isacharparenright}\ set}\\
24.7 +\isa{op\ {\isacharcircum}{\isacharcircum}} & \isa{{\isacharparenleft}{\isacharprime}a\ {\isasymtimes}\ {\isacharprime}a{\isacharparenright}\ set\ {\isasymRightarrow}\ nat\ {\isasymRightarrow}\ {\isacharparenleft}{\isacharprime}a\ {\isasymtimes}\ {\isacharprime}a{\isacharparenright}\ set}\\
24.8 \end{tabular}
24.9
24.10 \subsubsection*{Syntax}
24.11 @@ -328,7 +329,6 @@
24.12 \isa{op\ {\isacharplus}} &
24.13 \isa{op\ {\isacharminus}} &
24.14 \isa{op\ {\isacharasterisk}} &
24.15 -\isa{op\ {\isacharcircum}} &
24.16 \isa{op\ div}&
24.17 \isa{op\ mod}&
24.18 \isa{op\ dvd}\\
24.19 @@ -341,7 +341,9 @@
24.20 \end{tabular}
24.21
24.22 \begin{tabular}{@ {} l @ {~::~} l @ {}}
24.23 -\isa{of{\isacharunderscore}nat} & \isa{nat\ {\isasymRightarrow}\ {\isacharprime}a}
24.24 +\isa{of{\isacharunderscore}nat} & \isa{nat\ {\isasymRightarrow}\ {\isacharprime}a}\\
24.25 +\isa{op\ {\isacharcircum}{\isacharcircum}} &
24.26 + \isa{{\isacharparenleft}{\isacharprime}a\ {\isasymRightarrow}\ {\isacharprime}a{\isacharparenright}\ {\isasymRightarrow}\ nat\ {\isasymRightarrow}\ {\isacharprime}a\ {\isasymRightarrow}\ {\isacharprime}a}
24.27 \end{tabular}
24.28
24.29 \section{Int}
24.30 @@ -460,14 +462,6 @@
24.31 \end{tabular}
24.32
24.33
24.34 -\section{Iterated Functions and Relations}
24.35 -
24.36 -Theory: \isa{Relation{\isacharunderscore}Power}
24.37 -
24.38 -Iterated functions \ \isa{{\isachardoublequote}{\isacharparenleft}f{\isacharcolon}{\isacharcolon}{\isacharprime}a{\isasymRightarrow}{\isacharprime}a{\isacharparenright}\ {\isacharcircum}\ n{\isachardoublequote}} \
24.39 -and relations \ \isa{{\isachardoublequote}{\isacharparenleft}r{\isacharcolon}{\isacharcolon}{\isacharparenleft}{\isacharprime}a{\isasymtimes}{\isacharprime}a{\isacharparenright}set{\isacharparenright}\ {\isacharcircum}\ n{\isachardoublequote}}.
24.40 -
24.41 -
24.42 \section{Option}
24.43
24.44 \isa{\isacommand{datatype}\ {\isacharprime}a\ option\ {\isacharequal}\ None\ {\isacharbar}\ Some\ {\isacharprime}a}
25.1 --- a/doc-src/TutorialI/tutorial.tex Mon May 11 09:39:53 2009 +0200
25.2 +++ b/doc-src/TutorialI/tutorial.tex Mon May 11 17:20:52 2009 +0200
25.3 @@ -39,10 +39,11 @@
25.4 %University of Cambridge\\
25.5 %Computer Laboratory
25.6 }
25.7 +\pagenumbering{roman}
25.8 \maketitle
25.9 +\newpage
25.10
25.11 -\pagenumbering{roman}
25.12 -\setcounter{page}{5}
25.13 +%\setcounter{page}{5}
25.14 %\vspace*{\fill}
25.15 %\begin{center}
25.16 %\LARGE In memoriam \\[1ex]
25.17 @@ -52,6 +53,7 @@
25.18 %\vspace*{\fill}
25.19 %\vspace*{\fill}
25.20 %\newpage
25.21 +
25.22 \include{preface}
25.23
25.24 \tableofcontents
26.1 --- a/doc-src/more_antiquote.ML Mon May 11 09:39:53 2009 +0200
26.2 +++ b/doc-src/more_antiquote.ML Mon May 11 17:20:52 2009 +0200
26.3 @@ -88,7 +88,7 @@
26.4 let
26.5 val thy = ProofContext.theory_of ctxt;
26.6 val const = Code_Unit.check_const thy raw_const;
26.7 - val (_, funcgr) = Code_Wellsorted.make thy [const];
26.8 + val (_, funcgr) = Code_Wellsorted.obtain thy [const] [];
26.9 fun holize thm = @{thm meta_eq_to_obj_eq} OF [thm];
26.10 val thms = Code_Wellsorted.eqns funcgr const
26.11 |> map_filter (fn (thm, linear) => if linear then SOME thm else NONE)
27.1 --- a/etc/isar-keywords.el Mon May 11 09:39:53 2009 +0200
27.2 +++ b/etc/isar-keywords.el Mon May 11 17:20:52 2009 +0200
27.3 @@ -35,6 +35,7 @@
27.4 "atp_info"
27.5 "atp_kill"
27.6 "atp_messages"
27.7 + "atp_minimize"
27.8 "attribute_setup"
27.9 "automaton"
27.10 "ax_specification"
27.11 @@ -340,6 +341,7 @@
27.12 "atp_info"
27.13 "atp_kill"
27.14 "atp_messages"
27.15 + "atp_minimize"
27.16 "cd"
27.17 "class_deps"
27.18 "code_deps"
28.1 --- a/lib/jedit/isabelle.xml Mon May 11 09:39:53 2009 +0200
28.2 +++ b/lib/jedit/isabelle.xml Mon May 11 17:20:52 2009 +0200
28.3 @@ -60,6 +60,7 @@
28.4 <LABEL>atp_info</LABEL>
28.5 <LABEL>atp_kill</LABEL>
28.6 <LABEL>atp_messages</LABEL>
28.7 + <LABEL>atp_minimize</LABEL>
28.8 <KEYWORD4>attach</KEYWORD4>
28.9 <OPERATOR>attribute_setup</OPERATOR>
28.10 <OPERATOR>automaton</OPERATOR>
29.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
29.2 +++ b/lib/scripts/SystemOnTPTP Mon May 11 17:20:52 2009 +0200
29.3 @@ -0,0 +1,120 @@
29.4 +#!/usr/bin/env perl
29.5 +#
29.6 +# Wrapper for custom remote provers on SystemOnTPTP
29.7 +# Author: Fabian Immler, TU Muenchen
29.8 +#
29.9 +
29.10 +use warnings;
29.11 +use strict;
29.12 +use Getopt::Std;
29.13 +use HTTP::Request::Common;
29.14 +use LWP;
29.15 +
29.16 +my $SystemOnTPTPFormReplyURL = "http://www.cs.miami.edu/~tptp/cgi-bin/SystemOnTPTPFormReply";
29.17 +
29.18 +# default parameters
29.19 +my %URLParameters = (
29.20 + "NoHTML" => 1,
29.21 + "QuietFlag" => "-q01",
29.22 + "X2TPTP" => "-S",
29.23 + "SubmitButton" => "RunSelectedSystems",
29.24 + "ProblemSource" => "UPLOAD",
29.25 + );
29.26 +
29.27 +#----Get format and transform options if specified
29.28 +my %Options;
29.29 +getopts("hws:t:c:",\%Options);
29.30 +
29.31 +#----Usage
29.32 +sub usage() {
29.33 + print("Usage: remote [<options>] <File name>\n");
29.34 + print(" <options> are ...\n");
29.35 + print(" -h - print this help\n");
29.36 + print(" -w - list available ATP systems\n");
29.37 + print(" -s<system> - specified system to use\n");
29.38 + print(" -t<timelimit> - CPU time limit for system\n");
29.39 + print(" -c<command> - custom command for system\n");
29.40 + print(" <File name> - TPTP problem file\n");
29.41 + exit(0);
29.42 +}
29.43 +if (exists($Options{'h'})) {
29.44 + usage();
29.45 +}
29.46 +#----What systems flag
29.47 +if (exists($Options{'w'})) {
29.48 + $URLParameters{"SubmitButton"} = "ListSystems";
29.49 + delete($URLParameters{"ProblemSource"});
29.50 +}
29.51 +#----Selected system
29.52 +my $System;
29.53 +if (exists($Options{'s'})) {
29.54 + $System = $Options{'s'};
29.55 +} else {
29.56 + # use Vampire as default
29.57 + $System = "Vampire---9.0";
29.58 +}
29.59 +$URLParameters{"System___$System"} = $System;
29.60 +
29.61 +#----Time limit
29.62 +if (exists($Options{'t'})) {
29.63 + $URLParameters{"TimeLimit___$System"} = $Options{'t'};
29.64 +}
29.65 +#----Custom command
29.66 +if (exists($Options{'c'})) {
29.67 + $URLParameters{"Command___$System"} = $Options{'c'};
29.68 +}
29.69 +
29.70 +#----Get single file name
29.71 +if (exists($URLParameters{"ProblemSource"})) {
29.72 + if (scalar(@ARGV) >= 1) {
29.73 + $URLParameters{"UPLOADProblem"} = [shift(@ARGV)];
29.74 + } else {
29.75 + print("Missing problem file\n");
29.76 + usage();
29.77 + die;
29.78 + }
29.79 +}
29.80 +
29.81 +# Query Server
29.82 +my $Agent = LWP::UserAgent->new;
29.83 +if (exists($Options{'t'})) {
29.84 + # give server more time to respond
29.85 + $Agent->timeout($Options{'t'} + 10);
29.86 +}
29.87 +my $Request = POST($SystemOnTPTPFormReplyURL,
29.88 + Content_Type => 'form-data',Content => \%URLParameters);
29.89 +my $Response = $Agent->request($Request);
29.90 +
29.91 +#catch errors / failure
29.92 +if(! $Response->is_success){
29.93 + print "HTTP-Error: " . $Response->message . "\n";
29.94 + exit(-1);
29.95 +} elsif (exists($Options{'w'})) {
29.96 + print $Response->content;
29.97 + exit (0);
29.98 +} elsif ($Response->content =~ /WARNING: (\S*) does not exist/) {
29.99 + print "Specified System $1 does not exist\n";
29.100 + exit(-1);
29.101 +} elsif ($Response->content =~ /%\s*Result\s*:\s*Unsatisfiable.*\n%\s*Output\s*:\s*(CNF)?Refutation.*\n%/) {
29.102 + my @lines = split( /\n/, $Response->content);
29.103 + my $extract = "";
29.104 + foreach my $line (@lines){
29.105 + #ignore comments
29.106 + if ($line !~ /^%/ && !($line eq "")) {
29.107 + $extract .= "$line";
29.108 + }
29.109 + }
29.110 + # insert newlines after ').'
29.111 + $extract =~ s/\s//g;
29.112 + $extract =~ s/\)\.cnf/\)\.\ncnf/g;
29.113 +
29.114 + # orientation for res_reconstruct.ML
29.115 + print "# SZS output start CNFRefutation.\n";
29.116 + print "$extract\n";
29.117 + print "# SZS output end CNFRefutation.\n";
29.118 + exit(0);
29.119 +} else {
29.120 + print "Remote-script could not extract proof:\n".$Response->content;
29.121 + exit(-1);
29.122 +}
29.123 +
30.1 --- a/src/HOL/ATP_Linkup.thy Mon May 11 09:39:53 2009 +0200
30.2 +++ b/src/HOL/ATP_Linkup.thy Mon May 11 17:20:52 2009 +0200
30.3 @@ -17,6 +17,7 @@
30.4 ("Tools/res_atp.ML")
30.5 ("Tools/atp_manager.ML")
30.6 ("Tools/atp_wrapper.ML")
30.7 + ("Tools/atp_minimal.ML")
30.8 "~~/src/Tools/Metis/metis.ML"
30.9 ("Tools/metis_tools.ML")
30.10 begin
30.11 @@ -98,6 +99,8 @@
30.12 use "Tools/atp_manager.ML"
30.13 use "Tools/atp_wrapper.ML"
30.14
30.15 +use "Tools/atp_minimal.ML"
30.16 +
30.17 text {* basic provers *}
30.18 setup {* AtpManager.add_prover "spass" AtpWrapper.spass *}
30.19 setup {* AtpManager.add_prover "vampire" AtpWrapper.vampire *}
31.1 --- a/src/HOL/Algebra/abstract/Ring2.thy Mon May 11 09:39:53 2009 +0200
31.2 +++ b/src/HOL/Algebra/abstract/Ring2.thy Mon May 11 17:20:52 2009 +0200
31.3 @@ -12,7 +12,7 @@
31.4
31.5 subsection {* Ring axioms *}
31.6
31.7 -class ring = zero + one + plus + minus + uminus + times + inverse + power + Ring_and_Field.dvd +
31.8 +class ring = zero + one + plus + minus + uminus + times + inverse + power + dvd +
31.9 assumes a_assoc: "(a + b) + c = a + (b + c)"
31.10 and l_zero: "0 + a = a"
31.11 and l_neg: "(-a) + a = 0"
31.12 @@ -28,8 +28,6 @@
31.13 assumes minus_def: "a - b = a + (-b)"
31.14 and inverse_def: "inverse a = (if a dvd 1 then THE x. a*x = 1 else 0)"
31.15 and divide_def: "a / b = a * inverse b"
31.16 - and power_0 [simp]: "a ^ 0 = 1"
31.17 - and power_Suc [simp]: "a ^ Suc n = a ^ n * a"
31.18 begin
31.19
31.20 definition assoc :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "assoc" 50) where
32.1 --- a/src/HOL/Algebra/poly/LongDiv.thy Mon May 11 09:39:53 2009 +0200
32.2 +++ b/src/HOL/Algebra/poly/LongDiv.thy Mon May 11 17:20:52 2009 +0200
32.3 @@ -1,6 +1,5 @@
32.4 (*
32.5 Experimental theory: long division of polynomials
32.6 - $Id$
32.7 Author: Clemens Ballarin, started 23 June 1999
32.8 *)
32.9
32.10 @@ -133,9 +132,9 @@
32.11 delsimprocs [ring_simproc]) 1 *})
32.12 apply (tactic {* asm_simp_tac (@{simpset} delsimprocs [ring_simproc]) 1 *})
32.13 apply (tactic {* simp_tac (@{simpset} addsimps [thm "minus_def", thm "smult_r_distr",
32.14 - thm "smult_r_minus", thm "monom_mult_smult", thm "smult_assoc1", thm "smult_assoc2"]
32.15 + thm "smult_r_minus", thm "monom_mult_smult", thm "smult_assoc2"]
32.16 delsimprocs [ring_simproc]) 1 *})
32.17 - apply simp
32.18 + apply (simp add: smult_assoc1 [symmetric])
32.19 done
32.20
32.21 ML {*
33.1 --- a/src/HOL/Algebra/poly/UnivPoly2.thy Mon May 11 09:39:53 2009 +0200
33.2 +++ b/src/HOL/Algebra/poly/UnivPoly2.thy Mon May 11 17:20:52 2009 +0200
33.3 @@ -155,16 +155,6 @@
33.4
33.5 end
33.6
33.7 -instantiation up :: ("{times, one, comm_monoid_add}") power
33.8 -begin
33.9 -
33.10 -primrec power_up where
33.11 - "(a \<Colon> 'a up) ^ 0 = 1"
33.12 - | "(a \<Colon> 'a up) ^ Suc n = a ^ n * a"
33.13 -
33.14 -instance ..
33.15 -
33.16 -end
33.17
33.18 subsection {* Effect of operations on coefficients *}
33.19
33.20 @@ -328,8 +318,9 @@
33.21 qed
33.22 show "(p + q) * r = p * r + q * r"
33.23 by (rule up_eqI) simp
33.24 - show "p * q = q * p"
33.25 + show "\<And>q. p * q = q * p"
33.26 proof (rule up_eqI)
33.27 + fix q
33.28 fix n
33.29 {
33.30 fix k
33.31 @@ -354,9 +345,6 @@
33.32 by (simp add: up_inverse_def)
33.33 show "p / q = p * inverse q"
33.34 by (simp add: up_divide_def)
33.35 - fix n
33.36 - show "p ^ 0 = 1" by simp
33.37 - show "p ^ Suc n = p ^ n * p" by simp
33.38 qed
33.39
33.40 (* Further properties of monom *)
34.1 --- a/src/HOL/Bali/Trans.thy Mon May 11 09:39:53 2009 +0200
34.2 +++ b/src/HOL/Bali/Trans.thy Mon May 11 17:20:52 2009 +0200
34.3 @@ -359,7 +359,7 @@
34.4
34.5 abbreviation
34.6 stepn:: "[prog, term \<times> state,nat,term \<times> state] \<Rightarrow> bool" ("_\<turnstile>_ \<mapsto>_ _"[61,82,82] 81)
34.7 - where "G\<turnstile>p \<mapsto>n p' \<equiv> (p,p') \<in> {(x, y). step G x y}^n"
34.8 + where "G\<turnstile>p \<mapsto>n p' \<equiv> (p,p') \<in> {(x, y). step G x y}^^n"
34.9
34.10 abbreviation
34.11 steptr:: "[prog,term \<times> state,term \<times> state] \<Rightarrow> bool" ("_\<turnstile>_ \<mapsto>* _"[61,82,82] 81)
34.12 @@ -370,25 +370,6 @@
34.13 Smallstep zu Bigstep, nur wenn nicht die Ausdrücke Callee, FinA ,\<dots>
34.14 *)
34.15
34.16 -lemma rtrancl_imp_rel_pow: "p \<in> R^* \<Longrightarrow> \<exists>n. p \<in> R^n"
34.17 -proof -
34.18 - assume "p \<in> R\<^sup>*"
34.19 - moreover obtain x y where p: "p = (x,y)" by (cases p)
34.20 - ultimately have "(x,y) \<in> R\<^sup>*" by hypsubst
34.21 - hence "\<exists>n. (x,y) \<in> R^n"
34.22 - proof induct
34.23 - fix a have "(a,a) \<in> R^0" by simp
34.24 - thus "\<exists>n. (a,a) \<in> R ^ n" ..
34.25 - next
34.26 - fix a b c assume "\<exists>n. (a,b) \<in> R ^ n"
34.27 - then obtain n where "(a,b) \<in> R^n" ..
34.28 - moreover assume "(b,c) \<in> R"
34.29 - ultimately have "(a,c) \<in> R^(Suc n)" by auto
34.30 - thus "\<exists>n. (a,c) \<in> R^n" ..
34.31 - qed
34.32 - with p show ?thesis by hypsubst
34.33 -qed
34.34 -
34.35 (*
34.36 lemma imp_eval_trans:
34.37 assumes eval: "G\<turnstile>s0 \<midarrow>t\<succ>\<rightarrow> (v,s1)"
35.1 --- a/src/HOL/Code_Eval.thy Mon May 11 09:39:53 2009 +0200
35.2 +++ b/src/HOL/Code_Eval.thy Mon May 11 17:20:52 2009 +0200
35.3 @@ -23,7 +23,7 @@
35.4 code_datatype Const App
35.5
35.6 class term_of = typerep +
35.7 - fixes term_of :: "'a::{} \<Rightarrow> term"
35.8 + fixes term_of :: "'a \<Rightarrow> term"
35.9
35.10 lemma term_of_anything: "term_of x \<equiv> t"
35.11 by (rule eq_reflection) (cases "term_of x", cases t, simp)
35.12 @@ -33,7 +33,7 @@
35.13 struct
35.14
35.15 fun mk_term f g (Const (c, ty)) =
35.16 - @{term Const} $ Message_String.mk c $ g ty
35.17 + @{term Const} $ HOLogic.mk_message_string c $ g ty
35.18 | mk_term f g (t1 $ t2) =
35.19 @{term App} $ mk_term f g t1 $ mk_term f g t2
35.20 | mk_term f g (Free v) = f v
35.21 @@ -67,18 +67,19 @@
35.22 |> Class.prove_instantiation_instance (K (Class.intro_classes_tac []))
35.23 |> LocalTheory.exit_global
35.24 end;
35.25 - fun interpretator (tyco, (raw_vs, _)) thy =
35.26 - let
35.27 - val has_inst = can (Sorts.mg_domain (Sign.classes_of thy) tyco) @{sort term_of};
35.28 - val constrain_sort =
35.29 - curry (Sorts.inter_sort (Sign.classes_of thy)) @{sort term_of};
35.30 - val vs = (map o apsnd) constrain_sort raw_vs;
35.31 - val ty = Type (tyco, map TFree vs);
35.32 - in
35.33 - thy
35.34 - |> Typerep.perhaps_add_def tyco
35.35 - |> not has_inst ? add_term_of_def ty vs tyco
35.36 - end;
35.37 + fun interpretator ("prop", (raw_vs, _)) thy = thy
35.38 + | interpretator (tyco, (raw_vs, _)) thy =
35.39 + let
35.40 + val has_inst = can (Sorts.mg_domain (Sign.classes_of thy) tyco) @{sort term_of};
35.41 + val constrain_sort =
35.42 + curry (Sorts.inter_sort (Sign.classes_of thy)) @{sort term_of};
35.43 + val vs = (map o apsnd) constrain_sort raw_vs;
35.44 + val ty = Type (tyco, map TFree vs);
35.45 + in
35.46 + thy
35.47 + |> Typerep.perhaps_add_def tyco
35.48 + |> not has_inst ? add_term_of_def ty vs tyco
35.49 + end;
35.50 in
35.51 Code.type_interpretation interpretator
35.52 end
35.53 @@ -105,21 +106,22 @@
35.54 thy
35.55 |> Code.add_eqn thm
35.56 end;
35.57 - fun interpretator (tyco, (raw_vs, raw_cs)) thy =
35.58 - let
35.59 - val constrain_sort =
35.60 - curry (Sorts.inter_sort (Sign.classes_of thy)) @{sort term_of};
35.61 - val vs = (map o apsnd) constrain_sort raw_vs;
35.62 - val cs = (map o apsnd o map o map_atyps)
35.63 - (fn TFree (v, sort) => TFree (v, constrain_sort sort)) raw_cs;
35.64 - val ty = Type (tyco, map TFree vs);
35.65 - val eqs = map (mk_term_of_eq ty vs tyco) cs;
35.66 - val const = AxClass.param_of_inst thy (@{const_name term_of}, tyco);
35.67 - in
35.68 - thy
35.69 - |> Code.del_eqns const
35.70 - |> fold (prove_term_of_eq ty) eqs
35.71 - end;
35.72 + fun interpretator ("prop", (raw_vs, _)) thy = thy
35.73 + | interpretator (tyco, (raw_vs, raw_cs)) thy =
35.74 + let
35.75 + val constrain_sort =
35.76 + curry (Sorts.inter_sort (Sign.classes_of thy)) @{sort term_of};
35.77 + val vs = (map o apsnd) constrain_sort raw_vs;
35.78 + val cs = (map o apsnd o map o map_atyps)
35.79 + (fn TFree (v, sort) => TFree (v, constrain_sort sort)) raw_cs;
35.80 + val ty = Type (tyco, map TFree vs);
35.81 + val eqs = map (mk_term_of_eq ty vs tyco) cs;
35.82 + val const = AxClass.param_of_inst thy (@{const_name term_of}, tyco);
35.83 + in
35.84 + thy
35.85 + |> Code.del_eqns const
35.86 + |> fold (prove_term_of_eq ty) eqs
35.87 + end;
35.88 in
35.89 Code.type_interpretation interpretator
35.90 end
35.91 @@ -146,13 +148,15 @@
35.92 by (subst term_of_anything) rule
35.93
35.94 code_type "term"
35.95 - (SML "Term.term")
35.96 + (Eval "Term.term")
35.97
35.98 code_const Const and App
35.99 - (SML "Term.Const/ (_, _)" and "Term.$/ (_, _)")
35.100 + (Eval "Term.Const/ (_, _)" and "Term.$/ (_, _)")
35.101
35.102 code_const "term_of \<Colon> message_string \<Rightarrow> term"
35.103 - (SML "Message'_String.mk")
35.104 + (Eval "HOLogic.mk'_message'_string")
35.105 +
35.106 +code_reserved Eval HOLogic
35.107
35.108
35.109 subsection {* Evaluation setup *}
35.110 @@ -161,6 +165,7 @@
35.111 signature EVAL =
35.112 sig
35.113 val mk_term: ((string * typ) -> term) -> (typ -> term) -> term -> term
35.114 + val mk_term_of: typ -> term -> term
35.115 val eval_ref: (unit -> term) option ref
35.116 val eval_term: theory -> term -> term
35.117 end;
35.118 @@ -175,8 +180,7 @@
35.119 fun eval_term thy t =
35.120 t
35.121 |> Eval.mk_term_of (fastype_of t)
35.122 - |> (fn t => Code_ML.eval_term ("Eval.eval_ref", eval_ref) thy t [])
35.123 - |> Code.postprocess_term thy;
35.124 + |> (fn t => Code_ML.eval NONE ("Eval.eval_ref", eval_ref) I thy t []);
35.125
35.126 end;
35.127 *}
36.1 --- a/src/HOL/Code_Message.thy Mon May 11 09:39:53 2009 +0200
36.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
36.3 @@ -1,58 +0,0 @@
36.4 -(* ID: $Id$
36.5 - Author: Florian Haftmann, TU Muenchen
36.6 -*)
36.7 -
36.8 -header {* Monolithic strings (message strings) for code generation *}
36.9 -
36.10 -theory Code_Message
36.11 -imports Plain "~~/src/HOL/List"
36.12 -begin
36.13 -
36.14 -subsection {* Datatype of messages *}
36.15 -
36.16 -datatype message_string = STR string
36.17 -
36.18 -lemmas [code del] = message_string.recs message_string.cases
36.19 -
36.20 -lemma [code]: "size (s\<Colon>message_string) = 0"
36.21 - by (cases s) simp_all
36.22 -
36.23 -lemma [code]: "message_string_size (s\<Colon>message_string) = 0"
36.24 - by (cases s) simp_all
36.25 -
36.26 -subsection {* ML interface *}
36.27 -
36.28 -ML {*
36.29 -structure Message_String =
36.30 -struct
36.31 -
36.32 -fun mk s = @{term STR} $ HOLogic.mk_string s;
36.33 -
36.34 -end;
36.35 -*}
36.36 -
36.37 -
36.38 -subsection {* Code serialization *}
36.39 -
36.40 -code_type message_string
36.41 - (SML "string")
36.42 - (OCaml "string")
36.43 - (Haskell "String")
36.44 -
36.45 -setup {*
36.46 - fold (fn target => add_literal_message @{const_name STR} target)
36.47 - ["SML", "OCaml", "Haskell"]
36.48 -*}
36.49 -
36.50 -code_reserved SML string
36.51 -code_reserved OCaml string
36.52 -
36.53 -code_instance message_string :: eq
36.54 - (Haskell -)
36.55 -
36.56 -code_const "eq_class.eq \<Colon> message_string \<Rightarrow> message_string \<Rightarrow> bool"
36.57 - (SML "!((_ : string) = _)")
36.58 - (OCaml "!((_ : string) = _)")
36.59 - (Haskell infixl 4 "==")
36.60 -
36.61 -end
37.1 --- a/src/HOL/Code_Setup.thy Mon May 11 09:39:53 2009 +0200
37.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
37.3 @@ -1,253 +0,0 @@
37.4 -(* Title: HOL/Code_Setup.thy
37.5 - ID: $Id$
37.6 - Author: Florian Haftmann
37.7 -*)
37.8 -
37.9 -header {* Setup of code generators and related tools *}
37.10 -
37.11 -theory Code_Setup
37.12 -imports HOL
37.13 -begin
37.14 -
37.15 -subsection {* Generic code generator foundation *}
37.16 -
37.17 -text {* Datatypes *}
37.18 -
37.19 -code_datatype True False
37.20 -
37.21 -code_datatype "TYPE('a\<Colon>{})"
37.22 -
37.23 -code_datatype Trueprop "prop"
37.24 -
37.25 -text {* Code equations *}
37.26 -
37.27 -lemma [code]:
37.28 - shows "(True \<Longrightarrow> PROP P) \<equiv> PROP P"
37.29 - and "(False \<Longrightarrow> Q) \<equiv> Trueprop True"
37.30 - and "(PROP P \<Longrightarrow> True) \<equiv> Trueprop True"
37.31 - and "(Q \<Longrightarrow> False) \<equiv> Trueprop (\<not> Q)" by (auto intro!: equal_intr_rule)
37.32 -
37.33 -lemma [code]:
37.34 - shows "False \<and> x \<longleftrightarrow> False"
37.35 - and "True \<and> x \<longleftrightarrow> x"
37.36 - and "x \<and> False \<longleftrightarrow> False"
37.37 - and "x \<and> True \<longleftrightarrow> x" by simp_all
37.38 -
37.39 -lemma [code]:
37.40 - shows "False \<or> x \<longleftrightarrow> x"
37.41 - and "True \<or> x \<longleftrightarrow> True"
37.42 - and "x \<or> False \<longleftrightarrow> x"
37.43 - and "x \<or> True \<longleftrightarrow> True" by simp_all
37.44 -
37.45 -lemma [code]:
37.46 - shows "\<not> True \<longleftrightarrow> False"
37.47 - and "\<not> False \<longleftrightarrow> True" by (rule HOL.simp_thms)+
37.48 -
37.49 -lemmas [code] = Let_def if_True if_False
37.50 -
37.51 -lemmas [code, code unfold, symmetric, code post] = imp_conv_disj
37.52 -
37.53 -text {* Equality *}
37.54 -
37.55 -context eq
37.56 -begin
37.57 -
37.58 -lemma equals_eq [code inline, code]: "op = \<equiv> eq"
37.59 - by (rule eq_reflection) (rule ext, rule ext, rule sym, rule eq_equals)
37.60 -
37.61 -declare eq [code unfold, code inline del]
37.62 -
37.63 -declare equals_eq [symmetric, code post]
37.64 -
37.65 -end
37.66 -
37.67 -declare simp_thms(6) [code nbe]
37.68 -
37.69 -hide (open) const eq
37.70 -hide const eq
37.71 -
37.72 -setup {*
37.73 - Code_Unit.add_const_alias @{thm equals_eq}
37.74 -*}
37.75 -
37.76 -text {* Cases *}
37.77 -
37.78 -lemma Let_case_cert:
37.79 - assumes "CASE \<equiv> (\<lambda>x. Let x f)"
37.80 - shows "CASE x \<equiv> f x"
37.81 - using assms by simp_all
37.82 -
37.83 -lemma If_case_cert:
37.84 - assumes "CASE \<equiv> (\<lambda>b. If b f g)"
37.85 - shows "(CASE True \<equiv> f) &&& (CASE False \<equiv> g)"
37.86 - using assms by simp_all
37.87 -
37.88 -setup {*
37.89 - Code.add_case @{thm Let_case_cert}
37.90 - #> Code.add_case @{thm If_case_cert}
37.91 - #> Code.add_undefined @{const_name undefined}
37.92 -*}
37.93 -
37.94 -code_abort undefined
37.95 -
37.96 -
37.97 -subsection {* Generic code generator preprocessor *}
37.98 -
37.99 -setup {*
37.100 - Code.map_pre (K HOL_basic_ss)
37.101 - #> Code.map_post (K HOL_basic_ss)
37.102 -*}
37.103 -
37.104 -
37.105 -subsection {* Generic code generator target languages *}
37.106 -
37.107 -text {* type bool *}
37.108 -
37.109 -code_type bool
37.110 - (SML "bool")
37.111 - (OCaml "bool")
37.112 - (Haskell "Bool")
37.113 -
37.114 -code_const True and False and Not and "op &" and "op |" and If
37.115 - (SML "true" and "false" and "not"
37.116 - and infixl 1 "andalso" and infixl 0 "orelse"
37.117 - and "!(if (_)/ then (_)/ else (_))")
37.118 - (OCaml "true" and "false" and "not"
37.119 - and infixl 4 "&&" and infixl 2 "||"
37.120 - and "!(if (_)/ then (_)/ else (_))")
37.121 - (Haskell "True" and "False" and "not"
37.122 - and infixl 3 "&&" and infixl 2 "||"
37.123 - and "!(if (_)/ then (_)/ else (_))")
37.124 -
37.125 -code_reserved SML
37.126 - bool true false not
37.127 -
37.128 -code_reserved OCaml
37.129 - bool not
37.130 -
37.131 -text {* using built-in Haskell equality *}
37.132 -
37.133 -code_class eq
37.134 - (Haskell "Eq")
37.135 -
37.136 -code_const "eq_class.eq"
37.137 - (Haskell infixl 4 "==")
37.138 -
37.139 -code_const "op ="
37.140 - (Haskell infixl 4 "==")
37.141 -
37.142 -text {* undefined *}
37.143 -
37.144 -code_const undefined
37.145 - (SML "!(raise/ Fail/ \"undefined\")")
37.146 - (OCaml "failwith/ \"undefined\"")
37.147 - (Haskell "error/ \"undefined\"")
37.148 -
37.149 -
37.150 -subsection {* SML code generator setup *}
37.151 -
37.152 -types_code
37.153 - "bool" ("bool")
37.154 -attach (term_of) {*
37.155 -fun term_of_bool b = if b then HOLogic.true_const else HOLogic.false_const;
37.156 -*}
37.157 -attach (test) {*
37.158 -fun gen_bool i =
37.159 - let val b = one_of [false, true]
37.160 - in (b, fn () => term_of_bool b) end;
37.161 -*}
37.162 - "prop" ("bool")
37.163 -attach (term_of) {*
37.164 -fun term_of_prop b =
37.165 - HOLogic.mk_Trueprop (if b then HOLogic.true_const else HOLogic.false_const);
37.166 -*}
37.167 -
37.168 -consts_code
37.169 - "Trueprop" ("(_)")
37.170 - "True" ("true")
37.171 - "False" ("false")
37.172 - "Not" ("Bool.not")
37.173 - "op |" ("(_ orelse/ _)")
37.174 - "op &" ("(_ andalso/ _)")
37.175 - "If" ("(if _/ then _/ else _)")
37.176 -
37.177 -setup {*
37.178 -let
37.179 -
37.180 -fun eq_codegen thy defs dep thyname b t gr =
37.181 - (case strip_comb t of
37.182 - (Const ("op =", Type (_, [Type ("fun", _), _])), _) => NONE
37.183 - | (Const ("op =", _), [t, u]) =>
37.184 - let
37.185 - val (pt, gr') = Codegen.invoke_codegen thy defs dep thyname false t gr;
37.186 - val (pu, gr'') = Codegen.invoke_codegen thy defs dep thyname false u gr';
37.187 - val (_, gr''') = Codegen.invoke_tycodegen thy defs dep thyname false HOLogic.boolT gr'';
37.188 - in
37.189 - SOME (Codegen.parens
37.190 - (Pretty.block [pt, Codegen.str " =", Pretty.brk 1, pu]), gr''')
37.191 - end
37.192 - | (t as Const ("op =", _), ts) => SOME (Codegen.invoke_codegen
37.193 - thy defs dep thyname b (Codegen.eta_expand t ts 2) gr)
37.194 - | _ => NONE);
37.195 -
37.196 -in
37.197 - Codegen.add_codegen "eq_codegen" eq_codegen
37.198 -end
37.199 -*}
37.200 -
37.201 -
37.202 -subsection {* Evaluation and normalization by evaluation *}
37.203 -
37.204 -setup {*
37.205 - Value.add_evaluator ("SML", Codegen.eval_term o ProofContext.theory_of)
37.206 -*}
37.207 -
37.208 -ML {*
37.209 -structure Eval_Method =
37.210 -struct
37.211 -
37.212 -val eval_ref : (unit -> bool) option ref = ref NONE;
37.213 -
37.214 -end;
37.215 -*}
37.216 -
37.217 -oracle eval_oracle = {* fn ct =>
37.218 - let
37.219 - val thy = Thm.theory_of_cterm ct;
37.220 - val t = Thm.term_of ct;
37.221 - val dummy = @{cprop True};
37.222 - in case try HOLogic.dest_Trueprop t
37.223 - of SOME t' => if Code_ML.eval_term
37.224 - ("Eval_Method.eval_ref", Eval_Method.eval_ref) thy t' []
37.225 - then Thm.capply (Thm.capply @{cterm "op \<equiv> \<Colon> prop \<Rightarrow> prop \<Rightarrow> prop"} ct) dummy
37.226 - else dummy
37.227 - | NONE => dummy
37.228 - end
37.229 -*}
37.230 -
37.231 -ML {*
37.232 -fun gen_eval_method conv ctxt = SIMPLE_METHOD'
37.233 - (CONVERSION (Conv.params_conv (~1) (K (Conv.concl_conv (~1) conv)) ctxt)
37.234 - THEN' rtac TrueI)
37.235 -*}
37.236 -
37.237 -method_setup eval = {* Scan.succeed (gen_eval_method eval_oracle) *}
37.238 - "solve goal by evaluation"
37.239 -
37.240 -method_setup evaluation = {* Scan.succeed (gen_eval_method Codegen.evaluation_conv) *}
37.241 - "solve goal by evaluation"
37.242 -
37.243 -method_setup normalization = {*
37.244 - Scan.succeed (K (SIMPLE_METHOD' (CONVERSION Nbe.norm_conv THEN' (fn k => TRY (rtac TrueI k)))))
37.245 -*} "solve goal by normalization"
37.246 -
37.247 -
37.248 -subsection {* Quickcheck *}
37.249 -
37.250 -setup {*
37.251 - Quickcheck.add_generator ("SML", Codegen.test_term)
37.252 -*}
37.253 -
37.254 -quickcheck_params [size = 5, iterations = 50]
37.255 -
37.256 -end
38.1 --- a/src/HOL/Complex.thy Mon May 11 09:39:53 2009 +0200
38.2 +++ b/src/HOL/Complex.thy Mon May 11 17:20:52 2009 +0200
38.3 @@ -157,23 +157,6 @@
38.4 end
38.5
38.6
38.7 -subsection {* Exponentiation *}
38.8 -
38.9 -instantiation complex :: recpower
38.10 -begin
38.11 -
38.12 -primrec power_complex where
38.13 - "z ^ 0 = (1\<Colon>complex)"
38.14 -| "z ^ Suc n = (z\<Colon>complex) * z ^ n"
38.15 -
38.16 -instance proof
38.17 -qed simp_all
38.18 -
38.19 -declare power_complex.simps [simp del]
38.20 -
38.21 -end
38.22 -
38.23 -
38.24 subsection {* Numerals and Arithmetic *}
38.25
38.26 instantiation complex :: number_ring
39.1 --- a/src/HOL/Decision_Procs/Approximation.thy Mon May 11 09:39:53 2009 +0200
39.2 +++ b/src/HOL/Decision_Procs/Approximation.thy Mon May 11 17:20:52 2009 +0200
39.3 @@ -23,8 +23,8 @@
39.4 qed
39.5
39.6 lemma horner_schema: fixes f :: "nat \<Rightarrow> nat" and G :: "nat \<Rightarrow> nat \<Rightarrow> nat" and F :: "nat \<Rightarrow> nat"
39.7 - assumes f_Suc: "\<And>n. f (Suc n) = G ((F^n) s) (f n)"
39.8 - shows "horner F G n ((F^j') s) (f j') x = (\<Sum> j = 0..< n. -1^j * (1 / real (f (j' + j))) * x^j)"
39.9 + assumes f_Suc: "\<And>n. f (Suc n) = G ((F ^^ n) s) (f n)"
39.10 + shows "horner F G n ((F ^^ j') s) (f j') x = (\<Sum> j = 0..< n. -1 ^ j * (1 / real (f (j' + j))) * x ^ j)"
39.11 proof (induct n arbitrary: i k j')
39.12 case (Suc n)
39.13
39.14 @@ -33,13 +33,13 @@
39.15 qed auto
39.16
39.17 lemma horner_bounds':
39.18 - assumes "0 \<le> Ifloat x" and f_Suc: "\<And>n. f (Suc n) = G ((F^n) s) (f n)"
39.19 + assumes "0 \<le> Ifloat x" and f_Suc: "\<And>n. f (Suc n) = G ((F ^^ n) s) (f n)"
39.20 and lb_0: "\<And> i k x. lb 0 i k x = 0"
39.21 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)"
39.22 and ub_0: "\<And> i k x. ub 0 i k x = 0"
39.23 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)"
39.24 - shows "Ifloat (lb n ((F^j') s) (f j') x) \<le> horner F G n ((F^j') s) (f j') (Ifloat x) \<and>
39.25 - horner F G n ((F^j') s) (f j') (Ifloat x) \<le> Ifloat (ub n ((F^j') s) (f j') x)"
39.26 + shows "Ifloat (lb n ((F ^^ j') s) (f j') x) \<le> horner F G n ((F ^^ j') s) (f j') (Ifloat x) \<and>
39.27 + horner F G n ((F ^^ j') s) (f j') (Ifloat x) \<le> Ifloat (ub n ((F ^^ j') s) (f j') x)"
39.28 (is "?lb n j' \<le> ?horner n j' \<and> ?horner n j' \<le> ?ub n j'")
39.29 proof (induct n arbitrary: j')
39.30 case 0 thus ?case unfolding lb_0 ub_0 horner.simps by auto
39.31 @@ -49,15 +49,15 @@
39.32 proof (rule add_mono)
39.33 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
39.34 from Suc[where j'="Suc j'", unfolded funpow.simps comp_def f_Suc, THEN conjunct2] `0 \<le> Ifloat x`
39.35 - 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))"
39.36 + 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))"
39.37 unfolding Ifloat_mult neg_le_iff_le by (rule mult_left_mono)
39.38 qed
39.39 moreover have "?horner (Suc n) j' \<le> ?ub (Suc n) j'" unfolding ub_Suc ub_Suc horner.simps Ifloat_sub diff_def
39.40 proof (rule add_mono)
39.41 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
39.42 from Suc[where j'="Suc j'", unfolded funpow.simps comp_def f_Suc, THEN conjunct1] `0 \<le> Ifloat x`
39.43 - show "- (Ifloat x * horner F G n (F ((F ^ j') s)) (G ((F ^ j') s) (f j')) (Ifloat x)) \<le>
39.44 - - Ifloat (x * lb n (F ((F ^ j') s)) (G ((F ^ j') s) (f j')) x)"
39.45 + show "- (Ifloat x * horner F G n (F ((F ^^ j') s)) (G ((F ^^ j') s) (f j')) (Ifloat x)) \<le>
39.46 + - Ifloat (x * lb n (F ((F ^^ j') s)) (G ((F ^^ j') s) (f j')) x)"
39.47 unfolding Ifloat_mult neg_le_iff_le by (rule mult_left_mono)
39.48 qed
39.49 ultimately show ?case by blast
39.50 @@ -73,13 +73,13 @@
39.51 *}
39.52
39.53 lemma horner_bounds: fixes F :: "nat \<Rightarrow> nat" and G :: "nat \<Rightarrow> nat \<Rightarrow> nat"
39.54 - assumes "0 \<le> Ifloat x" and f_Suc: "\<And>n. f (Suc n) = G ((F^n) s) (f n)"
39.55 + assumes "0 \<le> Ifloat x" and f_Suc: "\<And>n. f (Suc n) = G ((F ^^ n) s) (f n)"
39.56 and lb_0: "\<And> i k x. lb 0 i k x = 0"
39.57 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)"
39.58 and ub_0: "\<And> i k x. ub 0 i k x = 0"
39.59 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)"
39.60 - 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
39.61 - "(\<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")
39.62 + 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
39.63 + "(\<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")
39.64 proof -
39.65 have "?lb \<and> ?ub"
39.66 using horner_bounds'[where lb=lb, OF `0 \<le> Ifloat x` f_Suc lb_0 lb_Suc ub_0 ub_Suc]
39.67 @@ -88,29 +88,29 @@
39.68 qed
39.69
39.70 lemma horner_bounds_nonpos: fixes F :: "nat \<Rightarrow> nat" and G :: "nat \<Rightarrow> nat \<Rightarrow> nat"
39.71 - assumes "Ifloat x \<le> 0" and f_Suc: "\<And>n. f (Suc n) = G ((F^n) s) (f n)"
39.72 + assumes "Ifloat x \<le> 0" and f_Suc: "\<And>n. f (Suc n) = G ((F ^^ n) s) (f n)"
39.73 and lb_0: "\<And> i k x. lb 0 i k x = 0"
39.74 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)"
39.75 and ub_0: "\<And> i k x. ub 0 i k x = 0"
39.76 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)"
39.77 - 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
39.78 - "(\<Sum>j=0..<n. (1 / real (f (j' + j))) * (Ifloat x)^j) \<le> Ifloat (ub n ((F^j') s) (f j') x)" (is "?ub")
39.79 + 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
39.80 + "(\<Sum>j=0..<n. (1 / real (f (j' + j))) * (Ifloat x ^ j)) \<le> Ifloat (ub n ((F ^^ j') s) (f j') x)" (is "?ub")
39.81 proof -
39.82 { fix x y z :: float have "x - y * z = x + - y * z"
39.83 - by (cases x, cases y, cases z, simp add: plus_float.simps minus_float.simps uminus_float.simps times_float.simps algebra_simps)
39.84 + by (cases x, cases y, cases z, simp add: plus_float.simps minus_float_def uminus_float.simps times_float.simps algebra_simps)
39.85 } note diff_mult_minus = this
39.86
39.87 { fix x :: float have "- (- x) = x" by (cases x, auto simp add: uminus_float.simps) } note minus_minus = this
39.88
39.89 have move_minus: "Ifloat (-x) = -1 * Ifloat x" by auto
39.90
39.91 - have sum_eq: "(\<Sum>j=0..<n. (1 / real (f (j' + j))) * (Ifloat x)^j) =
39.92 + have sum_eq: "(\<Sum>j=0..<n. (1 / real (f (j' + j))) * Ifloat x ^ j) =
39.93 (\<Sum>j = 0..<n. -1 ^ j * (1 / real (f (j' + j))) * Ifloat (- x) ^ j)"
39.94 proof (rule setsum_cong, simp)
39.95 fix j assume "j \<in> {0 ..< n}"
39.96 show "1 / real (f (j' + j)) * Ifloat x ^ j = -1 ^ j * (1 / real (f (j' + j))) * Ifloat (- x) ^ j"
39.97 unfolding move_minus power_mult_distrib real_mult_assoc[symmetric]
39.98 - unfolding real_mult_commute unfolding real_mult_assoc[of "-1^j", symmetric] power_mult_distrib[symmetric]
39.99 + unfolding real_mult_commute unfolding real_mult_assoc[of "-1 ^ j", symmetric] power_mult_distrib[symmetric]
39.100 by auto
39.101 qed
39.102
39.103 @@ -160,21 +160,21 @@
39.104 else (0, (max (-l) u) ^ n))"
39.105
39.106 lemma float_power_bnds: assumes "(l1, u1) = float_power_bnds n l u" and "x \<in> {Ifloat l .. Ifloat u}"
39.107 - shows "x^n \<in> {Ifloat l1..Ifloat u1}"
39.108 + shows "x ^ n \<in> {Ifloat l1..Ifloat u1}"
39.109 proof (cases "even n")
39.110 case True
39.111 show ?thesis
39.112 proof (cases "0 < l")
39.113 case True hence "odd n \<or> 0 < l" and "0 \<le> Ifloat l" unfolding less_float_def by auto
39.114 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
39.115 - 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
39.116 + 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
39.117 thus ?thesis using assms `0 < l` unfolding atLeastAtMost_iff l1 u1 float_power less_float_def by auto
39.118 next
39.119 case False hence P: "\<not> (odd n \<or> 0 < l)" using `even n` by auto
39.120 show ?thesis
39.121 proof (cases "u < 0")
39.122 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
39.123 - 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]
39.124 + 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]
39.125 unfolding power_minus_even[OF `even n`] by auto
39.126 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
39.127 ultimately show ?thesis using float_power by auto
39.128 @@ -194,11 +194,11 @@
39.129 next
39.130 case False hence "odd n \<or> 0 < l" by auto
39.131 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
39.132 - 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
39.133 + 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
39.134 thus ?thesis unfolding atLeastAtMost_iff l1 u1 float_power less_float_def by auto
39.135 qed
39.136
39.137 -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"
39.138 +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"
39.139 using float_power_bnds by auto
39.140
39.141 section "Square root"
39.142 @@ -794,8 +794,8 @@
39.143 let "?f n" = "fact (2 * n)"
39.144
39.145 { fix n
39.146 - have F: "\<And>m. ((\<lambda>i. i + 2) ^ n) m = m + 2 * n" by (induct n arbitrary: m, auto)
39.147 - have "?f (Suc n) = ?f n * ((\<lambda>i. i + 2) ^ n) 1 * (((\<lambda>i. i + 2) ^ n) 1 + 1)"
39.148 + have F: "\<And>m. ((\<lambda>i. i + 2) ^^ n) m = m + 2 * n" by (induct n arbitrary: m, auto)
39.149 + have "?f (Suc n) = ?f n * ((\<lambda>i. i + 2) ^^ n) 1 * (((\<lambda>i. i + 2) ^^ n) 1 + 1)"
39.150 unfolding F by auto } note f_eq = this
39.151
39.152 from horner_bounds[where lb="lb_sin_cos_aux prec" and ub="ub_sin_cos_aux prec" and j'=0,
39.153 @@ -811,7 +811,7 @@
39.154 have "0 < x * x" using `0 < x` unfolding less_float_def Ifloat_mult Ifloat_0
39.155 using mult_pos_pos[where a="Ifloat x" and b="Ifloat x"] by auto
39.156
39.157 - { fix x n have "(\<Sum> i=0..<n. -1^i * (1/real (fact (2 * i))) * x^(2 * i))
39.158 + { fix x n have "(\<Sum> i=0..<n. -1^i * (1/real (fact (2 * i))) * x ^ (2 * i))
39.159 = (\<Sum> i = 0 ..< 2 * n. (if even(i) then (-1 ^ (i div 2))/(real (fact i)) else 0) * x ^ i)" (is "?sum = ?ifsum")
39.160 proof -
39.161 have "?sum = ?sum + (\<Sum> j = 0 ..< n. 0)" by auto
39.162 @@ -905,8 +905,8 @@
39.163 let "?f n" = "fact (2 * n + 1)"
39.164
39.165 { fix n
39.166 - have F: "\<And>m. ((\<lambda>i. i + 2) ^ n) m = m + 2 * n" by (induct n arbitrary: m, auto)
39.167 - have "?f (Suc n) = ?f n * ((\<lambda>i. i + 2) ^ n) 2 * (((\<lambda>i. i + 2) ^ n) 2 + 1)"
39.168 + have F: "\<And>m. ((\<lambda>i. i + 2) ^^ n) m = m + 2 * n" by (induct n arbitrary: m, auto)
39.169 + have "?f (Suc n) = ?f n * ((\<lambda>i. i + 2) ^^ n) 2 * (((\<lambda>i. i + 2) ^^ n) 2 + 1)"
39.170 unfolding F by auto } note f_eq = this
39.171
39.172 from horner_bounds[where lb="lb_sin_cos_aux prec" and ub="ub_sin_cos_aux prec" and j'=0,
39.173 @@ -1382,8 +1382,8 @@
39.174 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) }"
39.175 proof -
39.176 { fix n
39.177 - have F: "\<And> m. ((\<lambda>i. i + 1) ^ n) m = n + m" by (induct n, auto)
39.178 - have "fact (Suc n) = fact n * ((\<lambda>i. i + 1) ^ n) 1" unfolding F by auto } note f_eq = this
39.179 + have F: "\<And> m. ((\<lambda>i. i + 1) ^^ n) m = n + m" by (induct n, auto)
39.180 + have "fact (Suc n) = fact n * ((\<lambda>i. i + 1) ^^ n) 1" unfolding F by auto } note f_eq = this
39.181
39.182 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,
39.183 OF assms f_eq lb_exp_horner.simps ub_exp_horner.simps]
39.184 @@ -1462,7 +1462,8 @@
39.185 finally have "0 < Ifloat ((?horner x) ^ num)" .
39.186 }
39.187 ultimately show ?thesis
39.188 - 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)
39.189 + unfolding lb_exp.simps if_not_P[OF `\<not> 0 < x`] Let_def
39.190 + by (cases "floor_fl x", cases "x < - 1", auto simp add: float_power le_float_def less_float_def)
39.191 qed
39.192
39.193 lemma exp_boundaries': assumes "x \<le> 0"
39.194 @@ -1631,10 +1632,10 @@
39.195
39.196 lemma ln_bounds:
39.197 assumes "0 \<le> x" and "x < 1"
39.198 - shows "(\<Sum>i=0..<2*n. -1^i * (1 / real (i + 1)) * x^(Suc i)) \<le> ln (x + 1)" (is "?lb")
39.199 - and "ln (x + 1) \<le> (\<Sum>i=0..<2*n + 1. -1^i * (1 / real (i + 1)) * x^(Suc i))" (is "?ub")
39.200 + shows "(\<Sum>i=0..<2*n. -1^i * (1 / real (i + 1)) * x ^ (Suc i)) \<le> ln (x + 1)" (is "?lb")
39.201 + and "ln (x + 1) \<le> (\<Sum>i=0..<2*n + 1. -1^i * (1 / real (i + 1)) * x ^ (Suc i))" (is "?ub")
39.202 proof -
39.203 - let "?a n" = "(1/real (n +1)) * x^(Suc n)"
39.204 + let "?a n" = "(1/real (n +1)) * x ^ (Suc n)"
39.205
39.206 have ln_eq: "(\<Sum> i. -1^i * ?a i) = ln (x + 1)"
39.207 using ln_series[of "x + 1"] `0 \<le> x` `x < 1` by auto
39.208 @@ -2479,7 +2480,7 @@
39.209 fun lift_var (Free (varname, _)) = (case AList.lookup (op =) bound_eqs varname of
39.210 SOME bound => bound
39.211 | NONE => raise TERM ("No bound equations found for " ^ varname, []))
39.212 - | lift_var t = raise TERM ("Can not convert expression " ^
39.213 + | lift_var t = raise TERM ("Can not convert expression " ^
39.214 (Syntax.string_of_term ctxt t), [t])
39.215
39.216 val _ $ vs = HOLogic.dest_Trueprop (Logic.strip_imp_concl goal')
40.1 --- a/src/HOL/Decision_Procs/Dense_Linear_Order.thy Mon May 11 09:39:53 2009 +0200
40.2 +++ b/src/HOL/Decision_Procs/Dense_Linear_Order.thy Mon May 11 17:20:52 2009 +0200
40.3 @@ -639,7 +639,7 @@
40.4
40.5 interpretation class_ordered_field_dense_linear_order: constr_dense_linear_order
40.6 "op <=" "op <"
40.7 - "\<lambda> x y. 1/2 * ((x::'a::{ordered_field,recpower,number_ring}) + y)"
40.8 + "\<lambda> x y. 1/2 * ((x::'a::{ordered_field,number_ring}) + y)"
40.9 proof (unfold_locales, dlo, dlo, auto)
40.10 fix x y::'a assume lt: "x < y"
40.11 from less_half_sum[OF lt] show "x < (x + y) /2" by simp
41.1 --- a/src/HOL/Decision_Procs/cooper_tac.ML Mon May 11 09:39:53 2009 +0200
41.2 +++ b/src/HOL/Decision_Procs/cooper_tac.ML Mon May 11 17:20:52 2009 +0200
41.3 @@ -76,14 +76,14 @@
41.4 @{thm "div_by_1"}, @{thm "mod_by_1"}, @{thm "div_1"}, @{thm "mod_1"},
41.5 Suc_plus1]
41.6 addsimps @{thms add_ac}
41.7 - addsimprocs [cancel_div_mod_proc]
41.8 + addsimprocs [cancel_div_mod_nat_proc, cancel_div_mod_int_proc]
41.9 val simpset0 = HOL_basic_ss
41.10 addsimps [mod_div_equality', Suc_plus1]
41.11 addsimps comp_arith
41.12 addsplits [split_zdiv, split_zmod, split_div', @{thm "split_min"}, @{thm "split_max"}]
41.13 (* Simp rules for changing (n::int) to int n *)
41.14 val simpset1 = HOL_basic_ss
41.15 - addsimps [nat_number_of_def, zdvd_int] @ map (fn r => r RS sym)
41.16 + addsimps [@{thm nat_number_of_def}, zdvd_int] @ map (fn r => r RS sym)
41.17 [@{thm int_int_eq}, @{thm zle_int}, @{thm zless_int}, @{thm zadd_int}, @{thm zmult_int}]
41.18 addsplits [zdiff_int_split]
41.19 (*simp rules for elimination of int n*)
42.1 --- a/src/HOL/Decision_Procs/ex/Dense_Linear_Order_Ex.thy Mon May 11 09:39:53 2009 +0200
42.2 +++ b/src/HOL/Decision_Procs/ex/Dense_Linear_Order_Ex.thy Mon May 11 17:20:52 2009 +0200
42.3 @@ -7,147 +7,147 @@
42.4 begin
42.5
42.6 lemma
42.7 - "\<exists>(y::'a::{ordered_field,recpower,number_ring, division_by_zero}) <2. x + 3* y < 0 \<and> x - y >0"
42.8 + "\<exists>(y::'a::{ordered_field,number_ring, division_by_zero}) <2. x + 3* y < 0 \<and> x - y >0"
42.9 by ferrack
42.10
42.11 -lemma "~ (ALL x (y::'a::{ordered_field,recpower,number_ring, division_by_zero}). x < y --> 10*x < 11*y)"
42.12 +lemma "~ (ALL x (y::'a::{ordered_field,number_ring, division_by_zero}). x < y --> 10*x < 11*y)"
42.13 by ferrack
42.14
42.15 -lemma "ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y. x < y --> (10*(x + 5*y + -1) < 60*y)"
42.16 +lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y. x < y --> (10*(x + 5*y + -1) < 60*y)"
42.17 by ferrack
42.18
42.19 -lemma "EX (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y. x ~= y --> x < y"
42.20 +lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y. x ~= y --> x < y"
42.21 by ferrack
42.22
42.23 -lemma "EX (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y. (x ~= y & 10*x ~= 9*y & 10*x < y) --> x < y"
42.24 +lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y. (x ~= y & 10*x ~= 9*y & 10*x < y) --> x < y"
42.25 by ferrack
42.26
42.27 -lemma "ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y. (x ~= y & 5*x <= y) --> 500*x <= 100*y"
42.28 +lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y. (x ~= y & 5*x <= y) --> 500*x <= 100*y"
42.29 by ferrack
42.30
42.31 -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)"
42.32 +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)"
42.33 by ferrack
42.34
42.35 -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)"
42.36 +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)"
42.37 by ferrack
42.38
42.39 -lemma "EX (x::'a::{ordered_field,recpower,number_ring, division_by_zero}). (0 < x & x < 1) --> (ALL y > 1. x + y ~= 1)"
42.40 +lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}). (0 < x & x < 1) --> (ALL y > 1. x + y ~= 1)"
42.41 by ferrack
42.42
42.43 -lemma "EX x. (ALL (y::'a::{ordered_field,recpower,number_ring, division_by_zero}). y < 2 --> 2*(y - x) \<le> 0 )"
42.44 +lemma "EX x. (ALL (y::'a::{ordered_field,number_ring, division_by_zero}). y < 2 --> 2*(y - x) \<le> 0 )"
42.45 by ferrack
42.46
42.47 -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)"
42.48 +lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}). x < 10 | x > 20 | (EX y. y>= 0 & y <= 10 & x+y = 20)"
42.49 by ferrack
42.50
42.51 -lemma "ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y z. x + y < z --> y >= z --> x < 0"
42.52 +lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y z. x + y < z --> y >= z --> x < 0"
42.53 by ferrack
42.54
42.55 -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"
42.56 +lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y z. x + 7*y < 5* z & 5*y >= 7*z & x < 0"
42.57 by ferrack
42.58
42.59 -lemma "ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y z. abs (x + y) <= z --> (abs z = z)"
42.60 +lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y z. abs (x + y) <= z --> (abs z = z)"
42.61 by ferrack
42.62
42.63 -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"
42.64 +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"
42.65 by ferrack
42.66
42.67 -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))"
42.68 +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))"
42.69 by ferrack
42.70
42.71 -lemma "ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y. x < y --> (EX z>0. x+z = y)"
42.72 +lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y. x < y --> (EX z>0. x+z = y)"
42.73 by ferrack
42.74
42.75 -lemma "ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y. x < y --> (EX z>0. x+z = y)"
42.76 +lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y. x < y --> (EX z>0. x+z = y)"
42.77 by ferrack
42.78
42.79 -lemma "ALL (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y. (EX z>0. abs (x - y) <= z )"
42.80 +lemma "ALL (x::'a::{ordered_field,number_ring, division_by_zero}) y. (EX z>0. abs (x - y) <= z )"
42.81 by ferrack
42.82
42.83 -lemma "EX (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y. (ALL z<0. (z < x --> z <= y) & (z > y --> z >= x))"
42.84 +lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y. (ALL z<0. (z < x --> z <= y) & (z > y --> z >= x))"
42.85 by ferrack
42.86
42.87 -lemma "EX (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y. (ALL z>=0. abs (3*x+7*y) <= 2*z + 1)"
42.88 +lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y. (ALL z>=0. abs (3*x+7*y) <= 2*z + 1)"
42.89 by ferrack
42.90
42.91 -lemma "EX (x::'a::{ordered_field,recpower,number_ring, division_by_zero}) y. (ALL z<0. (z < x --> z <= y) & (z > y --> z >= x))"
42.92 +lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}) y. (ALL z<0. (z < x --> z <= y) & (z > y --> z >= x))"
42.93 by ferrack
42.94
42.95 -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))"
42.96 +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))"
42.97 by ferrack
42.98
42.99 -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))"
42.100 +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))"
42.101 by ferrack
42.102
42.103 -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))"
42.104 +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))"
42.105 by ferrack
42.106
42.107 -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) ))"
42.108 +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) ))"
42.109 by ferrack
42.110
42.111 -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))"
42.112 +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))"
42.113 by ferrack
42.114
42.115 -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"
42.116 +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"
42.117 by ferrack
42.118
42.119 -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"
42.120 +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"
42.121 by ferrack
42.122
42.123 -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)"
42.124 +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)"
42.125 by ferrack
42.126
42.127 -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)"
42.128 +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)"
42.129 by ferrack
42.130
42.131 -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)"
42.132 +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)"
42.133 by ferrack
42.134
42.135 -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))"
42.136 +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))"
42.137 by ferrack
42.138
42.139 -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)"
42.140 +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)"
42.141 by ferrack
42.142
42.143 -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))"
42.144 +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))"
42.145 by ferrack
42.146
42.147 -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)"
42.148 +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)"
42.149 by ferrack
42.150
42.151 -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))"
42.152 +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))"
42.153 by ferrack
42.154
42.155 -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))"
42.156 +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))"
42.157 by ferrack
42.158
42.159 -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))"
42.160 +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))"
42.161 by ferrack
42.162
42.163 -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)))"
42.164 +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)))"
42.165 by ferrack
42.166
42.167 -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))"
42.168 +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))"
42.169 by ferrack
42.170
42.171 -lemma "EX (x::'a::{ordered_field,recpower,number_ring, division_by_zero}). (ALL y < x. (EX z > (x+y).
42.172 +lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}). (ALL y < x. (EX z > (x+y).
42.173 (ALL w. 5*w + 10*x - z >= y --> w + 7*x + 3*z >= 2*y)))"
42.174 by ferrack
42.175
42.176 -lemma "EX (x::'a::{ordered_field,recpower,number_ring, division_by_zero}). (ALL y. (EX z > y.
42.177 +lemma "EX (x::'a::{ordered_field,number_ring, division_by_zero}). (ALL y. (EX z > y.
42.178 (ALL w . w < 13 --> w + 10*x - z >= y --> 5*w + 7*x + 13*z >= 2*y)))"
42.179 by ferrack
42.180
42.181 -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)"
42.182 +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)"
42.183 by ferrack
42.184
42.185 -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)))"
42.186 +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)))"
42.187 by ferrack
42.188
42.189 -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)))"
42.190 +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)))"
42.191 by ferrack
42.192
42.193 -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)))"
42.194 +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)))"
42.195 by ferrack
42.196
42.197 end
43.1 --- a/src/HOL/Decision_Procs/mir_tac.ML Mon May 11 09:39:53 2009 +0200
43.2 +++ b/src/HOL/Decision_Procs/mir_tac.ML Mon May 11 17:20:52 2009 +0200
43.3 @@ -99,7 +99,7 @@
43.4 @{thm "div_by_1"}, @{thm "mod_by_1"}, @{thm "div_1"}, @{thm "mod_1"},
43.5 @{thm "Suc_plus1"}]
43.6 addsimps @{thms add_ac}
43.7 - addsimprocs [cancel_div_mod_proc]
43.8 + addsimprocs [cancel_div_mod_nat_proc, cancel_div_mod_int_proc]
43.9 val simpset0 = HOL_basic_ss
43.10 addsimps [mod_div_equality', Suc_plus1]
43.11 addsimps comp_ths
44.1 --- a/src/HOL/Deriv.thy Mon May 11 09:39:53 2009 +0200
44.2 +++ b/src/HOL/Deriv.thy Mon May 11 17:20:52 2009 +0200
44.3 @@ -1,5 +1,4 @@
44.4 (* Title : Deriv.thy
44.5 - ID : $Id$
44.6 Author : Jacques D. Fleuriot
44.7 Copyright : 1998 University of Cambridge
44.8 Conversion to Isar and new proofs by Lawrence C Paulson, 2004
44.9 @@ -197,7 +196,7 @@
44.10 done
44.11
44.12 lemma DERIV_power_Suc:
44.13 - fixes f :: "'a \<Rightarrow> 'a::{real_normed_field,recpower}"
44.14 + fixes f :: "'a \<Rightarrow> 'a::{real_normed_field}"
44.15 assumes f: "DERIV f x :> D"
44.16 shows "DERIV (\<lambda>x. f x ^ Suc n) x :> (1 + of_nat n) * (D * f x ^ n)"
44.17 proof (induct n)
44.18 @@ -211,7 +210,7 @@
44.19 qed
44.20
44.21 lemma DERIV_power:
44.22 - fixes f :: "'a \<Rightarrow> 'a::{real_normed_field,recpower}"
44.23 + fixes f :: "'a \<Rightarrow> 'a::{real_normed_field}"
44.24 assumes f: "DERIV f x :> D"
44.25 shows "DERIV (\<lambda>x. f x ^ n) x :> of_nat n * (D * f x ^ (n - Suc 0))"
44.26 by (cases "n", simp, simp add: DERIV_power_Suc f del: power_Suc)
44.27 @@ -287,20 +286,20 @@
44.28 text{*Power of -1*}
44.29
44.30 lemma DERIV_inverse:
44.31 - fixes x :: "'a::{real_normed_field,recpower}"
44.32 + fixes x :: "'a::{real_normed_field}"
44.33 shows "x \<noteq> 0 ==> DERIV (%x. inverse(x)) x :> (-(inverse x ^ Suc (Suc 0)))"
44.34 by (drule DERIV_inverse' [OF DERIV_ident]) simp
44.35
44.36 text{*Derivative of inverse*}
44.37 lemma DERIV_inverse_fun:
44.38 - fixes x :: "'a::{real_normed_field,recpower}"
44.39 + fixes x :: "'a::{real_normed_field}"
44.40 shows "[| DERIV f x :> d; f(x) \<noteq> 0 |]
44.41 ==> DERIV (%x. inverse(f x)) x :> (- (d * inverse(f(x) ^ Suc (Suc 0))))"
44.42 by (drule (1) DERIV_inverse') (simp add: mult_ac nonzero_inverse_mult_distrib)
44.43
44.44 text{*Derivative of quotient*}
44.45 lemma DERIV_quotient:
44.46 - fixes x :: "'a::{real_normed_field,recpower}"
44.47 + fixes x :: "'a::{real_normed_field}"
44.48 shows "[| DERIV f x :> d; DERIV g x :> e; g(x) \<noteq> 0 |]
44.49 ==> DERIV (%y. f(y) / (g y)) x :> (d*g(x) - (e*f(x))) / (g(x) ^ Suc (Suc 0))"
44.50 by (drule (2) DERIV_divide) (simp add: mult_commute)
44.51 @@ -404,7 +403,7 @@
44.52 unfolding divide_inverse using prems by simp
44.53
44.54 lemma differentiable_power [simp]:
44.55 - fixes f :: "'a::{recpower,real_normed_field} \<Rightarrow> 'a"
44.56 + fixes f :: "'a::{real_normed_field} \<Rightarrow> 'a"
44.57 assumes "f differentiable x"
44.58 shows "(\<lambda>x. f x ^ n) differentiable x"
44.59 by (induct n, simp, simp add: prems)
45.1 --- a/src/HOL/Divides.thy Mon May 11 09:39:53 2009 +0200
45.2 +++ b/src/HOL/Divides.thy Mon May 11 17:20:52 2009 +0200
45.3 @@ -1,5 +1,4 @@
45.4 (* Title: HOL/Divides.thy
45.5 - ID: $Id$
45.6 Author: Lawrence C Paulson, Cambridge University Computer Laboratory
45.7 Copyright 1999 University of Cambridge
45.8 *)
45.9 @@ -20,11 +19,12 @@
45.10
45.11 subsection {* Abstract division in commutative semirings. *}
45.12
45.13 -class semiring_div = comm_semiring_1_cancel + div +
45.14 +class semiring_div = comm_semiring_1_cancel + no_zero_divisors + div +
45.15 assumes mod_div_equality: "a div b * b + a mod b = a"
45.16 and div_by_0 [simp]: "a div 0 = 0"
45.17 and div_0 [simp]: "0 div a = 0"
45.18 and div_mult_self1 [simp]: "b \<noteq> 0 \<Longrightarrow> (a + c * b) div b = c + a div b"
45.19 + and div_mult_mult1 [simp]: "c \<noteq> 0 \<Longrightarrow> (c * a) div (c * b) = a div b"
45.20 begin
45.21
45.22 text {* @{const div} and @{const mod} *}
45.23 @@ -38,16 +38,16 @@
45.24 by (simp only: add_ac)
45.25
45.26 lemma div_mod_equality: "((a div b) * b + a mod b) + c = a + c"
45.27 -by (simp add: mod_div_equality)
45.28 + by (simp add: mod_div_equality)
45.29
45.30 lemma div_mod_equality2: "(b * (a div b) + a mod b) + c = a + c"
45.31 -by (simp add: mod_div_equality2)
45.32 + by (simp add: mod_div_equality2)
45.33
45.34 lemma mod_by_0 [simp]: "a mod 0 = a"
45.35 -using mod_div_equality [of a zero] by simp
45.36 + using mod_div_equality [of a zero] by simp
45.37
45.38 lemma mod_0 [simp]: "0 mod a = 0"
45.39 -using mod_div_equality [of zero a] div_0 by simp
45.40 + using mod_div_equality [of zero a] div_0 by simp
45.41
45.42 lemma div_mult_self2 [simp]:
45.43 assumes "b \<noteq> 0"
45.44 @@ -72,7 +72,7 @@
45.45 qed
45.46
45.47 lemma mod_mult_self2 [simp]: "(a + b * c) mod b = a mod b"
45.48 -by (simp add: mult_commute [of b])
45.49 + by (simp add: mult_commute [of b])
45.50
45.51 lemma div_mult_self1_is_id [simp]: "b \<noteq> 0 \<Longrightarrow> b * a div b = a"
45.52 using div_mult_self2 [of b 0 a] by simp
45.53 @@ -238,9 +238,9 @@
45.54 by (simp only: mod_add_eq [symmetric])
45.55 qed
45.56
45.57 -lemma div_add[simp]: "z dvd x \<Longrightarrow> z dvd y
45.58 +lemma div_add [simp]: "z dvd x \<Longrightarrow> z dvd y
45.59 \<Longrightarrow> (x + y) div z = x div z + y div z"
45.60 -by(cases "z=0", simp, unfold dvd_def, auto simp add: algebra_simps)
45.61 +by (cases "z = 0", simp, unfold dvd_def, auto simp add: algebra_simps)
45.62
45.63 text {* Multiplication respects modular equivalence. *}
45.64
45.65 @@ -297,24 +297,45 @@
45.66 finally show ?thesis .
45.67 qed
45.68
45.69 +lemma div_mult_div_if_dvd:
45.70 + "y dvd x \<Longrightarrow> z dvd w \<Longrightarrow> (x div y) * (w div z) = (x * w) div (y * z)"
45.71 + apply (cases "y = 0", simp)
45.72 + apply (cases "z = 0", simp)
45.73 + apply (auto elim!: dvdE simp add: algebra_simps)
45.74 + apply (subst mult_assoc [symmetric])
45.75 + apply (simp add: no_zero_divisors)
45.76 + done
45.77 +
45.78 +lemma div_mult_mult2 [simp]:
45.79 + "c \<noteq> 0 \<Longrightarrow> (a * c) div (b * c) = a div b"
45.80 + by (drule div_mult_mult1) (simp add: mult_commute)
45.81 +
45.82 +lemma div_mult_mult1_if [simp]:
45.83 + "(c * a) div (c * b) = (if c = 0 then 0 else a div b)"
45.84 + by simp_all
45.85 +
45.86 +lemma mod_mult_mult1:
45.87 + "(c * a) mod (c * b) = c * (a mod b)"
45.88 +proof (cases "c = 0")
45.89 + case True then show ?thesis by simp
45.90 +next
45.91 + case False
45.92 + from mod_div_equality
45.93 + have "((c * a) div (c * b)) * (c * b) + (c * a) mod (c * b) = c * a" .
45.94 + with False have "c * ((a div b) * b + a mod b) + (c * a) mod (c * b)
45.95 + = c * a + c * (a mod b)" by (simp add: algebra_simps)
45.96 + with mod_div_equality show ?thesis by simp
45.97 +qed
45.98 +
45.99 +lemma mod_mult_mult2:
45.100 + "(a * c) mod (b * c) = (a mod b) * c"
45.101 + using mod_mult_mult1 [of c a b] by (simp add: mult_commute)
45.102 +
45.103 end
45.104
45.105 -lemma div_mult_div_if_dvd: "(y::'a::{semiring_div,no_zero_divisors}) dvd x \<Longrightarrow>
45.106 - z dvd w \<Longrightarrow> (x div y) * (w div z) = (x * w) div (y * z)"
45.107 -unfolding dvd_def
45.108 - apply clarify
45.109 - apply (case_tac "y = 0")
45.110 - apply simp
45.111 - apply (case_tac "z = 0")
45.112 - apply simp
45.113 - apply (simp add: algebra_simps)
45.114 - apply (subst mult_assoc [symmetric])
45.115 - apply (simp add: no_zero_divisors)
45.116 -done
45.117 -
45.118 -
45.119 -lemma div_power: "(y::'a::{semiring_div,no_zero_divisors,recpower}) dvd x \<Longrightarrow>
45.120 - (x div y)^n = x^n div y^n"
45.121 +lemma div_power:
45.122 + "(y::'a::{semiring_div,no_zero_divisors,power}) dvd x \<Longrightarrow>
45.123 + (x div y) ^ n = x ^ n div y ^ n"
45.124 apply (induct n)
45.125 apply simp
45.126 apply(simp add: div_mult_div_if_dvd dvd_power_same)
45.127 @@ -398,15 +419,17 @@
45.128 @{term "q\<Colon>nat"}(uotient) and @{term "r\<Colon>nat"}(emainder).
45.129 *}
45.130
45.131 -definition divmod_rel :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
45.132 - "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)"
45.133 +definition divmod_rel :: "nat \<Rightarrow> nat \<Rightarrow> nat \<times> nat \<Rightarrow> bool" where
45.134 + "divmod_rel m n qr \<longleftrightarrow>
45.135 + m = fst qr * n + snd qr \<and>
45.136 + (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)"
45.137
45.138 text {* @{const divmod_rel} is total: *}
45.139
45.140 lemma divmod_rel_ex:
45.141 - obtains q r where "divmod_rel m n q r"
45.142 + obtains q r where "divmod_rel m n (q, r)"
45.143 proof (cases "n = 0")
45.144 - case True with that show thesis
45.145 + case True with that show thesis
45.146 by (auto simp add: divmod_rel_def)
45.147 next
45.148 case False
45.149 @@ -436,13 +459,14 @@
45.150
45.151 text {* @{const divmod_rel} is injective: *}
45.152
45.153 -lemma divmod_rel_unique_div:
45.154 - assumes "divmod_rel m n q r"
45.155 - and "divmod_rel m n q' r'"
45.156 - shows "q = q'"
45.157 +lemma divmod_rel_unique:
45.158 + assumes "divmod_rel m n qr"
45.159 + and "divmod_rel m n qr'"
45.160 + shows "qr = qr'"
45.161 proof (cases "n = 0")
45.162 case True with assms show ?thesis
45.163 - by (simp add: divmod_rel_def)
45.164 + by (cases qr, cases qr')
45.165 + (simp add: divmod_rel_def)
45.166 next
45.167 case False
45.168 have aux: "\<And>q r q' r'. q' * n + r' = q * n + r \<Longrightarrow> r < n \<Longrightarrow> q' \<le> (q\<Colon>nat)"
45.169 @@ -450,18 +474,11 @@
45.170 apply (subst less_iff_Suc_add)
45.171 apply (auto simp add: add_mult_distrib)
45.172 done
45.173 - from `n \<noteq> 0` assms show ?thesis
45.174 - by (auto simp add: divmod_rel_def
45.175 - intro: order_antisym dest: aux sym)
45.176 -qed
45.177 -
45.178 -lemma divmod_rel_unique_mod:
45.179 - assumes "divmod_rel m n q r"
45.180 - and "divmod_rel m n q' r'"
45.181 - shows "r = r'"
45.182 -proof -
45.183 - from assms have "q = q'" by (rule divmod_rel_unique_div)
45.184 - with assms show ?thesis by (simp add: divmod_rel_def)
45.185 + from `n \<noteq> 0` assms have "fst qr = fst qr'"
45.186 + by (auto simp add: divmod_rel_def intro: order_antisym dest: aux sym)
45.187 + moreover from this assms have "snd qr = snd qr'"
45.188 + by (simp add: divmod_rel_def)
45.189 + ultimately show ?thesis by (cases qr, cases qr') simp
45.190 qed
45.191
45.192 text {*
45.193 @@ -473,7 +490,21 @@
45.194 begin
45.195
45.196 definition divmod :: "nat \<Rightarrow> nat \<Rightarrow> nat \<times> nat" where
45.197 - [code del]: "divmod m n = (THE (q, r). divmod_rel m n q r)"
45.198 + [code del]: "divmod m n = (THE qr. divmod_rel m n qr)"
45.199 +
45.200 +lemma divmod_rel_divmod:
45.201 + "divmod_rel m n (divmod m n)"
45.202 +proof -
45.203 + from divmod_rel_ex
45.204 + obtain qr where rel: "divmod_rel m n qr" .
45.205 + then show ?thesis
45.206 + by (auto simp add: divmod_def intro: theI elim: divmod_rel_unique)
45.207 +qed
45.208 +
45.209 +lemma divmod_eq:
45.210 + assumes "divmod_rel m n qr"
45.211 + shows "divmod m n = qr"
45.212 + using assms by (auto intro: divmod_rel_unique divmod_rel_divmod)
45.213
45.214 definition div_nat where
45.215 "m div n = fst (divmod m n)"
45.216 @@ -485,30 +516,18 @@
45.217 "divmod m n = (m div n, m mod n)"
45.218 unfolding div_nat_def mod_nat_def by simp
45.219
45.220 -lemma divmod_eq:
45.221 - assumes "divmod_rel m n q r"
45.222 - shows "divmod m n = (q, r)"
45.223 - using assms by (auto simp add: divmod_def
45.224 - dest: divmod_rel_unique_div divmod_rel_unique_mod)
45.225 -
45.226 lemma div_eq:
45.227 - assumes "divmod_rel m n q r"
45.228 + assumes "divmod_rel m n (q, r)"
45.229 shows "m div n = q"
45.230 - using assms by (auto dest: divmod_eq simp add: div_nat_def)
45.231 + using assms by (auto dest: divmod_eq simp add: divmod_div_mod)
45.232
45.233 lemma mod_eq:
45.234 - assumes "divmod_rel m n q r"
45.235 + assumes "divmod_rel m n (q, r)"
45.236 shows "m mod n = r"
45.237 - using assms by (auto dest: divmod_eq simp add: mod_nat_def)
45.238 + using assms by (auto dest: divmod_eq simp add: divmod_div_mod)
45.239
45.240 -lemma divmod_rel: "divmod_rel m n (m div n) (m mod n)"
45.241 -proof -
45.242 - from divmod_rel_ex
45.243 - obtain q r where rel: "divmod_rel m n q r" .
45.244 - moreover with div_eq mod_eq have "m div n = q" and "m mod n = r"
45.245 - by simp_all
45.246 - ultimately show ?thesis by simp
45.247 -qed
45.248 +lemma divmod_rel: "divmod_rel m n (m div n, m mod n)"
45.249 + by (simp add: div_nat_def mod_nat_def divmod_rel_divmod)
45.250
45.251 lemma divmod_zero:
45.252 "divmod m 0 = (0, m)"
45.253 @@ -531,10 +550,10 @@
45.254 assumes "0 < n" and "n \<le> m"
45.255 shows "divmod m n = (Suc ((m - n) div n), (m - n) mod n)"
45.256 proof -
45.257 - from divmod_rel have divmod_m_n: "divmod_rel m n (m div n) (m mod n)" .
45.258 + from divmod_rel have divmod_m_n: "divmod_rel m n (m div n, m mod n)" .
45.259 with assms have m_div_n: "m div n \<ge> 1"
45.260 by (cases "m div n") (auto simp add: divmod_rel_def)
45.261 - from assms divmod_m_n have "divmod_rel (m - n) n (m div n - Suc 0) (m mod n)"
45.262 + from assms divmod_m_n have "divmod_rel (m - n) n (m div n - Suc 0, m mod n)"
45.263 by (cases "m div n") (auto simp add: divmod_rel_def)
45.264 with divmod_eq have "divmod (m - n) n = (m div n - Suc 0, m mod n)" by simp
45.265 moreover from divmod_div_mod have "divmod (m - n) n = ((m - n) div n, (m - n) mod n)" .
45.266 @@ -569,55 +588,74 @@
45.267 shows "m mod n = (m - n) mod n"
45.268 using assms divmod_step divmod_div_mod by (cases "n = 0") simp_all
45.269
45.270 -instance proof
45.271 - fix m n :: nat show "m div n * n + m mod n = m"
45.272 - using divmod_rel [of m n] by (simp add: divmod_rel_def)
45.273 -next
45.274 - fix n :: nat show "n div 0 = 0"
45.275 - using divmod_zero divmod_div_mod [of n 0] by simp
45.276 -next
45.277 - fix n :: nat show "0 div n = 0"
45.278 - using divmod_rel [of 0 n] by (cases n) (simp_all add: divmod_rel_def)
45.279 -next
45.280 - fix m n q :: nat assume "n \<noteq> 0" then show "(q + m * n) div n = m + q div n"
45.281 - by (induct m) (simp_all add: le_div_geq)
45.282 +instance proof -
45.283 + have [simp]: "\<And>n::nat. n div 0 = 0"
45.284 + by (simp add: div_nat_def divmod_zero)
45.285 + have [simp]: "\<And>n::nat. 0 div n = 0"
45.286 + proof -
45.287 + fix n :: nat
45.288 + show "0 div n = 0"
45.289 + by (cases "n = 0") simp_all
45.290 + qed
45.291 + show "OFCLASS(nat, semiring_div_class)" proof
45.292 + fix m n :: nat
45.293 + show "m div n * n + m mod n = m"
45.294 + using divmod_rel [of m n] by (simp add: divmod_rel_def)
45.295 + next
45.296 + fix m n q :: nat
45.297 + assume "n \<noteq> 0"
45.298 + then show "(q + m * n) div n = m + q div n"
45.299 + by (induct m) (simp_all add: le_div_geq)
45.300 + next
45.301 + fix m n q :: nat
45.302 + assume "m \<noteq> 0"
45.303 + then show "(m * n) div (m * q) = n div q"
45.304 + proof (cases "n \<noteq> 0 \<and> q \<noteq> 0")
45.305 + case False then show ?thesis by auto
45.306 + next
45.307 + case True with `m \<noteq> 0`
45.308 + have "m > 0" and "n > 0" and "q > 0" by auto
45.309 + then have "\<And>a b. divmod_rel n q (a, b) \<Longrightarrow> divmod_rel (m * n) (m * q) (a, m * b)"
45.310 + by (auto simp add: divmod_rel_def) (simp_all add: algebra_simps)
45.311 + moreover from divmod_rel have "divmod_rel n q (n div q, n mod q)" .
45.312 + ultimately have "divmod_rel (m * n) (m * q) (n div q, m * (n mod q))" .
45.313 + then show ?thesis by (simp add: div_eq)
45.314 + qed
45.315 + qed simp_all
45.316 qed
45.317
45.318 end
45.319
45.320 text {* Simproc for cancelling @{const div} and @{const mod} *}
45.321
45.322 -(*lemmas mod_div_equality_nat = semiring_div_class.times_div_mod_plus_zero_one.mod_div_equality [of "m\<Colon>nat" n, standard]
45.323 -lemmas mod_div_equality2_nat = mod_div_equality2 [of "n\<Colon>nat" m, standard*)
45.324 +ML {*
45.325 +local
45.326
45.327 -ML {*
45.328 -structure CancelDivModData =
45.329 -struct
45.330 +structure CancelDivMod = CancelDivModFun(struct
45.331
45.332 -val div_name = @{const_name div};
45.333 -val mod_name = @{const_name mod};
45.334 -val mk_binop = HOLogic.mk_binop;
45.335 -val mk_sum = Nat_Arith.mk_sum;
45.336 -val dest_sum = Nat_Arith.dest_sum;
45.337 + val div_name = @{const_name div};
45.338 + val mod_name = @{const_name mod};
45.339 + val mk_binop = HOLogic.mk_binop;
45.340 + val mk_sum = Nat_Arith.mk_sum;
45.341 + val dest_sum = Nat_Arith.dest_sum;
45.342
45.343 -(*logic*)
45.344 + val div_mod_eqs = map mk_meta_eq [@{thm div_mod_equality}, @{thm div_mod_equality2}];
45.345
45.346 -val div_mod_eqs = map mk_meta_eq [@{thm div_mod_equality}, @{thm div_mod_equality2}]
45.347 + val trans = trans;
45.348
45.349 -val trans = trans
45.350 + val prove_eq_sums = Arith_Data.prove_conv2 all_tac (Arith_Data.simp_all_tac
45.351 + (@{thm monoid_add_class.add_0_left} :: @{thm monoid_add_class.add_0_right} :: @{thms add_ac}))
45.352
45.353 -val prove_eq_sums =
45.354 - let val simps = @{thm add_0} :: @{thm add_0_right} :: @{thms add_ac}
45.355 - in Arith_Data.prove_conv2 all_tac (Arith_Data.simp_all_tac simps) end;
45.356 +end)
45.357
45.358 -end;
45.359 +in
45.360
45.361 -structure CancelDivMod = CancelDivModFun(CancelDivModData);
45.362 -
45.363 -val cancel_div_mod_proc = Simplifier.simproc (the_context ())
45.364 +val cancel_div_mod_nat_proc = Simplifier.simproc (the_context ())
45.365 "cancel_div_mod" ["(m::nat) + n"] (K CancelDivMod.proc);
45.366
45.367 -Addsimprocs[cancel_div_mod_proc];
45.368 +val _ = Addsimprocs [cancel_div_mod_nat_proc];
45.369 +
45.370 +end
45.371 *}
45.372
45.373 text {* code generator setup *}
45.374 @@ -658,7 +696,7 @@
45.375 fixes m n :: nat
45.376 assumes "n > 0"
45.377 shows "m mod n < (n::nat)"
45.378 - using assms divmod_rel unfolding divmod_rel_def by auto
45.379 + using assms divmod_rel [of m n] unfolding divmod_rel_def by auto
45.380
45.381 lemma mod_less_eq_dividend [simp]:
45.382 fixes m n :: nat
45.383 @@ -700,18 +738,19 @@
45.384 subsubsection {* Quotient and Remainder *}
45.385
45.386 lemma divmod_rel_mult1_eq:
45.387 - "[| divmod_rel b c q r; c > 0 |]
45.388 - ==> divmod_rel (a*b) c (a*q + a*r div c) (a*r mod c)"
45.389 + "divmod_rel b c (q, r) \<Longrightarrow> c > 0
45.390 + \<Longrightarrow> divmod_rel (a * b) c (a * q + a * r div c, a * r mod c)"
45.391 by (auto simp add: split_ifs divmod_rel_def algebra_simps)
45.392
45.393 -lemma div_mult1_eq: "(a*b) div c = a*(b div c) + a*(b mod c) div (c::nat)"
45.394 +lemma div_mult1_eq:
45.395 + "(a * b) div c = a * (b div c) + a * (b mod c) div (c::nat)"
45.396 apply (cases "c = 0", simp)
45.397 apply (blast intro: divmod_rel [THEN divmod_rel_mult1_eq, THEN div_eq])
45.398 done
45.399
45.400 lemma divmod_rel_add1_eq:
45.401 - "[| divmod_rel a c aq ar; divmod_rel b c bq br; c > 0 |]
45.402 - ==> divmod_rel (a + b) c (aq + bq + (ar+br) div c) ((ar + br) mod c)"
45.403 + "divmod_rel a c (aq, ar) \<Longrightarrow> divmod_rel b c (bq, br) \<Longrightarrow> c > 0
45.404 + \<Longrightarrow> divmod_rel (a + b) c (aq + bq + (ar + br) div c, (ar + br) mod c)"
45.405 by (auto simp add: split_ifs divmod_rel_def algebra_simps)
45.406
45.407 (*NOT suitable for rewriting: the RHS has an instance of the LHS*)
45.408 @@ -728,8 +767,9 @@
45.409 apply (simp add: add_mult_distrib2)
45.410 done
45.411
45.412 -lemma divmod_rel_mult2_eq: "[| divmod_rel a b q r; 0 < b; 0 < c |]
45.413 - ==> divmod_rel a (b*c) (q div c) (b*(q mod c) + r)"
45.414 +lemma divmod_rel_mult2_eq:
45.415 + "divmod_rel a b (q, r) \<Longrightarrow> 0 < b \<Longrightarrow> 0 < c
45.416 + \<Longrightarrow> divmod_rel a (b * c) (q div c, b *(q mod c) + r)"
45.417 by (auto simp add: mult_ac divmod_rel_def add_mult_distrib2 [symmetric] mod_lemma)
45.418
45.419 lemma div_mult2_eq: "a div (b*c) = (a div b) div (c::nat)"
45.420 @@ -745,23 +785,6 @@
45.421 done
45.422
45.423
45.424 -subsubsection{*Cancellation of Common Factors in Division*}
45.425 -
45.426 -lemma div_mult_mult_lemma:
45.427 - "[| (0::nat) < b; 0 < c |] ==> (c*a) div (c*b) = a div b"
45.428 -by (auto simp add: div_mult2_eq)
45.429 -
45.430 -lemma div_mult_mult1 [simp]: "(0::nat) < c ==> (c*a) div (c*b) = a div b"
45.431 - apply (cases "b = 0")
45.432 - apply (auto simp add: linorder_neq_iff [of b] div_mult_mult_lemma)
45.433 - done
45.434 -
45.435 -lemma div_mult_mult2 [simp]: "(0::nat) < c ==> (a*c) div (b*c) = a div b"
45.436 - apply (drule div_mult_mult1)
45.437 - apply (auto simp add: mult_commute)
45.438 - done
45.439 -
45.440 -
45.441 subsubsection{*Further Facts about Quotient and Remainder*}
45.442
45.443 lemma div_1 [simp]: "m div Suc 0 = m"
45.444 @@ -769,7 +792,7 @@
45.445
45.446
45.447 (* Monotonicity of div in first argument *)
45.448 -lemma div_le_mono [rule_format]:
45.449 +lemma div_le_mono [rule_format (no_asm)]:
45.450 "\<forall>m::nat. m \<le> n --> (m div k) \<le> (n div k)"
45.451 apply (case_tac "k=0", simp)
45.452 apply (induct "n" rule: nat_less_induct, clarify)
45.453 @@ -824,12 +847,6 @@
45.454 apply (simp_all)
45.455 done
45.456
45.457 -lemma nat_div_eq_0 [simp]: "(n::nat) > 0 ==> ((m div n) = 0) = (m < n)"
45.458 -by(auto, subst mod_div_equality [of m n, symmetric], auto)
45.459 -
45.460 -lemma nat_div_gt_0 [simp]: "(n::nat) > 0 ==> ((m div n) > 0) = (m >= n)"
45.461 -by (subst neq0_conv [symmetric], auto)
45.462 -
45.463 declare div_less_dividend [simp]
45.464
45.465 text{*A fact for the mutilated chess board*}
45.466 @@ -915,21 +932,13 @@
45.467 done
45.468
45.469 lemma dvd_imp_le: "[| k dvd n; 0 < n |] ==> k \<le> (n::nat)"
45.470 -by (auto elim!: dvdE) (auto simp add: gr0_conv_Suc)
45.471 -
45.472 -lemma nat_dvd_not_less: "(0::nat) < m \<Longrightarrow> m < n \<Longrightarrow> \<not> n dvd m"
45.473 -by (auto elim!: dvdE) (auto simp add: gr0_conv_Suc)
45.474 + by (auto elim!: dvdE) (auto simp add: gr0_conv_Suc)
45.475
45.476 lemma dvd_mult_div_cancel: "n dvd m ==> n * (m div n) = (m::nat)"
45.477 - apply (subgoal_tac "m mod n = 0")
45.478 - apply (simp add: mult_div_cancel)
45.479 - apply (simp only: dvd_eq_mod_eq_0)
45.480 - done
45.481 + by (simp add: dvd_eq_mod_eq_0 mult_div_cancel)
45.482
45.483 -lemma nat_zero_less_power_iff [simp]: "(x^n > 0) = (x > (0::nat) | n=0)"
45.484 - by (induct n) auto
45.485 -
45.486 -lemma power_dvd_imp_le: "[|i^m dvd i^n; (1::nat) < i|] ==> m \<le> n"
45.487 +lemma power_dvd_imp_le:
45.488 + "i ^ m dvd i ^ n \<Longrightarrow> (1::nat) < i \<Longrightarrow> m \<le> n"
45.489 apply (rule power_le_imp_le_exp, assumption)
45.490 apply (erule dvd_imp_le, simp)
45.491 done
45.492 @@ -1001,9 +1010,11 @@
45.493 from A B show ?lhs ..
45.494 next
45.495 assume P: ?lhs
45.496 - then have "divmod_rel m n q (m - n * q)"
45.497 + then have "divmod_rel m n (q, m - n * q)"
45.498 unfolding divmod_rel_def by (auto simp add: mult_ac)
45.499 - then show ?rhs using divmod_rel by (rule divmod_rel_unique_div)
45.500 + with divmod_rel_unique divmod_rel [of m n]
45.501 + have "(q, m - n * q) = (m div n, m mod n)" by auto
45.502 + then show ?rhs by simp
45.503 qed
45.504
45.505 theorem split_div':
45.506 @@ -1155,4 +1166,9 @@
45.507 with j show ?thesis by blast
45.508 qed
45.509
45.510 +lemma nat_dvd_not_less:
45.511 + fixes m n :: nat
45.512 + shows "0 < m \<Longrightarrow> m < n \<Longrightarrow> \<not> n dvd m"
45.513 +by (auto elim!: dvdE) (auto simp add: gr0_conv_Suc)
45.514 +
45.515 end
46.1 --- a/src/HOL/Finite_Set.thy Mon May 11 09:39:53 2009 +0200
46.2 +++ b/src/HOL/Finite_Set.thy Mon May 11 17:20:52 2009 +0200
46.3 @@ -365,6 +365,29 @@
46.4 lemma finite_Plus: "[| finite A; finite B |] ==> finite (A <+> B)"
46.5 by (simp add: Plus_def)
46.6
46.7 +lemma finite_PlusD:
46.8 + fixes A :: "'a set" and B :: "'b set"
46.9 + assumes fin: "finite (A <+> B)"
46.10 + shows "finite A" "finite B"
46.11 +proof -
46.12 + have "Inl ` A \<subseteq> A <+> B" by auto
46.13 + hence "finite (Inl ` A :: ('a + 'b) set)" using fin by(rule finite_subset)
46.14 + thus "finite A" by(rule finite_imageD)(auto intro: inj_onI)
46.15 +next
46.16 + have "Inr ` B \<subseteq> A <+> B" by auto
46.17 + hence "finite (Inr ` B :: ('a + 'b) set)" using fin by(rule finite_subset)
46.18 + thus "finite B" by(rule finite_imageD)(auto intro: inj_onI)
46.19 +qed
46.20 +
46.21 +lemma finite_Plus_iff[simp]: "finite (A <+> B) \<longleftrightarrow> finite A \<and> finite B"
46.22 +by(auto intro: finite_PlusD finite_Plus)
46.23 +
46.24 +lemma finite_Plus_UNIV_iff[simp]:
46.25 + "finite (UNIV :: ('a + 'b) set) =
46.26 + (finite (UNIV :: 'a set) & finite (UNIV :: 'b set))"
46.27 +by(subst UNIV_Plus_UNIV[symmetric])(rule finite_Plus_iff)
46.28 +
46.29 +
46.30 text {* Sigma of finite sets *}
46.31
46.32 lemma finite_SigmaI [simp]:
46.33 @@ -1563,6 +1586,20 @@
46.34 qed
46.35
46.36
46.37 +lemma setsum_Plus:
46.38 + fixes A :: "'a set" and B :: "'b set"
46.39 + assumes fin: "finite A" "finite B"
46.40 + shows "setsum f (A <+> B) = setsum (f \<circ> Inl) A + setsum (f \<circ> Inr) B"
46.41 +proof -
46.42 + have "A <+> B = Inl ` A \<union> Inr ` B" by auto
46.43 + moreover from fin have "finite (Inl ` A :: ('a + 'b) set)" "finite (Inr ` B :: ('a + 'b) set)"
46.44 + by(auto intro: finite_imageI)
46.45 + moreover have "Inl ` A \<inter> Inr ` B = ({} :: ('a + 'b) set)" by auto
46.46 + moreover have "inj_on (Inl :: 'a \<Rightarrow> 'a + 'b) A" "inj_on (Inr :: 'b \<Rightarrow> 'a + 'b) B" by(auto intro: inj_onI)
46.47 + ultimately show ?thesis using fin by(simp add: setsum_Un_disjoint setsum_reindex)
46.48 +qed
46.49 +
46.50 +
46.51 text {* Commuting outer and inner summation *}
46.52
46.53 lemma swap_inj_on:
46.54 @@ -2047,14 +2084,14 @@
46.55 apply (auto simp add: algebra_simps)
46.56 done
46.57
46.58 -lemma setprod_constant: "finite A ==> (\<Prod>x\<in> A. (y::'a::{recpower, comm_monoid_mult})) = y^(card A)"
46.59 +lemma setprod_constant: "finite A ==> (\<Prod>x\<in> A. (y::'a::{comm_monoid_mult})) = y^(card A)"
46.60 apply (erule finite_induct)
46.61 apply (auto simp add: power_Suc)
46.62 done
46.63
46.64 lemma setprod_gen_delta:
46.65 assumes fS: "finite S"
46.66 - 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)"
46.67 + 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)"
46.68 proof-
46.69 let ?f = "(\<lambda>k. if k=a then b k else c)"
46.70 {assume a: "a \<notin> S"
46.71 @@ -2091,6 +2128,10 @@
46.72 qed
46.73
46.74
46.75 +lemma card_UNIV_unit: "card (UNIV :: unit set) = 1"
46.76 + unfolding UNIV_unit by simp
46.77 +
46.78 +
46.79 subsubsection {* Cardinality of unions *}
46.80
46.81 lemma card_UN_disjoint:
46.82 @@ -2201,6 +2242,10 @@
46.83 by (simp add: card_Un_disjoint card_image)
46.84 qed
46.85
46.86 +lemma card_Plus_conv_if:
46.87 + "card (A <+> B) = (if finite A \<and> finite B then card(A) + card(B) else 0)"
46.88 +by(auto simp: card_def setsum_Plus simp del: setsum_constant)
46.89 +
46.90
46.91 subsubsection {* Cardinality of the Powerset *}
46.92
47.1 --- a/src/HOL/Fun.thy Mon May 11 09:39:53 2009 +0200
47.2 +++ b/src/HOL/Fun.thy Mon May 11 17:20:52 2009 +0200
47.3 @@ -412,6 +412,9 @@
47.4 "f(x:=y) ` A = (if x \<in> A then insert y (f ` (A-{x})) else f ` A)"
47.5 by auto
47.6
47.7 +lemma fun_upd_comp: "f \<circ> (g(x := y)) = (f \<circ> g)(x := f y)"
47.8 +by(auto intro: ext)
47.9 +
47.10
47.11 subsection {* @{text override_on} *}
47.12
48.1 --- a/src/HOL/Groebner_Basis.thy Mon May 11 09:39:53 2009 +0200
48.2 +++ b/src/HOL/Groebner_Basis.thy Mon May 11 17:20:52 2009 +0200
48.3 @@ -5,7 +5,7 @@
48.4 header {* Semiring normalization and Groebner Bases *}
48.5
48.6 theory Groebner_Basis
48.7 -imports NatBin
48.8 +imports Nat_Numeral
48.9 uses
48.10 "Tools/Groebner_Basis/misc.ML"
48.11 "Tools/Groebner_Basis/normalizer_data.ML"
48.12 @@ -164,7 +164,7 @@
48.13 end
48.14
48.15 interpretation class_semiring: gb_semiring
48.16 - "op +" "op *" "op ^" "0::'a::{comm_semiring_1, recpower}" "1"
48.17 + "op +" "op *" "op ^" "0::'a::{comm_semiring_1}" "1"
48.18 proof qed (auto simp add: algebra_simps power_Suc)
48.19
48.20 lemmas nat_arith =
48.21 @@ -242,7 +242,7 @@
48.22
48.23
48.24 interpretation class_ring: gb_ring "op +" "op *" "op ^"
48.25 - "0::'a::{comm_semiring_1,recpower,number_ring}" 1 "op -" "uminus"
48.26 + "0::'a::{comm_semiring_1,number_ring}" 1 "op -" "uminus"
48.27 proof qed simp_all
48.28
48.29
48.30 @@ -349,9 +349,9 @@
48.31 qed
48.32
48.33 interpretation class_ringb: ringb
48.34 - "op +" "op *" "op ^" "0::'a::{idom,recpower,number_ring}" "1" "op -" "uminus"
48.35 + "op +" "op *" "op ^" "0::'a::{idom,number_ring}" "1" "op -" "uminus"
48.36 proof(unfold_locales, simp add: algebra_simps power_Suc, auto)
48.37 - fix w x y z ::"'a::{idom,recpower,number_ring}"
48.38 + fix w x y z ::"'a::{idom,number_ring}"
48.39 assume p: "w * y + x * z = w * z + x * y" and ynz: "y \<noteq> z"
48.40 hence ynz': "y - z \<noteq> 0" by simp
48.41 from p have "w * y + x* z - w*z - x*y = 0" by simp
48.42 @@ -471,7 +471,7 @@
48.43 subsection{* Groebner Bases for fields *}
48.44
48.45 interpretation class_fieldgb:
48.46 - fieldgb "op +" "op *" "op ^" "0::'a::{field,recpower,number_ring}" "1" "op -" "uminus" "op /" "inverse" apply (unfold_locales) by (simp_all add: divide_inverse)
48.47 + fieldgb "op +" "op *" "op ^" "0::'a::{field,number_ring}" "1" "op -" "uminus" "op /" "inverse" apply (unfold_locales) by (simp_all add: divide_inverse)
48.48
48.49 lemma divide_Numeral1: "(x::'a::{field,number_ring}) / Numeral1 = x" by simp
48.50 lemma divide_Numeral0: "(x::'a::{field,number_ring, division_by_zero}) / Numeral0 = 0"
48.51 @@ -635,7 +635,7 @@
48.52 val comp_conv = (Simplifier.rewrite
48.53 (HOL_basic_ss addsimps @{thms "Groebner_Basis.comp_arith"}
48.54 addsimps ths addsimps simp_thms
48.55 - addsimprocs field_cancel_numeral_factors
48.56 + addsimprocs Numeral_Simprocs.field_cancel_numeral_factors
48.57 addsimprocs [add_frac_frac_simproc, add_frac_num_simproc,
48.58 ord_frac_simproc]
48.59 addcongs [@{thm "if_weak_cong"}]))
49.1 --- a/src/HOL/HOL.thy Mon May 11 09:39:53 2009 +0200
49.2 +++ b/src/HOL/HOL.thy Mon May 11 17:20:52 2009 +0200
49.3 @@ -5,9 +5,10 @@
49.4 header {* The basis of Higher-Order Logic *}
49.5
49.6 theory HOL
49.7 -imports Pure
49.8 +imports Pure "~~/src/Tools/Code_Generator"
49.9 uses
49.10 ("Tools/hologic.ML")
49.11 + "~~/src/Tools/auto_solve.ML"
49.12 "~~/src/Tools/IsaPlanner/zipper.ML"
49.13 "~~/src/Tools/IsaPlanner/isand.ML"
49.14 "~~/src/Tools/IsaPlanner/rw_tools.ML"
49.15 @@ -27,16 +28,6 @@
49.16 "~~/src/Tools/atomize_elim.ML"
49.17 "~~/src/Tools/induct.ML"
49.18 ("~~/src/Tools/induct_tacs.ML")
49.19 - "~~/src/Tools/value.ML"
49.20 - "~~/src/Tools/code/code_name.ML"
49.21 - "~~/src/Tools/code/code_funcgr.ML" (*formal dependency*)
49.22 - "~~/src/Tools/code/code_wellsorted.ML"
49.23 - "~~/src/Tools/code/code_thingol.ML"
49.24 - "~~/src/Tools/code/code_printer.ML"
49.25 - "~~/src/Tools/code/code_target.ML"
49.26 - "~~/src/Tools/code/code_ml.ML"
49.27 - "~~/src/Tools/code/code_haskell.ML"
49.28 - "~~/src/Tools/nbe.ML"
49.29 ("Tools/recfun_codegen.ML")
49.30 begin
49.31
49.32 @@ -1577,6 +1568,56 @@
49.33 setup Coherent.setup
49.34
49.35
49.36 +subsubsection {* Reorienting equalities *}
49.37 +
49.38 +ML {*
49.39 +signature REORIENT_PROC =
49.40 +sig
49.41 + val init : theory -> theory
49.42 + val add : (term -> bool) -> theory -> theory
49.43 + val proc : morphism -> simpset -> cterm -> thm option
49.44 +end;
49.45 +
49.46 +structure ReorientProc : REORIENT_PROC =
49.47 +struct
49.48 + structure Data = TheoryDataFun
49.49 + (
49.50 + type T = term -> bool;
49.51 + val empty = (fn _ => false);
49.52 + val copy = I;
49.53 + val extend = I;
49.54 + fun merge _ (m1, m2) = (fn t => m1 t orelse m2 t);
49.55 + )
49.56 +
49.57 + val init = Data.init;
49.58 + fun add m = Data.map (fn matches => fn t => matches t orelse m t);
49.59 + val meta_reorient = @{thm eq_commute [THEN eq_reflection]};
49.60 + fun proc phi ss ct =
49.61 + let
49.62 + val ctxt = Simplifier.the_context ss;
49.63 + val thy = ProofContext.theory_of ctxt;
49.64 + val matches = Data.get thy;
49.65 + in
49.66 + case Thm.term_of ct of
49.67 + (_ $ t $ u) => if matches u then NONE else SOME meta_reorient
49.68 + | _ => NONE
49.69 + end;
49.70 +end;
49.71 +*}
49.72 +
49.73 +setup ReorientProc.init
49.74 +
49.75 +setup {*
49.76 + ReorientProc.add
49.77 + (fn Const(@{const_name HOL.zero}, _) => true
49.78 + | Const(@{const_name HOL.one}, _) => true
49.79 + | _ => false)
49.80 +*}
49.81 +
49.82 +simproc_setup reorient_zero ("0 = x") = ReorientProc.proc
49.83 +simproc_setup reorient_one ("1 = x") = ReorientProc.proc
49.84 +
49.85 +
49.86 subsection {* Other simple lemmas and lemma duplicates *}
49.87
49.88 lemma Let_0 [simp]: "Let 0 f = f 0"
49.89 @@ -1674,37 +1715,264 @@
49.90 *}
49.91
49.92
49.93 -subsection {* Code generator basics -- see further theory @{text "Code_Setup"} *}
49.94 +subsection {* Code generator setup *}
49.95
49.96 -text {* Equality *}
49.97 +subsubsection {* SML code generator setup *}
49.98 +
49.99 +use "Tools/recfun_codegen.ML"
49.100 +
49.101 +setup {*
49.102 + Codegen.setup
49.103 + #> RecfunCodegen.setup
49.104 +*}
49.105 +
49.106 +types_code
49.107 + "bool" ("bool")
49.108 +attach (term_of) {*
49.109 +fun term_of_bool b = if b then HOLogic.true_const else HOLogic.false_const;
49.110 +*}
49.111 +attach (test) {*
49.112 +fun gen_bool i =
49.113 + let val b = one_of [false, true]
49.114 + in (b, fn () => term_of_bool b) end;
49.115 +*}
49.116 + "prop" ("bool")
49.117 +attach (term_of) {*
49.118 +fun term_of_prop b =
49.119 + HOLogic.mk_Trueprop (if b then HOLogic.true_const else HOLogic.false_const);
49.120 +*}
49.121 +
49.122 +consts_code
49.123 + "Trueprop" ("(_)")
49.124 + "True" ("true")
49.125 + "False" ("false")
49.126 + "Not" ("Bool.not")
49.127 + "op |" ("(_ orelse/ _)")
49.128 + "op &" ("(_ andalso/ _)")
49.129 + "If" ("(if _/ then _/ else _)")
49.130 +
49.131 +setup {*
49.132 +let
49.133 +
49.134 +fun eq_codegen thy defs dep thyname b t gr =
49.135 + (case strip_comb t of
49.136 + (Const ("op =", Type (_, [Type ("fun", _), _])), _) => NONE
49.137 + | (Const ("op =", _), [t, u]) =>
49.138 + let
49.139 + val (pt, gr') = Codegen.invoke_codegen thy defs dep thyname false t gr;
49.140 + val (pu, gr'') = Codegen.invoke_codegen thy defs dep thyname false u gr';
49.141 + val (_, gr''') = Codegen.invoke_tycodegen thy defs dep thyname false HOLogic.boolT gr'';
49.142 + in
49.143 + SOME (Codegen.parens
49.144 + (Pretty.block [pt, Codegen.str " =", Pretty.brk 1, pu]), gr''')
49.145 + end
49.146 + | (t as Const ("op =", _), ts) => SOME (Codegen.invoke_codegen
49.147 + thy defs dep thyname b (Codegen.eta_expand t ts 2) gr)
49.148 + | _ => NONE);
49.149 +
49.150 +in
49.151 + Codegen.add_codegen "eq_codegen" eq_codegen
49.152 +end
49.153 +*}
49.154 +
49.155 +subsubsection {* Equality *}
49.156
49.157 class eq =
49.158 fixes eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
49.159 assumes eq_equals: "eq x y \<longleftrightarrow> x = y"
49.160 begin
49.161
49.162 -lemma eq: "eq = (op =)"
49.163 +lemma eq [code unfold, code inline del]: "eq = (op =)"
49.164 by (rule ext eq_equals)+
49.165
49.166 lemma eq_refl: "eq x x \<longleftrightarrow> True"
49.167 unfolding eq by rule+
49.168
49.169 +lemma equals_eq [code inline]: "(op =) \<equiv> eq"
49.170 + by (rule eq_reflection) (rule ext, rule ext, rule sym, rule eq_equals)
49.171 +
49.172 +declare equals_eq [symmetric, code post]
49.173 +
49.174 end
49.175
49.176 -text {* Module setup *}
49.177 +declare equals_eq [code]
49.178
49.179 -use "Tools/recfun_codegen.ML"
49.180 +
49.181 +subsubsection {* Generic code generator foundation *}
49.182 +
49.183 +text {* Datatypes *}
49.184 +
49.185 +code_datatype True False
49.186 +
49.187 +code_datatype "TYPE('a\<Colon>{})"
49.188 +
49.189 +code_datatype Trueprop "prop"
49.190 +
49.191 +text {* Code equations *}
49.192 +
49.193 +lemma [code]:
49.194 + shows "(True \<Longrightarrow> PROP P) \<equiv> PROP P"
49.195 + and "(False \<Longrightarrow> Q) \<equiv> Trueprop True"
49.196 + and "(PROP P \<Longrightarrow> True) \<equiv> Trueprop True"
49.197 + and "(Q \<Longrightarrow> False) \<equiv> Trueprop (\<not> Q)" by (auto intro!: equal_intr_rule)
49.198 +
49.199 +lemma [code]:
49.200 + shows "False \<and> x \<longleftrightarrow> False"
49.201 + and "True \<and> x \<longleftrightarrow> x"
49.202 + and "x \<and> False \<longleftrightarrow> False"
49.203 + and "x \<and> True \<longleftrightarrow> x" by simp_all
49.204 +
49.205 +lemma [code]:
49.206 + shows "False \<or> x \<longleftrightarrow> x"
49.207 + and "True \<or> x \<longleftrightarrow> True"
49.208 + and "x \<or> False \<longleftrightarrow> x"
49.209 + and "x \<or> True \<longleftrightarrow> True" by simp_all
49.210 +
49.211 +lemma [code]:
49.212 + shows "\<not> True \<longleftrightarrow> False"
49.213 + and "\<not> False \<longleftrightarrow> True" by (rule HOL.simp_thms)+
49.214 +
49.215 +lemmas [code] = Let_def if_True if_False
49.216 +
49.217 +lemmas [code, code unfold, symmetric, code post] = imp_conv_disj
49.218 +
49.219 +text {* Equality *}
49.220 +
49.221 +declare simp_thms(6) [code nbe]
49.222 +
49.223 +hide (open) const eq
49.224 +hide const eq
49.225
49.226 setup {*
49.227 - Code_ML.setup
49.228 - #> Code_Haskell.setup
49.229 - #> Nbe.setup
49.230 - #> Codegen.setup
49.231 - #> RecfunCodegen.setup
49.232 + Code_Unit.add_const_alias @{thm equals_eq}
49.233 *}
49.234
49.235 +text {* Cases *}
49.236
49.237 -subsection {* Nitpick hooks *}
49.238 +lemma Let_case_cert:
49.239 + assumes "CASE \<equiv> (\<lambda>x. Let x f)"
49.240 + shows "CASE x \<equiv> f x"
49.241 + using assms by simp_all
49.242 +
49.243 +lemma If_case_cert:
49.244 + assumes "CASE \<equiv> (\<lambda>b. If b f g)"
49.245 + shows "(CASE True \<equiv> f) &&& (CASE False \<equiv> g)"
49.246 + using assms by simp_all
49.247 +
49.248 +setup {*
49.249 + Code.add_case @{thm Let_case_cert}
49.250 + #> Code.add_case @{thm If_case_cert}
49.251 + #> Code.add_undefined @{const_name undefined}
49.252 +*}
49.253 +
49.254 +code_abort undefined
49.255 +
49.256 +subsubsection {* Generic code generator preprocessor *}
49.257 +
49.258 +setup {*
49.259 + Code.map_pre (K HOL_basic_ss)
49.260 + #> Code.map_post (K HOL_basic_ss)
49.261 +*}
49.262 +
49.263 +subsubsection {* Generic code generator target languages *}
49.264 +
49.265 +text {* type bool *}
49.266 +
49.267 +code_type bool
49.268 + (SML "bool")
49.269 + (OCaml "bool")
49.270 + (Haskell "Bool")
49.271 +
49.272 +code_const True and False and Not and "op &" and "op |" and If
49.273 + (SML "true" and "false" and "not"
49.274 + and infixl 1 "andalso" and infixl 0 "orelse"
49.275 + and "!(if (_)/ then (_)/ else (_))")
49.276 + (OCaml "true" and "false" and "not"
49.277 + and infixl 4 "&&" and infixl 2 "||"
49.278 + and "!(if (_)/ then (_)/ else (_))")
49.279 + (Haskell "True" and "False" and "not"
49.280 + and infixl 3 "&&" and infixl 2 "||"
49.281 + and "!(if (_)/ then (_)/ else (_))")
49.282 +
49.283 +code_reserved SML
49.284 + bool true false not
49.285 +
49.286 +code_reserved OCaml
49.287 + bool not
49.288 +
49.289 +text {* using built-in Haskell equality *}
49.290 +
49.291 +code_class eq
49.292 + (Haskell "Eq")
49.293 +
49.294 +code_const "eq_class.eq"
49.295 + (Haskell infixl 4 "==")
49.296 +
49.297 +code_const "op ="
49.298 + (Haskell infixl 4 "==")
49.299 +
49.300 +text {* undefined *}
49.301 +
49.302 +code_const undefined
49.303 + (SML "!(raise/ Fail/ \"undefined\")")
49.304 + (OCaml "failwith/ \"undefined\"")
49.305 + (Haskell "error/ \"undefined\"")
49.306 +
49.307 +subsubsection {* Evaluation and normalization by evaluation *}
49.308 +
49.309 +setup {*
49.310 + Value.add_evaluator ("SML", Codegen.eval_term o ProofContext.theory_of)
49.311 +*}
49.312 +
49.313 +ML {*
49.314 +structure Eval_Method =
49.315 +struct
49.316 +
49.317 +val eval_ref : (unit -> bool) option ref = ref NONE;
49.318 +
49.319 +end;
49.320 +*}
49.321 +
49.322 +oracle eval_oracle = {* fn ct =>
49.323 + let
49.324 + val thy = Thm.theory_of_cterm ct;
49.325 + val t = Thm.term_of ct;
49.326 + val dummy = @{cprop True};
49.327 + in case try HOLogic.dest_Trueprop t
49.328 + of SOME t' => if Code_ML.eval NONE
49.329 + ("Eval_Method.eval_ref", Eval_Method.eval_ref) (K I) thy t' []
49.330 + then Thm.capply (Thm.capply @{cterm "op \<equiv> \<Colon> prop \<Rightarrow> prop \<Rightarrow> prop"} ct) dummy
49.331 + else dummy
49.332 + | NONE => dummy
49.333 + end
49.334 +*}
49.335 +
49.336 +ML {*
49.337 +fun gen_eval_method conv ctxt = SIMPLE_METHOD'
49.338 + (CONVERSION (Conv.params_conv (~1) (K (Conv.concl_conv (~1) conv)) ctxt)
49.339 + THEN' rtac TrueI)
49.340 +*}
49.341 +
49.342 +method_setup eval = {* Scan.succeed (gen_eval_method eval_oracle) *}
49.343 + "solve goal by evaluation"
49.344 +
49.345 +method_setup evaluation = {* Scan.succeed (gen_eval_method Codegen.evaluation_conv) *}
49.346 + "solve goal by evaluation"
49.347 +
49.348 +method_setup normalization = {*
49.349 + Scan.succeed (K (SIMPLE_METHOD' (CONVERSION Nbe.norm_conv THEN' (fn k => TRY (rtac TrueI k)))))
49.350 +*} "solve goal by normalization"
49.351 +
49.352 +subsubsection {* Quickcheck *}
49.353 +
49.354 +setup {*
49.355 + Quickcheck.add_generator ("SML", Codegen.test_term)
49.356 +*}
49.357 +
49.358 +quickcheck_params [size = 5, iterations = 50]
49.359 +
49.360 +
49.361 +subsection {* Nitpick setup *}
49.362
49.363 text {* This will be relocated once Nitpick is moved to HOL. *}
49.364
49.365 @@ -1730,10 +1998,14 @@
49.366 val description = "introduction rules for (co)inductive predicates as needed by Nitpick"
49.367 )
49.368 *}
49.369 -setup {* Nitpick_Const_Def_Thms.setup
49.370 - #> Nitpick_Const_Simp_Thms.setup
49.371 - #> Nitpick_Const_Psimp_Thms.setup
49.372 - #> Nitpick_Ind_Intro_Thms.setup *}
49.373 +
49.374 +setup {*
49.375 + Nitpick_Const_Def_Thms.setup
49.376 + #> Nitpick_Const_Simp_Thms.setup
49.377 + #> Nitpick_Const_Psimp_Thms.setup
49.378 + #> Nitpick_Ind_Intro_Thms.setup
49.379 +*}
49.380 +
49.381
49.382 subsection {* Legacy tactics and ML bindings *}
49.383
50.1 --- a/src/HOL/HoareParallel/Graph.thy Mon May 11 09:39:53 2009 +0200
50.2 +++ b/src/HOL/HoareParallel/Graph.thy Mon May 11 17:20:52 2009 +0200
50.3 @@ -172,9 +172,9 @@
50.4 prefer 2 apply arith
50.5 apply(drule_tac n = "Suc nata" in Compl_lemma)
50.6 apply clarify
50.7 - using [[fast_arith_split_limit = 0]]
50.8 + using [[linarith_split_limit = 0]]
50.9 apply force
50.10 - using [[fast_arith_split_limit = 9]]
50.11 + using [[linarith_split_limit = 9]]
50.12 apply(drule leI)
50.13 apply(subgoal_tac "Suc (length path - Suc m + nata)=(length path - Suc 0) - (m - Suc nata)")
50.14 apply(erule_tac x = "m - (Suc nata)" in allE)
51.1 --- a/src/HOL/HoareParallel/OG_Tran.thy Mon May 11 09:39:53 2009 +0200
51.2 +++ b/src/HOL/HoareParallel/OG_Tran.thy Mon May 11 17:20:52 2009 +0200
51.3 @@ -74,7 +74,7 @@
51.4 abbreviation
51.5 ann_transition_n :: "('a ann_com_op \<times> 'a) \<Rightarrow> nat \<Rightarrow> ('a ann_com_op \<times> 'a)
51.6 \<Rightarrow> bool" ("_ -_\<rightarrow> _"[81,81] 100) where
51.7 - "con_0 -n\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> ann_transition^n"
51.8 + "con_0 -n\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> ann_transition ^^ n"
51.9
51.10 abbreviation
51.11 ann_transitions :: "('a ann_com_op \<times> 'a) \<Rightarrow> ('a ann_com_op \<times> 'a) \<Rightarrow> bool"
51.12 @@ -84,7 +84,7 @@
51.13 abbreviation
51.14 transition_n :: "('a com \<times> 'a) \<Rightarrow> nat \<Rightarrow> ('a com \<times> 'a) \<Rightarrow> bool"
51.15 ("_ -P_\<rightarrow> _"[81,81,81] 100) where
51.16 - "con_0 -Pn\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> transition^n"
51.17 + "con_0 -Pn\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> transition ^^ n"
51.18
51.19 subsection {* Definition of Semantics *}
51.20
52.1 --- a/src/HOL/IMP/Compiler0.thy Mon May 11 09:39:53 2009 +0200
52.2 +++ b/src/HOL/IMP/Compiler0.thy Mon May 11 17:20:52 2009 +0200
52.3 @@ -45,7 +45,7 @@
52.4 abbreviation
52.5 stepan :: "[instr list,state,nat,nat,state,nat] \<Rightarrow> bool"
52.6 ("_ \<turnstile>/ (3\<langle>_,_\<rangle>/ -(_)\<rightarrow> \<langle>_,_\<rangle>)" [50,0,0,0,0,0] 50) where
52.7 - "P \<turnstile> \<langle>s,m\<rangle> -(i)\<rightarrow> \<langle>t,n\<rangle> == ((s,m),t,n) : ((stepa1 P)^i)"
52.8 + "P \<turnstile> \<langle>s,m\<rangle> -(i)\<rightarrow> \<langle>t,n\<rangle> == ((s,m),t,n) : (stepa1 P ^^ i)"
52.9
52.10 subsection "The compiler"
52.11
53.1 --- a/src/HOL/IMP/Machines.thy Mon May 11 09:39:53 2009 +0200
53.2 +++ b/src/HOL/IMP/Machines.thy Mon May 11 17:20:52 2009 +0200
53.3 @@ -1,7 +1,6 @@
53.4 -
53.5 -(* $Id$ *)
53.6 -
53.7 -theory Machines imports Natural begin
53.8 +theory Machines
53.9 +imports Natural
53.10 +begin
53.11
53.12 lemma rtrancl_eq: "R^* = Id \<union> (R O R^*)"
53.13 by (fast intro: rtrancl_into_rtrancl elim: rtranclE)
53.14 @@ -11,20 +10,22 @@
53.15
53.16 lemmas converse_rel_powE = rel_pow_E2
53.17
53.18 -lemma R_O_Rn_commute: "R O R^n = R^n O R"
53.19 +lemma R_O_Rn_commute: "R O R ^^ n = R ^^ n O R"
53.20 by (induct n) (simp, simp add: O_assoc [symmetric])
53.21
53.22 lemma converse_in_rel_pow_eq:
53.23 - "((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))"
53.24 + "((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))"
53.25 apply(rule iffI)
53.26 apply(blast elim:converse_rel_powE)
53.27 apply (fastsimp simp add:gr0_conv_Suc R_O_Rn_commute)
53.28 done
53.29
53.30 -lemma rel_pow_plus: "R^(m+n) = R^n O R^m"
53.31 +lemma rel_pow_plus:
53.32 + "R ^^ (m+n) = R ^^ n O R ^^ m"
53.33 by (induct n) (simp, simp add: O_assoc)
53.34
53.35 -lemma rel_pow_plusI: "\<lbrakk> (x,y) \<in> R^m; (y,z) \<in> R^n \<rbrakk> \<Longrightarrow> (x,z) \<in> R^(m+n)"
53.36 +lemma rel_pow_plusI:
53.37 + "\<lbrakk> (x,y) \<in> R ^^ m; (y,z) \<in> R ^^ n \<rbrakk> \<Longrightarrow> (x,z) \<in> R ^^ (m+n)"
53.38 by (simp add: rel_pow_plus rel_compI)
53.39
53.40 subsection "Instructions"
53.41 @@ -57,7 +58,7 @@
53.42 abbreviation
53.43 exec0n :: "[instrs, nat,state, nat, nat,state] \<Rightarrow> bool"
53.44 ("(_/ \<turnstile> (1\<langle>_,/_\<rangle>)/ -_\<rightarrow> (1\<langle>_,/_\<rangle>))" [50,0,0,0,0] 50) where
53.45 - "p \<turnstile> \<langle>i,s\<rangle> -n\<rightarrow> \<langle>j,t\<rangle> == ((i,s),j,t) : (exec01 p)^n"
53.46 + "p \<turnstile> \<langle>i,s\<rangle> -n\<rightarrow> \<langle>j,t\<rangle> == ((i,s),j,t) : (exec01 p)^^n"
53.47
53.48 subsection "M0 with lists"
53.49
53.50 @@ -89,7 +90,7 @@
53.51 abbreviation
53.52 stepan :: "[instrs,instrs,state, nat, instrs,instrs,state] \<Rightarrow> bool"
53.53 ("((1\<langle>_,/_,/_\<rangle>)/ -_\<rightarrow> (1\<langle>_,/_,/_\<rangle>))" 50) where
53.54 - "\<langle>p,q,s\<rangle> -i\<rightarrow> \<langle>p',q',t\<rangle> == ((p,q,s),p',q',t) : (stepa1^i)"
53.55 + "\<langle>p,q,s\<rangle> -i\<rightarrow> \<langle>p',q',t\<rangle> == ((p,q,s),p',q',t) : (stepa1^^i)"
53.56
53.57 inductive_cases execE: "((i#is,p,s), (is',p',s')) : stepa1"
53.58
54.1 --- a/src/HOL/IMP/Transition.thy Mon May 11 09:39:53 2009 +0200
54.2 +++ b/src/HOL/IMP/Transition.thy Mon May 11 17:20:52 2009 +0200
54.3 @@ -1,5 +1,4 @@
54.4 (* Title: HOL/IMP/Transition.thy
54.5 - ID: $Id$
54.6 Author: Tobias Nipkow & Robert Sandner, TUM
54.7 Isar Version: Gerwin Klein, 2001
54.8 Copyright 1996 TUM
54.9 @@ -69,7 +68,7 @@
54.10 abbreviation
54.11 evalcn :: "[(com option\<times>state),nat,(com option\<times>state)] \<Rightarrow> bool"
54.12 ("_ -_\<rightarrow>\<^sub>1 _" [60,60,60] 60) where
54.13 - "cs -n\<rightarrow>\<^sub>1 cs' == (cs,cs') \<in> evalc1^n"
54.14 + "cs -n\<rightarrow>\<^sub>1 cs' == (cs,cs') \<in> evalc1^^n"
54.15
54.16 abbreviation
54.17 evalc' :: "[(com option\<times>state),(com option\<times>state)] \<Rightarrow> bool"
54.18 @@ -77,28 +76,9 @@
54.19 "cs \<longrightarrow>\<^sub>1\<^sup>* cs' == (cs,cs') \<in> evalc1^*"
54.20
54.21 (*<*)
54.22 -(* fixme: move to Relation_Power.thy *)
54.23 -lemma rel_pow_Suc_E2 [elim!]:
54.24 - "[| (x, z) \<in> R ^ Suc n; !!y. [| (x, y) \<in> R; (y, z) \<in> R ^ n |] ==> P |] ==> P"
54.25 - by (blast dest: rel_pow_Suc_D2)
54.26 +declare rel_pow_Suc_E2 [elim!]
54.27 +(*>*)
54.28
54.29 -lemma rtrancl_imp_rel_pow: "p \<in> R^* \<Longrightarrow> \<exists>n. p \<in> R^n"
54.30 -proof (induct p)
54.31 - fix x y
54.32 - assume "(x, y) \<in> R\<^sup>*"
54.33 - thus "\<exists>n. (x, y) \<in> R^n"
54.34 - proof induct
54.35 - fix a have "(a, a) \<in> R^0" by simp
54.36 - thus "\<exists>n. (a, a) \<in> R ^ n" ..
54.37 - next
54.38 - fix a b c assume "\<exists>n. (a, b) \<in> R ^ n"
54.39 - then obtain n where "(a, b) \<in> R^n" ..
54.40 - moreover assume "(b, c) \<in> R"
54.41 - ultimately have "(a, c) \<in> R^(Suc n)" by auto
54.42 - thus "\<exists>n. (a, c) \<in> R^n" ..
54.43 - qed
54.44 -qed
54.45 -(*>*)
54.46 text {*
54.47 As for the big step semantics you can read these rules in a
54.48 syntax directed way:
54.49 @@ -189,8 +169,8 @@
54.50 (*<*)
54.51 (* FIXME: relpow.simps don't work *)
54.52 lemmas [simp del] = relpow.simps
54.53 -lemma rel_pow_0 [simp]: "!!R::('a*'a) set. R^0 = Id" by (simp add: relpow.simps)
54.54 -lemma rel_pow_Suc_0 [simp]: "!!R::('a*'a) set. R^(Suc 0) = R" by (simp add: relpow.simps)
54.55 +lemma rel_pow_0 [simp]: "!!R::('a*'a) set. R ^^ 0 = Id" by (simp add: relpow.simps)
54.56 +lemma rel_pow_Suc_0 [simp]: "!!R::('a*'a) set. R ^^ Suc 0 = R" by (simp add: relpow.simps)
54.57
54.58 (*>*)
54.59 lemma evalc1_None_0 [simp]: "\<langle>s\<rangle> -n\<rightarrow>\<^sub>1 y = (n = 0 \<and> y = \<langle>s\<rangle>)"
55.1 --- a/src/HOL/Imperative_HOL/Heap_Monad.thy Mon May 11 09:39:53 2009 +0200
55.2 +++ b/src/HOL/Imperative_HOL/Heap_Monad.thy Mon May 11 17:20:52 2009 +0200
55.3 @@ -317,7 +317,7 @@
55.4 val dummy_type = ITyVar dummy_name;
55.5 val dummy_case_term = IVar dummy_name;
55.6 (*assumption: dummy values are not relevant for serialization*)
55.7 - val unitt = IConst (unit', ([], []));
55.8 + val unitt = IConst (unit', (([], []), []));
55.9 fun dest_abs ((v, ty) `|-> t, _) = ((v, ty), t)
55.10 | dest_abs (t, ty) =
55.11 let
55.12 @@ -353,10 +353,10 @@
55.13 | imp_monad_bind bind' return' unit' (ICase (((t, ty), pats), t0)) = ICase
55.14 (((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);
55.15
55.16 - fun imp_program naming = (Graph.map_nodes o map_terms_stmt)
55.17 - (imp_monad_bind (lookup naming @{const_name bindM})
55.18 - (lookup naming @{const_name return})
55.19 - (lookup naming @{const_name Unity}));
55.20 + fun imp_program naming = (Graph.map_nodes o map_terms_stmt)
55.21 + (imp_monad_bind (lookup naming @{const_name bindM})
55.22 + (lookup naming @{const_name return})
55.23 + (lookup naming @{const_name Unity}));
55.24
55.25 in
55.26
56.1 --- a/src/HOL/Import/HOL/HOL4Base.thy Mon May 11 09:39:53 2009 +0200
56.2 +++ b/src/HOL/Import/HOL/HOL4Base.thy Mon May 11 17:20:52 2009 +0200
56.3 @@ -2794,8 +2794,8 @@
56.4 by (import numeral numeral_fact)
56.5
56.6 lemma numeral_funpow: "ALL n::nat.
56.7 - ((f::'a::type => 'a::type) ^ n) (x::'a::type) =
56.8 - (if n = 0 then x else (f ^ (n - 1)) (f x))"
56.9 + ((f::'a::type => 'a::type) ^^ n) (x::'a::type) =
56.10 + (if n = 0 then x else (f ^^ (n - 1)) (f x))"
56.11 by (import numeral numeral_funpow)
56.12
56.13 ;end_setup
57.1 --- a/src/HOL/Import/HOL/HOL4Word32.thy Mon May 11 09:39:53 2009 +0200
57.2 +++ b/src/HOL/Import/HOL/HOL4Word32.thy Mon May 11 17:20:52 2009 +0200
57.3 @@ -434,15 +434,15 @@
57.4 by (import word32 EQUIV_QT)
57.5
57.6 lemma FUNPOW_THM: "ALL (f::'a::type => 'a::type) (n::nat) x::'a::type.
57.7 - (f ^ n) (f x) = f ((f ^ n) x)"
57.8 + (f ^^ n) (f x) = f ((f ^^ n) x)"
57.9 by (import word32 FUNPOW_THM)
57.10
57.11 lemma FUNPOW_THM2: "ALL (f::'a::type => 'a::type) (n::nat) x::'a::type.
57.12 - (f ^ Suc n) x = f ((f ^ n) x)"
57.13 + (f ^^ Suc n) x = f ((f ^^ n) x)"
57.14 by (import word32 FUNPOW_THM2)
57.15
57.16 lemma FUNPOW_COMP: "ALL (f::'a::type => 'a::type) (m::nat) (n::nat) a::'a::type.
57.17 - (f ^ m) ((f ^ n) a) = (f ^ (m + n)) a"
57.18 + (f ^^ m) ((f ^^ n) a) = (f ^^ (m + n)) a"
57.19 by (import word32 FUNPOW_COMP)
57.20
57.21 lemma INw_MODw: "ALL n::nat. INw (MODw n)"
57.22 @@ -1170,23 +1170,23 @@
57.23
57.24 constdefs
57.25 word_lsr :: "word32 => nat => word32"
57.26 - "word_lsr == %(a::word32) n::nat. (word_lsr1 ^ n) a"
57.27 + "word_lsr == %(a::word32) n::nat. (word_lsr1 ^^ n) a"
57.28
57.29 -lemma word_lsr: "ALL (a::word32) n::nat. word_lsr a n = (word_lsr1 ^ n) a"
57.30 +lemma word_lsr: "ALL (a::word32) n::nat. word_lsr a n = (word_lsr1 ^^ n) a"
57.31 by (import word32 word_lsr)
57.32
57.33 constdefs
57.34 word_asr :: "word32 => nat => word32"
57.35 - "word_asr == %(a::word32) n::nat. (word_asr1 ^ n) a"
57.36 + "word_asr == %(a::word32) n::nat. (word_asr1 ^^ n) a"
57.37
57.38 -lemma word_asr: "ALL (a::word32) n::nat. word_asr a n = (word_asr1 ^ n) a"
57.39 +lemma word_asr: "ALL (a::word32) n::nat. word_asr a n = (word_asr1 ^^ n) a"
57.40 by (import word32 word_asr)
57.41
57.42 constdefs
57.43 word_ror :: "word32 => nat => word32"
57.44 - "word_ror == %(a::word32) n::nat. (word_ror1 ^ n) a"
57.45 + "word_ror == %(a::word32) n::nat. (word_ror1 ^^ n) a"
57.46
57.47 -lemma word_ror: "ALL (a::word32) n::nat. word_ror a n = (word_ror1 ^ n) a"
57.48 +lemma word_ror: "ALL (a::word32) n::nat. word_ror a n = (word_ror1 ^^ n) a"
57.49 by (import word32 word_ror)
57.50
57.51 consts
57.52 @@ -1583,4 +1583,3 @@
57.53 ;end_setup
57.54
57.55 end
57.56 -
58.1 --- a/src/HOL/Import/HOL/arithmetic.imp Mon May 11 09:39:53 2009 +0200
58.2 +++ b/src/HOL/Import/HOL/arithmetic.imp Mon May 11 17:20:52 2009 +0200
58.3 @@ -43,7 +43,7 @@
58.4 "TWO" > "HOL4Base.arithmetic.TWO"
58.5 "TIMES2" > "NatSimprocs.nat_mult_2"
58.6 "SUC_SUB1" > "HOL4Base.arithmetic.SUC_SUB1"
58.7 - "SUC_ONE_ADD" > "NatBin.Suc_eq_add_numeral_1_left"
58.8 + "SUC_ONE_ADD" > "Nat_Numeral.Suc_eq_add_numeral_1_left"
58.9 "SUC_NOT" > "Nat.nat.simps_2"
58.10 "SUC_ELIM_THM" > "HOL4Base.arithmetic.SUC_ELIM_THM"
58.11 "SUC_ADD_SYM" > "HOL4Base.arithmetic.SUC_ADD_SYM"
58.12 @@ -233,7 +233,7 @@
58.13 "EVEN_AND_ODD" > "HOL4Base.arithmetic.EVEN_AND_ODD"
58.14 "EVEN_ADD" > "HOL4Base.arithmetic.EVEN_ADD"
58.15 "EVEN" > "HOL4Base.arithmetic.EVEN"
58.16 - "EQ_MULT_LCANCEL" > "NatBin.nat_mult_eq_cancel_disj"
58.17 + "EQ_MULT_LCANCEL" > "Nat_Numeral.nat_mult_eq_cancel_disj"
58.18 "EQ_MONO_ADD_EQ" > "Nat.nat_add_right_cancel"
58.19 "EQ_LESS_EQ" > "Orderings.order_eq_iff"
58.20 "EQ_ADD_RCANCEL" > "Nat.nat_add_right_cancel"
59.1 --- a/src/HOL/Import/HOL/real.imp Mon May 11 09:39:53 2009 +0200
59.2 +++ b/src/HOL/Import/HOL/real.imp Mon May 11 17:20:52 2009 +0200
59.3 @@ -99,7 +99,7 @@
59.4 "REAL_POW_INV" > "Power.power_inverse"
59.5 "REAL_POW_DIV" > "Power.power_divide"
59.6 "REAL_POW_ADD" > "Power.power_add"
59.7 - "REAL_POW2_ABS" > "NatBin.power2_abs"
59.8 + "REAL_POW2_ABS" > "Nat_Numeral.power2_abs"
59.9 "REAL_POS_NZ" > "HOL4Real.real.REAL_POS_NZ"
59.10 "REAL_POS" > "RealDef.real_of_nat_ge_zero"
59.11 "REAL_POASQ" > "HOL4Real.real.REAL_POASQ"
59.12 @@ -210,7 +210,7 @@
59.13 "REAL_LE_RDIV_EQ" > "Ring_and_Field.pos_le_divide_eq"
59.14 "REAL_LE_RDIV" > "Ring_and_Field.mult_imp_le_div_pos"
59.15 "REAL_LE_RADD" > "OrderedGroup.add_le_cancel_right"
59.16 - "REAL_LE_POW2" > "NatBin.zero_compare_simps_12"
59.17 + "REAL_LE_POW2" > "Nat_Numeral.zero_compare_simps_12"
59.18 "REAL_LE_NEGTOTAL" > "HOL4Real.real.REAL_LE_NEGTOTAL"
59.19 "REAL_LE_NEGR" > "OrderedGroup.le_minus_self_iff"
59.20 "REAL_LE_NEGL" > "OrderedGroup.minus_le_self_iff"
59.21 @@ -313,7 +313,7 @@
59.22 "POW_ONE" > "Power.power_one"
59.23 "POW_NZ" > "Power.field_power_not_zero"
59.24 "POW_MUL" > "Power.power_mult_distrib"
59.25 - "POW_MINUS1" > "NatBin.power_minus1_even"
59.26 + "POW_MINUS1" > "Nat_Numeral.power_minus1_even"
59.27 "POW_M1" > "HOL4Real.real.POW_M1"
59.28 "POW_LT" > "HOL4Real.real.POW_LT"
59.29 "POW_LE" > "Power.power_mono"
59.30 @@ -323,7 +323,7 @@
59.31 "POW_ABS" > "Power.power_abs"
59.32 "POW_2_LT" > "RealPow.two_realpow_gt"
59.33 "POW_2_LE1" > "RealPow.two_realpow_ge_one"
59.34 - "POW_2" > "NatBin.power2_eq_square"
59.35 + "POW_2" > "Nat_Numeral.power2_eq_square"
59.36 "POW_1" > "Power.power_one_right"
59.37 "POW_0" > "Power.power_0_Suc"
59.38 "ABS_ZERO" > "OrderedGroup.abs_eq_0"
59.39 @@ -335,7 +335,7 @@
59.40 "ABS_SIGN2" > "HOL4Real.real.ABS_SIGN2"
59.41 "ABS_SIGN" > "HOL4Real.real.ABS_SIGN"
59.42 "ABS_REFL" > "HOL4Real.real.ABS_REFL"
59.43 - "ABS_POW2" > "NatBin.abs_power2"
59.44 + "ABS_POW2" > "Nat_Numeral.abs_power2"
59.45 "ABS_POS" > "OrderedGroup.abs_ge_zero"
59.46 "ABS_NZ" > "OrderedGroup.zero_less_abs_iff"
59.47 "ABS_NEG" > "OrderedGroup.abs_minus_cancel"
60.1 --- a/src/HOL/Import/HOL4Compat.thy Mon May 11 09:39:53 2009 +0200
60.2 +++ b/src/HOL/Import/HOL4Compat.thy Mon May 11 17:20:52 2009 +0200
60.3 @@ -202,19 +202,13 @@
60.4
60.5 constdefs
60.6 FUNPOW :: "('a => 'a) => nat => 'a => 'a"
60.7 - "FUNPOW f n == f ^ n"
60.8 + "FUNPOW f n == f ^^ n"
60.9
60.10 -lemma FUNPOW: "(ALL f x. (f ^ 0) x = x) &
60.11 - (ALL f n x. (f ^ Suc n) x = (f ^ n) (f x))"
60.12 -proof auto
60.13 - fix f n x
60.14 - have "ALL x. f ((f ^ n) x) = (f ^ n) (f x)"
60.15 - by (induct n,auto)
60.16 - thus "f ((f ^ n) x) = (f ^ n) (f x)"
60.17 - ..
60.18 -qed
60.19 +lemma FUNPOW: "(ALL f x. (f ^^ 0) x = x) &
60.20 + (ALL f n x. (f ^^ Suc n) x = (f ^^ n) (f x))"
60.21 + by (simp add: funpow_swap1)
60.22
60.23 -lemma [hol4rew]: "FUNPOW f n = f ^ n"
60.24 +lemma [hol4rew]: "FUNPOW f n = f ^^ n"
60.25 by (simp add: FUNPOW_def)
60.26
60.27 lemma ADD: "(!n. (0::nat) + n = n) & (!m n. Suc m + n = Suc (m + n))"
60.28 @@ -224,7 +218,7 @@
60.29 by simp
60.30
60.31 lemma SUB: "(!m. (0::nat) - m = 0) & (!m n. (Suc m) - n = (if m < n then 0 else Suc (m - n)))"
60.32 - by (simp, arith)
60.33 + by (simp) arith
60.34
60.35 lemma MAX_DEF: "max (m::nat) n = (if m < n then n else m)"
60.36 by (simp add: max_def)
61.1 --- a/src/HOL/Import/HOLLight/hollight.imp Mon May 11 09:39:53 2009 +0200
61.2 +++ b/src/HOL/Import/HOLLight/hollight.imp Mon May 11 17:20:52 2009 +0200
61.3 @@ -1515,7 +1515,7 @@
61.4 "EQ_REFL_T" > "HOL.simp_thms_6"
61.5 "EQ_REFL" > "Presburger.fm_modd_pinf"
61.6 "EQ_MULT_RCANCEL" > "Nat.mult_cancel2"
61.7 - "EQ_MULT_LCANCEL" > "NatBin.nat_mult_eq_cancel_disj"
61.8 + "EQ_MULT_LCANCEL" > "Nat_Numeral.nat_mult_eq_cancel_disj"
61.9 "EQ_IMP_LE" > "HOLLight.hollight.EQ_IMP_LE"
61.10 "EQ_EXT" > "HOL.meta_eq_to_obj_eq"
61.11 "EQ_CLAUSES" > "HOLLight.hollight.EQ_CLAUSES"
62.1 --- a/src/HOL/Int.thy Mon May 11 09:39:53 2009 +0200
62.2 +++ b/src/HOL/Int.thy Mon May 11 17:20:52 2009 +0200
62.3 @@ -12,10 +12,13 @@
62.4 uses
62.5 ("Tools/numeral.ML")
62.6 ("Tools/numeral_syntax.ML")
62.7 + ("Tools/int_arith.ML")
62.8 "~~/src/Provers/Arith/assoc_fold.ML"
62.9 "~~/src/Provers/Arith/cancel_numerals.ML"
62.10 "~~/src/Provers/Arith/combine_numerals.ML"
62.11 - ("Tools/int_arith.ML")
62.12 + "~~/src/Provers/Arith/cancel_numeral_factor.ML"
62.13 + "~~/src/Provers/Arith/extract_common_term.ML"
62.14 + ("Tools/numeral_simprocs.ML")
62.15 begin
62.16
62.17 subsection {* The equivalence relation underlying the integers *}
62.18 @@ -292,9 +295,7 @@
62.19 context ring_1
62.20 begin
62.21
62.22 -definition
62.23 - of_int :: "int \<Rightarrow> 'a"
62.24 -where
62.25 +definition of_int :: "int \<Rightarrow> 'a" where
62.26 [code del]: "of_int z = contents (\<Union>(i, j) \<in> Rep_Integ z. { of_nat i - of_nat j })"
62.27
62.28 lemma of_int: "of_int (Abs_Integ (intrel `` {(i,j)})) = of_nat i - of_nat j"
62.29 @@ -330,6 +331,10 @@
62.30 lemma of_int_of_nat_eq [simp]: "of_int (of_nat n) = of_nat n"
62.31 by (induct n) auto
62.32
62.33 +lemma of_int_power:
62.34 + "of_int (z ^ n) = of_int z ^ n"
62.35 + by (induct n) simp_all
62.36 +
62.37 end
62.38
62.39 context ordered_idom
62.40 @@ -1266,14 +1271,9 @@
62.41 definition Ints :: "'a set" where
62.42 [code del]: "Ints = range of_int"
62.43
62.44 -end
62.45 -
62.46 notation (xsymbols)
62.47 Ints ("\<int>")
62.48
62.49 -context ring_1
62.50 -begin
62.51 -
62.52 lemma Ints_0 [simp]: "0 \<in> \<int>"
62.53 apply (simp add: Ints_def)
62.54 apply (rule range_eqI)
62.55 @@ -1518,9 +1518,18 @@
62.56 of_nat_0 of_nat_1 of_nat_Suc of_nat_add of_nat_mult
62.57 of_int_0 of_int_1 of_int_add of_int_mult
62.58
62.59 +use "Tools/numeral_simprocs.ML"
62.60 +
62.61 use "Tools/int_arith.ML"
62.62 declaration {* K Int_Arith.setup *}
62.63
62.64 +setup {*
62.65 + ReorientProc.add
62.66 + (fn Const (@{const_name number_of}, _) $ _ => true | _ => false)
62.67 +*}
62.68 +
62.69 +simproc_setup reorient_numeral ("number_of w = x") = ReorientProc.proc
62.70 +
62.71
62.72 subsection{*Lemmas About Small Numerals*}
62.73
62.74 @@ -1536,7 +1545,7 @@
62.75 by (simp add: abs_if)
62.76
62.77 lemma abs_power_minus_one [simp]:
62.78 - "abs(-1 ^ n) = (1::'a::{ordered_idom,number_ring,recpower})"
62.79 + "abs(-1 ^ n) = (1::'a::{ordered_idom,number_ring})"
62.80 by (simp add: power_abs)
62.81
62.82 lemma of_int_number_of_eq [simp]:
62.83 @@ -1846,49 +1855,6 @@
62.84 qed
62.85
62.86
62.87 -subsection {* Integer Powers *}
62.88 -
62.89 -instantiation int :: recpower
62.90 -begin
62.91 -
62.92 -primrec power_int where
62.93 - "p ^ 0 = (1\<Colon>int)"
62.94 - | "p ^ (Suc n) = (p\<Colon>int) * (p ^ n)"
62.95 -
62.96 -instance proof
62.97 - fix z :: int
62.98 - fix n :: nat
62.99 - show "z ^ 0 = 1" by simp
62.100 - show "z ^ Suc n = z * (z ^ n)" by simp
62.101 -qed
62.102 -
62.103 -declare power_int.simps [simp del]
62.104 -
62.105 -end
62.106 -
62.107 -lemma zpower_zadd_distrib: "x ^ (y + z) = ((x ^ y) * (x ^ z)::int)"
62.108 - by (rule Power.power_add)
62.109 -
62.110 -lemma zpower_zpower: "(x ^ y) ^ z = (x ^ (y * z)::int)"
62.111 - by (rule Power.power_mult [symmetric])
62.112 -
62.113 -lemma zero_less_zpower_abs_iff [simp]:
62.114 - "(0 < abs x ^ n) \<longleftrightarrow> (x \<noteq> (0::int) | n = 0)"
62.115 - by (induct n) (auto simp add: zero_less_mult_iff)
62.116 -
62.117 -lemma zero_le_zpower_abs [simp]: "(0::int) \<le> abs x ^ n"
62.118 - by (induct n) (auto simp add: zero_le_mult_iff)
62.119 -
62.120 -lemma of_int_power:
62.121 - "of_int (z ^ n) = (of_int z ^ n :: 'a::{recpower, ring_1})"
62.122 - by (induct n) simp_all
62.123 -
62.124 -lemma int_power: "int (m^n) = (int m) ^ n"
62.125 - by (rule of_nat_power)
62.126 -
62.127 -lemmas zpower_int = int_power [symmetric]
62.128 -
62.129 -
62.130 subsection {* Further theorems on numerals *}
62.131
62.132 subsubsection{*Special Simplification for Constants*}
62.133 @@ -2278,4 +2244,25 @@
62.134 lemmas zless_le = less_int_def
62.135 lemmas int_eq_of_nat = TrueI
62.136
62.137 +lemma zpower_zadd_distrib:
62.138 + "x ^ (y + z) = ((x ^ y) * (x ^ z)::int)"
62.139 + by (rule power_add)
62.140 +
62.141 +lemma zero_less_zpower_abs_iff:
62.142 + "(0 < abs x ^ n) \<longleftrightarrow> (x \<noteq> (0::int) | n = 0)"
62.143 + by (rule zero_less_power_abs_iff)
62.144 +
62.145 +lemma zero_le_zpower_abs: "(0::int) \<le> abs x ^ n"
62.146 + by (rule zero_le_power_abs)
62.147 +
62.148 +lemma zpower_zpower:
62.149 + "(x ^ y) ^ z = (x ^ (y * z)::int)"
62.150 + by (rule power_mult [symmetric])
62.151 +
62.152 +lemma int_power:
62.153 + "int (m ^ n) = int m ^ n"
62.154 + by (rule of_nat_power)
62.155 +
62.156 +lemmas zpower_int = int_power [symmetric]
62.157 +
62.158 end
63.1 --- a/src/HOL/IntDiv.thy Mon May 11 09:39:53 2009 +0200
63.2 +++ b/src/HOL/IntDiv.thy Mon May 11 17:20:52 2009 +0200
63.3 @@ -8,10 +8,6 @@
63.4
63.5 theory IntDiv
63.6 imports Int Divides FunDef
63.7 -uses
63.8 - "~~/src/Provers/Arith/cancel_numeral_factor.ML"
63.9 - "~~/src/Provers/Arith/extract_common_term.ML"
63.10 - ("Tools/int_factor_simprocs.ML")
63.11 begin
63.12
63.13 definition divmod_rel :: "int \<Rightarrow> int \<Rightarrow> int \<times> int \<Rightarrow> bool" where
63.14 @@ -249,33 +245,33 @@
63.15 text {* Tool setup *}
63.16
63.17 ML {*
63.18 -local
63.19 +local
63.20
63.21 -structure CancelDivMod = CancelDivModFun(
63.22 -struct
63.23 - val div_name = @{const_name Divides.div};
63.24 - val mod_name = @{const_name Divides.mod};
63.25 +structure CancelDivMod = CancelDivModFun(struct
63.26 +
63.27 + val div_name = @{const_name div};
63.28 + val mod_name = @{const_name mod};
63.29 val mk_binop = HOLogic.mk_binop;
63.30 - val mk_sum = Int_Numeral_Simprocs.mk_sum HOLogic.intT;
63.31 - val dest_sum = Int_Numeral_Simprocs.dest_sum;
63.32 - val div_mod_eqs =
63.33 - map mk_meta_eq [@{thm zdiv_zmod_equality},
63.34 - @{thm zdiv_zmod_equality2}];
63.35 + val mk_sum = Numeral_Simprocs.mk_sum HOLogic.intT;
63.36 + val dest_sum = Numeral_Simprocs.dest_sum;
63.37 +
63.38 + val div_mod_eqs = map mk_meta_eq [@{thm zdiv_zmod_equality}, @{thm zdiv_zmod_equality2}];
63.39 +
63.40 val trans = trans;
63.41 - val prove_eq_sums =
63.42 - let
63.43 - val simps = @{thm diff_int_def} :: Int_Numeral_Simprocs.add_0s @ @{thms zadd_ac}
63.44 - in Arith_Data.prove_conv2 all_tac (Arith_Data.simp_all_tac simps) end;
63.45 +
63.46 + val prove_eq_sums = Arith_Data.prove_conv2 all_tac (Arith_Data.simp_all_tac
63.47 + (@{thm diff_minus} :: @{thms add_0s} @ @{thms add_ac}))
63.48 +
63.49 end)
63.50
63.51 in
63.52
63.53 -val cancel_zdiv_zmod_proc = Simplifier.simproc (the_context ())
63.54 - "cancel_zdiv_zmod" ["(m::int) + n"] (K CancelDivMod.proc)
63.55 +val cancel_div_mod_int_proc = Simplifier.simproc (the_context ())
63.56 + "cancel_zdiv_zmod" ["(k::int) + l"] (K CancelDivMod.proc);
63.57
63.58 -end;
63.59 +val _ = Addsimprocs [cancel_div_mod_int_proc];
63.60
63.61 -Addsimprocs [cancel_zdiv_zmod_proc]
63.62 +end
63.63 *}
63.64
63.65 lemma pos_mod_conj : "(0::int) < b ==> 0 \<le> a mod b & a mod b < b"
63.66 @@ -711,6 +707,25 @@
63.67 show "(a + c * b) div b = c + a div b"
63.68 unfolding zdiv_zadd1_eq [of a "c * b"] using not0
63.69 by (simp add: zmod_zmult1_eq zmod_zdiv_trivial zdiv_zmult1_eq)
63.70 +next
63.71 + fix a b c :: int
63.72 + assume "a \<noteq> 0"
63.73 + then show "(a * b) div (a * c) = b div c"
63.74 + proof (cases "b \<noteq> 0 \<and> c \<noteq> 0")
63.75 + case False then show ?thesis by auto
63.76 + next
63.77 + case True then have "b \<noteq> 0" and "c \<noteq> 0" by auto
63.78 + with `a \<noteq> 0`
63.79 + have "\<And>q r. divmod_rel b c (q, r) \<Longrightarrow> divmod_rel (a * b) (a * c) (q, a * r)"
63.80 + apply (auto simp add: divmod_rel_def)
63.81 + apply (auto simp add: algebra_simps)
63.82 + apply (auto simp add: zero_less_mult_iff zero_le_mult_iff mult_le_0_iff)
63.83 + done
63.84 + moreover with `c \<noteq> 0` divmod_rel_div_mod have "divmod_rel b c (b div c, b mod c)" by auto
63.85 + ultimately have "divmod_rel (a * b) (a * c) (b div c, a * (b mod c))" .
63.86 + moreover from `a \<noteq> 0` `c \<noteq> 0` have "a * c \<noteq> 0" by simp
63.87 + ultimately show ?thesis by (rule divmod_rel_div)
63.88 + qed
63.89 qed auto
63.90
63.91 lemma posDivAlg_div_mod:
63.92 @@ -808,52 +823,6 @@
63.93 done
63.94
63.95
63.96 -subsection{*Cancellation of Common Factors in div*}
63.97 -
63.98 -lemma zdiv_zmult_zmult1_aux1:
63.99 - "[| (0::int) < b; c \<noteq> 0 |] ==> (c*a) div (c*b) = a div b"
63.100 -by (subst zdiv_zmult2_eq, auto)
63.101 -
63.102 -lemma zdiv_zmult_zmult1_aux2:
63.103 - "[| b < (0::int); c \<noteq> 0 |] ==> (c*a) div (c*b) = a div b"
63.104 -apply (subgoal_tac " (c * (-a)) div (c * (-b)) = (-a) div (-b) ")
63.105 -apply (rule_tac [2] zdiv_zmult_zmult1_aux1, auto)
63.106 -done
63.107 -
63.108 -lemma zdiv_zmult_zmult1: "c \<noteq> (0::int) ==> (c*a) div (c*b) = a div b"
63.109 -apply (case_tac "b = 0", simp)
63.110 -apply (auto simp add: linorder_neq_iff zdiv_zmult_zmult1_aux1 zdiv_zmult_zmult1_aux2)
63.111 -done
63.112 -
63.113 -lemma zdiv_zmult_zmult1_if[simp]:
63.114 - "(k*m) div (k*n) = (if k = (0::int) then 0 else m div n)"
63.115 -by (simp add:zdiv_zmult_zmult1)
63.116 -
63.117 -
63.118 -subsection{*Distribution of Factors over mod*}
63.119 -
63.120 -lemma zmod_zmult_zmult1_aux1:
63.121 - "[| (0::int) < b; c \<noteq> 0 |] ==> (c*a) mod (c*b) = c * (a mod b)"
63.122 -by (subst zmod_zmult2_eq, auto)
63.123 -
63.124 -lemma zmod_zmult_zmult1_aux2:
63.125 - "[| b < (0::int); c \<noteq> 0 |] ==> (c*a) mod (c*b) = c * (a mod b)"
63.126 -apply (subgoal_tac " (c * (-a)) mod (c * (-b)) = c * ((-a) mod (-b))")
63.127 -apply (rule_tac [2] zmod_zmult_zmult1_aux1, auto)
63.128 -done
63.129 -
63.130 -lemma zmod_zmult_zmult1: "(c*a) mod (c*b) = (c::int) * (a mod b)"
63.131 -apply (case_tac "b = 0", simp)
63.132 -apply (case_tac "c = 0", simp)
63.133 -apply (auto simp add: linorder_neq_iff zmod_zmult_zmult1_aux1 zmod_zmult_zmult1_aux2)
63.134 -done
63.135 -
63.136 -lemma zmod_zmult_zmult2: "(a*c) mod (b*c) = (a mod b) * (c::int)"
63.137 -apply (cut_tac c = c in zmod_zmult_zmult1)
63.138 -apply (auto simp add: mult_commute)
63.139 -done
63.140 -
63.141 -
63.142 subsection {*Splitting Rules for div and mod*}
63.143
63.144 text{*The proofs of the two lemmas below are essentially identical*}
63.145 @@ -937,7 +906,7 @@
63.146 right_distrib)
63.147 thus ?thesis
63.148 by (subst zdiv_zadd1_eq,
63.149 - simp add: zdiv_zmult_zmult1 zmod_zmult_zmult1 one_less_a2
63.150 + simp add: mod_mult_mult1 one_less_a2
63.151 div_pos_pos_trivial)
63.152 qed
63.153
63.154 @@ -961,7 +930,7 @@
63.155 then number_of v div (number_of w)
63.156 else (number_of v + (1::int)) div (number_of w))"
63.157 apply (simp only: number_of_eq numeral_simps UNIV_I split: split_if)
63.158 -apply (simp add: zdiv_zmult_zmult1 pos_zdiv_mult_2 neg_zdiv_mult_2 add_ac)
63.159 +apply (simp add: pos_zdiv_mult_2 neg_zdiv_mult_2 add_ac)
63.160 done
63.161
63.162
63.163 @@ -977,7 +946,7 @@
63.164 apply (auto simp add: add_commute [of 1] mult_commute add1_zle_eq
63.165 pos_mod_bound)
63.166 apply (subst mod_add_eq)
63.167 -apply (simp add: zmod_zmult_zmult2 mod_pos_pos_trivial)
63.168 +apply (simp add: mod_mult_mult2 mod_pos_pos_trivial)
63.169 apply (rule mod_pos_pos_trivial)
63.170 apply (auto simp add: mod_pos_pos_trivial ring_distribs)
63.171 apply (subgoal_tac "0 \<le> b mod a", arith, simp)
63.172 @@ -998,7 +967,7 @@
63.173 "number_of (Int.Bit0 v) mod number_of (Int.Bit0 w) =
63.174 (2::int) * (number_of v mod number_of w)"
63.175 apply (simp only: number_of_eq numeral_simps)
63.176 -apply (simp add: zmod_zmult_zmult1 pos_zmod_mult_2
63.177 +apply (simp add: mod_mult_mult1 pos_zmod_mult_2
63.178 neg_zmod_mult_2 add_ac)
63.179 done
63.180
63.181 @@ -1008,7 +977,7 @@
63.182 then 2 * (number_of v mod number_of w) + 1
63.183 else 2 * ((number_of v + (1::int)) mod number_of w) - 1)"
63.184 apply (simp only: number_of_eq numeral_simps)
63.185 -apply (simp add: zmod_zmult_zmult1 pos_zmod_mult_2
63.186 +apply (simp add: mod_mult_mult1 pos_zmod_mult_2
63.187 neg_zmod_mult_2 add_ac)
63.188 done
63.189
63.190 @@ -1090,9 +1059,7 @@
63.191 done
63.192
63.193 lemma zdvd_zmod: "f dvd m ==> f dvd (n::int) ==> f dvd m mod n"
63.194 - apply (simp add: dvd_def)
63.195 - apply (auto simp add: zmod_zmult_zmult1)
63.196 - done
63.197 + by (auto elim!: dvdE simp add: mod_mult_mult1)
63.198
63.199 lemma zdvd_zmod_imp_zdvd: "k dvd m mod n ==> k dvd n ==> k dvd (m::int)"
63.200 apply (subgoal_tac "k dvd n * (m div n) + m mod n")
63.201 @@ -1106,8 +1073,6 @@
63.202 prefer 2
63.203 apply (blast intro: order_less_trans)
63.204 apply (simp add: zero_less_mult_iff)
63.205 - apply (subgoal_tac "n * k < n * 1")
63.206 - apply (drule mult_less_cancel_left [THEN iffD1], auto)
63.207 done
63.208
63.209 lemma zmult_div_cancel: "(n::int) * (m div n) = m - (m mod n)"
63.210 @@ -1247,9 +1212,9 @@
63.211 lemmas zmod_simps =
63.212 mod_add_left_eq [symmetric]
63.213 mod_add_right_eq [symmetric]
63.214 - IntDiv.zmod_zmult1_eq [symmetric]
63.215 - mod_mult_left_eq [symmetric]
63.216 - IntDiv.zpower_zmod
63.217 + zmod_zmult1_eq [symmetric]
63.218 + mod_mult_left_eq [symmetric]
63.219 + zpower_zmod
63.220 zminus_zmod zdiff_zmod_left zdiff_zmod_right
63.221
63.222 text {* Distributive laws for function @{text nat}. *}
63.223 @@ -1362,11 +1327,6 @@
63.224 qed
63.225
63.226
63.227 -subsection {* Simproc setup *}
63.228 -
63.229 -use "Tools/int_factor_simprocs.ML"
63.230 -
63.231 -
63.232 subsection {* Code generation *}
63.233
63.234 definition pdivmod :: "int \<Rightarrow> int \<Rightarrow> int \<times> int" where
64.1 --- a/src/HOL/IsaMakefile Mon May 11 09:39:53 2009 +0200
64.2 +++ b/src/HOL/IsaMakefile Mon May 11 17:20:52 2009 +0200
64.3 @@ -89,10 +89,9 @@
64.4 $(SRC)/Tools/IsaPlanner/rw_tools.ML \
64.5 $(SRC)/Tools/IsaPlanner/zipper.ML \
64.6 $(SRC)/Tools/atomize_elim.ML \
64.7 - $(SRC)/Tools/code/code_funcgr.ML \
64.8 + $(SRC)/Tools/auto_solve.ML \
64.9 $(SRC)/Tools/code/code_haskell.ML \
64.10 $(SRC)/Tools/code/code_ml.ML \
64.11 - $(SRC)/Tools/code/code_name.ML \
64.12 $(SRC)/Tools/code/code_printer.ML \
64.13 $(SRC)/Tools/code/code_target.ML \
64.14 $(SRC)/Tools/code/code_thingol.ML \
64.15 @@ -103,10 +102,11 @@
64.16 $(SRC)/Tools/intuitionistic.ML \
64.17 $(SRC)/Tools/induct_tacs.ML \
64.18 $(SRC)/Tools/nbe.ML \
64.19 + $(SRC)/Tools/quickcheck.ML \
64.20 $(SRC)/Tools/project_rule.ML \
64.21 $(SRC)/Tools/random_word.ML \
64.22 $(SRC)/Tools/value.ML \
64.23 - Code_Setup.thy \
64.24 + $(SRC)/Tools/Code_Generator.thy \
64.25 HOL.thy \
64.26 Tools/hologic.ML \
64.27 Tools/recfun_codegen.ML \
64.28 @@ -206,7 +206,6 @@
64.29 MAIN_DEPENDENCIES = $(PLAIN_DEPENDENCIES) \
64.30 ATP_Linkup.thy \
64.31 Code_Eval.thy \
64.32 - Code_Message.thy \
64.33 Equiv_Relations.thy \
64.34 Groebner_Basis.thy \
64.35 Hilbert_Choice.thy \
64.36 @@ -216,29 +215,30 @@
64.37 List.thy \
64.38 Main.thy \
64.39 Map.thy \
64.40 - NatBin.thy \
64.41 + Nat_Numeral.thy \
64.42 Presburger.thy \
64.43 Recdef.thy \
64.44 - Relation_Power.thy \
64.45 SetInterval.thy \
64.46 + String.thy \
64.47 $(SRC)/Provers/Arith/assoc_fold.ML \
64.48 $(SRC)/Provers/Arith/cancel_numeral_factor.ML \
64.49 $(SRC)/Provers/Arith/cancel_numerals.ML \
64.50 $(SRC)/Provers/Arith/combine_numerals.ML \
64.51 $(SRC)/Provers/Arith/extract_common_term.ML \
64.52 $(SRC)/Tools/Metis/metis.ML \
64.53 - Tools/int_arith.ML \
64.54 - Tools/int_factor_simprocs.ML \
64.55 - Tools/nat_simprocs.ML \
64.56 Tools/Groebner_Basis/groebner.ML \
64.57 Tools/Groebner_Basis/misc.ML \
64.58 Tools/Groebner_Basis/normalizer_data.ML \
64.59 Tools/Groebner_Basis/normalizer.ML \
64.60 Tools/atp_manager.ML \
64.61 Tools/atp_wrapper.ML \
64.62 + Tools/int_arith.ML \
64.63 + Tools/list_code.ML \
64.64 Tools/meson.ML \
64.65 Tools/metis_tools.ML \
64.66 + Tools/nat_numeral_simprocs.ML \
64.67 Tools/numeral.ML \
64.68 + Tools/numeral_simprocs.ML \
64.69 Tools/numeral_syntax.ML \
64.70 Tools/polyhash.ML \
64.71 Tools/Qelim/cooper_data.ML \
64.72 @@ -253,6 +253,7 @@
64.73 Tools/res_hol_clause.ML \
64.74 Tools/res_reconstruct.ML \
64.75 Tools/specification_package.ML \
64.76 + Tools/string_code.ML \
64.77 Tools/string_syntax.ML \
64.78 Tools/TFL/casesplit.ML \
64.79 Tools/TFL/dcterm.ML \
64.80 @@ -341,6 +342,7 @@
64.81 Library/Random.thy Library/Quickcheck.thy \
64.82 Library/Poly_Deriv.thy \
64.83 Library/Polynomial.thy \
64.84 + Library/Preorder.thy \
64.85 Library/Product_plus.thy \
64.86 Library/Product_Vector.thy \
64.87 Library/Enum.thy Library/Float.thy $(SRC)/Tools/float.ML $(SRC)/HOL/Tools/float_arith.ML \
65.1 --- a/src/HOL/Library/Binomial.thy Mon May 11 09:39:53 2009 +0200
65.2 +++ b/src/HOL/Library/Binomial.thy Mon May 11 17:20:52 2009 +0200
65.3 @@ -292,7 +292,7 @@
65.4
65.5 subsection{* Generalized binomial coefficients *}
65.6
65.7 -definition gbinomial :: "'a::{field, recpower,ring_char_0} \<Rightarrow> nat \<Rightarrow> 'a" (infixl "gchoose" 65)
65.8 +definition gbinomial :: "'a::{field, ring_char_0} \<Rightarrow> nat \<Rightarrow> 'a" (infixl "gchoose" 65)
65.9 where "a gchoose n = (if n = 0 then 1 else (setprod (\<lambda>i. a - of_nat i) {0 .. n - 1}) / of_nat (fact n))"
65.10
65.11 lemma gbinomial_0[simp]: "a gchoose 0 = 1" "0 gchoose (Suc n) = 0"
65.12 @@ -420,16 +420,16 @@
65.13 by (simp add: gbinomial_def)
65.14
65.15 lemma gbinomial_mult_fact:
65.16 - "(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})"
65.17 + "(of_nat (fact (Suc k)) :: 'a) * ((a::'a::{field, ring_char_0}) gchoose (Suc k)) = (setprod (\<lambda>i. a - of_nat i) {0 .. k})"
65.18 unfolding gbinomial_Suc
65.19 by (simp_all add: field_simps del: fact_Suc)
65.20
65.21 lemma gbinomial_mult_fact':
65.22 - "((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})"
65.23 + "((a::'a::{field, ring_char_0}) gchoose (Suc k)) * (of_nat (fact (Suc k)) :: 'a) = (setprod (\<lambda>i. a - of_nat i) {0 .. k})"
65.24 using gbinomial_mult_fact[of k a]
65.25 apply (subst mult_commute) .
65.26
65.27 -lemma gbinomial_Suc_Suc: "((a::'a::{field,recpower, ring_char_0}) + 1) gchoose (Suc k) = a gchoose k + (a gchoose (Suc k))"
65.28 +lemma gbinomial_Suc_Suc: "((a::'a::{field, ring_char_0}) + 1) gchoose (Suc k) = a gchoose k + (a gchoose (Suc k))"
65.29 proof-
65.30 {assume "k = 0" then have ?thesis by simp}
65.31 moreover
66.1 --- a/src/HOL/Library/Code_Char.thy Mon May 11 09:39:53 2009 +0200
66.2 +++ b/src/HOL/Library/Code_Char.thy Mon May 11 17:20:52 2009 +0200
66.3 @@ -14,8 +14,8 @@
66.4 (Haskell "Char")
66.5
66.6 setup {*
66.7 - fold (fn target => add_literal_char target) ["SML", "OCaml", "Haskell"]
66.8 - #> add_literal_list_string "Haskell"
66.9 + fold String_Code.add_literal_char ["SML", "OCaml", "Haskell"]
66.10 + #> String_Code.add_literal_list_string "Haskell"
66.11 *}
66.12
66.13 code_instance char :: eq
66.14 @@ -33,6 +33,6 @@
66.15 (Haskell infixl 4 "==")
66.16
66.17 code_const "Code_Eval.term_of \<Colon> char \<Rightarrow> term"
66.18 - (SML "HOLogic.mk'_char/ (IntInf.fromInt/ (Char.ord/ _))")
66.19 + (Eval "HOLogic.mk'_char/ (IntInf.fromInt/ (Char.ord/ _))")
66.20
66.21 end
67.1 --- a/src/HOL/Library/Code_Index.thy Mon May 11 09:39:53 2009 +0200
67.2 +++ b/src/HOL/Library/Code_Index.thy Mon May 11 17:20:52 2009 +0200
67.3 @@ -144,7 +144,7 @@
67.4
67.5 subsection {* Basic arithmetic *}
67.6
67.7 -instantiation index :: "{minus, ordered_semidom, Divides.div, linorder}"
67.8 +instantiation index :: "{minus, ordered_semidom, semiring_div, linorder}"
67.9 begin
67.10
67.11 definition [simp, code del]:
67.12 @@ -172,7 +172,7 @@
67.13 "n < m \<longleftrightarrow> nat_of n < nat_of m"
67.14
67.15 instance proof
67.16 -qed (auto simp add: left_distrib)
67.17 +qed (auto simp add: index left_distrib div_mult_self1)
67.18
67.19 end
67.20
68.1 --- a/src/HOL/Library/Coinductive_List.thy Mon May 11 09:39:53 2009 +0200
68.2 +++ b/src/HOL/Library/Coinductive_List.thy Mon May 11 17:20:52 2009 +0200
68.3 @@ -786,7 +786,7 @@
68.4
68.5 lemma funpow_lmap:
68.6 fixes f :: "'a \<Rightarrow> 'a"
68.7 - shows "(lmap f ^ n) (LCons b l) = LCons ((f ^ n) b) ((lmap f ^ n) l)"
68.8 + shows "(lmap f ^^ n) (LCons b l) = LCons ((f ^^ n) b) ((lmap f ^^ n) l)"
68.9 by (induct n) simp_all
68.10
68.11
68.12 @@ -796,35 +796,35 @@
68.13 proof
68.14 fix x
68.15 have "(h x, iterates f x) \<in>
68.16 - {((lmap f ^ n) (h u), (lmap f ^ n) (iterates f u)) | u n. True}"
68.17 + {((lmap f ^^ n) (h u), (lmap f ^^ n) (iterates f u)) | u n. True}"
68.18 proof -
68.19 - have "(h x, iterates f x) = ((lmap f ^ 0) (h x), (lmap f ^ 0) (iterates f x))"
68.20 + have "(h x, iterates f x) = ((lmap f ^^ 0) (h x), (lmap f ^^ 0) (iterates f x))"
68.21 by simp
68.22 then show ?thesis by blast
68.23 qed
68.24 then show "h x = iterates f x"
68.25 proof (coinduct rule: llist_equalityI)
68.26 case (Eqllist q)
68.27 - then obtain u n where "q = ((lmap f ^ n) (h u), (lmap f ^ n) (iterates f u))"
68.28 + then obtain u n where "q = ((lmap f ^^ n) (h u), (lmap f ^^ n) (iterates f u))"
68.29 (is "_ = (?q1, ?q2)")
68.30 by auto
68.31 - also have "?q1 = LCons ((f ^ n) u) ((lmap f ^ Suc n) (h u))"
68.32 + also have "?q1 = LCons ((f ^^ n) u) ((lmap f ^^ Suc n) (h u))"
68.33 proof -
68.34 - have "?q1 = (lmap f ^ n) (LCons u (lmap f (h u)))"
68.35 + have "?q1 = (lmap f ^^ n) (LCons u (lmap f (h u)))"
68.36 by (subst h) rule
68.37 - also have "\<dots> = LCons ((f ^ n) u) ((lmap f ^ n) (lmap f (h u)))"
68.38 + also have "\<dots> = LCons ((f ^^ n) u) ((lmap f ^^ n) (lmap f (h u)))"
68.39 by (rule funpow_lmap)
68.40 - also have "(lmap f ^ n) (lmap f (h u)) = (lmap f ^ Suc n) (h u)"
68.41 + also have "(lmap f ^^ n) (lmap f (h u)) = (lmap f ^^ Suc n) (h u)"
68.42 by (simp add: funpow_swap1)
68.43 finally show ?thesis .
68.44 qed
68.45 - also have "?q2 = LCons ((f ^ n) u) ((lmap f ^ Suc n) (iterates f u))"
68.46 + also have "?q2 = LCons ((f ^^ n) u) ((lmap f ^^ Suc n) (iterates f u))"
68.47 proof -
68.48 - have "?q2 = (lmap f ^ n) (LCons u (iterates f (f u)))"
68.49 + have "?q2 = (lmap f ^^ n) (LCons u (iterates f (f u)))"
68.50 by (subst iterates) rule
68.51 - also have "\<dots> = LCons ((f ^ n) u) ((lmap f ^ n) (iterates f (f u)))"
68.52 + also have "\<dots> = LCons ((f ^^ n) u) ((lmap f ^^ n) (iterates f (f u)))"
68.53 by (rule funpow_lmap)
68.54 - also have "(lmap f ^ n) (iterates f (f u)) = (lmap f ^ Suc n) (iterates f u)"
68.55 + also have "(lmap f ^^ n) (iterates f (f u)) = (lmap f ^^ Suc n) (iterates f u)"
68.56 by (simp add: lmap_iterates funpow_swap1)
68.57 finally show ?thesis .
68.58 qed
69.1 --- a/src/HOL/Library/Commutative_Ring.thy Mon May 11 09:39:53 2009 +0200
69.2 +++ b/src/HOL/Library/Commutative_Ring.thy Mon May 11 17:20:52 2009 +0200
69.3 @@ -27,15 +27,15 @@
69.4
69.5 text {* Interpretation functions for the shadow syntax. *}
69.6
69.7 -fun
69.8 - Ipol :: "'a::{comm_ring,recpower} list \<Rightarrow> 'a pol \<Rightarrow> 'a"
69.9 +primrec
69.10 + Ipol :: "'a::{comm_ring_1} list \<Rightarrow> 'a pol \<Rightarrow> 'a"
69.11 where
69.12 "Ipol l (Pc c) = c"
69.13 | "Ipol l (Pinj i P) = Ipol (drop i l) P"
69.14 | "Ipol l (PX P x Q) = Ipol l P * (hd l)^x + Ipol (drop 1 l) Q"
69.15
69.16 -fun
69.17 - Ipolex :: "'a::{comm_ring,recpower} list \<Rightarrow> 'a polex \<Rightarrow> 'a"
69.18 +primrec
69.19 + Ipolex :: "'a::{comm_ring_1} list \<Rightarrow> 'a polex \<Rightarrow> 'a"
69.20 where
69.21 "Ipolex l (Pol P) = Ipol l P"
69.22 | "Ipolex l (Add P Q) = Ipolex l P + Ipolex l Q"
69.23 @@ -54,7 +54,7 @@
69.24 PX p1 y p2 \<Rightarrow> Pinj x P)"
69.25
69.26 definition
69.27 - mkPX :: "'a::{comm_ring,recpower} pol \<Rightarrow> nat \<Rightarrow> 'a pol \<Rightarrow> 'a pol" where
69.28 + mkPX :: "'a::{comm_ring} pol \<Rightarrow> nat \<Rightarrow> 'a pol \<Rightarrow> 'a pol" where
69.29 "mkPX P i Q = (case P of
69.30 Pc c \<Rightarrow> (if (c = 0) then (mkPinj 1 Q) else (PX P i Q)) |
69.31 Pinj j R \<Rightarrow> PX P i Q |
69.32 @@ -63,7 +63,7 @@
69.33 text {* Defining the basic ring operations on normalized polynomials *}
69.34
69.35 function
69.36 - add :: "'a::{comm_ring,recpower} pol \<Rightarrow> 'a pol \<Rightarrow> 'a pol" (infixl "\<oplus>" 65)
69.37 + add :: "'a::{comm_ring} pol \<Rightarrow> 'a pol \<Rightarrow> 'a pol" (infixl "\<oplus>" 65)
69.38 where
69.39 "Pc a \<oplus> Pc b = Pc (a + b)"
69.40 | "Pc c \<oplus> Pinj i P = Pinj i (P \<oplus> Pc c)"
69.41 @@ -90,7 +90,7 @@
69.42 termination by (relation "measure (\<lambda>(x, y). size x + size y)") auto
69.43
69.44 function
69.45 - mul :: "'a::{comm_ring,recpower} pol \<Rightarrow> 'a pol \<Rightarrow> 'a pol" (infixl "\<otimes>" 70)
69.46 + mul :: "'a::{comm_ring} pol \<Rightarrow> 'a pol \<Rightarrow> 'a pol" (infixl "\<otimes>" 70)
69.47 where
69.48 "Pc a \<otimes> Pc b = Pc (a * b)"
69.49 | "Pc c \<otimes> Pinj i P =
69.50 @@ -122,8 +122,8 @@
69.51 (auto simp add: mkPinj_def split: pol.split)
69.52
69.53 text {* Negation*}
69.54 -fun
69.55 - neg :: "'a::{comm_ring,recpower} pol \<Rightarrow> 'a pol"
69.56 +primrec
69.57 + neg :: "'a::{comm_ring} pol \<Rightarrow> 'a pol"
69.58 where
69.59 "neg (Pc c) = Pc (-c)"
69.60 | "neg (Pinj i P) = Pinj i (neg P)"
69.61 @@ -131,13 +131,13 @@
69.62
69.63 text {* Substraction *}
69.64 definition
69.65 - sub :: "'a::{comm_ring,recpower} pol \<Rightarrow> 'a pol \<Rightarrow> 'a pol" (infixl "\<ominus>" 65)
69.66 + sub :: "'a::{comm_ring} pol \<Rightarrow> 'a pol \<Rightarrow> 'a pol" (infixl "\<ominus>" 65)
69.67 where
69.68 "sub P Q = P \<oplus> neg Q"
69.69
69.70 text {* Square for Fast Exponentation *}
69.71 -fun
69.72 - sqr :: "'a::{comm_ring,recpower} pol \<Rightarrow> 'a pol"
69.73 +primrec
69.74 + sqr :: "'a::{comm_ring_1} pol \<Rightarrow> 'a pol"
69.75 where
69.76 "sqr (Pc c) = Pc (c * c)"
69.77 | "sqr (Pinj i P) = mkPinj i (sqr P)"
69.78 @@ -146,7 +146,7 @@
69.79
69.80 text {* Fast Exponentation *}
69.81 fun
69.82 - pow :: "nat \<Rightarrow> 'a::{comm_ring,recpower} pol \<Rightarrow> 'a pol"
69.83 + pow :: "nat \<Rightarrow> 'a::{comm_ring_1} pol \<Rightarrow> 'a pol"
69.84 where
69.85 "pow 0 P = Pc 1"
69.86 | "pow n P = (if even n then pow (n div 2) (sqr P)
69.87 @@ -161,8 +161,8 @@
69.88
69.89 text {* Normalization of polynomial expressions *}
69.90
69.91 -fun
69.92 - norm :: "'a::{comm_ring,recpower} polex \<Rightarrow> 'a pol"
69.93 +primrec
69.94 + norm :: "'a::{comm_ring_1} polex \<Rightarrow> 'a pol"
69.95 where
69.96 "norm (Pol P) = P"
69.97 | "norm (Add P Q) = norm P \<oplus> norm Q"
70.1 --- a/src/HOL/Library/Continuity.thy Mon May 11 09:39:53 2009 +0200
70.2 +++ b/src/HOL/Library/Continuity.thy Mon May 11 17:20:52 2009 +0200
70.3 @@ -5,7 +5,7 @@
70.4 header {* Continuity and iterations (of set transformers) *}
70.5
70.6 theory Continuity
70.7 -imports Relation_Power Main
70.8 +imports Transitive_Closure Main
70.9 begin
70.10
70.11 subsection {* Continuity for complete lattices *}
70.12 @@ -48,25 +48,25 @@
70.13 qed
70.14
70.15 lemma continuous_lfp:
70.16 - assumes "continuous F" shows "lfp F = (SUP i. (F^i) bot)"
70.17 + assumes "continuous F" shows "lfp F = (SUP i. (F ^^ i) bot)"
70.18 proof -
70.19 note mono = continuous_mono[OF `continuous F`]
70.20 - { fix i have "(F^i) bot \<le> lfp F"
70.21 + { fix i have "(F ^^ i) bot \<le> lfp F"
70.22 proof (induct i)
70.23 - show "(F^0) bot \<le> lfp F" by simp
70.24 + show "(F ^^ 0) bot \<le> lfp F" by simp
70.25 next
70.26 case (Suc i)
70.27 - have "(F^(Suc i)) bot = F((F^i) bot)" by simp
70.28 + have "(F ^^ Suc i) bot = F((F ^^ i) bot)" by simp
70.29 also have "\<dots> \<le> F(lfp F)" by(rule monoD[OF mono Suc])
70.30 also have "\<dots> = lfp F" by(simp add:lfp_unfold[OF mono, symmetric])
70.31 finally show ?case .
70.32 qed }
70.33 - hence "(SUP i. (F^i) bot) \<le> lfp F" by (blast intro!:SUP_leI)
70.34 - moreover have "lfp F \<le> (SUP i. (F^i) bot)" (is "_ \<le> ?U")
70.35 + hence "(SUP i. (F ^^ i) bot) \<le> lfp F" by (blast intro!:SUP_leI)
70.36 + moreover have "lfp F \<le> (SUP i. (F ^^ i) bot)" (is "_ \<le> ?U")
70.37 proof (rule lfp_lowerbound)
70.38 - have "chain(%i. (F^i) bot)"
70.39 + have "chain(%i. (F ^^ i) bot)"
70.40 proof -
70.41 - { fix i have "(F^i) bot \<le> (F^(Suc i)) bot"
70.42 + { fix i have "(F ^^ i) bot \<le> (F ^^ (Suc i)) bot"
70.43 proof (induct i)
70.44 case 0 show ?case by simp
70.45 next
70.46 @@ -74,7 +74,7 @@
70.47 qed }
70.48 thus ?thesis by(auto simp add:chain_def)
70.49 qed
70.50 - hence "F ?U = (SUP i. (F^(i+1)) bot)" using `continuous F` by (simp add:continuous_def)
70.51 + hence "F ?U = (SUP i. (F ^^ (i+1)) bot)" using `continuous F` by (simp add:continuous_def)
70.52 also have "\<dots> \<le> ?U" by(fast intro:SUP_leI le_SUPI)
70.53 finally show "F ?U \<le> ?U" .
70.54 qed
70.55 @@ -193,7 +193,7 @@
70.56
70.57 definition
70.58 up_iterate :: "('a set => 'a set) => nat => 'a set" where
70.59 - "up_iterate f n = (f^n) {}"
70.60 + "up_iterate f n = (f ^^ n) {}"
70.61
70.62 lemma up_iterate_0 [simp]: "up_iterate f 0 = {}"
70.63 by (simp add: up_iterate_def)
70.64 @@ -245,7 +245,7 @@
70.65
70.66 definition
70.67 down_iterate :: "('a set => 'a set) => nat => 'a set" where
70.68 - "down_iterate f n = (f^n) UNIV"
70.69 + "down_iterate f n = (f ^^ n) UNIV"
70.70
70.71 lemma down_iterate_0 [simp]: "down_iterate f 0 = UNIV"
70.72 by (simp add: down_iterate_def)
71.1 --- a/src/HOL/Library/Efficient_Nat.thy Mon May 11 09:39:53 2009 +0200
71.2 +++ b/src/HOL/Library/Efficient_Nat.thy Mon May 11 17:20:52 2009 +0200
71.3 @@ -179,10 +179,8 @@
71.4 else NONE
71.5 end;
71.6
71.7 -fun eqn_suc_preproc thy = map fst
71.8 - #> gen_eqn_suc_preproc
71.9 - @{thm Suc_if_eq} I (fst o Logic.dest_equals) thy
71.10 - #> (Option.map o map) (Code_Unit.mk_eqn thy);
71.11 +val eqn_suc_preproc = Code.simple_functrans (gen_eqn_suc_preproc
71.12 + @{thm Suc_if_eq} I (fst o Logic.dest_equals));
71.13
71.14 fun eqn_suc_preproc' thy thms = gen_eqn_suc_preproc
71.15 @{thm Suc_if_eq'} (snd o Thm.dest_comb) (fst o HOLogic.dest_eq o HOLogic.dest_Trueprop) thy thms
72.1 --- a/src/HOL/Library/Euclidean_Space.thy Mon May 11 09:39:53 2009 +0200
72.2 +++ b/src/HOL/Library/Euclidean_Space.thy Mon May 11 17:20:52 2009 +0200
72.3 @@ -253,13 +253,6 @@
72.4 "vector_power x 0 = 1"
72.5 | "vector_power x (Suc n) = x * vector_power x n"
72.6
72.7 -instantiation "^" :: (recpower,type) recpower
72.8 -begin
72.9 - definition vec_power_def: "op ^ \<equiv> vector_power"
72.10 - instance
72.11 - apply (intro_classes) by (simp_all add: vec_power_def)
72.12 -end
72.13 -
72.14 instance "^" :: (semiring,type) semiring
72.15 apply (intro_classes) by (vector ring_simps)+
72.16
72.17 @@ -600,7 +593,7 @@
72.18 from insert.prems have Fx: "f x \<ge> 0" and Fp: "\<forall> a \<in> F. f a \<ge> 0" by simp_all
72.19 from insert.hyps Fp setsum_nonneg[OF Fp]
72.20 have h: "setsum f F = 0 \<longleftrightarrow> (\<forall>a \<in>F. f a = 0)" by metis
72.21 - from sum_nonneg_eq_zero_iff[OF Fx setsum_nonneg[OF Fp]] insert.hyps(1,2)
72.22 + from add_nonneg_eq_0_iff[OF Fx setsum_nonneg[OF Fp]] insert.hyps(1,2)
72.23 show ?case by (simp add: h)
72.24 qed
72.25
72.26 @@ -2762,7 +2755,7 @@
72.27 (* Geometric progression. *)
72.28 (* ------------------------------------------------------------------------- *)
72.29
72.30 -lemma sum_gp_basic: "((1::'a::{field, recpower}) - x) * setsum (\<lambda>i. x^i) {0 .. n} = (1 - x^(Suc n))"
72.31 +lemma sum_gp_basic: "((1::'a::{field}) - x) * setsum (\<lambda>i. x^i) {0 .. n} = (1 - x^(Suc n))"
72.32 (is "?lhs = ?rhs")
72.33 proof-
72.34 {assume x1: "x = 1" hence ?thesis by simp}
72.35 @@ -2780,7 +2773,7 @@
72.36 qed
72.37
72.38 lemma sum_gp_multiplied: assumes mn: "m <= n"
72.39 - shows "((1::'a::{field, recpower}) - x) * setsum (op ^ x) {m..n} = x^m - x^ Suc n"
72.40 + shows "((1::'a::{field}) - x) * setsum (op ^ x) {m..n} = x^m - x^ Suc n"
72.41 (is "?lhs = ?rhs")
72.42 proof-
72.43 let ?S = "{0..(n - m)}"
72.44 @@ -2797,7 +2790,7 @@
72.45 by (simp add: ring_simps power_add[symmetric])
72.46 qed
72.47
72.48 -lemma sum_gp: "setsum (op ^ (x::'a::{field, recpower})) {m .. n} =
72.49 +lemma sum_gp: "setsum (op ^ (x::'a::{field})) {m .. n} =
72.50 (if n < m then 0 else if x = 1 then of_nat ((n + 1) - m)
72.51 else (x^ m - x^ (Suc n)) / (1 - x))"
72.52 proof-
72.53 @@ -2813,7 +2806,7 @@
72.54 ultimately show ?thesis by metis
72.55 qed
72.56
72.57 -lemma sum_gp_offset: "setsum (op ^ (x::'a::{field,recpower})) {m .. m+n} =
72.58 +lemma sum_gp_offset: "setsum (op ^ (x::'a::{field})) {m .. m+n} =
72.59 (if x = 1 then of_nat n + 1 else x^m * (1 - x^Suc n) / (1 - x))"
72.60 unfolding sum_gp[of x m "m + n"] power_Suc
72.61 by (simp add: ring_simps power_add)
73.1 --- a/src/HOL/Library/Eval_Witness.thy Mon May 11 09:39:53 2009 +0200
73.2 +++ b/src/HOL/Library/Eval_Witness.thy Mon May 11 17:20:52 2009 +0200
73.3 @@ -68,7 +68,7 @@
73.4 | dest_exs _ _ = sys_error "dest_exs";
73.5 val t = dest_exs (length ws) (HOLogic.dest_Trueprop goal);
73.6 in
73.7 - if Code_ML.eval_term ("Eval_Witness_Method.eval_ref", Eval_Witness_Method.eval_ref) thy t ws
73.8 + if Code_ML.eval NONE ("Eval_Witness_Method.eval_ref", Eval_Witness_Method.eval_ref) (K I) thy t ws
73.9 then Thm.cterm_of thy goal
73.10 else @{cprop True} (*dummy*)
73.11 end
74.1 --- a/src/HOL/Library/Float.thy Mon May 11 09:39:53 2009 +0200
74.2 +++ b/src/HOL/Library/Float.thy Mon May 11 17:20:52 2009 +0200
74.3 @@ -15,8 +15,8 @@
74.4
74.5 datatype float = Float int int
74.6
74.7 -fun Ifloat :: "float \<Rightarrow> real" where
74.8 -"Ifloat (Float a b) = real a * pow2 b"
74.9 +primrec Ifloat :: "float \<Rightarrow> real" where
74.10 + "Ifloat (Float a b) = real a * pow2 b"
74.11
74.12 instantiation float :: zero begin
74.13 definition zero_float where "0 = Float 0 0"
74.14 @@ -33,11 +33,11 @@
74.15 instance ..
74.16 end
74.17
74.18 -fun mantissa :: "float \<Rightarrow> int" where
74.19 -"mantissa (Float a b) = a"
74.20 +primrec mantissa :: "float \<Rightarrow> int" where
74.21 + "mantissa (Float a b) = a"
74.22
74.23 -fun scale :: "float \<Rightarrow> int" where
74.24 -"scale (Float a b) = b"
74.25 +primrec scale :: "float \<Rightarrow> int" where
74.26 + "scale (Float a b) = b"
74.27
74.28 lemma Ifloat_neg_exp: "e < 0 \<Longrightarrow> Ifloat (Float m e) = real m * inverse (2^nat (-e))" by auto
74.29 lemma Ifloat_nge0_exp: "\<not> 0 \<le> e \<Longrightarrow> Ifloat (Float m e) = real m * inverse (2^nat (-e))" by auto
74.30 @@ -320,12 +320,12 @@
74.31 end
74.32
74.33 instantiation float :: uminus begin
74.34 -fun uminus_float where [simp del]: "uminus_float (Float m e) = Float (-m) e"
74.35 +primrec uminus_float where [simp del]: "uminus_float (Float m e) = Float (-m) e"
74.36 instance ..
74.37 end
74.38
74.39 instantiation float :: minus begin
74.40 -fun minus_float where [simp del]: "(z::float) - w = z + (- w)"
74.41 +definition minus_float where [simp del]: "(z::float) - w = z + (- w)"
74.42 instance ..
74.43 end
74.44
74.45 @@ -334,11 +334,11 @@
74.46 instance ..
74.47 end
74.48
74.49 -fun float_pprt :: "float \<Rightarrow> float" where
74.50 -"float_pprt (Float a e) = (if 0 <= a then (Float a e) else 0)"
74.51 +primrec float_pprt :: "float \<Rightarrow> float" where
74.52 + "float_pprt (Float a e) = (if 0 <= a then (Float a e) else 0)"
74.53
74.54 -fun float_nprt :: "float \<Rightarrow> float" where
74.55 -"float_nprt (Float a e) = (if 0 <= a then 0 else (Float a e))"
74.56 +primrec float_nprt :: "float \<Rightarrow> float" where
74.57 + "float_nprt (Float a e) = (if 0 <= a then 0 else (Float a e))"
74.58
74.59 instantiation float :: ord begin
74.60 definition le_float_def: "z \<le> w \<equiv> Ifloat z \<le> Ifloat w"
74.61 @@ -354,7 +354,7 @@
74.62 by (cases a, simp add: uminus_float.simps)
74.63
74.64 lemma Ifloat_sub[simp]: "Ifloat (a - b) = Ifloat a - Ifloat b"
74.65 - by (cases a, cases b, simp add: minus_float.simps)
74.66 + by (cases a, cases b, simp add: minus_float_def)
74.67
74.68 lemma Ifloat_mult[simp]: "Ifloat (a*b) = Ifloat a * Ifloat b"
74.69 by (cases a, cases b, simp add: times_float.simps pow2_add)
74.70 @@ -443,37 +443,8 @@
74.71 lemma Ifloat_min: "Ifloat (min x y) = min (Ifloat x) (Ifloat y)" unfolding min_def le_float_def by auto
74.72 lemma Ifloat_max: "Ifloat (max a b) = max (Ifloat a) (Ifloat b)" unfolding max_def le_float_def by auto
74.73
74.74 -instantiation float :: power begin
74.75 -fun power_float where [simp del]: "(Float m e) ^ n = Float (m ^ n) (e * int n)"
74.76 -instance ..
74.77 -end
74.78 -
74.79 -instance float :: recpower
74.80 -proof (intro_classes)
74.81 - fix a :: float show "a ^ 0 = 1" by (cases a, auto simp add: power_float.simps one_float_def)
74.82 -next
74.83 - fix a :: float and n :: nat show "a ^ (Suc n) = a * a ^ n"
74.84 - by (cases a, auto simp add: power_float.simps times_float.simps algebra_simps)
74.85 -qed
74.86 -
74.87 -lemma float_power: "Ifloat (x ^ n) = (Ifloat x) ^ n"
74.88 -proof (cases x)
74.89 - case (Float m e)
74.90 -
74.91 - have "pow2 e ^ n = pow2 (e * int n)"
74.92 - proof (cases "e >= 0")
74.93 - case True hence e_nat: "e = int (nat e)" by auto
74.94 - hence "pow2 e ^ n = (2 ^ nat e) ^ n" using pow2_int[of "nat e"] by auto
74.95 - thus ?thesis unfolding power_mult[symmetric] unfolding pow2_int[symmetric] int_mult e_nat[symmetric] .
74.96 - next
74.97 - case False hence e_minus: "-e = int (nat (-e))" by auto
74.98 - hence "pow2 (-e) ^ n = (2 ^ nat (-e)) ^ n" using pow2_int[of "nat (-e)"] by auto
74.99 - hence "pow2 (-e) ^ n = pow2 ((-e) * int n)" unfolding power_mult[symmetric] unfolding pow2_int[symmetric] int_mult e_minus[symmetric] zmult_zminus .
74.100 - 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]
74.101 - using nonzero_inverse_eq_imp_eq[OF _ pow2_neq_zero pow2_neq_zero] by auto
74.102 - qed
74.103 - thus ?thesis by (auto simp add: Float power_mult_distrib Ifloat.simps power_float.simps)
74.104 -qed
74.105 +lemma float_power: "Ifloat (x ^ n) = Ifloat x ^ n"
74.106 + by (induct n) simp_all
74.107
74.108 lemma zero_le_pow2[simp]: "0 \<le> pow2 s"
74.109 apply (subgoal_tac "0 < pow2 s")
74.110 @@ -1182,12 +1153,12 @@
74.111 unfolding x_eq y_eq float_divr.simps Let_def le_float_def Ifloat_0 Ifloat_mult by (auto intro!: mult_nonneg_nonpos)
74.112 qed
74.113
74.114 -fun round_down :: "nat \<Rightarrow> float \<Rightarrow> float" where
74.115 +primrec round_down :: "nat \<Rightarrow> float \<Rightarrow> float" where
74.116 "round_down prec (Float m e) = (let d = bitlen m - int prec in
74.117 if 0 < d then let P = 2^nat d ; n = m div P in Float n (e + d)
74.118 else Float m e)"
74.119
74.120 -fun round_up :: "nat \<Rightarrow> float \<Rightarrow> float" where
74.121 +primrec round_up :: "nat \<Rightarrow> float \<Rightarrow> float" where
74.122 "round_up prec (Float m e) = (let d = bitlen m - int prec in
74.123 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)
74.124 else Float m e)"
74.125 @@ -1314,8 +1285,8 @@
74.126 finally show ?thesis .
74.127 qed
74.128
74.129 -fun float_abs :: "float \<Rightarrow> float" where
74.130 -"float_abs (Float m e) = Float \<bar>m\<bar> e"
74.131 +primrec float_abs :: "float \<Rightarrow> float" where
74.132 + "float_abs (Float m e) = Float \<bar>m\<bar> e"
74.133
74.134 instantiation float :: abs begin
74.135 definition abs_float_def: "\<bar>x\<bar> = float_abs x"
74.136 @@ -1329,8 +1300,8 @@
74.137 thus ?thesis unfolding Float abs_float_def float_abs.simps Ifloat.simps by auto
74.138 qed
74.139
74.140 -fun floor_fl :: "float \<Rightarrow> float" where
74.141 -"floor_fl (Float m e) = (if 0 \<le> e then Float m e
74.142 +primrec floor_fl :: "float \<Rightarrow> float" where
74.143 + "floor_fl (Float m e) = (if 0 \<le> e then Float m e
74.144 else Float (m div (2 ^ (nat (-e)))) 0)"
74.145
74.146 lemma floor_fl: "Ifloat (floor_fl x) \<le> Ifloat x"
74.147 @@ -1358,8 +1329,8 @@
74.148
74.149 declare floor_fl.simps[simp del]
74.150
74.151 -fun ceiling_fl :: "float \<Rightarrow> float" where
74.152 -"ceiling_fl (Float m e) = (if 0 \<le> e then Float m e
74.153 +primrec ceiling_fl :: "float \<Rightarrow> float" where
74.154 + "ceiling_fl (Float m e) = (if 0 \<le> e then Float m e
74.155 else Float (m div (2 ^ (nat (-e))) + 1) 0)"
74.156
74.157 lemma ceiling_fl: "Ifloat x \<le> Ifloat (ceiling_fl x)"
75.1 --- a/src/HOL/Library/Formal_Power_Series.thy Mon May 11 09:39:53 2009 +0200
75.2 +++ b/src/HOL/Library/Formal_Power_Series.thy Mon May 11 17:20:52 2009 +0200
75.3 @@ -680,30 +680,12 @@
75.4
75.5 subsection {* Powers*}
75.6
75.7 -instantiation fps :: (semiring_1) power
75.8 -begin
75.9 -
75.10 -fun fps_pow :: "nat \<Rightarrow> 'a fps \<Rightarrow> 'a fps" where
75.11 - "fps_pow 0 f = 1"
75.12 -| "fps_pow (Suc n) f = f * fps_pow n f"
75.13 -
75.14 -definition fps_power_def: "power (f::'a fps) n = fps_pow n f"
75.15 -instance ..
75.16 -end
75.17 -
75.18 -instantiation fps :: (comm_ring_1) recpower
75.19 -begin
75.20 -instance
75.21 - apply (intro_classes)
75.22 - by (simp_all add: fps_power_def)
75.23 -end
75.24 -
75.25 lemma fps_power_zeroth_eq_one: "a$0 =1 \<Longrightarrow> a^n $ 0 = (1::'a::semiring_1)"
75.26 - by (induct n, auto simp add: fps_power_def expand_fps_eq fps_mult_nth)
75.27 + by (induct n, auto simp add: expand_fps_eq fps_mult_nth)
75.28
75.29 lemma fps_power_first_eq: "(a:: 'a::comm_ring_1 fps)$0 =1 \<Longrightarrow> a^n $ 1 = of_nat n * a$1"
75.30 proof(induct n)
75.31 - case 0 thus ?case by (simp add: fps_power_def)
75.32 + case 0 thus ?case by simp
75.33 next
75.34 case (Suc n)
75.35 note h = Suc.hyps[OF `a$0 = 1`]
75.36 @@ -712,16 +694,16 @@
75.37 qed
75.38
75.39 lemma startsby_one_power:"a $ 0 = (1::'a::comm_ring_1) \<Longrightarrow> a^n $ 0 = 1"
75.40 - by (induct n, auto simp add: fps_power_def fps_mult_nth)
75.41 + by (induct n, auto simp add: fps_mult_nth)
75.42
75.43 lemma startsby_zero_power:"a $0 = (0::'a::comm_ring_1) \<Longrightarrow> n > 0 \<Longrightarrow> a^n $0 = 0"
75.44 - by (induct n, auto simp add: fps_power_def fps_mult_nth)
75.45 + by (induct n, auto simp add: fps_mult_nth)
75.46
75.47 -lemma startsby_power:"a $0 = (v::'a::{comm_ring_1, recpower}) \<Longrightarrow> a^n $0 = v^n"
75.48 - by (induct n, auto simp add: fps_power_def fps_mult_nth power_Suc)
75.49 +lemma startsby_power:"a $0 = (v::'a::{comm_ring_1}) \<Longrightarrow> a^n $0 = v^n"
75.50 + by (induct n, auto simp add: fps_mult_nth power_Suc)
75.51
75.52 lemma startsby_zero_power_iff[simp]:
75.53 - "a^n $0 = (0::'a::{idom, recpower}) \<longleftrightarrow> (n \<noteq> 0 \<and> a$0 = 0)"
75.54 + "a^n $0 = (0::'a::{idom}) \<longleftrightarrow> (n \<noteq> 0 \<and> a$0 = 0)"
75.55 apply (rule iffI)
75.56 apply (induct n, auto simp add: power_Suc fps_mult_nth)
75.57 by (rule startsby_zero_power, simp_all)
75.58 @@ -764,7 +746,7 @@
75.59 apply (rule startsby_zero_power_prefix[rule_format, OF a0])
75.60 by arith
75.61
75.62 -lemma startsby_zero_power_nth_same: assumes a0: "a$0 = (0::'a::{recpower, idom})"
75.63 +lemma startsby_zero_power_nth_same: assumes a0: "a$0 = (0::'a::{idom})"
75.64 shows "a^n $ n = (a$1) ^ n"
75.65 proof(induct n)
75.66 case 0 thus ?case by (simp add: power_0)
75.67 @@ -785,7 +767,7 @@
75.68 qed
75.69
75.70 lemma fps_inverse_power:
75.71 - fixes a :: "('a::{field, recpower}) fps"
75.72 + fixes a :: "('a::{field}) fps"
75.73 shows "inverse (a^n) = inverse a ^ n"
75.74 proof-
75.75 {assume a0: "a$0 = 0"
75.76 @@ -874,7 +856,7 @@
75.77
75.78 subsection{* The eXtractor series X*}
75.79
75.80 -lemma minus_one_power_iff: "(- (1::'a :: {recpower, comm_ring_1})) ^ n = (if even n then 1 else - 1)"
75.81 +lemma minus_one_power_iff: "(- (1::'a :: {comm_ring_1})) ^ n = (if even n then 1 else - 1)"
75.82 by (induct n, auto)
75.83
75.84 definition "X = Abs_fps (\<lambda>n. if n = 1 then 1 else 0)"
75.85 @@ -901,7 +883,7 @@
75.86
75.87 lemma X_power_iff: "X^k = Abs_fps (\<lambda>n. if n = k then (1::'a::comm_ring_1) else 0)"
75.88 proof(induct k)
75.89 - case 0 thus ?case by (simp add: X_def fps_power_def fps_eq_iff)
75.90 + case 0 thus ?case by (simp add: X_def fps_eq_iff)
75.91 next
75.92 case (Suc k)
75.93 {fix m
75.94 @@ -931,7 +913,7 @@
75.95 by (simp add: X_power_iff)
75.96
75.97 lemma fps_inverse_X_plus1:
75.98 - "inverse (1 + X) = Abs_fps (\<lambda>n. (- (1::'a::{recpower, field})) ^ n)" (is "_ = ?r")
75.99 + "inverse (1 + X) = Abs_fps (\<lambda>n. (- (1::'a::{field})) ^ n)" (is "_ = ?r")
75.100 proof-
75.101 have eq: "(1 + X) * ?r = 1"
75.102 unfolding minus_one_power_iff
75.103 @@ -979,7 +961,7 @@
75.104 (* {a_{n+k}}_0^infty Corresponds to (f - setsum (\<lambda>i. a_i * x^i))/x^h, for h>0*)
75.105
75.106 lemma fps_power_mult_eq_shift:
75.107 - "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")
75.108 + "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")
75.109 proof-
75.110 {fix n:: nat
75.111 have "?lhs $ n = (if n < Suc k then 0 else a n)"
75.112 @@ -990,7 +972,7 @@
75.113 next
75.114 case (Suc k)
75.115 note th = Suc.hyps[symmetric]
75.116 - 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)
75.117 + 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)
75.118 also have "\<dots> = (if n < Suc k then 0 else a n) - (fps_const (a (Suc k)) * X^ Suc k)$n"
75.119 using th
75.120 unfolding fps_sub_nth by simp
75.121 @@ -1022,13 +1004,16 @@
75.122 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)"
75.123 by simp
75.124
75.125 -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)"
75.126 +lemma XDN_linear:
75.127 + "(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)"
75.128 by (induct n, simp_all)
75.129
75.130 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)
75.131
75.132 -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)"
75.133 -by (induct k arbitrary: a) (simp_all add: power_Suc XD_def fps_eq_iff ring_simps del: One_nat_def)
75.134 +
75.135 +lemma fps_mult_XD_shift:
75.136 + "(XD ^^ k) (a:: ('a::{comm_ring_1}) fps) = Abs_fps (\<lambda>n. (of_nat n ^ k) * a$n)"
75.137 + by (induct k arbitrary: a) (simp_all add: power_Suc XD_def fps_eq_iff ring_simps del: One_nat_def)
75.138
75.139 subsubsection{* Rule 3 is trivial and is given by @{text fps_times_def}*}
75.140 subsubsection{* Rule 5 --- summation and "division" by (1 - X)*}
75.141 @@ -1309,7 +1294,7 @@
75.142 by (cases m, simp_all add: fps_power_nth_Suc del: power_Suc)
75.143
75.144 lemma fps_nth_power_0:
75.145 - fixes m :: nat and a :: "('a::{comm_ring_1, recpower}) fps"
75.146 + fixes m :: nat and a :: "('a::{comm_ring_1}) fps"
75.147 shows "(a ^m)$0 = (a$0) ^ m"
75.148 proof-
75.149 {assume "m=0" hence ?thesis by simp}
75.150 @@ -1325,7 +1310,7 @@
75.151 qed
75.152
75.153 lemma fps_compose_inj_right:
75.154 - assumes a0: "a$0 = (0::'a::{recpower,idom})"
75.155 + assumes a0: "a$0 = (0::'a::{idom})"
75.156 and a1: "a$1 \<noteq> 0"
75.157 shows "(b oo a = c oo a) \<longleftrightarrow> b = c" (is "?lhs \<longleftrightarrow>?rhs")
75.158 proof-
75.159 @@ -1366,7 +1351,7 @@
75.160 subsection {* Radicals *}
75.161
75.162 declare setprod_cong[fundef_cong]
75.163 -function radical :: "(nat \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> ('a::{field, recpower}) fps \<Rightarrow> nat \<Rightarrow> 'a" where
75.164 +function radical :: "(nat \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> ('a::{field}) fps \<Rightarrow> nat \<Rightarrow> 'a" where
75.165 "radical r 0 a 0 = 1"
75.166 | "radical r 0 a (Suc n) = 0"
75.167 | "radical r (Suc k) a 0 = r (Suc k) (a$0)"
75.168 @@ -1454,7 +1439,68 @@
75.169 qed
75.170
75.171 lemma power_radical:
75.172 - fixes a:: "'a ::{field, ring_char_0, recpower} fps"
75.173 + fixes a:: "'a ::{field, ring_char_0} fps"
75.174 + assumes a0: "a$0 \<noteq> 0"
75.175 + shows "(r (Suc k) (a$0)) ^ Suc k = a$0 \<longleftrightarrow> (fps_radical r (Suc k) a) ^ (Suc k) = a"
75.176 +proof-
75.177 + let ?r = "fps_radical r (Suc k) a"
75.178 + {assume r0: "(r (Suc k) (a$0)) ^ Suc k = a$0"
75.179 + from a0 r0 have r00: "r (Suc k) (a$0) \<noteq> 0" by auto
75.180 + {fix z have "?r ^ Suc k $ z = a$z"
75.181 + proof(induct z rule: nat_less_induct)
75.182 + fix n assume H: "\<forall>m<n. ?r ^ Suc k $ m = a$m"
75.183 + {assume "n = 0" hence "?r ^ Suc k $ n = a $n"
75.184 + using fps_radical_power_nth[of r "Suc k" a, OF r0] by simp}
75.185 + moreover
75.186 + {fix n1 assume n1: "n = Suc n1"
75.187 + have fK: "finite {0..k}" by simp
75.188 + have nz: "n \<noteq> 0" using n1 by arith
75.189 + let ?Pnk = "natpermute n (k + 1)"
75.190 + let ?Pnkn = "{xs \<in> ?Pnk. n \<in> set xs}"
75.191 + let ?Pnknn = "{xs \<in> ?Pnk. n \<notin> set xs}"
75.192 + have eq: "?Pnkn \<union> ?Pnknn = ?Pnk" by blast
75.193 + have d: "?Pnkn \<inter> ?Pnknn = {}" by blast
75.194 + have f: "finite ?Pnkn" "finite ?Pnknn"
75.195 + using finite_Un[of ?Pnkn ?Pnknn, unfolded eq]
75.196 + by (metis natpermute_finite)+
75.197 + let ?f = "\<lambda>v. \<Prod>j\<in>{0..k}. ?r $ v ! j"
75.198 + have "setsum ?f ?Pnkn = setsum (\<lambda>v. ?r $ n * r (Suc k) (a $ 0) ^ k) ?Pnkn"
75.199 + proof(rule setsum_cong2)
75.200 + fix v assume v: "v \<in> {xs \<in> natpermute n (k + 1). n \<in> set xs}"
75.201 + 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"
75.202 + from v obtain i where i: "i \<in> {0..k}" "v = replicate (k+1) 0 [i:= n]"
75.203 + unfolding natpermute_contain_maximal by auto
75.204 + 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))"
75.205 + apply (rule setprod_cong, simp)
75.206 + using i r0 by (simp del: replicate.simps)
75.207 + also have "\<dots> = (fps_radical r (Suc k) a $ n) * r (Suc k) (a$0) ^ k"
75.208 + unfolding setprod_gen_delta[OF fK] using i r0 by simp
75.209 + finally show ?ths .
75.210 + qed
75.211 + then have "setsum ?f ?Pnkn = of_nat (k+1) * ?r $ n * r (Suc k) (a $ 0) ^ k"
75.212 + by (simp add: natpermute_max_card[OF nz, simplified])
75.213 + also have "\<dots> = a$n - setsum ?f ?Pnknn"
75.214 + unfolding n1 using r00 a0 by (simp add: field_simps fps_radical_def del: of_nat_Suc )
75.215 + finally have fn: "setsum ?f ?Pnkn = a$n - setsum ?f ?Pnknn" .
75.216 + have "(?r ^ Suc k)$n = setsum ?f ?Pnkn + setsum ?f ?Pnknn"
75.217 + unfolding fps_power_nth_Suc setsum_Un_disjoint[OF f d, unfolded eq] ..
75.218 + also have "\<dots> = a$n" unfolding fn by simp
75.219 + finally have "?r ^ Suc k $ n = a $n" .}
75.220 + ultimately show "?r ^ Suc k $ n = a $n" by (cases n, auto)
75.221 + qed }
75.222 + then have ?thesis using r0 by (simp add: fps_eq_iff)}
75.223 +moreover
75.224 +{ assume h: "(fps_radical r (Suc k) a) ^ (Suc k) = a"
75.225 + hence "((fps_radical r (Suc k) a) ^ (Suc k))$0 = a$0" by simp
75.226 + then have "(r (Suc k) (a$0)) ^ Suc k = a$0"
75.227 + unfolding fps_power_nth_Suc
75.228 + by (simp add: setprod_constant del: replicate.simps)}
75.229 +ultimately show ?thesis by blast
75.230 +qed
75.231 +
75.232 +(*
75.233 +lemma power_radical:
75.234 + fixes a:: "'a ::{field, ring_char_0} fps"
75.235 assumes r0: "(r (Suc k) (a$0)) ^ Suc k = a$0" and a0: "a$0 \<noteq> 0"
75.236 shows "(fps_radical r (Suc k) a) ^ (Suc k) = a"
75.237 proof-
75.238 @@ -1505,6 +1551,7 @@
75.239 then show ?thesis by (simp add: fps_eq_iff)
75.240 qed
75.241
75.242 +*)
75.243 lemma eq_divide_imp': assumes c0: "(c::'a::field) ~= 0" and eq: "a * c = b"
75.244 shows "a = b / c"
75.245 proof-
75.246 @@ -1515,16 +1562,15 @@
75.247
75.248 lemma radical_unique:
75.249 assumes r0: "(r (Suc k) (b$0)) ^ Suc k = b$0"
75.250 - and a0: "r (Suc k) (b$0 ::'a::{field, ring_char_0, recpower}) = a$0" and b0: "b$0 \<noteq> 0"
75.251 + and a0: "r (Suc k) (b$0 ::'a::{field, ring_char_0}) = a$0" and b0: "b$0 \<noteq> 0"
75.252 shows "a^(Suc k) = b \<longleftrightarrow> a = fps_radical r (Suc k) b"
75.253 proof-
75.254 let ?r = "fps_radical r (Suc k) b"
75.255 have r00: "r (Suc k) (b$0) \<noteq> 0" using b0 r0 by auto
75.256 {assume H: "a = ?r"
75.257 - from H have "a^Suc k = b" using power_radical[of r k, OF r0 b0] by simp}
75.258 + from H have "a^Suc k = b" using power_radical[OF b0, of r k, unfolded r0] by simp}
75.259 moreover
75.260 {assume H: "a^Suc k = b"
75.261 - (* Generally a$0 would need to be the k+1 st root of b$0 *)
75.262 have ceq: "card {0..k} = Suc k" by simp
75.263 have fk: "finite {0..k}" by simp
75.264 from a0 have a0r0: "a$0 = ?r$0" by simp
75.265 @@ -1610,7 +1656,7 @@
75.266
75.267 lemma radical_power:
75.268 assumes r0: "r (Suc k) ((a$0) ^ Suc k) = a$0"
75.269 - and a0: "(a$0 ::'a::{field, ring_char_0, recpower}) \<noteq> 0"
75.270 + and a0: "(a$0 ::'a::{field, ring_char_0}) \<noteq> 0"
75.271 shows "(fps_radical r (Suc k) (a ^ Suc k)) = a"
75.272 proof-
75.273 let ?ak = "a^ Suc k"
75.274 @@ -1622,7 +1668,7 @@
75.275 qed
75.276
75.277 lemma fps_deriv_radical:
75.278 - fixes a:: "'a ::{field, ring_char_0, recpower} fps"
75.279 + fixes a:: "'a ::{field, ring_char_0} fps"
75.280 assumes r0: "(r (Suc k) (a$0)) ^ Suc k = a$0" and a0: "a$0 \<noteq> 0"
75.281 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)"
75.282 proof-
75.283 @@ -1632,7 +1678,7 @@
75.284 from r0' have w0: "?w $ 0 \<noteq> 0" by (simp del: of_nat_Suc)
75.285 note th0 = inverse_mult_eq_1[OF w0]
75.286 let ?iw = "inverse ?w"
75.287 - from power_radical[of r, OF r0 a0]
75.288 + from iffD1[OF power_radical[of a r], OF a0 r0]
75.289 have "fps_deriv (?r ^ Suc k) = fps_deriv a" by simp
75.290 hence "fps_deriv ?r * ?w = fps_deriv a"
75.291 by (simp add: fps_deriv_power mult_ac del: power_Suc)
75.292 @@ -1643,11 +1689,45 @@
75.293 qed
75.294
75.295 lemma radical_mult_distrib:
75.296 - fixes a:: "'a ::{field, ring_char_0, recpower} fps"
75.297 + fixes a:: "'a ::{field, ring_char_0} fps"
75.298 assumes
75.299 - ra0: "r (k) (a $ 0) ^ k = a $ 0"
75.300 - and rb0: "r (k) (b $ 0) ^ k = b $ 0"
75.301 - and r0': "r (k) ((a * b) $ 0) = r (k) (a $ 0) * r (k) (b $ 0)"
75.302 + k: "k > 0"
75.303 + and ra0: "r k (a $ 0) ^ k = a $ 0"
75.304 + and rb0: "r k (b $ 0) ^ k = b $ 0"
75.305 + and a0: "a$0 \<noteq> 0"
75.306 + and b0: "b$0 \<noteq> 0"
75.307 + 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)"
75.308 +proof-
75.309 + {assume r0': "r k ((a * b) $ 0) = r k (a $ 0) * r k (b $ 0)"
75.310 + from r0' have r0: "(r (k) ((a*b)$0)) ^ k = (a*b)$0"
75.311 + by (simp add: fps_mult_nth ra0 rb0 power_mult_distrib)
75.312 + {assume "k=0" hence ?thesis using r0' by simp}
75.313 + moreover
75.314 + {fix h assume k: "k = Suc h"
75.315 + let ?ra = "fps_radical r (Suc h) a"
75.316 + let ?rb = "fps_radical r (Suc h) b"
75.317 + have th0: "r (Suc h) ((a * b) $ 0) = (fps_radical r (Suc h) a * fps_radical r (Suc h) b) $ 0"
75.318 + using r0' k by (simp add: fps_mult_nth)
75.319 + have ab0: "(a*b) $ 0 \<noteq> 0" using a0 b0 by (simp add: fps_mult_nth)
75.320 + 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]
75.321 + iffD1[OF power_radical[of _ r], OF a0 ra0[unfolded k]] iffD1[OF power_radical[of _ r], OF b0 rb0[unfolded k]] k r0'
75.322 + have ?thesis by (auto simp add: power_mult_distrib simp del: power_Suc)}
75.323 +ultimately have ?thesis by (cases k, auto)}
75.324 +moreover
75.325 +{assume h: "fps_radical r k (a*b) = fps_radical r k a * fps_radical r k b"
75.326 + hence "(fps_radical r k (a*b))$0 = (fps_radical r k a * fps_radical r k b)$0" by simp
75.327 + then have "r k ((a * b) $ 0) = r k (a $ 0) * r k (b $ 0)"
75.328 + using k by (simp add: fps_mult_nth)}
75.329 +ultimately show ?thesis by blast
75.330 +qed
75.331 +
75.332 +(*
75.333 +lemma radical_mult_distrib:
75.334 + fixes a:: "'a ::{field, ring_char_0} fps"
75.335 + assumes
75.336 + ra0: "r k (a $ 0) ^ k = a $ 0"
75.337 + and rb0: "r k (b $ 0) ^ k = b $ 0"
75.338 + and r0': "r k ((a * b) $ 0) = r k (a $ 0) * r k (b $ 0)"
75.339 and a0: "a$0 \<noteq> 0"
75.340 and b0: "b$0 \<noteq> 0"
75.341 shows "fps_radical r (k) (a*b) = fps_radical r (k) a * fps_radical r (k) (b)"
75.342 @@ -1667,87 +1747,59 @@
75.343 have ?thesis by (auto simp add: power_mult_distrib simp del: power_Suc)}
75.344 ultimately show ?thesis by (cases k, auto)
75.345 qed
75.346 +*)
75.347
75.348 -lemma radical_inverse:
75.349 - fixes a:: "'a ::{field, ring_char_0, recpower} fps"
75.350 - assumes
75.351 - ra0: "r (k) (a $ 0) ^ k = a $ 0"
75.352 - and ria0: "r (k) (inverse (a $ 0)) = inverse (r (k) (a $ 0))"
75.353 - and r1: "(r (k) 1) = 1"
75.354 - and a0: "a$0 \<noteq> 0"
75.355 - shows "fps_radical r (k) (inverse a) = inverse (fps_radical r (k) a)"
75.356 -proof-
75.357 - {assume "k=0" then have ?thesis by simp}
75.358 - moreover
75.359 - {fix h assume k[simp]: "k = Suc h"
75.360 - let ?ra = "fps_radical r (Suc h) a"
75.361 - let ?ria = "fps_radical r (Suc h) (inverse a)"
75.362 - from ra0 a0 have th00: "r (Suc h) (a$0) \<noteq> 0" by auto
75.363 - have ria0': "r (Suc h) (inverse a $ 0) ^ Suc h = inverse a$0"
75.364 - using ria0 ra0 a0
75.365 - by (simp add: fps_inverse_def nonzero_power_inverse[OF th00, symmetric]
75.366 - del: power_Suc)
75.367 - from inverse_mult_eq_1[OF a0] have th0: "a * inverse a = 1"
75.368 - by (simp add: mult_commute)
75.369 - from radical_unique[where a=1 and b=1 and r=r and k=h, simplified, OF r1[unfolded k]]
75.370 - have th01: "fps_radical r (Suc h) 1 = 1" .
75.371 - have th1: "r (Suc h) ((a * inverse a) $ 0) ^ Suc h = (a * inverse a) $ 0"
75.372 - "r (Suc h) ((a * inverse a) $ 0) =
75.373 -r (Suc h) (a $ 0) * r (Suc h) (inverse a $ 0)"
75.374 - using r1 unfolding th0 apply (simp_all add: ria0[symmetric])
75.375 - apply (simp add: fps_inverse_def a0)
75.376 - unfolding ria0[unfolded k]
75.377 - using th00 by simp
75.378 - from nonzero_imp_inverse_nonzero[OF a0] a0
75.379 - have th2: "inverse a $ 0 \<noteq> 0" by (simp add: fps_inverse_def)
75.380 - from radical_mult_distrib[of r "Suc h" a "inverse a", OF ra0[unfolded k] ria0' th1(2) a0 th2]
75.381 - have th3: "?ra * ?ria = 1" unfolding th0 th01 by simp
75.382 - from th00 have ra0: "?ra $ 0 \<noteq> 0" by simp
75.383 - from fps_inverse_unique[OF ra0 th3] have ?thesis by simp}
75.384 -ultimately show ?thesis by (cases k, auto)
75.385 -qed
75.386 -
75.387 -lemma fps_divide_inverse: "(a::('a::field) fps) / b = a * inverse b"
75.388 +lemma fps_divide_1[simp]: "(a:: ('a::field) fps) / 1 = a"
75.389 by (simp add: fps_divide_def)
75.390
75.391 lemma radical_divide:
75.392 - fixes a:: "'a ::{field, ring_char_0, recpower} fps"
75.393 + fixes a:: "'a ::{field, ring_char_0} fps"
75.394 assumes
75.395 - ra0: "r k (a $ 0) ^ k = a $ 0"
75.396 - and rb0: "r k (b $ 0) ^ k = b $ 0"
75.397 - and r1: "r k 1 = 1"
75.398 - and rb0': "r k (inverse (b $ 0)) = inverse (r k (b $ 0))"
75.399 - and raib': "r k (a$0 / (b$0)) = r k (a$0) / r k (b$0)"
75.400 + kp: "k>0"
75.401 + and ra0: "(r k (a $ 0)) ^ k = a $ 0"
75.402 + and rb0: "(r k (b $ 0)) ^ k = b $ 0"
75.403 and a0: "a$0 \<noteq> 0"
75.404 and b0: "b$0 \<noteq> 0"
75.405 - shows "fps_radical r k (a/b) = fps_radical r k a / fps_radical r k b"
75.406 + 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")
75.407 proof-
75.408 - from raib'
75.409 - have raib: "r k (a$0 / (b$0)) = r k (a$0) * r k (inverse (b$0))"
75.410 - by (simp add: divide_inverse rb0'[symmetric])
75.411 + let ?r = "fps_radical r k"
75.412 + from kp obtain h where k: "k = Suc h" by (cases k, auto)
75.413 + have ra0': "r k (a$0) \<noteq> 0" using a0 ra0 k by auto
75.414 + have rb0': "r k (b$0) \<noteq> 0" using b0 rb0 k by auto
75.415
75.416 - {assume "k=0" hence ?thesis by (simp add: fps_divide_def)}
75.417 + {assume ?rhs
75.418 + then have "?r (a/b) $ 0 = (?r a / ?r b)$0" by simp
75.419 + then have ?lhs using k a0 b0 rb0'
75.420 + by (simp add: fps_divide_def fps_mult_nth fps_inverse_def divide_inverse) }
75.421 moreover
75.422 - {assume k0: "k\<noteq> 0"
75.423 - from b0 k0 rb0 have rbn0: "r k (b $0) \<noteq> 0"
75.424 - by (auto simp add: power_0_left)
75.425 + {assume h: ?lhs
75.426 + from a0 b0 have ab0[simp]: "(a/b)$0 = a$0 / b$0"
75.427 + by (simp add: fps_divide_def fps_mult_nth divide_inverse fps_inverse_def)
75.428 + have th0: "r k ((a/b)$0) ^ k = (a/b)$0"
75.429 + by (simp add: h nonzero_power_divide[OF rb0'] ra0 rb0 del: k)
75.430 + from a0 b0 ra0' rb0' kp h
75.431 + have th1: "r k ((a / b) $ 0) = (fps_radical r k a / fps_radical r k b) $ 0"
75.432 + by (simp add: fps_divide_def fps_mult_nth fps_inverse_def divide_inverse del: k)
75.433 + from a0 b0 ra0' rb0' kp have ab0': "(a / b) $ 0 \<noteq> 0"
75.434 + by (simp add: fps_divide_def fps_mult_nth fps_inverse_def nonzero_imp_inverse_nonzero)
75.435 + note tha[simp] = iffD1[OF power_radical[where r=r and k=h], OF a0 ra0[unfolded k], unfolded k[symmetric]]
75.436 + note thb[simp] = iffD1[OF power_radical[where r=r and k=h], OF b0 rb0[unfolded k], unfolded k[symmetric]]
75.437 + have th2: "(?r a / ?r b)^k = a/b"
75.438 + by (simp add: fps_divide_def power_mult_distrib fps_inverse_power[symmetric])
75.439 + 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 .}
75.440 + ultimately show ?thesis by blast
75.441 +qed
75.442
75.443 - from rb0 rb0' have rib0: "(r k (inverse (b $ 0)))^k = inverse (b$0)"
75.444 - by (simp add: nonzero_power_inverse[OF rbn0, symmetric])
75.445 - from rib0 have th0: "r k (inverse b $ 0) ^ k = inverse b $ 0"
75.446 - by (simp add:fps_inverse_def b0)
75.447 - from raib
75.448 - have th1: "r k ((a * inverse b) $ 0) = r k (a $ 0) * r k (inverse b $ 0)"
75.449 - by (simp add: divide_inverse fps_inverse_def b0 fps_mult_nth)
75.450 - from nonzero_imp_inverse_nonzero[OF b0] b0 have th2: "inverse b $ 0 \<noteq> 0"
75.451 - by (simp add: fps_inverse_def)
75.452 - from radical_mult_distrib[of r k a "inverse b", OF ra0 th0 th1 a0 th2]
75.453 - have th: "fps_radical r k (a/b) = fps_radical r k a * fps_radical r k (inverse b)"
75.454 - by (simp add: fps_divide_def)
75.455 - with radical_inverse[of r k b, OF rb0 rb0' r1 b0]
75.456 - have ?thesis by (simp add: fps_divide_def)}
75.457 -ultimately show ?thesis by blast
75.458 -qed
75.459 +lemma radical_inverse:
75.460 + fixes a:: "'a ::{field, ring_char_0} fps"
75.461 + assumes
75.462 + k: "k>0"
75.463 + and ra0: "r k (a $ 0) ^ k = a $ 0"
75.464 + and r1: "(r k 1)^k = 1"
75.465 + and a0: "a$0 \<noteq> 0"
75.466 + 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"
75.467 + using radical_divide[where k=k and r=r and a=1 and b=a, OF k ] ra0 r1 a0
75.468 + by (simp add: divide_inverse fps_divide_def)
75.469
75.470 subsection{* Derivative of composition *}
75.471
75.472 @@ -1831,7 +1883,7 @@
75.473 subsection{* Compositional inverses *}
75.474
75.475
75.476 -fun compinv :: "'a fps \<Rightarrow> nat \<Rightarrow> 'a::{recpower,field}" where
75.477 +fun compinv :: "'a fps \<Rightarrow> nat \<Rightarrow> 'a::{field}" where
75.478 "compinv a 0 = X$0"
75.479 | "compinv a (Suc n) = (X$ Suc n - setsum (\<lambda>i. (compinv a i) * (a^i)$Suc n) {0 .. n}) / (a$1) ^ Suc n"
75.480
75.481 @@ -1862,7 +1914,7 @@
75.482 qed
75.483
75.484
75.485 -fun gcompinv :: "'a fps \<Rightarrow> 'a fps \<Rightarrow> nat \<Rightarrow> 'a::{recpower,field}" where
75.486 +fun gcompinv :: "'a fps \<Rightarrow> 'a fps \<Rightarrow> nat \<Rightarrow> 'a::{field}" where
75.487 "gcompinv b a 0 = b$0"
75.488 | "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"
75.489
75.490 @@ -1901,19 +1953,16 @@
75.491 done
75.492
75.493 lemma fps_compose_1[simp]: "1 oo a = 1"
75.494 - by (simp add: fps_eq_iff fps_compose_nth fps_power_def mult_delta_left setsum_delta)
75.495 + by (simp add: fps_eq_iff fps_compose_nth mult_delta_left setsum_delta)
75.496
75.497 lemma fps_compose_0[simp]: "0 oo a = 0"
75.498 by (simp add: fps_eq_iff fps_compose_nth)
75.499
75.500 -lemma fps_pow_0: "fps_pow n 0 = (if n = 0 then 1 else 0)"
75.501 - by (induct n, simp_all)
75.502 -
75.503 lemma fps_compose_0_right[simp]: "a oo 0 = fps_const (a$0)"
75.504 - by (auto simp add: fps_eq_iff fps_compose_nth fps_power_def fps_pow_0 setsum_0')
75.505 + by (auto simp add: fps_eq_iff fps_compose_nth power_0_left setsum_0')
75.506
75.507 lemma fps_compose_add_distrib: "(a + b) oo c = (a oo c) + (b oo c)"
75.508 - by (simp add: fps_eq_iff fps_compose_nth ring_simps setsum_addf)
75.509 + by (simp add: fps_eq_iff fps_compose_nth ring_simps setsum_addf)
75.510
75.511 lemma fps_compose_setsum_distrib: "(setsum f S) oo a = setsum (\<lambda>i. f i oo a) S"
75.512 proof-
75.513 @@ -2118,7 +2167,7 @@
75.514 qed
75.515
75.516 lemma fps_inv_deriv:
75.517 - assumes a0:"a$0 = (0::'a::{recpower,field})" and a1: "a$1 \<noteq> 0"
75.518 + assumes a0:"a$0 = (0::'a::{field})" and a1: "a$1 \<noteq> 0"
75.519 shows "fps_deriv (fps_inv a) = inverse (fps_deriv a oo fps_inv a)"
75.520 proof-
75.521 let ?ia = "fps_inv a"
75.522 @@ -2138,7 +2187,7 @@
75.523 subsubsection{* Exponential series *}
75.524 definition "E x = Abs_fps (\<lambda>n. x^n / of_nat (fact n))"
75.525
75.526 -lemma E_deriv[simp]: "fps_deriv (E a) = fps_const (a::'a::{field, recpower, ring_char_0}) * E a" (is "?l = ?r")
75.527 +lemma E_deriv[simp]: "fps_deriv (E a) = fps_const (a::'a::{field, ring_char_0}) * E a" (is "?l = ?r")
75.528 proof-
75.529 {fix n
75.530 have "?l$n = ?r $ n"
75.531 @@ -2148,7 +2197,7 @@
75.532 qed
75.533
75.534 lemma E_unique_ODE:
75.535 - "fps_deriv a = fps_const c * a \<longleftrightarrow> a = fps_const (a$0) * E (c :: 'a::{field, ring_char_0, recpower})"
75.536 + "fps_deriv a = fps_const c * a \<longleftrightarrow> a = fps_const (a$0) * E (c :: 'a::{field, ring_char_0})"
75.537 (is "?lhs \<longleftrightarrow> ?rhs")
75.538 proof-
75.539 {assume d: ?lhs
75.540 @@ -2175,7 +2224,7 @@
75.541 ultimately show ?thesis by blast
75.542 qed
75.543
75.544 -lemma E_add_mult: "E (a + b) = E (a::'a::{ring_char_0, field, recpower}) * E b" (is "?l = ?r")
75.545 +lemma E_add_mult: "E (a + b) = E (a::'a::{ring_char_0, field}) * E b" (is "?l = ?r")
75.546 proof-
75.547 have "fps_deriv (?r) = fps_const (a+b) * ?r"
75.548 by (simp add: fps_const_add[symmetric] ring_simps del: fps_const_add)
75.549 @@ -2187,10 +2236,10 @@
75.550 lemma E_nth[simp]: "E a $ n = a^n / of_nat (fact n)"
75.551 by (simp add: E_def)
75.552
75.553 -lemma E0[simp]: "E (0::'a::{field, recpower}) = 1"
75.554 +lemma E0[simp]: "E (0::'a::{field}) = 1"
75.555 by (simp add: fps_eq_iff power_0_left)
75.556
75.557 -lemma E_neg: "E (- a) = inverse (E (a::'a::{ring_char_0, field, recpower}))"
75.558 +lemma E_neg: "E (- a) = inverse (E (a::'a::{ring_char_0, field}))"
75.559 proof-
75.560 from E_add_mult[of a "- a"] have th0: "E a * E (- a) = 1"
75.561 by (simp )
75.562 @@ -2198,7 +2247,7 @@
75.563 from fps_inverse_unique[OF th1 th0] show ?thesis by simp
75.564 qed
75.565
75.566 -lemma E_nth_deriv[simp]: "fps_nth_deriv n (E (a::'a::{field, recpower, ring_char_0})) = (fps_const a)^n * (E a)"
75.567 +lemma E_nth_deriv[simp]: "fps_nth_deriv n (E (a::'a::{field, ring_char_0})) = (fps_const a)^n * (E a)"
75.568 by (induct n, auto simp add: power_Suc)
75.569
75.570 lemma fps_compose_uminus: "- (a::'a::ring_1 fps) oo c = - (a oo c)"
75.571 @@ -2211,7 +2260,7 @@
75.572 lemma X_fps_compose:"X oo a = Abs_fps (\<lambda>n. if n = 0 then (0::'a::comm_ring_1) else a$n)"
75.573 by (simp add: fps_eq_iff fps_compose_nth mult_delta_left setsum_delta power_Suc)
75.574
75.575 -lemma X_compose_E[simp]: "X oo E (a::'a::{field, recpower}) = E a - 1"
75.576 +lemma X_compose_E[simp]: "X oo E (a::'a::{field}) = E a - 1"
75.577 by (simp add: fps_eq_iff X_fps_compose)
75.578
75.579 lemma LE_compose:
75.580 @@ -2233,7 +2282,7 @@
75.581
75.582
75.583 lemma inverse_one_plus_X:
75.584 - "inverse (1 + X) = Abs_fps (\<lambda>n. (- 1 ::'a::{field, recpower})^n)"
75.585 + "inverse (1 + X) = Abs_fps (\<lambda>n. (- 1 ::'a::{field})^n)"
75.586 (is "inverse ?l = ?r")
75.587 proof-
75.588 have th: "?l * ?r = 1"
75.589 @@ -2244,11 +2293,11 @@
75.590 from fps_inverse_unique[OF th' th] show ?thesis .
75.591 qed
75.592
75.593 -lemma E_power_mult: "(E (c::'a::{field,recpower,ring_char_0}))^n = E (of_nat n * c)"
75.594 +lemma E_power_mult: "(E (c::'a::{field,ring_char_0}))^n = E (of_nat n * c)"
75.595 by (induct n, auto simp add: ring_simps E_add_mult power_Suc)
75.596
75.597 subsubsection{* Logarithmic series *}
75.598 -definition "(L::'a::{field, ring_char_0,recpower} fps)
75.599 +definition "(L::'a::{field, ring_char_0} fps)
75.600 = Abs_fps (\<lambda>n. (- 1) ^ Suc n / of_nat n)"
75.601
75.602 lemma fps_deriv_L: "fps_deriv L = inverse (1 + X)"
75.603 @@ -2259,7 +2308,7 @@
75.604 by (simp add: L_def)
75.605
75.606 lemma L_E_inv:
75.607 - assumes a: "a\<noteq> (0::'a::{field,division_by_zero,ring_char_0,recpower})"
75.608 + assumes a: "a\<noteq> (0::'a::{field,division_by_zero,ring_char_0})"
75.609 shows "L = fps_const a * fps_inv (E a - 1)" (is "?l = ?r")
75.610 proof-
75.611 let ?b = "E a - 1"
75.612 @@ -2283,10 +2332,10 @@
75.613
75.614 subsubsection{* Formal trigonometric functions *}
75.615
75.616 -definition "fps_sin (c::'a::{field, recpower, ring_char_0}) =
75.617 +definition "fps_sin (c::'a::{field, ring_char_0}) =
75.618 Abs_fps (\<lambda>n. if even n then 0 else (- 1) ^((n - 1) div 2) * c^n /(of_nat (fact n)))"
75.619
75.620 -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)"
75.621 +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)"
75.622
75.623 lemma fps_sin_deriv:
75.624 "fps_deriv (fps_sin c) = fps_const c * fps_cos c"
75.625 @@ -2341,11 +2390,11 @@
75.626 proof-
75.627 have "fps_deriv ?lhs = 0"
75.628 apply (simp add: fps_deriv_power fps_sin_deriv fps_cos_deriv power_Suc)
75.629 - by (simp add: fps_power_def ring_simps fps_const_neg[symmetric] del: fps_const_neg)
75.630 + by (simp add: ring_simps fps_const_neg[symmetric] del: fps_const_neg)
75.631 then have "?lhs = fps_const (?lhs $ 0)"
75.632 unfolding fps_deriv_eq_0_iff .
75.633 also have "\<dots> = 1"
75.634 - by (auto simp add: fps_eq_iff fps_power_def numeral_2_eq_2 fps_mult_nth fps_cos_def fps_sin_def)
75.635 + by (auto simp add: fps_eq_iff numeral_2_eq_2 fps_mult_nth fps_cos_def fps_sin_def)
75.636 finally show ?thesis .
75.637 qed
75.638
76.1 --- a/src/HOL/Library/FrechetDeriv.thy Mon May 11 09:39:53 2009 +0200
76.2 +++ b/src/HOL/Library/FrechetDeriv.thy Mon May 11 17:20:52 2009 +0200
76.3 @@ -382,7 +382,7 @@
76.4 subsection {* Powers *}
76.5
76.6 lemma FDERIV_power_Suc:
76.7 - fixes x :: "'a::{real_normed_algebra,recpower,comm_ring_1}"
76.8 + fixes x :: "'a::{real_normed_algebra,comm_ring_1}"
76.9 shows "FDERIV (\<lambda>x. x ^ Suc n) x :> (\<lambda>h. (1 + of_nat n) * x ^ n * h)"
76.10 apply (induct n)
76.11 apply (simp add: power_Suc FDERIV_ident)
76.12 @@ -392,7 +392,7 @@
76.13 done
76.14
76.15 lemma FDERIV_power:
76.16 - fixes x :: "'a::{real_normed_algebra,recpower,comm_ring_1}"
76.17 + fixes x :: "'a::{real_normed_algebra,comm_ring_1}"
76.18 shows "FDERIV (\<lambda>x. x ^ n) x :> (\<lambda>h. of_nat n * x ^ (n - 1) * h)"
76.19 apply (cases n)
76.20 apply (simp add: FDERIV_const)
77.1 --- a/src/HOL/Library/Fundamental_Theorem_Algebra.thy Mon May 11 09:39:53 2009 +0200
77.2 +++ b/src/HOL/Library/Fundamental_Theorem_Algebra.thy Mon May 11 17:20:52 2009 +0200
77.3 @@ -560,14 +560,14 @@
77.4 done
77.5
77.6 lemma poly_replicate_append:
77.7 - "poly (monom 1 n * p) (x::'a::{recpower, comm_ring_1}) = x^n * poly p x"
77.8 + "poly (monom 1 n * p) (x::'a::{comm_ring_1}) = x^n * poly p x"
77.9 by (simp add: poly_monom)
77.10
77.11 text {* Decomposition of polynomial, skipping zero coefficients
77.12 after the first. *}
77.13
77.14 lemma poly_decompose_lemma:
77.15 - assumes nz: "\<not>(\<forall>z. z\<noteq>0 \<longrightarrow> poly p z = (0::'a::{recpower,idom}))"
77.16 + assumes nz: "\<not>(\<forall>z. z\<noteq>0 \<longrightarrow> poly p z = (0::'a::{idom}))"
77.17 shows "\<exists>k a q. a\<noteq>0 \<and> Suc (psize q + k) = psize p \<and>
77.18 (\<forall>z. poly p z = z^k * poly (pCons a q) z)"
77.19 unfolding psize_def
77.20 @@ -595,7 +595,7 @@
77.21
77.22 lemma poly_decompose:
77.23 assumes nc: "~constant(poly p)"
77.24 - shows "\<exists>k a q. a\<noteq>(0::'a::{recpower,idom}) \<and> k\<noteq>0 \<and>
77.25 + shows "\<exists>k a q. a\<noteq>(0::'a::{idom}) \<and> k\<noteq>0 \<and>
77.26 psize q + k + 1 = psize p \<and>
77.27 (\<forall>z. poly p z = poly p 0 + z^k * poly (pCons a q) z)"
77.28 using nc
78.1 --- a/src/HOL/Library/Library.thy Mon May 11 09:39:53 2009 +0200
78.2 +++ b/src/HOL/Library/Library.thy Mon May 11 17:20:52 2009 +0200
78.3 @@ -42,6 +42,7 @@
78.4 Pocklington
78.5 Poly_Deriv
78.6 Polynomial
78.7 + Preorder
78.8 Primes
78.9 Product_Vector
78.10 Quickcheck
79.1 --- a/src/HOL/Library/Nat_Infinity.thy Mon May 11 09:39:53 2009 +0200
79.2 +++ b/src/HOL/Library/Nat_Infinity.thy Mon May 11 17:20:52 2009 +0200
79.3 @@ -24,6 +24,13 @@
79.4 Infty ("\<infinity>")
79.5
79.6
79.7 +lemma not_Infty_eq[iff]: "(x ~= Infty) = (EX i. x = Fin i)"
79.8 +by (cases x) auto
79.9 +
79.10 +lemma not_Fin_eq [iff]: "(ALL y. x ~= Fin y) = (x = Infty)"
79.11 +by (cases x) auto
79.12 +
79.13 +
79.14 subsection {* Constructors and numbers *}
79.15
79.16 instantiation inat :: "{zero, one, number}"
79.17 @@ -261,6 +268,9 @@
79.18
79.19 end
79.20
79.21 +instance inat :: linorder
79.22 +by intro_classes (auto simp add: less_eq_inat_def split: inat.splits)
79.23 +
79.24 instance inat :: pordered_comm_semiring
79.25 proof
79.26 fix a b c :: inat
79.27 @@ -413,4 +423,8 @@
79.28
79.29 lemmas inat_splits = inat.splits
79.30
79.31 +
79.32 +instance inat :: linorder
79.33 +by intro_classes (auto simp add: inat_defs split: inat.splits)
79.34 +
79.35 end
80.1 --- a/src/HOL/Library/Numeral_Type.thy Mon May 11 09:39:53 2009 +0200
80.2 +++ b/src/HOL/Library/Numeral_Type.thy Mon May 11 17:20:52 2009 +0200
80.3 @@ -55,7 +55,7 @@
80.4 unfolding UNIV_Plus_UNIV [symmetric] by (simp only: finite card_Plus)
80.5
80.6 lemma card_option [simp]: "CARD('a option) = Suc CARD('a::finite)"
80.7 - unfolding insert_None_conv_UNIV [symmetric]
80.8 + unfolding UNIV_option_conv
80.9 apply (subgoal_tac "(None::'a option) \<notin> range Some")
80.10 apply (simp add: card_image)
80.11 apply fast
80.12 @@ -154,8 +154,8 @@
80.13
80.14 locale mod_type =
80.15 fixes n :: int
80.16 - and Rep :: "'a::{zero,one,plus,times,uminus,minus,power} \<Rightarrow> int"
80.17 - and Abs :: "int \<Rightarrow> 'a::{zero,one,plus,times,uminus,minus,power}"
80.18 + and Rep :: "'a::{zero,one,plus,times,uminus,minus} \<Rightarrow> int"
80.19 + and Abs :: "int \<Rightarrow> 'a::{zero,one,plus,times,uminus,minus}"
80.20 assumes type: "type_definition Rep Abs {0..<n}"
80.21 and size1: "1 < n"
80.22 and zero_def: "0 = Abs 0"
80.23 @@ -164,14 +164,13 @@
80.24 and mult_def: "x * y = Abs ((Rep x * Rep y) mod n)"
80.25 and diff_def: "x - y = Abs ((Rep x - Rep y) mod n)"
80.26 and minus_def: "- x = Abs ((- Rep x) mod n)"
80.27 - and power_def: "x ^ k = Abs (Rep x ^ k mod n)"
80.28 begin
80.29
80.30 lemma size0: "0 < n"
80.31 by (cut_tac size1, simp)
80.32
80.33 lemmas definitions =
80.34 - zero_def one_def add_def mult_def minus_def diff_def power_def
80.35 + zero_def one_def add_def mult_def minus_def diff_def
80.36
80.37 lemma Rep_less_n: "Rep x < n"
80.38 by (rule type_definition.Rep [OF type, simplified, THEN conjunct2])
80.39 @@ -217,18 +216,12 @@
80.40 apply (simp_all add: Rep_simps zmod_simps ring_simps)
80.41 done
80.42
80.43 -lemma recpower: "OFCLASS('a, recpower_class)"
80.44 -apply (intro_classes, unfold definitions)
80.45 -apply (simp_all add: Rep_simps zmod_simps add_ac mult_assoc
80.46 - mod_pos_pos_trivial size1)
80.47 -done
80.48 -
80.49 end
80.50
80.51 locale mod_ring = mod_type +
80.52 constrains n :: int
80.53 - and Rep :: "'a::{number_ring,power} \<Rightarrow> int"
80.54 - and Abs :: "int \<Rightarrow> 'a::{number_ring,power}"
80.55 + and Rep :: "'a::{number_ring} \<Rightarrow> int"
80.56 + and Abs :: "int \<Rightarrow> 'a::{number_ring}"
80.57 begin
80.58
80.59 lemma of_nat_eq: "of_nat k = Abs (int k mod n)"
80.60 @@ -272,7 +265,7 @@
80.61 @{typ num1}, since 0 and 1 are not distinct.
80.62 *}
80.63
80.64 -instantiation num1 :: "{comm_ring,comm_monoid_mult,number,recpower}"
80.65 +instantiation num1 :: "{comm_ring,comm_monoid_mult,number}"
80.66 begin
80.67
80.68 lemma num1_eq_iff: "(x::num1) = (y::num1) \<longleftrightarrow> True"
80.69 @@ -284,7 +277,7 @@
80.70 end
80.71
80.72 instantiation
80.73 - bit0 and bit1 :: (finite) "{zero,one,plus,times,uminus,minus,power}"
80.74 + bit0 and bit1 :: (finite) "{zero,one,plus,times,uminus,minus}"
80.75 begin
80.76
80.77 definition Abs_bit0' :: "int \<Rightarrow> 'a bit0" where
80.78 @@ -299,7 +292,6 @@
80.79 definition "x * y = Abs_bit0' (Rep_bit0 x * Rep_bit0 y)"
80.80 definition "x - y = Abs_bit0' (Rep_bit0 x - Rep_bit0 y)"
80.81 definition "- x = Abs_bit0' (- Rep_bit0 x)"
80.82 -definition "x ^ k = Abs_bit0' (Rep_bit0 x ^ k)"
80.83
80.84 definition "0 = Abs_bit1 0"
80.85 definition "1 = Abs_bit1 1"
80.86 @@ -307,7 +299,6 @@
80.87 definition "x * y = Abs_bit1' (Rep_bit1 x * Rep_bit1 y)"
80.88 definition "x - y = Abs_bit1' (Rep_bit1 x - Rep_bit1 y)"
80.89 definition "- x = Abs_bit1' (- Rep_bit1 x)"
80.90 -definition "x ^ k = Abs_bit1' (Rep_bit1 x ^ k)"
80.91
80.92 instance ..
80.93
80.94 @@ -326,7 +317,6 @@
80.95 apply (rule times_bit0_def [unfolded Abs_bit0'_def])
80.96 apply (rule minus_bit0_def [unfolded Abs_bit0'_def])
80.97 apply (rule uminus_bit0_def [unfolded Abs_bit0'_def])
80.98 -apply (rule power_bit0_def [unfolded Abs_bit0'_def])
80.99 done
80.100
80.101 interpretation bit1:
80.102 @@ -342,14 +332,13 @@
80.103 apply (rule times_bit1_def [unfolded Abs_bit1'_def])
80.104 apply (rule minus_bit1_def [unfolded Abs_bit1'_def])
80.105 apply (rule uminus_bit1_def [unfolded Abs_bit1'_def])
80.106 -apply (rule power_bit1_def [unfolded Abs_bit1'_def])
80.107 done
80.108
80.109 -instance bit0 :: (finite) "{comm_ring_1,recpower}"
80.110 - by (rule bit0.comm_ring_1 bit0.recpower)+
80.111 +instance bit0 :: (finite) comm_ring_1
80.112 + by (rule bit0.comm_ring_1)+
80.113
80.114 -instance bit1 :: (finite) "{comm_ring_1,recpower}"
80.115 - by (rule bit1.comm_ring_1 bit1.recpower)+
80.116 +instance bit1 :: (finite) comm_ring_1
80.117 + by (rule bit1.comm_ring_1)+
80.118
80.119 instantiation bit0 and bit1 :: (finite) number_ring
80.120 begin
80.121 @@ -386,9 +375,6 @@
80.122 lemmas bit0_iszero_number_of [simp] = bit0.iszero_number_of
80.123 lemmas bit1_iszero_number_of [simp] = bit1.iszero_number_of
80.124
80.125 -declare power_Suc [where ?'a="'a::finite bit0", standard, simp]
80.126 -declare power_Suc [where ?'a="'a::finite bit1", standard, simp]
80.127 -
80.128
80.129 subsection {* Syntax *}
80.130
81.1 --- a/src/HOL/Library/Pocklington.thy Mon May 11 09:39:53 2009 +0200
81.2 +++ b/src/HOL/Library/Pocklington.thy Mon May 11 17:20:52 2009 +0200
81.3 @@ -568,7 +568,7 @@
81.4
81.5 lemma nproduct_cmul:
81.6 assumes fS:"finite S"
81.7 - shows "setprod (\<lambda>m. (c::'a::{comm_monoid_mult,recpower})* a(m)) S = c ^ (card S) * setprod a S"
81.8 + shows "setprod (\<lambda>m. (c::'a::{comm_monoid_mult})* a(m)) S = c ^ (card S) * setprod a S"
81.9 unfolding setprod_timesf setprod_constant[OF fS, of c] ..
81.10
81.11 lemma coprime_nproduct:
82.1 --- a/src/HOL/Library/Polynomial.thy Mon May 11 09:39:53 2009 +0200
82.2 +++ b/src/HOL/Library/Polynomial.thy Mon May 11 17:20:52 2009 +0200
82.3 @@ -632,20 +632,6 @@
82.4 shows "a \<noteq> 0 \<Longrightarrow> p dvd smult a q \<longleftrightarrow> p dvd q"
82.5 by (safe elim!: dvd_smult dvd_smult_cancel)
82.6
82.7 -instantiation poly :: (comm_semiring_1) recpower
82.8 -begin
82.9 -
82.10 -primrec power_poly where
82.11 - "(p::'a poly) ^ 0 = 1"
82.12 -| "(p::'a poly) ^ (Suc n) = p * p ^ n"
82.13 -
82.14 -instance
82.15 - by default simp_all
82.16 -
82.17 -declare power_poly.simps [simp del]
82.18 -
82.19 -end
82.20 -
82.21 lemma degree_power_le: "degree (p ^ n) \<le> degree p * n"
82.22 by (induct n, simp, auto intro: order_trans degree_mult_le)
82.23
82.24 @@ -987,6 +973,30 @@
82.25 by (simp add: pdivmod_rel_def left_distrib)
82.26 thus "(x + z * y) div y = z + x div y"
82.27 by (rule div_poly_eq)
82.28 +next
82.29 + fix x y z :: "'a poly"
82.30 + assume "x \<noteq> 0"
82.31 + show "(x * y) div (x * z) = y div z"
82.32 + proof (cases "y \<noteq> 0 \<and> z \<noteq> 0")
82.33 + have "\<And>x::'a poly. pdivmod_rel x 0 0 x"
82.34 + by (rule pdivmod_rel_by_0)
82.35 + then have [simp]: "\<And>x::'a poly. x div 0 = 0"
82.36 + by (rule div_poly_eq)
82.37 + have "\<And>x::'a poly. pdivmod_rel 0 x 0 0"
82.38 + by (rule pdivmod_rel_0)
82.39 + then have [simp]: "\<And>x::'a poly. 0 div x = 0"
82.40 + by (rule div_poly_eq)
82.41 + case False then show ?thesis by auto
82.42 + next
82.43 + case True then have "y \<noteq> 0" and "z \<noteq> 0" by auto
82.44 + with `x \<noteq> 0`
82.45 + have "\<And>q r. pdivmod_rel y z q r \<Longrightarrow> pdivmod_rel (x * y) (x * z) q (x * r)"
82.46 + by (auto simp add: pdivmod_rel_def algebra_simps)
82.47 + (rule classical, simp add: degree_mult_eq)
82.48 + moreover from pdivmod_rel have "pdivmod_rel y z (y div z) (y mod z)" .
82.49 + ultimately have "pdivmod_rel (x * y) (x * z) (y div z) (x * (y mod z))" .
82.50 + then show ?thesis by (simp add: div_poly_eq)
82.51 + qed
82.52 qed
82.53
82.54 end
82.55 @@ -1108,7 +1118,7 @@
82.56 unfolding one_poly_def by simp
82.57
82.58 lemma poly_monom:
82.59 - fixes a x :: "'a::{comm_semiring_1,recpower}"
82.60 + fixes a x :: "'a::{comm_semiring_1}"
82.61 shows "poly (monom a n) x = a * x ^ n"
82.62 by (induct n, simp add: monom_0, simp add: monom_Suc power_Suc mult_ac)
82.63
82.64 @@ -1137,7 +1147,7 @@
82.65 by (induct p, simp_all, simp add: algebra_simps)
82.66
82.67 lemma poly_power [simp]:
82.68 - fixes p :: "'a::{comm_semiring_1,recpower} poly"
82.69 + fixes p :: "'a::{comm_semiring_1} poly"
82.70 shows "poly (p ^ n) x = poly p x ^ n"
82.71 by (induct n, simp, simp add: power_Suc)
82.72
83.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
83.2 +++ b/src/HOL/Library/Preorder.thy Mon May 11 17:20:52 2009 +0200
83.3 @@ -0,0 +1,65 @@
83.4 +(* Author: Florian Haftmann, TU Muenchen *)
83.5 +
83.6 +header {* Preorders with explicit equivalence relation *}
83.7 +
83.8 +theory Preorder
83.9 +imports Orderings
83.10 +begin
83.11 +
83.12 +class preorder_equiv = preorder
83.13 +begin
83.14 +
83.15 +definition equiv :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
83.16 + "equiv x y \<longleftrightarrow> x \<le> y \<and> y \<le> x"
83.17 +
83.18 +notation
83.19 + equiv ("op ~~") and
83.20 + equiv ("(_/ ~~ _)" [51, 51] 50)
83.21 +
83.22 +notation (xsymbols)
83.23 + equiv ("op \<approx>") and
83.24 + equiv ("(_/ \<approx> _)" [51, 51] 50)
83.25 +
83.26 +notation (HTML output)
83.27 + equiv ("op \<approx>") and
83.28 + equiv ("(_/ \<approx> _)" [51, 51] 50)
83.29 +
83.30 +lemma refl [iff]:
83.31 + "x \<approx> x"
83.32 + unfolding equiv_def by simp
83.33 +
83.34 +lemma trans:
83.35 + "x \<approx> y \<Longrightarrow> y \<approx> z \<Longrightarrow> x \<approx> z"
83.36 + unfolding equiv_def by (auto intro: order_trans)
83.37 +
83.38 +lemma antisym:
83.39 + "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x \<approx> y"
83.40 + unfolding equiv_def ..
83.41 +
83.42 +lemma less_le: "x < y \<longleftrightarrow> x \<le> y \<and> \<not> x \<approx> y"
83.43 + by (auto simp add: equiv_def less_le_not_le)
83.44 +
83.45 +lemma le_less: "x \<le> y \<longleftrightarrow> x < y \<or> x \<approx> y"
83.46 + by (auto simp add: equiv_def less_le)
83.47 +
83.48 +lemma le_imp_less_or_eq: "x \<le> y \<Longrightarrow> x < y \<or> x \<approx> y"
83.49 + by (simp add: less_le)
83.50 +
83.51 +lemma less_imp_not_eq: "x < y \<Longrightarrow> x \<approx> y \<longleftrightarrow> False"
83.52 + by (simp add: less_le)
83.53 +
83.54 +lemma less_imp_not_eq2: "x < y \<Longrightarrow> y \<approx> x \<longleftrightarrow> False"
83.55 + by (simp add: equiv_def less_le)
83.56 +
83.57 +lemma neq_le_trans: "\<not> a \<approx> b \<Longrightarrow> a \<le> b \<Longrightarrow> a < b"
83.58 + by (simp add: less_le)
83.59 +
83.60 +lemma le_neq_trans: "a \<le> b \<Longrightarrow> \<not> a \<approx> b \<Longrightarrow> a < b"
83.61 + by (simp add: less_le)
83.62 +
83.63 +lemma antisym_conv: "y \<le> x \<Longrightarrow> x \<le> y \<longleftrightarrow> x \<approx> y"
83.64 + by (simp add: equiv_def)
83.65 +
83.66 +end
83.67 +
83.68 +end
84.1 --- a/src/HOL/Library/Primes.thy Mon May 11 09:39:53 2009 +0200
84.2 +++ b/src/HOL/Library/Primes.thy Mon May 11 17:20:52 2009 +0200
84.3 @@ -454,19 +454,11 @@
84.4 qed
84.5
84.6 lemma euclid: "\<exists>p. prime p \<and> p > n" using euclid_bound by auto
84.7 +
84.8 lemma primes_infinite: "\<not> (finite {p. prime p})"
84.9 -proof (auto simp add: finite_conv_nat_seg_image)
84.10 - fix n f
84.11 - assume H: "Collect prime = f ` {i. i < (n::nat)}"
84.12 - let ?P = "Collect prime"
84.13 - let ?m = "Max ?P"
84.14 - have P0: "?P \<noteq> {}" using two_is_prime by auto
84.15 - from H have fP: "finite ?P" using finite_conv_nat_seg_image by blast
84.16 - from Max_in [OF fP P0] have "?m \<in> ?P" .
84.17 - from Max_ge [OF fP] have contr: "\<forall> p. prime p \<longrightarrow> p \<le> ?m" by blast
84.18 - from euclid [of ?m] obtain q where q: "prime q" "q > ?m" by blast
84.19 - with contr show False by auto
84.20 -qed
84.21 +apply(simp add: finite_nat_set_iff_bounded_le)
84.22 +apply (metis euclid linorder_not_le)
84.23 +done
84.24
84.25 lemma coprime_prime: assumes ab: "coprime a b"
84.26 shows "~(prime p \<and> p dvd a \<and> p dvd b)"
85.1 --- a/src/HOL/Library/Product_ord.thy Mon May 11 09:39:53 2009 +0200
85.2 +++ b/src/HOL/Library/Product_ord.thy Mon May 11 17:20:52 2009 +0200
85.3 @@ -12,25 +12,28 @@
85.4 begin
85.5
85.6 definition
85.7 - prod_le_def [code del]: "x \<le> y \<longleftrightarrow> fst x < fst y \<or> fst x = fst y \<and> snd x \<le> snd y"
85.8 + 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"
85.9
85.10 definition
85.11 - prod_less_def [code del]: "x < y \<longleftrightarrow> fst x < fst y \<or> fst x = fst y \<and> snd x < snd y"
85.12 + prod_less_def [code del]: "x < y \<longleftrightarrow> fst x < fst y \<or> fst x \<le> fst y \<and> snd x < snd y"
85.13
85.14 instance ..
85.15
85.16 end
85.17
85.18 lemma [code]:
85.19 - "(x1\<Colon>'a\<Colon>{ord, eq}, y1) \<le> (x2, y2) \<longleftrightarrow> x1 < x2 \<or> x1 = x2 \<and> y1 \<le> y2"
85.20 - "(x1\<Colon>'a\<Colon>{ord, eq}, y1) < (x2, y2) \<longleftrightarrow> x1 < x2 \<or> x1 = x2 \<and> y1 < y2"
85.21 + "(x1\<Colon>'a\<Colon>{ord, eq}, y1) \<le> (x2, y2) \<longleftrightarrow> x1 < x2 \<or> x1 \<le> x2 \<and> y1 \<le> y2"
85.22 + "(x1\<Colon>'a\<Colon>{ord, eq}, y1) < (x2, y2) \<longleftrightarrow> x1 < x2 \<or> x1 \<le> x2 \<and> y1 < y2"
85.23 unfolding prod_le_def prod_less_def by simp_all
85.24
85.25 -instance * :: (order, order) order
85.26 - by default (auto simp: prod_le_def prod_less_def intro: order_less_trans)
85.27 +instance * :: (preorder, preorder) preorder proof
85.28 +qed (auto simp: prod_le_def prod_less_def less_le_not_le intro: order_trans)
85.29
85.30 -instance * :: (linorder, linorder) linorder
85.31 - by default (auto simp: prod_le_def)
85.32 +instance * :: (order, order) order proof
85.33 +qed (auto simp add: prod_le_def)
85.34 +
85.35 +instance * :: (linorder, linorder) linorder proof
85.36 +qed (auto simp: prod_le_def)
85.37
85.38 instantiation * :: (linorder, linorder) distrib_lattice
85.39 begin
85.40 @@ -41,9 +44,30 @@
85.41 definition
85.42 sup_prod_def: "(sup \<Colon> 'a \<times> 'b \<Rightarrow> _ \<Rightarrow> _) = max"
85.43
85.44 -instance
85.45 - by intro_classes
85.46 - (auto simp add: inf_prod_def sup_prod_def min_max.sup_inf_distrib1)
85.47 +instance proof
85.48 +qed (auto simp add: inf_prod_def sup_prod_def min_max.sup_inf_distrib1)
85.49 +
85.50 +end
85.51 +
85.52 +instantiation * :: (bot, bot) bot
85.53 +begin
85.54 +
85.55 +definition
85.56 + bot_prod_def: "bot = (bot, bot)"
85.57 +
85.58 +instance proof
85.59 +qed (auto simp add: bot_prod_def prod_le_def)
85.60 +
85.61 +end
85.62 +
85.63 +instantiation * :: (top, top) top
85.64 +begin
85.65 +
85.66 +definition
85.67 + top_prod_def: "top = (top, top)"
85.68 +
85.69 +instance proof
85.70 +qed (auto simp add: top_prod_def prod_le_def)
85.71
85.72 end
85.73
86.1 --- a/src/HOL/Library/Quickcheck.thy Mon May 11 09:39:53 2009 +0200
86.2 +++ b/src/HOL/Library/Quickcheck.thy Mon May 11 17:20:52 2009 +0200
86.3 @@ -47,6 +47,8 @@
86.4
86.5 val eval_ref : (unit -> int -> int * int -> term list option * (int * int)) option ref = ref NONE;
86.6
86.7 +val target = "Quickcheck";
86.8 +
86.9 fun mk_generator_expr thy prop tys =
86.10 let
86.11 val bound_max = length tys - 1;
86.12 @@ -72,14 +74,75 @@
86.13 let
86.14 val tys = (map snd o fst o strip_abs) t;
86.15 val t' = mk_generator_expr thy t tys;
86.16 - val f = Code_ML.eval_term ("Quickcheck.eval_ref", eval_ref) thy t' [];
86.17 - in f #> Random_Engine.run #> (Option.map o map) (Code.postprocess_term thy) end;
86.18 + val f = Code_ML.eval (SOME target) ("Quickcheck.eval_ref", eval_ref)
86.19 + (fn proc => fn g => fn s => g s #>> (Option.map o map) proc) thy t' [];
86.20 + in f #> Random_Engine.run end;
86.21
86.22 end
86.23 *}
86.24
86.25 setup {*
86.26 - Quickcheck.add_generator ("code", Quickcheck.compile_generator_expr o ProofContext.theory_of)
86.27 + Code_Target.extend_target (Quickcheck.target, (Code_ML.target_Eval, K I))
86.28 + #> Quickcheck.add_generator ("code", Quickcheck.compile_generator_expr o ProofContext.theory_of)
86.29 *}
86.30
86.31 +
86.32 +subsection {* Type @{typ "'a \<Rightarrow> 'b"} *}
86.33 +
86.34 +ML {*
86.35 +structure Random_Engine =
86.36 +struct
86.37 +
86.38 +open Random_Engine;
86.39 +
86.40 +fun random_fun (T1 : typ) (T2 : typ) (eq : 'a -> 'a -> bool) (term_of : 'a -> term)
86.41 + (random : Random_Engine.seed -> ('b * (unit -> term)) * Random_Engine.seed)
86.42 + (random_split : Random_Engine.seed -> Random_Engine.seed * Random_Engine.seed)
86.43 + (seed : Random_Engine.seed) =
86.44 + let
86.45 + val (seed', seed'') = random_split seed;
86.46 + val state = ref (seed', [], Const (@{const_name undefined}, T1 --> T2));
86.47 + val fun_upd = Const (@{const_name fun_upd},
86.48 + (T1 --> T2) --> T1 --> T2 --> T1 --> T2);
86.49 + fun random_fun' x =
86.50 + let
86.51 + val (seed, fun_map, f_t) = ! state;
86.52 + in case AList.lookup (uncurry eq) fun_map x
86.53 + of SOME y => y
86.54 + | NONE => let
86.55 + val t1 = term_of x;
86.56 + val ((y, t2), seed') = random seed;
86.57 + val fun_map' = (x, y) :: fun_map;
86.58 + val f_t' = fun_upd $ f_t $ t1 $ t2 ();
86.59 + val _ = state := (seed', fun_map', f_t');
86.60 + in y end
86.61 + end;
86.62 + fun term_fun' () = #3 (! state);
86.63 + in ((random_fun', term_fun'), seed'') end;
86.64 +
86.65 end
86.66 +*}
86.67 +
86.68 +axiomatization
86.69 + random_fun_aux :: "typerep \<Rightarrow> typerep \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> term)
86.70 + \<Rightarrow> (seed \<Rightarrow> ('b \<times> (unit \<Rightarrow> term)) \<times> seed) \<Rightarrow> (seed \<Rightarrow> seed \<times> seed)
86.71 + \<Rightarrow> seed \<Rightarrow> (('a \<Rightarrow> 'b) \<times> (unit \<Rightarrow> term)) \<times> seed"
86.72 +
86.73 +code_const random_fun_aux (Quickcheck "Random'_Engine.random'_fun")
86.74 + -- {* With enough criminal energy this can be abused to derive @{prop False};
86.75 + for this reason we use a distinguished target @{text Quickcheck}
86.76 + not spoiling the regular trusted code generation *}
86.77 +
86.78 +instantiation "fun" :: ("{eq, term_of}", "{type, random}") random
86.79 +begin
86.80 +
86.81 +definition random_fun :: "index \<Rightarrow> seed \<Rightarrow> (('a \<Rightarrow> 'b) \<times> (unit \<Rightarrow> term)) \<times> seed" where
86.82 + "random n = random_fun_aux TYPEREP('a) TYPEREP('b) (op =) Code_Eval.term_of (random n) split_seed"
86.83 +
86.84 +instance ..
86.85 +
86.86 +end
86.87 +
86.88 +code_reserved Quickcheck Random_Engine
86.89 +
86.90 +end
87.1 --- a/src/HOL/Library/State_Monad.thy Mon May 11 09:39:53 2009 +0200
87.2 +++ b/src/HOL/Library/State_Monad.thy Mon May 11 17:20:52 2009 +0200
87.3 @@ -190,7 +190,7 @@
87.4 *}
87.5
87.6 text {*
87.7 - For an example, see HOL/ex/Random.thy.
87.8 + For an example, see HOL/Extraction/Higman.thy.
87.9 *}
87.10
87.11 end
88.1 --- a/src/HOL/Library/Topology_Euclidean_Space.thy Mon May 11 09:39:53 2009 +0200
88.2 +++ b/src/HOL/Library/Topology_Euclidean_Space.thy Mon May 11 17:20:52 2009 +0200
88.3 @@ -5441,7 +5441,7 @@
88.4 have "1 - c > 0" using c by auto
88.5
88.6 from s(2) obtain z0 where "z0 \<in> s" by auto
88.7 - def z \<equiv> "\<lambda> n::nat. fun_pow n f z0"
88.8 + def z \<equiv> "\<lambda>n. (f ^^ n) z0"
88.9 { fix n::nat
88.10 have "z n \<in> s" unfolding z_def
88.11 proof(induct n) case 0 thus ?case using `z0 \<in>s` by auto
88.12 @@ -5580,7 +5580,7 @@
88.13 using dist[THEN bspec[where x=x], THEN bspec[where x=y]] by auto } note dist' = this
88.14 def y \<equiv> "g x"
88.15 have [simp]:"y\<in>s" unfolding y_def using gs[unfolded image_subset_iff] and `x\<in>s` by blast
88.16 - def f \<equiv> "\<lambda> n. fun_pow n g"
88.17 + def f \<equiv> "\<lambda>n. g ^^ n"
88.18 have [simp]:"\<And>n z. g (f n z) = f (Suc n) z" unfolding f_def by auto
88.19 have [simp]:"\<And>z. f 0 z = z" unfolding f_def by auto
88.20 { fix n::nat and z assume "z\<in>s"
89.1 --- a/src/HOL/Library/Univ_Poly.thy Mon May 11 09:39:53 2009 +0200
89.2 +++ b/src/HOL/Library/Univ_Poly.thy Mon May 11 17:20:52 2009 +0200
89.3 @@ -167,22 +167,9 @@
89.4 simp_all add: poly_cmult poly_add left_distrib right_distrib mult_ac)
89.5 qed
89.6
89.7 -class recpower_semiring = semiring + recpower
89.8 -class recpower_semiring_1 = semiring_1 + recpower
89.9 -class recpower_semiring_0 = semiring_0 + recpower
89.10 -class recpower_ring = ring + recpower
89.11 -class recpower_ring_1 = ring_1 + recpower
89.12 -subclass (in recpower_ring_1) recpower_ring ..
89.13 -class recpower_comm_semiring_1 = recpower + comm_semiring_1
89.14 -class recpower_comm_ring_1 = recpower + comm_ring_1
89.15 -subclass (in recpower_comm_ring_1) recpower_comm_semiring_1 ..
89.16 -class recpower_idom = recpower + idom
89.17 -subclass (in recpower_idom) recpower_comm_ring_1 ..
89.18 class idom_char_0 = idom + ring_char_0
89.19 -class recpower_idom_char_0 = recpower + idom_char_0
89.20 -subclass (in recpower_idom_char_0) recpower_idom ..
89.21
89.22 -lemma (in recpower_comm_ring_1) poly_exp: "poly (p %^ n) x = (poly p x) ^ n"
89.23 +lemma (in comm_ring_1) poly_exp: "poly (p %^ n) x = (poly p x) ^ n"
89.24 apply (induct "n")
89.25 apply (auto simp add: poly_cmult poly_mult power_Suc)
89.26 done
89.27 @@ -418,7 +405,7 @@
89.28 finally show ?thesis .
89.29 qed
89.30
89.31 -lemma (in recpower_idom) poly_exp_eq_zero[simp]:
89.32 +lemma (in idom) poly_exp_eq_zero[simp]:
89.33 "(poly (p %^ n) = poly []) = (poly p = poly [] & n \<noteq> 0)"
89.34 apply (simp only: fun_eq add: all_simps [symmetric])
89.35 apply (rule arg_cong [where f = All])
89.36 @@ -437,7 +424,7 @@
89.37 apply simp
89.38 done
89.39
89.40 -lemma (in recpower_idom) poly_exp_prime_eq_zero: "(poly ([a, 1] %^ n) \<noteq> poly [])"
89.41 +lemma (in idom) poly_exp_prime_eq_zero: "(poly ([a, 1] %^ n) \<noteq> poly [])"
89.42 by auto
89.43
89.44 text{*A more constructive notion of polynomials being trivial*}
89.45 @@ -507,7 +494,7 @@
89.46 done
89.47
89.48
89.49 -lemma (in recpower_comm_semiring_1) poly_divides_exp: "m \<le> n ==> (p %^ m) divides (p %^ n)"
89.50 +lemma (in comm_semiring_1) poly_divides_exp: "m \<le> n ==> (p %^ m) divides (p %^ n)"
89.51 apply (auto simp add: le_iff_add)
89.52 apply (induct_tac k)
89.53 apply (rule_tac [2] poly_divides_trans)
89.54 @@ -516,7 +503,7 @@
89.55 apply (auto simp add: poly_mult fun_eq mult_ac)
89.56 done
89.57
89.58 -lemma (in recpower_comm_semiring_1) poly_exp_divides: "[| (p %^ n) divides q; m\<le>n |] ==> (p %^ m) divides q"
89.59 +lemma (in comm_semiring_1) poly_exp_divides: "[| (p %^ n) divides q; m\<le>n |] ==> (p %^ m) divides q"
89.60 by (blast intro: poly_divides_exp poly_divides_trans)
89.61
89.62 lemma (in comm_semiring_0) poly_divides_add:
89.63 @@ -583,7 +570,7 @@
89.64 qed
89.65
89.66
89.67 -lemma (in recpower_comm_semiring_1) poly_mulexp: "poly (mulexp n p q) x = (poly p x) ^ n * poly q x"
89.68 +lemma (in comm_semiring_1) poly_mulexp: "poly (mulexp n p q) x = (poly p x) ^ n * poly q x"
89.69 by(induct n, auto simp add: poly_mult power_Suc mult_ac)
89.70
89.71 lemma (in comm_semiring_1) divides_left_mult:
89.72 @@ -600,11 +587,11 @@
89.73
89.74 (* FIXME: Tidy up *)
89.75
89.76 -lemma (in recpower_semiring_1)
89.77 +lemma (in semiring_1)
89.78 zero_power_iff: "0 ^ n = (if n = 0 then 1 else 0)"
89.79 by (induct n, simp_all add: power_Suc)
89.80
89.81 -lemma (in recpower_idom_char_0) poly_order_exists:
89.82 +lemma (in idom_char_0) poly_order_exists:
89.83 assumes lp: "length p = d" and p0: "poly p \<noteq> poly []"
89.84 shows "\<exists>n. ([-a, 1] %^ n) divides p & ~(([-a, 1] %^ (Suc n)) divides p)"
89.85 proof-
89.86 @@ -637,7 +624,7 @@
89.87 lemma (in semiring_1) poly_one_divides[simp]: "[1] divides p"
89.88 by (simp add: divides_def, auto)
89.89
89.90 -lemma (in recpower_idom_char_0) poly_order: "poly p \<noteq> poly []
89.91 +lemma (in idom_char_0) poly_order: "poly p \<noteq> poly []
89.92 ==> EX! n. ([-a, 1] %^ n) divides p &
89.93 ~(([-a, 1] %^ (Suc n)) divides p)"
89.94 apply (auto intro: poly_order_exists simp add: less_linear simp del: pmult_Cons pexp_Suc)
89.95 @@ -652,7 +639,7 @@
89.96 lemma some1_equalityD: "[| n = (@n. P n); EX! n. P n |] ==> P n"
89.97 by (blast intro: someI2)
89.98
89.99 -lemma (in recpower_idom_char_0) order:
89.100 +lemma (in idom_char_0) order:
89.101 "(([-a, 1] %^ n) divides p &
89.102 ~(([-a, 1] %^ (Suc n)) divides p)) =
89.103 ((n = order a p) & ~(poly p = poly []))"
89.104 @@ -662,17 +649,17 @@
89.105 apply (blast intro!: poly_order [THEN [2] some1_equalityD])
89.106 done
89.107
89.108 -lemma (in recpower_idom_char_0) order2: "[| poly p \<noteq> poly [] |]
89.109 +lemma (in idom_char_0) order2: "[| poly p \<noteq> poly [] |]
89.110 ==> ([-a, 1] %^ (order a p)) divides p &
89.111 ~(([-a, 1] %^ (Suc(order a p))) divides p)"
89.112 by (simp add: order del: pexp_Suc)
89.113
89.114 -lemma (in recpower_idom_char_0) order_unique: "[| poly p \<noteq> poly []; ([-a, 1] %^ n) divides p;
89.115 +lemma (in idom_char_0) order_unique: "[| poly p \<noteq> poly []; ([-a, 1] %^ n) divides p;
89.116 ~(([-a, 1] %^ (Suc n)) divides p)
89.117 |] ==> (n = order a p)"
89.118 by (insert order [of a n p], auto)
89.119
89.120 -lemma (in recpower_idom_char_0) order_unique_lemma: "(poly p \<noteq> poly [] & ([-a, 1] %^ n) divides p &
89.121 +lemma (in idom_char_0) order_unique_lemma: "(poly p \<noteq> poly [] & ([-a, 1] %^ n) divides p &
89.122 ~(([-a, 1] %^ (Suc n)) divides p))
89.123 ==> (n = order a p)"
89.124 by (blast intro: order_unique)
89.125 @@ -692,7 +679,7 @@
89.126 apply (auto simp add: divides_def poly_mult simp del: pmult_Cons)
89.127 done
89.128
89.129 -lemma (in recpower_idom_char_0) order_root: "(poly p a = 0) = ((poly p = poly []) | order a p \<noteq> 0)"
89.130 +lemma (in idom_char_0) order_root: "(poly p a = 0) = ((poly p = poly []) | order a p \<noteq> 0)"
89.131 proof-
89.132 let ?poly = poly
89.133 show ?thesis
89.134 @@ -706,7 +693,7 @@
89.135 done
89.136 qed
89.137
89.138 -lemma (in recpower_idom_char_0) order_divides: "(([-a, 1] %^ n) divides p) = ((poly p = poly []) | n \<le> order a p)"
89.139 +lemma (in idom_char_0) order_divides: "(([-a, 1] %^ n) divides p) = ((poly p = poly []) | n \<le> order a p)"
89.140 proof-
89.141 let ?poly = poly
89.142 show ?thesis
89.143 @@ -718,7 +705,7 @@
89.144 done
89.145 qed
89.146
89.147 -lemma (in recpower_idom_char_0) order_decomp:
89.148 +lemma (in idom_char_0) order_decomp:
89.149 "poly p \<noteq> poly []
89.150 ==> \<exists>q. (poly p = poly (([-a, 1] %^ (order a p)) *** q)) &
89.151 ~([-a, 1] divides q)"
89.152 @@ -732,7 +719,7 @@
89.153
89.154 text{*Important composition properties of orders.*}
89.155 lemma order_mult: "poly (p *** q) \<noteq> poly []
89.156 - ==> order a (p *** q) = order a p + order (a::'a::{recpower_idom_char_0}) q"
89.157 + ==> order a (p *** q) = order a p + order (a::'a::{idom_char_0}) q"
89.158 apply (cut_tac a = a and p = "p *** q" and n = "order a p + order a q" in order)
89.159 apply (auto simp add: poly_entire simp del: pmult_Cons)
89.160 apply (drule_tac a = a in order2)+
89.161 @@ -753,7 +740,7 @@
89.162 apply (simp add: fun_eq poly_exp_add poly_mult mult_ac del: pmult_Cons)
89.163 done
89.164
89.165 -lemma (in recpower_idom_char_0) order_mult:
89.166 +lemma (in idom_char_0) order_mult:
89.167 assumes pq0: "poly (p *** q) \<noteq> poly []"
89.168 shows "order a (p *** q) = order a p + order a q"
89.169 proof-
89.170 @@ -783,7 +770,7 @@
89.171 done
89.172 qed
89.173
89.174 -lemma (in recpower_idom_char_0) order_root2: "poly p \<noteq> poly [] ==> (poly p a = 0) = (order a p \<noteq> 0)"
89.175 +lemma (in idom_char_0) order_root2: "poly p \<noteq> poly [] ==> (poly p a = 0) = (order a p \<noteq> 0)"
89.176 by (rule order_root [THEN ssubst], auto)
89.177
89.178 lemma (in semiring_1) pmult_one[simp]: "[1] *** p = p" by auto
89.179 @@ -791,7 +778,7 @@
89.180 lemma (in semiring_0) poly_Nil_zero: "poly [] = poly [0]"
89.181 by (simp add: fun_eq)
89.182
89.183 -lemma (in recpower_idom_char_0) rsquarefree_decomp:
89.184 +lemma (in idom_char_0) rsquarefree_decomp:
89.185 "[| rsquarefree p; poly p a = 0 |]
89.186 ==> \<exists>q. (poly p = poly ([-a, 1] *** q)) & poly q a \<noteq> 0"
89.187 apply (simp add: rsquarefree_def, safe)
89.188 @@ -999,7 +986,7 @@
89.189 ultimately show ?case by blast
89.190 qed
89.191
89.192 -lemma (in recpower_idom_char_0) order_degree:
89.193 +lemma (in idom_char_0) order_degree:
89.194 assumes p0: "poly p \<noteq> poly []"
89.195 shows "order a p \<le> degree p"
89.196 proof-
90.1 --- a/src/HOL/Library/Word.thy Mon May 11 09:39:53 2009 +0200
90.2 +++ b/src/HOL/Library/Word.thy Mon May 11 17:20:52 2009 +0200
90.3 @@ -1,5 +1,4 @@
90.4 (* Title: HOL/Library/Word.thy
90.5 - ID: $Id$
90.6 Author: Sebastian Skalberg (TU Muenchen)
90.7 *)
90.8
90.9 @@ -40,10 +39,8 @@
90.10 Zero ("\<zero>")
90.11 | One ("\<one>")
90.12
90.13 -primrec
90.14 - bitval :: "bit => nat"
90.15 -where
90.16 - "bitval \<zero> = 0"
90.17 +primrec bitval :: "bit => nat" where
90.18 + "bitval \<zero> = 0"
90.19 | "bitval \<one> = 1"
90.20
90.21 consts
90.22 @@ -1531,7 +1528,7 @@
90.23 show ?thesis
90.24 apply simp
90.25 apply (subst power_Suc [symmetric])
90.26 - apply (simp del: power_int.simps)
90.27 + apply simp
90.28 done
90.29 qed
90.30 finally show ?thesis .
91.1 --- a/src/HOL/Library/comm_ring.ML Mon May 11 09:39:53 2009 +0200
91.2 +++ b/src/HOL/Library/comm_ring.ML Mon May 11 17:20:52 2009 +0200
91.3 @@ -65,7 +65,7 @@
91.4 | reif_polex T vs t = polex_pol T $ reif_pol T vs t;
91.5
91.6 (* reification of the equation *)
91.7 -val TFree (_, cr_sort) = @{typ "'a :: {comm_ring, recpower}"};
91.8 +val cr_sort = @{sort "comm_ring_1"};
91.9
91.10 fun reif_eq thy (eq as Const("op =", Type("fun", [T, _])) $ lhs $ rhs) =
91.11 if Sign.of_sort thy (T, cr_sort) then
92.1 --- a/src/HOL/Library/reflection.ML Mon May 11 09:39:53 2009 +0200
92.2 +++ b/src/HOL/Library/reflection.ML Mon May 11 17:20:52 2009 +0200
92.3 @@ -314,5 +314,6 @@
92.4 in (rtac th i THEN TRY(rtac TrueI i)) st end);
92.5
92.6 fun reflection_tac ctxt = gen_reflection_tac ctxt Codegen.evaluation_conv;
92.7 + (*FIXME why Codegen.evaluation_conv? very specific...*)
92.8
92.9 end
93.1 --- a/src/HOL/Lim.thy Mon May 11 09:39:53 2009 +0200
93.2 +++ b/src/HOL/Lim.thy Mon May 11 17:20:52 2009 +0200
93.3 @@ -383,7 +383,7 @@
93.4 lemmas LIM_of_real = of_real.LIM
93.5
93.6 lemma LIM_power:
93.7 - fixes f :: "'a::real_normed_vector \<Rightarrow> 'b::{recpower,real_normed_algebra}"
93.8 + fixes f :: "'a::real_normed_vector \<Rightarrow> 'b::{power,real_normed_algebra}"
93.9 assumes f: "f -- a --> l"
93.10 shows "(\<lambda>x. f x ^ n) -- a --> l ^ n"
93.11 by (induct n, simp, simp add: LIM_mult f)
93.12 @@ -530,7 +530,7 @@
93.13 unfolding isCont_def by (rule LIM_of_real)
93.14
93.15 lemma isCont_power:
93.16 - fixes f :: "'a::real_normed_vector \<Rightarrow> 'b::{recpower,real_normed_algebra}"
93.17 + fixes f :: "'a::real_normed_vector \<Rightarrow> 'b::{power,real_normed_algebra}"
93.18 shows "isCont f a \<Longrightarrow> isCont (\<lambda>x. f x ^ n) a"
93.19 unfolding isCont_def by (rule LIM_power)
93.20
94.1 --- a/src/HOL/List.thy Mon May 11 09:39:53 2009 +0200
94.2 +++ b/src/HOL/List.thy Mon May 11 17:20:52 2009 +0200
94.3 @@ -5,8 +5,8 @@
94.4 header {* The datatype of finite lists *}
94.5
94.6 theory List
94.7 -imports Plain Relation_Power Presburger Recdef ATP_Linkup
94.8 -uses "Tools/string_syntax.ML"
94.9 +imports Plain Presburger Recdef ATP_Linkup
94.10 +uses ("Tools/list_code.ML")
94.11 begin
94.12
94.13 datatype 'a list =
94.14 @@ -198,7 +198,7 @@
94.15
94.16 definition
94.17 rotate :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
94.18 - "rotate n = rotate1 ^ n"
94.19 + "rotate n = rotate1 ^^ n"
94.20
94.21 definition
94.22 list_all2 :: "('a => 'b => bool) => 'a list => 'b list => bool" where
94.23 @@ -1324,6 +1324,9 @@
94.24 apply simp_all
94.25 done
94.26
94.27 +lemma list_update_nonempty[simp]: "xs[k:=x] = [] \<longleftrightarrow> xs=[]"
94.28 +by(metis length_0_conv length_list_update)
94.29 +
94.30 lemma list_update_same_conv:
94.31 "i < length xs ==> (xs[i := x] = xs) = (xs!i = x)"
94.32 by (induct xs arbitrary: i) (auto split: nat.split)
94.33 @@ -1344,8 +1347,7 @@
94.34 by (induct xs, auto)
94.35
94.36 lemma update_zip:
94.37 - "length xs = length ys ==>
94.38 - (zip xs ys)[i:=xy] = zip (xs[i:=fst xy]) (ys[i:=snd xy])"
94.39 + "(zip xs ys)[i:=xy] = zip (xs[i:=fst xy]) (ys[i:=snd xy])"
94.40 by (induct ys arbitrary: i xy xs) (auto, case_tac xs, auto split: nat.split)
94.41
94.42 lemma set_update_subset_insert: "set(xs[i:=x]) <= insert x (set xs)"
94.43 @@ -1357,12 +1359,10 @@
94.44 lemma set_update_memI: "n < length xs \<Longrightarrow> x \<in> set (xs[n := x])"
94.45 by (induct xs arbitrary: n) (auto split:nat.splits)
94.46
94.47 -lemma list_update_overwrite:
94.48 +lemma list_update_overwrite[simp]:
94.49 "xs [i := x, i := y] = xs [i := y]"
94.50 -apply (induct xs arbitrary: i)
94.51 -apply simp
94.52 -apply (case_tac i)
94.53 -apply simp_all
94.54 +apply (induct xs arbitrary: i) apply simp
94.55 +apply (case_tac i, simp_all)
94.56 done
94.57
94.58 lemma list_update_swap:
94.59 @@ -1444,6 +1444,18 @@
94.60 lemma butlast_conv_take: "butlast xs = take (length xs - 1) xs"
94.61 by (induct xs, simp, case_tac xs, simp_all)
94.62
94.63 +lemma last_list_update:
94.64 + "xs \<noteq> [] \<Longrightarrow> last(xs[k:=x]) = (if k = size xs - 1 then x else last xs)"
94.65 +by (auto simp: last_conv_nth)
94.66 +
94.67 +lemma butlast_list_update:
94.68 + "butlast(xs[k:=x]) =
94.69 + (if k = size xs - 1 then butlast xs else (butlast xs)[k:=x])"
94.70 +apply(cases xs rule:rev_cases)
94.71 +apply simp
94.72 +apply(simp add:list_update_append split:nat.splits)
94.73 +done
94.74 +
94.75
94.76 subsubsection {* @{text take} and @{text drop} *}
94.77
94.78 @@ -1723,6 +1735,13 @@
94.79 "(dropWhile P xs = y#ys) = (xs = takeWhile P xs @ y # ys & \<not> P y)"
94.80 by(induct xs, auto)
94.81
94.82 +lemma distinct_takeWhile[simp]: "distinct xs ==> distinct (takeWhile P xs)"
94.83 +by (induct xs) (auto dest: set_takeWhileD)
94.84 +
94.85 +lemma distinct_dropWhile[simp]: "distinct xs ==> distinct (dropWhile P xs)"
94.86 +by (induct xs) auto
94.87 +
94.88 +
94.89 text{* The following two lemmmas could be generalized to an arbitrary
94.90 property. *}
94.91
94.92 @@ -1809,6 +1828,10 @@
94.93 apply simp_all
94.94 done
94.95
94.96 +text{* Courtesy of Andreas Lochbihler: *}
94.97 +lemma zip_same_conv_map: "zip xs xs = map (\<lambda>x. (x, x)) xs"
94.98 +by(induct xs) auto
94.99 +
94.100 lemma nth_zip [simp]:
94.101 "[| i < length xs; i < length ys|] ==> (zip xs ys)!i = (xs!i, ys!i)"
94.102 apply (induct ys arbitrary: i xs, simp)
94.103 @@ -1818,11 +1841,11 @@
94.104
94.105 lemma set_zip:
94.106 "set (zip xs ys) = {(xs!i, ys!i) | i. i < min (length xs) (length ys)}"
94.107 -by (simp add: set_conv_nth cong: rev_conj_cong)
94.108 +by(simp add: set_conv_nth cong: rev_conj_cong)
94.109
94.110 lemma zip_update:
94.111 -"length xs = length ys ==> zip (xs[i:=x]) (ys[i:=y]) = (zip xs ys)[i:=(x,y)]"
94.112 -by (rule sym, simp add: update_zip)
94.113 + "zip (xs[i:=x]) (ys[i:=y]) = (zip xs ys)[i:=(x,y)]"
94.114 +by(rule sym, simp add: update_zip)
94.115
94.116 lemma zip_replicate [simp]:
94.117 "zip (replicate i x) (replicate j y) = replicate (min i j) (x,y)"
94.118 @@ -2120,6 +2143,15 @@
94.119 shows "listsum (rev xs) = listsum xs"
94.120 by (induct xs) (simp_all add:add_ac)
94.121
94.122 +lemma listsum_map_remove1:
94.123 +fixes f :: "'a \<Rightarrow> ('b::comm_monoid_add)"
94.124 +shows "x : set xs \<Longrightarrow> listsum(map f xs) = f x + listsum(map f (remove1 x xs))"
94.125 +by (induct xs)(auto simp add:add_ac)
94.126 +
94.127 +lemma list_size_conv_listsum:
94.128 + "list_size f xs = listsum (map f xs) + size xs"
94.129 +by(induct xs) auto
94.130 +
94.131 lemma listsum_foldr: "listsum xs = foldr (op +) xs 0"
94.132 by (induct xs) auto
94.133
94.134 @@ -2131,6 +2163,10 @@
94.135 lemma listsum[code unfold]: "listsum xs = foldl (op +) 0 xs"
94.136 by(simp add:listsum_foldr foldl_foldr1)
94.137
94.138 +lemma distinct_listsum_conv_Setsum:
94.139 + "distinct xs \<Longrightarrow> listsum xs = Setsum(set xs)"
94.140 +by (induct xs) simp_all
94.141 +
94.142
94.143 text{* Some syntactic sugar for summing a function over a list: *}
94.144
94.145 @@ -2544,6 +2580,11 @@
94.146 apply (simp add: add_commute)
94.147 done
94.148
94.149 +text{* Courtesy of Andreas Lochbihler: *}
94.150 +lemma filter_replicate:
94.151 + "filter P (replicate n x) = (if P x then replicate n x else [])"
94.152 +by(induct n) auto
94.153 +
94.154 lemma hd_replicate [simp]: "n \<noteq> 0 ==> hd (replicate n x) = x"
94.155 by (induct n) auto
94.156
94.157 @@ -3424,77 +3465,6 @@
94.158 by (auto simp add: set_Cons_def intro: listrel.intros)
94.159
94.160
94.161 -subsection{*Miscellany*}
94.162 -
94.163 -subsubsection {* Characters and strings *}
94.164 -
94.165 -datatype nibble =
94.166 - Nibble0 | Nibble1 | Nibble2 | Nibble3 | Nibble4 | Nibble5 | Nibble6 | Nibble7
94.167 - | Nibble8 | Nibble9 | NibbleA | NibbleB | NibbleC | NibbleD | NibbleE | NibbleF
94.168 -
94.169 -lemma UNIV_nibble:
94.170 - "UNIV = {Nibble0, Nibble1, Nibble2, Nibble3, Nibble4, Nibble5, Nibble6, Nibble7,
94.171 - Nibble8, Nibble9, NibbleA, NibbleB, NibbleC, NibbleD, NibbleE, NibbleF}" (is "_ = ?A")
94.172 -proof (rule UNIV_eq_I)
94.173 - fix x show "x \<in> ?A" by (cases x) simp_all
94.174 -qed
94.175 -
94.176 -instance nibble :: finite
94.177 - by default (simp add: UNIV_nibble)
94.178 -
94.179 -datatype char = Char nibble nibble
94.180 - -- "Note: canonical order of character encoding coincides with standard term ordering"
94.181 -
94.182 -lemma UNIV_char:
94.183 - "UNIV = image (split Char) (UNIV \<times> UNIV)"
94.184 -proof (rule UNIV_eq_I)
94.185 - fix x show "x \<in> image (split Char) (UNIV \<times> UNIV)" by (cases x) auto
94.186 -qed
94.187 -
94.188 -instance char :: finite
94.189 - by default (simp add: UNIV_char)
94.190 -
94.191 -lemma size_char [code, simp]:
94.192 - "size (c::char) = 0" by (cases c) simp
94.193 -
94.194 -lemma char_size [code, simp]:
94.195 - "char_size (c::char) = 0" by (cases c) simp
94.196 -
94.197 -primrec nibble_pair_of_char :: "char \<Rightarrow> nibble \<times> nibble" where
94.198 - "nibble_pair_of_char (Char n m) = (n, m)"
94.199 -
94.200 -declare nibble_pair_of_char.simps [code del]
94.201 -
94.202 -setup {*
94.203 -let
94.204 - val nibbles = map (Thm.cterm_of @{theory} o HOLogic.mk_nibble) (0 upto 15);
94.205 - val thms = map_product
94.206 - (fn n => fn m => Drule.instantiate' [] [SOME n, SOME m] @{thm nibble_pair_of_char.simps})
94.207 - nibbles nibbles;
94.208 -in
94.209 - PureThy.note_thmss Thm.lemmaK [((Binding.name "nibble_pair_of_char_simps", []), [(thms, [])])]
94.210 - #-> (fn [(_, thms)] => fold_rev Code.add_eqn thms)
94.211 -end
94.212 -*}
94.213 -
94.214 -lemma char_case_nibble_pair [code, code inline]:
94.215 - "char_case f = split f o nibble_pair_of_char"
94.216 - by (simp add: expand_fun_eq split: char.split)
94.217 -
94.218 -lemma char_rec_nibble_pair [code, code inline]:
94.219 - "char_rec f = split f o nibble_pair_of_char"
94.220 - unfolding char_case_nibble_pair [symmetric]
94.221 - by (simp add: expand_fun_eq split: char.split)
94.222 -
94.223 -types string = "char list"
94.224 -
94.225 -syntax
94.226 - "_Char" :: "xstr => char" ("CHR _")
94.227 - "_String" :: "xstr => string" ("_")
94.228 -
94.229 -setup StringSyntax.setup
94.230 -
94.231 -
94.232 subsection {* Size function *}
94.233
94.234 lemma [measure_function]: "is_measure f \<Longrightarrow> is_measure (list_size f)"
94.235 @@ -3518,10 +3488,35 @@
94.236 "(\<And>x. x \<in> set xs \<Longrightarrow> f x < g x) \<Longrightarrow> list_size f xs \<le> list_size g xs"
94.237 by (induct xs) force+
94.238
94.239 +
94.240 subsection {* Code generator *}
94.241
94.242 subsubsection {* Setup *}
94.243
94.244 +use "Tools/list_code.ML"
94.245 +
94.246 +code_type list
94.247 + (SML "_ list")
94.248 + (OCaml "_ list")
94.249 + (Haskell "![_]")
94.250 +
94.251 +code_const Nil
94.252 + (SML "[]")
94.253 + (OCaml "[]")
94.254 + (Haskell "[]")
94.255 +
94.256 +code_instance list :: eq
94.257 + (Haskell -)
94.258 +
94.259 +code_const "eq_class.eq \<Colon> 'a\<Colon>eq list \<Rightarrow> 'a list \<Rightarrow> bool"
94.260 + (Haskell infixl 4 "==")
94.261 +
94.262 +code_reserved SML
94.263 + list
94.264 +
94.265 +code_reserved OCaml
94.266 + list
94.267 +
94.268 types_code
94.269 "list" ("_ list")
94.270 attach (term_of) {*
94.271 @@ -3537,206 +3532,23 @@
94.272 (1, fn () => ([], fn () => HOLogic.nil_const aT))] ()
94.273 and gen_list aG aT i = gen_list' aG aT i i;
94.274 *}
94.275 - "char" ("string")
94.276 -attach (term_of) {*
94.277 -val term_of_char = HOLogic.mk_char o ord;
94.278 -*}
94.279 -attach (test) {*
94.280 -fun gen_char i =
94.281 - let val j = random_range (ord "a") (Int.min (ord "a" + i, ord "z"))
94.282 - in (chr j, fn () => HOLogic.mk_char j) end;
94.283 -*}
94.284 -
94.285 -consts_code "Cons" ("(_ ::/ _)")
94.286 -
94.287 -code_type list
94.288 - (SML "_ list")
94.289 - (OCaml "_ list")
94.290 - (Haskell "![_]")
94.291 -
94.292 -code_reserved SML
94.293 - list
94.294 -
94.295 -code_reserved OCaml
94.296 - list
94.297 -
94.298 -code_const Nil
94.299 - (SML "[]")
94.300 - (OCaml "[]")
94.301 - (Haskell "[]")
94.302 -
94.303 -ML {*
94.304 -local
94.305 -
94.306 -open Basic_Code_Thingol;
94.307 -
94.308 -fun implode_list naming t = case pairself
94.309 - (Code_Thingol.lookup_const naming) (@{const_name Nil}, @{const_name Cons})
94.310 - of (SOME nil', SOME cons') => let
94.311 - fun dest_cons (IConst (c, _) `$ t1 `$ t2) =
94.312 - if c = cons'
94.313 - then SOME (t1, t2)
94.314 - else NONE
94.315 - | dest_cons _ = NONE;
94.316 - val (ts, t') = Code_Thingol.unfoldr dest_cons t;
94.317 - in case t'
94.318 - of IConst (c, _) => if c = nil' then SOME ts else NONE
94.319 - | _ => NONE
94.320 - end
94.321 - | _ => NONE
94.322 -
94.323 -fun decode_char naming (IConst (c1, _), IConst (c2, _)) = (case map_filter
94.324 - (Code_Thingol.lookup_const naming)[@{const_name Nibble0}, @{const_name Nibble1},
94.325 - @{const_name Nibble2}, @{const_name Nibble3},
94.326 - @{const_name Nibble4}, @{const_name Nibble5},
94.327 - @{const_name Nibble6}, @{const_name Nibble7},
94.328 - @{const_name Nibble8}, @{const_name Nibble9},
94.329 - @{const_name NibbleA}, @{const_name NibbleB},
94.330 - @{const_name NibbleC}, @{const_name NibbleD},
94.331 - @{const_name NibbleE}, @{const_name NibbleF}]
94.332 - of nibbles' as [_, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _] => let
94.333 - fun idx c = find_index (curry (op =) c) nibbles';
94.334 - fun decode ~1 _ = NONE
94.335 - | decode _ ~1 = NONE
94.336 - | decode n m = SOME (chr (n * 16 + m));
94.337 - in decode (idx c1) (idx c2) end
94.338 - | _ => NONE)
94.339 - | decode_char _ _ = NONE
94.340 -
94.341 -fun implode_string naming mk_char mk_string ts = case
94.342 - Code_Thingol.lookup_const naming @{const_name Char}
94.343 - of SOME char' => let
94.344 - fun implode_char (IConst (c, _) `$ t1 `$ t2) =
94.345 - if c = char' then decode_char naming (t1, t2) else NONE
94.346 - | implode_char _ = NONE;
94.347 - val ts' = map implode_char ts;
94.348 - in if forall is_some ts'
94.349 - then (SOME o Code_Printer.str o mk_string o implode o map_filter I) ts'
94.350 - else NONE
94.351 - end
94.352 - | _ => NONE;
94.353 -
94.354 -fun default_list (target_fxy, target_cons) pr fxy t1 t2 =
94.355 - Code_Printer.brackify_infix (target_fxy, Code_Printer.R) fxy [
94.356 - pr (Code_Printer.INFX (target_fxy, Code_Printer.X)) t1,
94.357 - Code_Printer.str target_cons,
94.358 - pr (Code_Printer.INFX (target_fxy, Code_Printer.R)) t2
94.359 - ];
94.360 -
94.361 -fun pretty_list literals =
94.362 - let
94.363 - val mk_list = Code_Printer.literal_list literals;
94.364 - fun pretty pr naming thm vars fxy [(t1, _), (t2, _)] =
94.365 - case Option.map (cons t1) (implode_list naming t2)
94.366 - of SOME ts => mk_list (map (pr vars Code_Printer.NOBR) ts)
94.367 - | NONE => default_list (Code_Printer.infix_cons literals) (pr vars) fxy t1 t2;
94.368 - in (2, pretty) end;
94.369 -
94.370 -fun pretty_list_string literals =
94.371 - let
94.372 - val mk_list = Code_Printer.literal_list literals;
94.373 - val mk_char = Code_Printer.literal_char literals;
94.374 - val mk_string = Code_Printer.literal_string literals;
94.375 - fun pretty pr naming thm vars fxy [(t1, _), (t2, _)] =
94.376 - case Option.map (cons t1) (implode_list naming t2)
94.377 - of SOME ts => (case implode_string naming mk_char mk_string ts
94.378 - of SOME p => p
94.379 - | NONE => mk_list (map (pr vars Code_Printer.NOBR) ts))
94.380 - | NONE => default_list (Code_Printer.infix_cons literals) (pr vars) fxy t1 t2;
94.381 - in (2, pretty) end;
94.382 -
94.383 -fun pretty_char literals =
94.384 - let
94.385 - val mk_char = Code_Printer.literal_char literals;
94.386 - fun pretty _ naming thm _ _ [(t1, _), (t2, _)] =
94.387 - case decode_char naming (t1, t2)
94.388 - of SOME c => (Code_Printer.str o mk_char) c
94.389 - | NONE => Code_Printer.nerror thm "Illegal character expression";
94.390 - in (2, pretty) end;
94.391 -
94.392 -fun pretty_message literals =
94.393 - let
94.394 - val mk_char = Code_Printer.literal_char literals;
94.395 - val mk_string = Code_Printer.literal_string literals;
94.396 - fun pretty _ naming thm _ _ [(t, _)] =
94.397 - case implode_list naming t
94.398 - of SOME ts => (case implode_string naming mk_char mk_string ts
94.399 - of SOME p => p
94.400 - | NONE => Code_Printer.nerror thm "Illegal message expression")
94.401 - | NONE => Code_Printer.nerror thm "Illegal message expression";
94.402 - in (1, pretty) end;
94.403 -
94.404 -in
94.405 -
94.406 -fun add_literal_list target thy =
94.407 - let
94.408 - val pr = pretty_list (Code_Target.the_literals thy target);
94.409 - in
94.410 - thy
94.411 - |> Code_Target.add_syntax_const target @{const_name Cons} (SOME pr)
94.412 - end;
94.413 -
94.414 -fun add_literal_list_string target thy =
94.415 - let
94.416 - val pr = pretty_list_string (Code_Target.the_literals thy target);
94.417 - in
94.418 - thy
94.419 - |> Code_Target.add_syntax_const target @{const_name Cons} (SOME pr)
94.420 - end;
94.421 -
94.422 -fun add_literal_char target thy =
94.423 - let
94.424 - val pr = pretty_char (Code_Target.the_literals thy target);
94.425 - in
94.426 - thy
94.427 - |> Code_Target.add_syntax_const target @{const_name Char} (SOME pr)
94.428 - end;
94.429 -
94.430 -fun add_literal_message str target thy =
94.431 - let
94.432 - val pr = pretty_message (Code_Target.the_literals thy target);
94.433 - in
94.434 - thy
94.435 - |> Code_Target.add_syntax_const target str (SOME pr)
94.436 - end;
94.437 -
94.438 -end;
94.439 -*}
94.440 -
94.441 -setup {*
94.442 - fold (fn target => add_literal_list target) ["SML", "OCaml", "Haskell"]
94.443 -*}
94.444 -
94.445 -code_instance list :: eq
94.446 - (Haskell -)
94.447 -
94.448 -code_const "eq_class.eq \<Colon> 'a\<Colon>eq list \<Rightarrow> 'a list \<Rightarrow> bool"
94.449 - (Haskell infixl 4 "==")
94.450 +
94.451 +consts_code Cons ("(_ ::/ _)")
94.452
94.453 setup {*
94.454 let
94.455 -
94.456 -fun list_codegen thy defs dep thyname b t gr =
94.457 - let
94.458 - val ts = HOLogic.dest_list t;
94.459 - val (_, gr') = Codegen.invoke_tycodegen thy defs dep thyname false
94.460 - (fastype_of t) gr;
94.461 - val (ps, gr'') = fold_map
94.462 - (Codegen.invoke_codegen thy defs dep thyname false) ts gr'
94.463 - in SOME (Pretty.list "[" "]" ps, gr'') end handle TERM _ => NONE;
94.464 -
94.465 -fun char_codegen thy defs dep thyname b t gr =
94.466 - let
94.467 - val i = HOLogic.dest_char t;
94.468 - val (_, gr') = Codegen.invoke_tycodegen thy defs dep thyname false
94.469 - (fastype_of t) gr;
94.470 - in SOME (Codegen.str (ML_Syntax.print_string (chr i)), gr')
94.471 - end handle TERM _ => NONE;
94.472 -
94.473 + fun list_codegen thy defs dep thyname b t gr =
94.474 + let
94.475 + val ts = HOLogic.dest_list t;
94.476 + val (_, gr') = Codegen.invoke_tycodegen thy defs dep thyname false
94.477 + (fastype_of t) gr;
94.478 + val (ps, gr'') = fold_map
94.479 + (Codegen.invoke_codegen thy defs dep thyname false) ts gr'
94.480 + in SOME (Pretty.list "[" "]" ps, gr'') end handle TERM _ => NONE;
94.481 in
94.482 - Codegen.add_codegen "list_codegen" list_codegen
94.483 - #> Codegen.add_codegen "char_codegen" char_codegen
94.484 -end;
94.485 + fold (List_Code.add_literal_list) ["SML", "OCaml", "Haskell"]
94.486 + #> Codegen.add_codegen "list_codegen" list_codegen
94.487 +end
94.488 *}
94.489
94.490
95.1 --- a/src/HOL/Map.thy Mon May 11 09:39:53 2009 +0200
95.2 +++ b/src/HOL/Map.thy Mon May 11 17:20:52 2009 +0200
95.3 @@ -11,7 +11,7 @@
95.4 imports List
95.5 begin
95.6
95.7 -types ('a,'b) "~=>" = "'a => 'b option" (infixr 0)
95.8 +types ('a,'b) "~=>" = "'a => 'b option" (infixr "~=>" 0)
95.9 translations (type) "a ~=> b " <= (type) "a => b option"
95.10
95.11 syntax (xsymbols)
95.12 @@ -452,6 +452,9 @@
95.13
95.14 subsection {* @{term [source] dom} *}
95.15
95.16 +lemma dom_eq_empty_conv [simp]: "dom f = {} \<longleftrightarrow> f = empty"
95.17 +by(auto intro!:ext simp: dom_def)
95.18 +
95.19 lemma domI: "m a = Some b ==> a : dom m"
95.20 by(simp add:dom_def)
95.21 (* declare domI [intro]? *)
95.22 @@ -593,4 +596,19 @@
95.23 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"
95.24 by (clarsimp simp add: map_le_def map_add_def dom_def split: option.splits)
95.25
95.26 +
95.27 +lemma dom_eq_singleton_conv: "dom f = {x} \<longleftrightarrow> (\<exists>v. f = [x \<mapsto> v])"
95.28 +proof(rule iffI)
95.29 + assume "\<exists>v. f = [x \<mapsto> v]"
95.30 + thus "dom f = {x}" by(auto split: split_if_asm)
95.31 +next
95.32 + assume "dom f = {x}"
95.33 + then obtain v where "f x = Some v" by auto
95.34 + hence "[x \<mapsto> v] \<subseteq>\<^sub>m f" by(auto simp add: map_le_def)
95.35 + moreover have "f \<subseteq>\<^sub>m [x \<mapsto> v]" using `dom f = {x}` `f x = Some v`
95.36 + by(auto simp add: map_le_def)
95.37 + ultimately have "f = [x \<mapsto> v]" by-(rule map_le_antisym)
95.38 + thus "\<exists>v. f = [x \<mapsto> v]" by blast
95.39 +qed
95.40 +
95.41 end
96.1 --- a/src/HOL/MicroJava/Comp/CorrCompTp.thy Mon May 11 09:39:53 2009 +0200
96.2 +++ b/src/HOL/MicroJava/Comp/CorrCompTp.thy Mon May 11 17:20:52 2009 +0200
96.3 @@ -454,7 +454,7 @@
96.4 apply (simp add: max_of_list_def)
96.5 apply (induct xs)
96.6 apply simp
96.7 -using [[fast_arith_split_limit = 0]]
96.8 +using [[linarith_split_limit = 0]]
96.9 apply simp
96.10 apply arith
96.11 done
97.1 --- a/src/HOL/NSA/HDeriv.thy Mon May 11 09:39:53 2009 +0200
97.2 +++ b/src/HOL/NSA/HDeriv.thy Mon May 11 17:20:52 2009 +0200
97.3 @@ -1,5 +1,4 @@
97.4 (* Title : Deriv.thy
97.5 - ID : $Id$
97.6 Author : Jacques D. Fleuriot
97.7 Copyright : 1998 University of Cambridge
97.8 Conversion to Isar and new proofs by Lawrence C Paulson, 2004
97.9 @@ -345,7 +344,7 @@
97.10
97.11 (*Can't get rid of x \<noteq> 0 because it isn't continuous at zero*)
97.12 lemma NSDERIV_inverse:
97.13 - fixes x :: "'a::{real_normed_field,recpower}"
97.14 + fixes x :: "'a::{real_normed_field}"
97.15 shows "x \<noteq> 0 ==> NSDERIV (%x. inverse(x)) x :> (- (inverse x ^ Suc (Suc 0)))"
97.16 apply (simp add: nsderiv_def)
97.17 apply (rule ballI, simp, clarify)
97.18 @@ -383,7 +382,7 @@
97.19 text{*Derivative of inverse*}
97.20
97.21 lemma NSDERIV_inverse_fun:
97.22 - fixes x :: "'a::{real_normed_field,recpower}"
97.23 + fixes x :: "'a::{real_normed_field}"
97.24 shows "[| NSDERIV f x :> d; f(x) \<noteq> 0 |]
97.25 ==> NSDERIV (%x. inverse(f x)) x :> (- (d * inverse(f(x) ^ Suc (Suc 0))))"
97.26 by (simp add: NSDERIV_DERIV_iff DERIV_inverse_fun del: power_Suc)
97.27 @@ -391,7 +390,7 @@
97.28 text{*Derivative of quotient*}
97.29
97.30 lemma NSDERIV_quotient:
97.31 - fixes x :: "'a::{real_normed_field,recpower}"
97.32 + fixes x :: "'a::{real_normed_field}"
97.33 shows "[| NSDERIV f x :> d; NSDERIV g x :> e; g(x) \<noteq> 0 |]
97.34 ==> NSDERIV (%y. f(y) / (g y)) x :> (d*g(x)
97.35 - (e*f(x))) / (g(x) ^ Suc (Suc 0))"
98.1 --- a/src/HOL/NSA/HSEQ.thy Mon May 11 09:39:53 2009 +0200
98.2 +++ b/src/HOL/NSA/HSEQ.thy Mon May 11 17:20:52 2009 +0200
98.3 @@ -110,7 +110,7 @@
98.4 done
98.5
98.6 lemma NSLIMSEQ_pow [rule_format]:
98.7 - fixes a :: "'a::{real_normed_algebra,recpower}"
98.8 + fixes a :: "'a::{real_normed_algebra,power}"
98.9 shows "(X ----NS> a) --> ((%n. (X n) ^ m) ----NS> a ^ m)"
98.10 apply (induct "m")
98.11 apply (auto simp add: power_Suc intro: NSLIMSEQ_mult NSLIMSEQ_const)
99.1 --- a/src/HOL/NSA/HyperDef.thy Mon May 11 09:39:53 2009 +0200
99.2 +++ b/src/HOL/NSA/HyperDef.thy Mon May 11 17:20:52 2009 +0200
99.3 @@ -417,7 +417,7 @@
99.4 declare power_hypreal_of_real_number_of [of _ "number_of w", standard, simp]
99.5 (*
99.6 lemma hrealpow_HFinite:
99.7 - fixes x :: "'a::{real_normed_algebra,recpower} star"
99.8 + fixes x :: "'a::{real_normed_algebra,power} star"
99.9 shows "x \<in> HFinite ==> x ^ n \<in> HFinite"
99.10 apply (induct_tac "n")
99.11 apply (auto simp add: power_Suc intro: HFinite_mult)
99.12 @@ -438,71 +438,71 @@
99.13 by (simp add: hyperpow_def starfun2_star_n)
99.14
99.15 lemma hyperpow_zero [simp]:
99.16 - "\<And>n. (0::'a::{recpower,semiring_0} star) pow (n + (1::hypnat)) = 0"
99.17 + "\<And>n. (0::'a::{power,semiring_0} star) pow (n + (1::hypnat)) = 0"
99.18 by transfer simp
99.19
99.20 lemma hyperpow_not_zero:
99.21 - "\<And>r n. r \<noteq> (0::'a::{recpower,field} star) ==> r pow n \<noteq> 0"
99.22 + "\<And>r n. r \<noteq> (0::'a::{field} star) ==> r pow n \<noteq> 0"
99.23 by transfer (rule field_power_not_zero)
99.24
99.25 lemma hyperpow_inverse:
99.26 - "\<And>r n. r \<noteq> (0::'a::{recpower,division_by_zero,field} star)
99.27 + "\<And>r n. r \<noteq> (0::'a::{division_by_zero,field} star)
99.28 \<Longrightarrow> inverse (r pow n) = (inverse r) pow n"
99.29 by transfer (rule power_inverse)
99.30 -
99.31 +
99.32 lemma hyperpow_hrabs:
99.33 - "\<And>r n. abs (r::'a::{recpower,ordered_idom} star) pow n = abs (r pow n)"
99.34 + "\<And>r n. abs (r::'a::{ordered_idom} star) pow n = abs (r pow n)"
99.35 by transfer (rule power_abs [symmetric])
99.36
99.37 lemma hyperpow_add:
99.38 - "\<And>r n m. (r::'a::recpower star) pow (n + m) = (r pow n) * (r pow m)"
99.39 + "\<And>r n m. (r::'a::monoid_mult star) pow (n + m) = (r pow n) * (r pow m)"
99.40 by transfer (rule power_add)
99.41
99.42 lemma hyperpow_one [simp]:
99.43 - "\<And>r. (r::'a::recpower star) pow (1::hypnat) = r"
99.44 + "\<And>r. (r::'a::monoid_mult star) pow (1::hypnat) = r"
99.45 by transfer (rule power_one_right)
99.46
99.47 lemma hyperpow_two:
99.48 - "\<And>r. (r::'a::recpower star) pow ((1::hypnat) + (1::hypnat)) = r * r"
99.49 -by transfer (simp add: power_Suc)
99.50 + "\<And>r. (r::'a::monoid_mult star) pow ((1::hypnat) + (1::hypnat)) = r * r"
99.51 +by transfer simp
99.52
99.53 lemma hyperpow_gt_zero:
99.54 - "\<And>r n. (0::'a::{recpower,ordered_semidom} star) < r \<Longrightarrow> 0 < r pow n"
99.55 + "\<And>r n. (0::'a::{ordered_semidom} star) < r \<Longrightarrow> 0 < r pow n"
99.56 by transfer (rule zero_less_power)
99.57
99.58 lemma hyperpow_ge_zero:
99.59 - "\<And>r n. (0::'a::{recpower,ordered_semidom} star) \<le> r \<Longrightarrow> 0 \<le> r pow n"
99.60 + "\<And>r n. (0::'a::{ordered_semidom} star) \<le> r \<Longrightarrow> 0 \<le> r pow n"
99.61 by transfer (rule zero_le_power)
99.62
99.63 lemma hyperpow_le:
99.64 - "\<And>x y n. \<lbrakk>(0::'a::{recpower,ordered_semidom} star) < x; x \<le> y\<rbrakk>
99.65 + "\<And>x y n. \<lbrakk>(0::'a::{ordered_semidom} star) < x; x \<le> y\<rbrakk>
99.66 \<Longrightarrow> x pow n \<le> y pow n"
99.67 by transfer (rule power_mono [OF _ order_less_imp_le])
99.68
99.69 lemma hyperpow_eq_one [simp]:
99.70 - "\<And>n. 1 pow n = (1::'a::recpower star)"
99.71 + "\<And>n. 1 pow n = (1::'a::monoid_mult star)"
99.72 by transfer (rule power_one)
99.73
99.74 lemma hrabs_hyperpow_minus_one [simp]:
99.75 - "\<And>n. abs(-1 pow n) = (1::'a::{number_ring,recpower,ordered_idom} star)"
99.76 + "\<And>n. abs(-1 pow n) = (1::'a::{number_ring,ordered_idom} star)"
99.77 by transfer (rule abs_power_minus_one)
99.78
99.79 lemma hyperpow_mult:
99.80 - "\<And>r s n. (r * s::'a::{comm_monoid_mult,recpower} star) pow n
99.81 + "\<And>r s n. (r * s::'a::{comm_monoid_mult} star) pow n
99.82 = (r pow n) * (s pow n)"
99.83 by transfer (rule power_mult_distrib)
99.84
99.85 lemma hyperpow_two_le [simp]:
99.86 - "(0::'a::{recpower,ordered_ring_strict} star) \<le> r pow (1 + 1)"
99.87 + "(0::'a::{monoid_mult,ordered_ring_strict} star) \<le> r pow (1 + 1)"
99.88 by (auto simp add: hyperpow_two zero_le_mult_iff)
99.89
99.90 lemma hrabs_hyperpow_two [simp]:
99.91 "abs(x pow (1 + 1)) =
99.92 - (x::'a::{recpower,ordered_ring_strict} star) pow (1 + 1)"
99.93 + (x::'a::{monoid_mult,ordered_ring_strict} star) pow (1 + 1)"
99.94 by (simp only: abs_of_nonneg hyperpow_two_le)
99.95
99.96 lemma hyperpow_two_hrabs [simp]:
99.97 - "abs(x::'a::{recpower,ordered_idom} star) pow (1 + 1) = x pow (1 + 1)"
99.98 + "abs(x::'a::{ordered_idom} star) pow (1 + 1) = x pow (1 + 1)"
99.99 by (simp add: hyperpow_hrabs)
99.100
99.101 text{*The precondition could be weakened to @{term "0\<le>x"}*}
99.102 @@ -511,11 +511,11 @@
99.103 by (simp add: Ring_and_Field.mult_strict_mono order_less_imp_le)
99.104
99.105 lemma hyperpow_two_gt_one:
99.106 - "\<And>r::'a::{recpower,ordered_semidom} star. 1 < r \<Longrightarrow> 1 < r pow (1 + 1)"
99.107 + "\<And>r::'a::{ordered_semidom} star. 1 < r \<Longrightarrow> 1 < r pow (1 + 1)"
99.108 by transfer (simp add: power_gt1 del: power_Suc)
99.109
99.110 lemma hyperpow_two_ge_one:
99.111 - "\<And>r::'a::{recpower,ordered_semidom} star. 1 \<le> r \<Longrightarrow> 1 \<le> r pow (1 + 1)"
99.112 + "\<And>r::'a::{ordered_semidom} star. 1 \<le> r \<Longrightarrow> 1 \<le> r pow (1 + 1)"
99.113 by transfer (simp add: one_le_power del: power_Suc)
99.114
99.115 lemma two_hyperpow_ge_one [simp]: "(1::hypreal) \<le> 2 pow n"
99.116 @@ -565,7 +565,7 @@
99.117
99.118 lemma of_hypreal_hyperpow:
99.119 "\<And>x n. of_hypreal (x pow n) =
99.120 - (of_hypreal x::'a::{real_algebra_1,recpower} star) pow n"
99.121 + (of_hypreal x::'a::{real_algebra_1} star) pow n"
99.122 by transfer (rule of_real_power)
99.123
99.124 end
100.1 --- a/src/HOL/NSA/NSA.thy Mon May 11 09:39:53 2009 +0200
100.2 +++ b/src/HOL/NSA/NSA.thy Mon May 11 17:20:52 2009 +0200
100.3 @@ -101,7 +101,7 @@
100.4 by transfer (rule norm_mult)
100.5
100.6 lemma hnorm_hyperpow:
100.7 - "\<And>(x::'a::{real_normed_div_algebra,recpower} star) n.
100.8 + "\<And>(x::'a::{real_normed_div_algebra} star) n.
100.9 hnorm (x pow n) = hnorm x pow n"
100.10 by transfer (rule norm_power)
100.11
100.12 @@ -304,15 +304,15 @@
100.13 unfolding star_one_def by (rule HFinite_star_of)
100.14
100.15 lemma hrealpow_HFinite:
100.16 - fixes x :: "'a::{real_normed_algebra,recpower} star"
100.17 + fixes x :: "'a::{real_normed_algebra,monoid_mult} star"
100.18 shows "x \<in> HFinite ==> x ^ n \<in> HFinite"
100.19 -apply (induct_tac "n")
100.20 +apply (induct n)
100.21 apply (auto simp add: power_Suc intro: HFinite_mult)
100.22 done
100.23
100.24 lemma HFinite_bounded:
100.25 "[|(x::hypreal) \<in> HFinite; y \<le> x; 0 \<le> y |] ==> y \<in> HFinite"
100.26 -apply (case_tac "x \<le> 0")
100.27 +apply (cases "x \<le> 0")
100.28 apply (drule_tac y = x in order_trans)
100.29 apply (drule_tac [2] order_antisym)
100.30 apply (auto simp add: linorder_not_le)
101.1 --- a/src/HOL/NSA/NSComplex.thy Mon May 11 09:39:53 2009 +0200
101.2 +++ b/src/HOL/NSA/NSComplex.thy Mon May 11 17:20:52 2009 +0200
101.3 @@ -383,7 +383,7 @@
101.4 by transfer (rule power_mult_distrib)
101.5
101.6 lemma hcpow_zero2 [simp]:
101.7 - "\<And>n. 0 pow (hSuc n) = (0::'a::{recpower,semiring_0} star)"
101.8 + "\<And>n. 0 pow (hSuc n) = (0::'a::{power,semiring_0} star)"
101.9 by transfer (rule power_0_Suc)
101.10
101.11 lemma hcpow_not_zero [simp,intro]:
102.1 --- a/src/HOL/NSA/StarDef.thy Mon May 11 09:39:53 2009 +0200
102.2 +++ b/src/HOL/NSA/StarDef.thy Mon May 11 17:20:52 2009 +0200
102.3 @@ -1,5 +1,4 @@
102.4 (* Title : HOL/Hyperreal/StarDef.thy
102.5 - ID : $Id$
102.6 Author : Jacques D. Fleuriot and Brian Huffman
102.7 *)
102.8
102.9 @@ -546,16 +545,6 @@
102.10
102.11 end
102.12
102.13 -instantiation star :: (power) power
102.14 -begin
102.15 -
102.16 -definition
102.17 - star_power_def: "(op ^) \<equiv> \<lambda>x n. ( *f* (\<lambda>x. x ^ n)) x"
102.18 -
102.19 -instance ..
102.20 -
102.21 -end
102.22 -
102.23 instantiation star :: (ord) ord
102.24 begin
102.25
102.26 @@ -574,7 +563,7 @@
102.27 star_add_def star_diff_def star_minus_def
102.28 star_mult_def star_divide_def star_inverse_def
102.29 star_le_def star_less_def star_abs_def star_sgn_def
102.30 - star_div_def star_mod_def star_power_def
102.31 + star_div_def star_mod_def
102.32
102.33 text {* Class operations preserve standard elements *}
102.34
102.35 @@ -614,15 +603,11 @@
102.36 lemma Standard_mod: "\<lbrakk>x \<in> Standard; y \<in> Standard\<rbrakk> \<Longrightarrow> x mod y \<in> Standard"
102.37 by (simp add: star_mod_def)
102.38
102.39 -lemma Standard_power: "x \<in> Standard \<Longrightarrow> x ^ n \<in> Standard"
102.40 -by (simp add: star_power_def)
102.41 -
102.42 lemmas Standard_simps [simp] =
102.43 Standard_zero Standard_one Standard_number_of
102.44 Standard_add Standard_diff Standard_minus
102.45 Standard_mult Standard_divide Standard_inverse
102.46 Standard_abs Standard_div Standard_mod
102.47 - Standard_power
102.48
102.49 text {* @{term star_of} preserves class operations *}
102.50
102.51 @@ -650,9 +635,6 @@
102.52 lemma star_of_mod: "star_of (x mod y) = star_of x mod star_of y"
102.53 by transfer (rule refl)
102.54
102.55 -lemma star_of_power: "star_of (x ^ n) = star_of x ^ n"
102.56 -by transfer (rule refl)
102.57 -
102.58 lemma star_of_abs: "star_of (abs x) = abs (star_of x)"
102.59 by transfer (rule refl)
102.60
102.61 @@ -717,8 +699,7 @@
102.62 lemmas star_of_simps [simp] =
102.63 star_of_add star_of_diff star_of_minus
102.64 star_of_mult star_of_divide star_of_inverse
102.65 - star_of_div star_of_mod
102.66 - star_of_power star_of_abs
102.67 + star_of_div star_of_mod star_of_abs
102.68 star_of_zero star_of_one star_of_number_of
102.69 star_of_less star_of_le star_of_eq
102.70 star_of_0_less star_of_0_le star_of_0_eq
102.71 @@ -970,26 +951,34 @@
102.72 instance star :: (ordered_idom) ordered_idom ..
102.73 instance star :: (ordered_field) ordered_field ..
102.74
102.75 -subsection {* Power classes *}
102.76
102.77 -text {*
102.78 - Proving the class axiom @{thm [source] power_Suc} for type
102.79 - @{typ "'a star"} is a little tricky, because it quantifies
102.80 - over values of type @{typ nat}. The transfer principle does
102.81 - not handle quantification over non-star types in general,
102.82 - but we can work around this by fixing an arbitrary @{typ nat}
102.83 - value, and then applying the transfer principle.
102.84 -*}
102.85 +subsection {* Power *}
102.86
102.87 -instance star :: (recpower) recpower
102.88 -proof
102.89 - show "\<And>a::'a star. a ^ 0 = 1"
102.90 - by transfer (rule power_0)
102.91 -next
102.92 - fix n show "\<And>a::'a star. a ^ Suc n = a * a ^ n"
102.93 - by transfer (rule power_Suc)
102.94 +lemma star_power_def [transfer_unfold]:
102.95 + "(op ^) \<equiv> \<lambda>x n. ( *f* (\<lambda>x. x ^ n)) x"
102.96 +proof (rule eq_reflection, rule ext, rule ext)
102.97 + fix n :: nat
102.98 + show "\<And>x::'a star. x ^ n = ( *f* (\<lambda>x. x ^ n)) x"
102.99 + proof (induct n)
102.100 + case 0
102.101 + have "\<And>x::'a star. ( *f* (\<lambda>x. 1)) x = 1"
102.102 + by transfer simp
102.103 + then show ?case by simp
102.104 + next
102.105 + case (Suc n)
102.106 + have "\<And>x::'a star. x * ( *f* (\<lambda>x\<Colon>'a. x ^ n)) x = ( *f* (\<lambda>x\<Colon>'a. x * x ^ n)) x"
102.107 + by transfer simp
102.108 + with Suc show ?case by simp
102.109 + qed
102.110 qed
102.111
102.112 +lemma Standard_power [simp]: "x \<in> Standard \<Longrightarrow> x ^ n \<in> Standard"
102.113 + by (simp add: star_power_def)
102.114 +
102.115 +lemma star_of_power [simp]: "star_of (x ^ n) = star_of x ^ n"
102.116 + by transfer (rule refl)
102.117 +
102.118 +
102.119 subsection {* Number classes *}
102.120
102.121 lemma star_of_nat_def [transfer_unfold]: "of_nat n = star_of (of_nat n)"
103.1 --- a/src/HOL/NSA/hypreal_arith.ML Mon May 11 09:39:53 2009 +0200
103.2 +++ b/src/HOL/NSA/hypreal_arith.ML Mon May 11 17:20:52 2009 +0200
103.3 @@ -1,5 +1,4 @@
103.4 (* Title: HOL/NSA/hypreal_arith.ML
103.5 - ID: $Id$
103.6 Author: Tobias Nipkow, TU Muenchen
103.7 Copyright 1999 TU Muenchen
103.8
103.9 @@ -24,7 +23,7 @@
103.10
103.11 in
103.12
103.13 -val hyprealT = Type ("StarDef.star", [HOLogic.realT]);
103.14 +val hyprealT = Type (@{type_name StarDef.star}, [HOLogic.realT]);
103.15
103.16 val fast_hypreal_arith_simproc =
103.17 Simplifier.simproc (the_context ())
103.18 @@ -40,7 +39,7 @@
103.19 lessD = lessD, (*Can't change lessD: the hypreals are dense!*)
103.20 neqE = neqE,
103.21 simpset = simpset addsimps simps}) #>
103.22 - arith_inj_const ("StarDef.star_of", HOLogic.realT --> hyprealT) #>
103.23 + Lin_Arith.add_inj_const (@{const_name "StarDef.star_of"}, HOLogic.realT --> hyprealT) #>
103.24 Simplifier.map_ss (fn ss => ss addsimprocs [fast_hypreal_arith_simproc]);
103.25
103.26 end;
104.1 --- a/src/HOL/Nat.thy Mon May 11 09:39:53 2009 +0200
104.2 +++ b/src/HOL/Nat.thy Mon May 11 17:20:52 2009 +0200
104.3 @@ -1164,6 +1164,64 @@
104.4 end
104.5
104.6
104.7 +subsection {* Natural operation of natural numbers on functions *}
104.8 +
104.9 +text {*
104.10 + We use the same logical constant for the power operations on
104.11 + functions and relations, in order to share the same syntax.
104.12 +*}
104.13 +
104.14 +consts compow :: "nat \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)"
104.15 +
104.16 +abbreviation compower :: "('a \<Rightarrow> 'b) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'b" (infixr "^^" 80) where
104.17 + "f ^^ n \<equiv> compow n f"
104.18 +
104.19 +notation (latex output)
104.20 + compower ("(_\<^bsup>_\<^esup>)" [1000] 1000)
104.21 +
104.22 +notation (HTML output)
104.23 + compower ("(_\<^bsup>_\<^esup>)" [1000] 1000)
104.24 +
104.25 +text {* @{text "f ^^ n = f o ... o f"}, the n-fold composition of @{text f} *}
104.26 +
104.27 +overloading
104.28 + funpow == "compow :: nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)"
104.29 +begin
104.30 +
104.31 +primrec funpow :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" where
104.32 + "funpow 0 f = id"
104.33 + | "funpow (Suc n) f = f o funpow n f"
104.34 +
104.35 +end
104.36 +
104.37 +text {* for code generation *}
104.38 +
104.39 +definition funpow :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" where
104.40 + funpow_code_def [code post]: "funpow = compow"
104.41 +
104.42 +lemmas [code inline] = funpow_code_def [symmetric]
104.43 +
104.44 +lemma [code]:
104.45 + "funpow 0 f = id"
104.46 + "funpow (Suc n) f = f o funpow n f"
104.47 + unfolding funpow_code_def by simp_all
104.48 +
104.49 +hide (open) const funpow
104.50 +
104.51 +lemma funpow_add:
104.52 + "f ^^ (m + n) = f ^^ m \<circ> f ^^ n"
104.53 + by (induct m) simp_all
104.54 +
104.55 +lemma funpow_swap1:
104.56 + "f ((f ^^ n) x) = (f ^^ n) (f x)"
104.57 +proof -
104.58 + have "f ((f ^^ n) x) = (f ^^ (n + 1)) x" by simp
104.59 + also have "\<dots> = (f ^^ n o f ^^ 1) x" by (simp only: funpow_add)
104.60 + also have "\<dots> = (f ^^ n) (f x)" by simp
104.61 + finally show ?thesis .
104.62 +qed
104.63 +
104.64 +
104.65 subsection {* Embedding of the Naturals into any
104.66 @{text semiring_1}: @{term of_nat} *}
104.67
104.68 @@ -1189,7 +1247,7 @@
104.69 "of_nat_aux inc 0 i = i"
104.70 | "of_nat_aux inc (Suc n) i = of_nat_aux inc n (inc i)" -- {* tail recursive *}
104.71
104.72 -lemma of_nat_code [code, code unfold, code inline del]:
104.73 +lemma of_nat_code:
104.74 "of_nat n = of_nat_aux (\<lambda>i. i + 1) n 0"
104.75 proof (induct n)
104.76 case 0 then show ?case by simp
104.77 @@ -1201,9 +1259,11 @@
104.78 by simp
104.79 with Suc show ?case by (simp add: add_commute)
104.80 qed
104.81 -
104.82 +
104.83 end
104.84
104.85 +declare of_nat_code [code, code unfold, code inline del]
104.86 +
104.87 text{*Class for unital semirings with characteristic zero.
104.88 Includes non-ordered rings like the complex numbers.*}
104.89
104.90 @@ -1214,10 +1274,10 @@
104.91 text{*Special cases where either operand is zero*}
104.92
104.93 lemma of_nat_0_eq_iff [simp, noatp]: "0 = of_nat n \<longleftrightarrow> 0 = n"
104.94 - by (rule of_nat_eq_iff [of 0, simplified])
104.95 + by (rule of_nat_eq_iff [of 0 n, unfolded of_nat_0])
104.96
104.97 lemma of_nat_eq_0_iff [simp, noatp]: "of_nat m = 0 \<longleftrightarrow> m = 0"
104.98 - by (rule of_nat_eq_iff [of _ 0, simplified])
104.99 + by (rule of_nat_eq_iff [of m 0, unfolded of_nat_0])
104.100
104.101 lemma inj_of_nat: "inj of_nat"
104.102 by (simp add: inj_on_def)
105.1 --- a/src/HOL/NatBin.thy Mon May 11 09:39:53 2009 +0200
105.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
105.3 @@ -1,975 +0,0 @@
105.4 -(* Title: HOL/NatBin.thy
105.5 - Author: Lawrence C Paulson, Cambridge University Computer Laboratory
105.6 - Copyright 1999 University of Cambridge
105.7 -*)
105.8 -
105.9 -header {* Binary arithmetic for the natural numbers *}
105.10 -
105.11 -theory NatBin
105.12 -imports IntDiv
105.13 -uses ("Tools/nat_simprocs.ML")
105.14 -begin
105.15 -
105.16 -text {*
105.17 - Arithmetic for naturals is reduced to that for the non-negative integers.
105.18 -*}
105.19 -
105.20 -instantiation nat :: number
105.21 -begin
105.22 -
105.23 -definition
105.24 - nat_number_of_def [code inline, code del]: "number_of v = nat (number_of v)"
105.25 -
105.26 -instance ..
105.27 -
105.28 -end
105.29 -
105.30 -lemma [code post]:
105.31 - "nat (number_of v) = number_of v"
105.32 - unfolding nat_number_of_def ..
105.33 -
105.34 -abbreviation (xsymbols)
105.35 - power2 :: "'a::power => 'a" ("(_\<twosuperior>)" [1000] 999) where
105.36 - "x\<twosuperior> == x^2"
105.37 -
105.38 -notation (latex output)
105.39 - power2 ("(_\<twosuperior>)" [1000] 999)
105.40 -
105.41 -notation (HTML output)
105.42 - power2 ("(_\<twosuperior>)" [1000] 999)
105.43 -
105.44 -
105.45 -subsection {* Predicate for negative binary numbers *}
105.46 -
105.47 -definition neg :: "int \<Rightarrow> bool" where
105.48 - "neg Z \<longleftrightarrow> Z < 0"
105.49 -
105.50 -lemma not_neg_int [simp]: "~ neg (of_nat n)"
105.51 -by (simp add: neg_def)
105.52 -
105.53 -lemma neg_zminus_int [simp]: "neg (- (of_nat (Suc n)))"
105.54 -by (simp add: neg_def neg_less_0_iff_less del: of_nat_Suc)
105.55 -
105.56 -lemmas neg_eq_less_0 = neg_def
105.57 -
105.58 -lemma not_neg_eq_ge_0: "(~neg x) = (0 \<le> x)"
105.59 -by (simp add: neg_def linorder_not_less)
105.60 -
105.61 -text{*To simplify inequalities when Numeral1 can get simplified to 1*}
105.62 -
105.63 -lemma not_neg_0: "~ neg 0"
105.64 -by (simp add: One_int_def neg_def)
105.65 -
105.66 -lemma not_neg_1: "~ neg 1"
105.67 -by (simp add: neg_def linorder_not_less zero_le_one)
105.68 -
105.69 -lemma neg_nat: "neg z ==> nat z = 0"
105.70 -by (simp add: neg_def order_less_imp_le)
105.71 -
105.72 -lemma not_neg_nat: "~ neg z ==> of_nat (nat z) = z"
105.73 -by (simp add: linorder_not_less neg_def)
105.74 -
105.75 -text {*
105.76 - If @{term Numeral0} is rewritten to 0 then this rule can't be applied:
105.77 - @{term Numeral0} IS @{term "number_of Pls"}
105.78 -*}
105.79 -
105.80 -lemma not_neg_number_of_Pls: "~ neg (number_of Int.Pls)"
105.81 - by (simp add: neg_def)
105.82 -
105.83 -lemma neg_number_of_Min: "neg (number_of Int.Min)"
105.84 - by (simp add: neg_def)
105.85 -
105.86 -lemma neg_number_of_Bit0:
105.87 - "neg (number_of (Int.Bit0 w)) = neg (number_of w)"
105.88 - by (simp add: neg_def)
105.89 -
105.90 -lemma neg_number_of_Bit1:
105.91 - "neg (number_of (Int.Bit1 w)) = neg (number_of w)"
105.92 - by (simp add: neg_def)
105.93 -
105.94 -lemmas neg_simps [simp] =
105.95 - not_neg_0 not_neg_1
105.96 - not_neg_number_of_Pls neg_number_of_Min
105.97 - neg_number_of_Bit0 neg_number_of_Bit1
105.98 -
105.99 -
105.100 -subsection{*Function @{term nat}: Coercion from Type @{typ int} to @{typ nat}*}
105.101 -
105.102 -declare nat_0 [simp] nat_1 [simp]
105.103 -
105.104 -lemma nat_number_of [simp]: "nat (number_of w) = number_of w"
105.105 -by (simp add: nat_number_of_def)
105.106 -
105.107 -lemma nat_numeral_0_eq_0 [simp]: "Numeral0 = (0::nat)"
105.108 -by (simp add: nat_number_of_def)
105.109 -
105.110 -lemma nat_numeral_1_eq_1 [simp]: "Numeral1 = (1::nat)"
105.111 -by (simp add: nat_1 nat_number_of_def)
105.112 -
105.113 -lemma numeral_1_eq_Suc_0: "Numeral1 = Suc 0"
105.114 -by (simp add: nat_numeral_1_eq_1)
105.115 -
105.116 -lemma numeral_2_eq_2: "2 = Suc (Suc 0)"
105.117 -apply (unfold nat_number_of_def)
105.118 -apply (rule nat_2)
105.119 -done
105.120 -
105.121 -
105.122 -subsection{*Function @{term int}: Coercion from Type @{typ nat} to @{typ int}*}
105.123 -
105.124 -lemma int_nat_number_of [simp]:
105.125 - "int (number_of v) =
105.126 - (if neg (number_of v :: int) then 0
105.127 - else (number_of v :: int))"
105.128 - unfolding nat_number_of_def number_of_is_id neg_def
105.129 - by simp
105.130 -
105.131 -
105.132 -subsubsection{*Successor *}
105.133 -
105.134 -lemma Suc_nat_eq_nat_zadd1: "(0::int) <= z ==> Suc (nat z) = nat (1 + z)"
105.135 -apply (rule sym)
105.136 -apply (simp add: nat_eq_iff int_Suc)
105.137 -done
105.138 -
105.139 -lemma Suc_nat_number_of_add:
105.140 - "Suc (number_of v + n) =
105.141 - (if neg (number_of v :: int) then 1+n else number_of (Int.succ v) + n)"
105.142 - unfolding nat_number_of_def number_of_is_id neg_def numeral_simps
105.143 - by (simp add: Suc_nat_eq_nat_zadd1 add_ac)
105.144 -
105.145 -lemma Suc_nat_number_of [simp]:
105.146 - "Suc (number_of v) =
105.147 - (if neg (number_of v :: int) then 1 else number_of (Int.succ v))"
105.148 -apply (cut_tac n = 0 in Suc_nat_number_of_add)
105.149 -apply (simp cong del: if_weak_cong)
105.150 -done
105.151 -
105.152 -
105.153 -subsubsection{*Addition *}
105.154 -
105.155 -lemma add_nat_number_of [simp]:
105.156 - "(number_of v :: nat) + number_of v' =
105.157 - (if v < Int.Pls then number_of v'
105.158 - else if v' < Int.Pls then number_of v
105.159 - else number_of (v + v'))"
105.160 - unfolding nat_number_of_def number_of_is_id numeral_simps
105.161 - by (simp add: nat_add_distrib)
105.162 -
105.163 -lemma nat_number_of_add_1 [simp]:
105.164 - "number_of v + (1::nat) =
105.165 - (if v < Int.Pls then 1 else number_of (Int.succ v))"
105.166 - unfolding nat_number_of_def number_of_is_id numeral_simps
105.167 - by (simp add: nat_add_distrib)
105.168 -
105.169 -lemma nat_1_add_number_of [simp]:
105.170 - "(1::nat) + number_of v =
105.171 - (if v < Int.Pls then 1 else number_of (Int.succ v))"
105.172 - unfolding nat_number_of_def number_of_is_id numeral_simps
105.173 - by (simp add: nat_add_distrib)
105.174 -
105.175 -lemma nat_1_add_1 [simp]: "1 + 1 = (2::nat)"
105.176 - by (rule int_int_eq [THEN iffD1]) simp
105.177 -
105.178 -
105.179 -subsubsection{*Subtraction *}
105.180 -
105.181 -lemma diff_nat_eq_if:
105.182 - "nat z - nat z' =
105.183 - (if neg z' then nat z
105.184 - else let d = z-z' in
105.185 - if neg d then 0 else nat d)"
105.186 -by (simp add: Let_def nat_diff_distrib [symmetric] neg_eq_less_0 not_neg_eq_ge_0)
105.187 -
105.188 -
105.189 -lemma diff_nat_number_of [simp]:
105.190 - "(number_of v :: nat) - number_of v' =
105.191 - (if v' < Int.Pls then number_of v
105.192 - else let d = number_of (v + uminus v') in
105.193 - if neg d then 0 else nat d)"
105.194 - unfolding nat_number_of_def number_of_is_id numeral_simps neg_def
105.195 - by auto
105.196 -
105.197 -lemma nat_number_of_diff_1 [simp]:
105.198 - "number_of v - (1::nat) =
105.199 - (if v \<le> Int.Pls then 0 else number_of (Int.pred v))"
105.200 - unfolding nat_number_of_def number_of_is_id numeral_simps
105.201 - by auto
105.202 -
105.203 -
105.204 -subsubsection{*Multiplication *}
105.205 -
105.206 -lemma mult_nat_number_of [simp]:
105.207 - "(number_of v :: nat) * number_of v' =
105.208 - (if v < Int.Pls then 0 else number_of (v * v'))"
105.209 - unfolding nat_number_of_def number_of_is_id numeral_simps
105.210 - by (simp add: nat_mult_distrib)
105.211 -
105.212 -
105.213 -subsubsection{*Quotient *}
105.214 -
105.215 -lemma div_nat_number_of [simp]:
105.216 - "(number_of v :: nat) div number_of v' =
105.217 - (if neg (number_of v :: int) then 0
105.218 - else nat (number_of v div number_of v'))"
105.219 - unfolding nat_number_of_def number_of_is_id neg_def
105.220 - by (simp add: nat_div_distrib)
105.221 -
105.222 -lemma one_div_nat_number_of [simp]:
105.223 - "Suc 0 div number_of v' = nat (1 div number_of v')"
105.224 -by (simp del: nat_numeral_1_eq_1 add: numeral_1_eq_Suc_0 [symmetric])
105.225 -
105.226 -
105.227 -subsubsection{*Remainder *}
105.228 -
105.229 -lemma mod_nat_number_of [simp]:
105.230 - "(number_of v :: nat) mod number_of v' =
105.231 - (if neg (number_of v :: int) then 0
105.232 - else if neg (number_of v' :: int) then number_of v
105.233 - else nat (number_of v mod number_of v'))"
105.234 - unfolding nat_number_of_def number_of_is_id neg_def
105.235 - by (simp add: nat_mod_distrib)
105.236 -
105.237 -lemma one_mod_nat_number_of [simp]:
105.238 - "Suc 0 mod number_of v' =
105.239 - (if neg (number_of v' :: int) then Suc 0
105.240 - else nat (1 mod number_of v'))"
105.241 -by (simp del: nat_numeral_1_eq_1 add: numeral_1_eq_Suc_0 [symmetric])
105.242 -
105.243 -
105.244 -subsubsection{* Divisibility *}
105.245 -
105.246 -lemmas dvd_eq_mod_eq_0_number_of =
105.247 - dvd_eq_mod_eq_0 [of "number_of x" "number_of y", standard]
105.248 -
105.249 -declare dvd_eq_mod_eq_0_number_of [simp]
105.250 -
105.251 -ML
105.252 -{*
105.253 -val nat_number_of_def = thm"nat_number_of_def";
105.254 -
105.255 -val nat_number_of = thm"nat_number_of";
105.256 -val nat_numeral_0_eq_0 = thm"nat_numeral_0_eq_0";
105.257 -val nat_numeral_1_eq_1 = thm"nat_numeral_1_eq_1";
105.258 -val numeral_1_eq_Suc_0 = thm"numeral_1_eq_Suc_0";
105.259 -val numeral_2_eq_2 = thm"numeral_2_eq_2";
105.260 -val nat_div_distrib = thm"nat_div_distrib";
105.261 -val nat_mod_distrib = thm"nat_mod_distrib";
105.262 -val int_nat_number_of = thm"int_nat_number_of";
105.263 -val Suc_nat_eq_nat_zadd1 = thm"Suc_nat_eq_nat_zadd1";
105.264 -val Suc_nat_number_of_add = thm"Suc_nat_number_of_add";
105.265 -val Suc_nat_number_of = thm"Suc_nat_number_of";
105.266 -val add_nat_number_of = thm"add_nat_number_of";
105.267 -val diff_nat_eq_if = thm"diff_nat_eq_if";
105.268 -val diff_nat_number_of = thm"diff_nat_number_of";
105.269 -val mult_nat_number_of = thm"mult_nat_number_of";
105.270 -val div_nat_number_of = thm"div_nat_number_of";
105.271 -val mod_nat_number_of = thm"mod_nat_number_of";
105.272 -*}
105.273 -
105.274 -
105.275 -subsection{*Comparisons*}
105.276 -
105.277 -subsubsection{*Equals (=) *}
105.278 -
105.279 -lemma eq_nat_nat_iff:
105.280 - "[| (0::int) <= z; 0 <= z' |] ==> (nat z = nat z') = (z=z')"
105.281 -by (auto elim!: nonneg_eq_int)
105.282 -
105.283 -lemma eq_nat_number_of [simp]:
105.284 - "((number_of v :: nat) = number_of v') =
105.285 - (if neg (number_of v :: int) then (number_of v' :: int) \<le> 0
105.286 - else if neg (number_of v' :: int) then (number_of v :: int) = 0
105.287 - else v = v')"
105.288 - unfolding nat_number_of_def number_of_is_id neg_def
105.289 - by auto
105.290 -
105.291 -
105.292 -subsubsection{*Less-than (<) *}
105.293 -
105.294 -lemma less_nat_number_of [simp]:
105.295 - "(number_of v :: nat) < number_of v' \<longleftrightarrow>
105.296 - (if v < v' then Int.Pls < v' else False)"
105.297 - unfolding nat_number_of_def number_of_is_id numeral_simps
105.298 - by auto
105.299 -
105.300 -
105.301 -subsubsection{*Less-than-or-equal *}
105.302 -
105.303 -lemma le_nat_number_of [simp]:
105.304 - "(number_of v :: nat) \<le> number_of v' \<longleftrightarrow>
105.305 - (if v \<le> v' then True else v \<le> Int.Pls)"
105.306 - unfolding nat_number_of_def number_of_is_id numeral_simps
105.307 - by auto
105.308 -
105.309 -(*Maps #n to n for n = 0, 1, 2*)
105.310 -lemmas numerals = nat_numeral_0_eq_0 nat_numeral_1_eq_1 numeral_2_eq_2
105.311 -
105.312 -
105.313 -subsection{*Powers with Numeric Exponents*}
105.314 -
105.315 -text{*We cannot refer to the number @{term 2} in @{text Ring_and_Field.thy}.
105.316 -We cannot prove general results about the numeral @{term "-1"}, so we have to
105.317 -use @{term "- 1"} instead.*}
105.318 -
105.319 -lemma power2_eq_square: "(a::'a::recpower)\<twosuperior> = a * a"
105.320 - by (simp add: numeral_2_eq_2 Power.power_Suc)
105.321 -
105.322 -lemma zero_power2 [simp]: "(0::'a::{semiring_1,recpower})\<twosuperior> = 0"
105.323 - by (simp add: power2_eq_square)
105.324 -
105.325 -lemma one_power2 [simp]: "(1::'a::{semiring_1,recpower})\<twosuperior> = 1"
105.326 - by (simp add: power2_eq_square)
105.327 -
105.328 -lemma power3_eq_cube: "(x::'a::recpower) ^ 3 = x * x * x"
105.329 - apply (subgoal_tac "3 = Suc (Suc (Suc 0))")
105.330 - apply (erule ssubst)
105.331 - apply (simp add: power_Suc mult_ac)
105.332 - apply (unfold nat_number_of_def)
105.333 - apply (subst nat_eq_iff)
105.334 - apply simp
105.335 -done
105.336 -
105.337 -text{*Squares of literal numerals will be evaluated.*}
105.338 -lemmas power2_eq_square_number_of =
105.339 - power2_eq_square [of "number_of w", standard]
105.340 -declare power2_eq_square_number_of [simp]
105.341 -
105.342 -
105.343 -lemma zero_le_power2[simp]: "0 \<le> (a\<twosuperior>::'a::{ordered_idom,recpower})"
105.344 - by (simp add: power2_eq_square)
105.345 -
105.346 -lemma zero_less_power2[simp]:
105.347 - "(0 < a\<twosuperior>) = (a \<noteq> (0::'a::{ordered_idom,recpower}))"
105.348 - by (force simp add: power2_eq_square zero_less_mult_iff linorder_neq_iff)
105.349 -
105.350 -lemma power2_less_0[simp]:
105.351 - fixes a :: "'a::{ordered_idom,recpower}"
105.352 - shows "~ (a\<twosuperior> < 0)"
105.353 -by (force simp add: power2_eq_square mult_less_0_iff)
105.354 -
105.355 -lemma zero_eq_power2[simp]:
105.356 - "(a\<twosuperior> = 0) = (a = (0::'a::{ordered_idom,recpower}))"
105.357 - by (force simp add: power2_eq_square mult_eq_0_iff)
105.358 -
105.359 -lemma abs_power2[simp]:
105.360 - "abs(a\<twosuperior>) = (a\<twosuperior>::'a::{ordered_idom,recpower})"
105.361 - by (simp add: power2_eq_square abs_mult abs_mult_self)
105.362 -
105.363 -lemma power2_abs[simp]:
105.364 - "(abs a)\<twosuperior> = (a\<twosuperior>::'a::{ordered_idom,recpower})"
105.365 - by (simp add: power2_eq_square abs_mult_self)
105.366 -
105.367 -lemma power2_minus[simp]:
105.368 - "(- a)\<twosuperior> = (a\<twosuperior>::'a::{comm_ring_1,recpower})"
105.369 - by (simp add: power2_eq_square)
105.370 -
105.371 -lemma power2_le_imp_le:
105.372 - fixes x y :: "'a::{ordered_semidom,recpower}"
105.373 - shows "\<lbrakk>x\<twosuperior> \<le> y\<twosuperior>; 0 \<le> y\<rbrakk> \<Longrightarrow> x \<le> y"
105.374 -unfolding numeral_2_eq_2 by (rule power_le_imp_le_base)
105.375 -
105.376 -lemma power2_less_imp_less:
105.377 - fixes x y :: "'a::{ordered_semidom,recpower}"
105.378 - shows "\<lbrakk>x\<twosuperior> < y\<twosuperior>; 0 \<le> y\<rbrakk> \<Longrightarrow> x < y"
105.379 -by (rule power_less_imp_less_base)
105.380 -
105.381 -lemma power2_eq_imp_eq:
105.382 - fixes x y :: "'a::{ordered_semidom,recpower}"
105.383 - shows "\<lbrakk>x\<twosuperior> = y\<twosuperior>; 0 \<le> x; 0 \<le> y\<rbrakk> \<Longrightarrow> x = y"
105.384 -unfolding numeral_2_eq_2 by (erule (2) power_eq_imp_eq_base, simp)
105.385 -
105.386 -lemma power_minus1_even[simp]: "(- 1) ^ (2*n) = (1::'a::{comm_ring_1,recpower})"
105.387 -proof (induct n)
105.388 - case 0 show ?case by simp
105.389 -next
105.390 - case (Suc n) then show ?case by (simp add: power_Suc power_add)
105.391 -qed
105.392 -
105.393 -lemma power_minus1_odd: "(- 1) ^ Suc(2*n) = -(1::'a::{comm_ring_1,recpower})"
105.394 - by (simp add: power_Suc)
105.395 -
105.396 -lemma power_even_eq: "(a::'a::recpower) ^ (2*n) = (a^n)^2"
105.397 -by (subst mult_commute) (simp add: power_mult)
105.398 -
105.399 -lemma power_odd_eq: "(a::int) ^ Suc(2*n) = a * (a^n)^2"
105.400 -by (simp add: power_even_eq)
105.401 -
105.402 -lemma power_minus_even [simp]:
105.403 - "(-a) ^ (2*n) = (a::'a::{comm_ring_1,recpower}) ^ (2*n)"
105.404 -by (simp add: power_minus1_even power_minus [of a])
105.405 -
105.406 -lemma zero_le_even_power'[simp]:
105.407 - "0 \<le> (a::'a::{ordered_idom,recpower}) ^ (2*n)"
105.408 -proof (induct "n")
105.409 - case 0
105.410 - show ?case by (simp add: zero_le_one)
105.411 -next
105.412 - case (Suc n)
105.413 - have "a ^ (2 * Suc n) = (a*a) * a ^ (2*n)"
105.414 - by (simp add: mult_ac power_add power2_eq_square)
105.415 - thus ?case
105.416 - by (simp add: prems zero_le_mult_iff)
105.417 -qed
105.418 -
105.419 -lemma odd_power_less_zero:
105.420 - "(a::'a::{ordered_idom,recpower}) < 0 ==> a ^ Suc(2*n) < 0"
105.421 -proof (induct "n")
105.422 - case 0
105.423 - then show ?case by simp
105.424 -next
105.425 - case (Suc n)
105.426 - have "a ^ Suc (2 * Suc n) = (a*a) * a ^ Suc(2*n)"
105.427 - by (simp add: mult_ac power_add power2_eq_square)
105.428 - thus ?case
105.429 - by (simp del: power_Suc add: prems mult_less_0_iff mult_neg_neg)
105.430 -qed
105.431 -
105.432 -lemma odd_0_le_power_imp_0_le:
105.433 - "0 \<le> a ^ Suc(2*n) ==> 0 \<le> (a::'a::{ordered_idom,recpower})"
105.434 -apply (insert odd_power_less_zero [of a n])
105.435 -apply (force simp add: linorder_not_less [symmetric])
105.436 -done
105.437 -
105.438 -text{*Simprules for comparisons where common factors can be cancelled.*}
105.439 -lemmas zero_compare_simps =
105.440 - add_strict_increasing add_strict_increasing2 add_increasing
105.441 - zero_le_mult_iff zero_le_divide_iff
105.442 - zero_less_mult_iff zero_less_divide_iff
105.443 - mult_le_0_iff divide_le_0_iff
105.444 - mult_less_0_iff divide_less_0_iff
105.445 - zero_le_power2 power2_less_0
105.446 -
105.447 -subsubsection{*Nat *}
105.448 -
105.449 -lemma Suc_pred': "0 < n ==> n = Suc(n - 1)"
105.450 -by (simp add: numerals)
105.451 -
105.452 -(*Expresses a natural number constant as the Suc of another one.
105.453 - NOT suitable for rewriting because n recurs in the condition.*)
105.454 -lemmas expand_Suc = Suc_pred' [of "number_of v", standard]
105.455 -
105.456 -subsubsection{*Arith *}
105.457 -
105.458 -lemma Suc_eq_add_numeral_1: "Suc n = n + 1"
105.459 -by (simp add: numerals)
105.460 -
105.461 -lemma Suc_eq_add_numeral_1_left: "Suc n = 1 + n"
105.462 -by (simp add: numerals)
105.463 -
105.464 -(* These two can be useful when m = number_of... *)
105.465 -
105.466 -lemma add_eq_if: "(m::nat) + n = (if m=0 then n else Suc ((m - 1) + n))"
105.467 - unfolding One_nat_def by (cases m) simp_all
105.468 -
105.469 -lemma mult_eq_if: "(m::nat) * n = (if m=0 then 0 else n + ((m - 1) * n))"
105.470 - unfolding One_nat_def by (cases m) simp_all
105.471 -
105.472 -lemma power_eq_if: "(p ^ m :: nat) = (if m=0 then 1 else p * (p ^ (m - 1)))"
105.473 - unfolding One_nat_def by (cases m) simp_all
105.474 -
105.475 -
105.476 -subsection{*Comparisons involving (0::nat) *}
105.477 -
105.478 -text{*Simplification already does @{term "n<0"}, @{term "n\<le>0"} and @{term "0\<le>n"}.*}
105.479 -
105.480 -lemma eq_number_of_0 [simp]:
105.481 - "number_of v = (0::nat) \<longleftrightarrow> v \<le> Int.Pls"
105.482 - unfolding nat_number_of_def number_of_is_id numeral_simps
105.483 - by auto
105.484 -
105.485 -lemma eq_0_number_of [simp]:
105.486 - "(0::nat) = number_of v \<longleftrightarrow> v \<le> Int.Pls"
105.487 -by (rule trans [OF eq_sym_conv eq_number_of_0])
105.488 -
105.489 -lemma less_0_number_of [simp]:
105.490 - "(0::nat) < number_of v \<longleftrightarrow> Int.Pls < v"
105.491 - unfolding nat_number_of_def number_of_is_id numeral_simps
105.492 - by simp
105.493 -
105.494 -lemma neg_imp_number_of_eq_0: "neg (number_of v :: int) ==> number_of v = (0::nat)"
105.495 -by (simp del: nat_numeral_0_eq_0 add: nat_numeral_0_eq_0 [symmetric])
105.496 -
105.497 -
105.498 -
105.499 -subsection{*Comparisons involving @{term Suc} *}
105.500 -
105.501 -lemma eq_number_of_Suc [simp]:
105.502 - "(number_of v = Suc n) =
105.503 - (let pv = number_of (Int.pred v) in
105.504 - if neg pv then False else nat pv = n)"
105.505 -apply (simp only: simp_thms Let_def neg_eq_less_0 linorder_not_less
105.506 - number_of_pred nat_number_of_def
105.507 - split add: split_if)
105.508 -apply (rule_tac x = "number_of v" in spec)
105.509 -apply (auto simp add: nat_eq_iff)
105.510 -done
105.511 -
105.512 -lemma Suc_eq_number_of [simp]:
105.513 - "(Suc n = number_of v) =
105.514 - (let pv = number_of (Int.pred v) in
105.515 - if neg pv then False else nat pv = n)"
105.516 -by (rule trans [OF eq_sym_conv eq_number_of_Suc])
105.517 -
105.518 -lemma less_number_of_Suc [simp]:
105.519 - "(number_of v < Suc n) =
105.520 - (let pv = number_of (Int.pred v) in
105.521 - if neg pv then True else nat pv < n)"
105.522 -apply (simp only: simp_thms Let_def neg_eq_less_0 linorder_not_less
105.523 - number_of_pred nat_number_of_def
105.524 - split add: split_if)
105.525 -apply (rule_tac x = "number_of v" in spec)
105.526 -apply (auto simp add: nat_less_iff)
105.527 -done
105.528 -
105.529 -lemma less_Suc_number_of [simp]:
105.530 - "(Suc n < number_of v) =
105.531 - (let pv = number_of (Int.pred v) in
105.532 - if neg pv then False else n < nat pv)"
105.533 -apply (simp only: simp_thms Let_def neg_eq_less_0 linorder_not_less
105.534 - number_of_pred nat_number_of_def
105.535 - split add: split_if)
105.536 -apply (rule_tac x = "number_of v" in spec)
105.537 -apply (auto simp add: zless_nat_eq_int_zless)
105.538 -done
105.539 -
105.540 -lemma le_number_of_Suc [simp]:
105.541 - "(number_of v <= Suc n) =
105.542 - (let pv = number_of (Int.pred v) in
105.543 - if neg pv then True else nat pv <= n)"
105.544 -by (simp add: Let_def less_Suc_number_of linorder_not_less [symmetric])
105.545 -
105.546 -lemma le_Suc_number_of [simp]:
105.547 - "(Suc n <= number_of v) =
105.548 - (let pv = number_of (Int.pred v) in
105.549 - if neg pv then False else n <= nat pv)"
105.550 -by (simp add: Let_def less_number_of_Suc linorder_not_less [symmetric])
105.551 -
105.552 -
105.553 -lemma eq_number_of_Pls_Min: "(Numeral0 ::int) ~= number_of Int.Min"
105.554 -by auto
105.555 -
105.556 -
105.557 -
105.558 -subsection{*Max and Min Combined with @{term Suc} *}
105.559 -
105.560 -lemma max_number_of_Suc [simp]:
105.561 - "max (Suc n) (number_of v) =
105.562 - (let pv = number_of (Int.pred v) in
105.563 - if neg pv then Suc n else Suc(max n (nat pv)))"
105.564 -apply (simp only: Let_def neg_eq_less_0 number_of_pred nat_number_of_def
105.565 - split add: split_if nat.split)
105.566 -apply (rule_tac x = "number_of v" in spec)
105.567 -apply auto
105.568 -done
105.569 -
105.570 -lemma max_Suc_number_of [simp]:
105.571 - "max (number_of v) (Suc n) =
105.572 - (let pv = number_of (Int.pred v) in
105.573 - if neg pv then Suc n else Suc(max (nat pv) n))"
105.574 -apply (simp only: Let_def neg_eq_less_0 number_of_pred nat_number_of_def
105.575 - split add: split_if nat.split)
105.576 -apply (rule_tac x = "number_of v" in spec)
105.577 -apply auto
105.578 -done
105.579 -
105.580 -lemma min_number_of_Suc [simp]:
105.581 - "min (Suc n) (number_of v) =
105.582 - (let pv = number_of (Int.pred v) in
105.583 - if neg pv then 0 else Suc(min n (nat pv)))"
105.584 -apply (simp only: Let_def neg_eq_less_0 number_of_pred nat_number_of_def
105.585 - split add: split_if nat.split)
105.586 -apply (rule_tac x = "number_of v" in spec)
105.587 -apply auto
105.588 -done
105.589 -
105.590 -lemma min_Suc_number_of [simp]:
105.591 - "min (number_of v) (Suc n) =
105.592 - (let pv = number_of (Int.pred v) in
105.593 - if neg pv then 0 else Suc(min (nat pv) n))"
105.594 -apply (simp only: Let_def neg_eq_less_0 number_of_pred nat_number_of_def
105.595 - split add: split_if nat.split)
105.596 -apply (rule_tac x = "number_of v" in spec)
105.597 -apply auto
105.598 -done
105.599 -
105.600 -subsection{*Literal arithmetic involving powers*}
105.601 -
105.602 -lemma nat_power_eq: "(0::int) <= z ==> nat (z^n) = nat z ^ n"
105.603 -apply (induct "n")
105.604 -apply (simp_all (no_asm_simp) add: nat_mult_distrib)
105.605 -done
105.606 -
105.607 -lemma power_nat_number_of:
105.608 - "(number_of v :: nat) ^ n =
105.609 - (if neg (number_of v :: int) then 0^n else nat ((number_of v :: int) ^ n))"
105.610 -by (simp only: simp_thms neg_nat not_neg_eq_ge_0 nat_number_of_def nat_power_eq
105.611 - split add: split_if cong: imp_cong)
105.612 -
105.613 -
105.614 -lemmas power_nat_number_of_number_of = power_nat_number_of [of _ "number_of w", standard]
105.615 -declare power_nat_number_of_number_of [simp]
105.616 -
105.617 -
105.618 -
105.619 -text{*For arbitrary rings*}
105.620 -
105.621 -lemma power_number_of_even:
105.622 - fixes z :: "'a::{number_ring,recpower}"
105.623 - shows "z ^ number_of (Int.Bit0 w) = (let w = z ^ (number_of w) in w * w)"
105.624 -unfolding Let_def nat_number_of_def number_of_Bit0
105.625 -apply (rule_tac x = "number_of w" in spec, clarify)
105.626 -apply (case_tac " (0::int) <= x")
105.627 -apply (auto simp add: nat_mult_distrib power_even_eq power2_eq_square)
105.628 -done
105.629 -
105.630 -lemma power_number_of_odd:
105.631 - fixes z :: "'a::{number_ring,recpower}"
105.632 - shows "z ^ number_of (Int.Bit1 w) = (if (0::int) <= number_of w
105.633 - then (let w = z ^ (number_of w) in z * w * w) else 1)"
105.634 -unfolding Let_def nat_number_of_def number_of_Bit1
105.635 -apply (rule_tac x = "number_of w" in spec, auto)
105.636 -apply (simp only: nat_add_distrib nat_mult_distrib)
105.637 -apply simp
105.638 -apply (auto simp add: nat_add_distrib nat_mult_distrib power_even_eq power2_eq_square neg_nat power_Suc)
105.639 -done
105.640 -
105.641 -lemmas zpower_number_of_even = power_number_of_even [where 'a=int]
105.642 -lemmas zpower_number_of_odd = power_number_of_odd [where 'a=int]
105.643 -
105.644 -lemmas power_number_of_even_number_of [simp] =
105.645 - power_number_of_even [of "number_of v", standard]
105.646 -
105.647 -lemmas power_number_of_odd_number_of [simp] =
105.648 - power_number_of_odd [of "number_of v", standard]
105.649 -
105.650 -
105.651 -
105.652 -ML
105.653 -{*
105.654 -val numeral_ss = @{simpset} addsimps @{thms numerals};
105.655 -
105.656 -val nat_bin_arith_setup =
105.657 - Lin_Arith.map_data
105.658 - (fn {add_mono_thms, mult_mono_thms, inj_thms, lessD, neqE, simpset} =>
105.659 - {add_mono_thms = add_mono_thms, mult_mono_thms = mult_mono_thms,
105.660 - inj_thms = inj_thms,
105.661 - lessD = lessD, neqE = neqE,
105.662 - simpset = simpset addsimps @{thms neg_simps} @
105.663 - [@{thm Suc_nat_number_of}, @{thm int_nat_number_of}]})
105.664 -*}
105.665 -
105.666 -declaration {* K nat_bin_arith_setup *}
105.667 -
105.668 -(* Enable arith to deal with div/mod k where k is a numeral: *)
105.669 -declare split_div[of _ _ "number_of k", standard, arith_split]
105.670 -declare split_mod[of _ _ "number_of k", standard, arith_split]
105.671 -
105.672 -lemma nat_number_of_Pls: "Numeral0 = (0::nat)"
105.673 - by (simp add: number_of_Pls nat_number_of_def)
105.674 -
105.675 -lemma nat_number_of_Min: "number_of Int.Min = (0::nat)"
105.676 - apply (simp only: number_of_Min nat_number_of_def nat_zminus_int)
105.677 - done
105.678 -
105.679 -lemma nat_number_of_Bit0:
105.680 - "number_of (Int.Bit0 w) = (let n::nat = number_of w in n + n)"
105.681 - unfolding nat_number_of_def number_of_is_id numeral_simps Let_def
105.682 - by auto
105.683 -
105.684 -lemma nat_number_of_Bit1:
105.685 - "number_of (Int.Bit1 w) =
105.686 - (if neg (number_of w :: int) then 0
105.687 - else let n = number_of w in Suc (n + n))"
105.688 - unfolding nat_number_of_def number_of_is_id numeral_simps neg_def Let_def
105.689 - by auto
105.690 -
105.691 -lemmas nat_number =
105.692 - nat_number_of_Pls nat_number_of_Min
105.693 - nat_number_of_Bit0 nat_number_of_Bit1
105.694 -
105.695 -lemma Let_Suc [simp]: "Let (Suc n) f == f (Suc n)"
105.696 - by (simp add: Let_def)
105.697 -
105.698 -lemma power_m1_even: "(-1) ^ (2*n) = (1::'a::{number_ring,recpower})"
105.699 -by (simp add: power_mult power_Suc);
105.700 -
105.701 -lemma power_m1_odd: "(-1) ^ Suc(2*n) = (-1::'a::{number_ring,recpower})"
105.702 -by (simp add: power_mult power_Suc);
105.703 -
105.704 -
105.705 -subsection{*Literal arithmetic and @{term of_nat}*}
105.706 -
105.707 -lemma of_nat_double:
105.708 - "0 \<le> x ==> of_nat (nat (2 * x)) = of_nat (nat x) + of_nat (nat x)"
105.709 -by (simp only: mult_2 nat_add_distrib of_nat_add)
105.710 -
105.711 -lemma nat_numeral_m1_eq_0: "-1 = (0::nat)"
105.712 -by (simp only: nat_number_of_def)
105.713 -
105.714 -lemma of_nat_number_of_lemma:
105.715 - "of_nat (number_of v :: nat) =
105.716 - (if 0 \<le> (number_of v :: int)
105.717 - then (number_of v :: 'a :: number_ring)
105.718 - else 0)"
105.719 -by (simp add: int_number_of_def nat_number_of_def number_of_eq of_nat_nat);
105.720 -
105.721 -lemma of_nat_number_of_eq [simp]:
105.722 - "of_nat (number_of v :: nat) =
105.723 - (if neg (number_of v :: int) then 0
105.724 - else (number_of v :: 'a :: number_ring))"
105.725 -by (simp only: of_nat_number_of_lemma neg_def, simp)
105.726 -
105.727 -
105.728 -subsection {*Lemmas for the Combination and Cancellation Simprocs*}
105.729 -
105.730 -lemma nat_number_of_add_left:
105.731 - "number_of v + (number_of v' + (k::nat)) =
105.732 - (if neg (number_of v :: int) then number_of v' + k
105.733 - else if neg (number_of v' :: int) then number_of v + k
105.734 - else number_of (v + v') + k)"
105.735 - unfolding nat_number_of_def number_of_is_id neg_def
105.736 - by auto
105.737 -
105.738 -lemma nat_number_of_mult_left:
105.739 - "number_of v * (number_of v' * (k::nat)) =
105.740 - (if v < Int.Pls then 0
105.741 - else number_of (v * v') * k)"
105.742 -by simp
105.743 -
105.744 -
105.745 -subsubsection{*For @{text combine_numerals}*}
105.746 -
105.747 -lemma left_add_mult_distrib: "i*u + (j*u + k) = (i+j)*u + (k::nat)"
105.748 -by (simp add: add_mult_distrib)
105.749 -
105.750 -
105.751 -subsubsection{*For @{text cancel_numerals}*}
105.752 -
105.753 -lemma nat_diff_add_eq1:
105.754 - "j <= (i::nat) ==> ((i*u + m) - (j*u + n)) = (((i-j)*u + m) - n)"
105.755 -by (simp split add: nat_diff_split add: add_mult_distrib)
105.756 -
105.757 -lemma nat_diff_add_eq2:
105.758 - "i <= (j::nat) ==> ((i*u + m) - (j*u + n)) = (m - ((j-i)*u + n))"
105.759 -by (simp split add: nat_diff_split add: add_mult_distrib)
105.760 -
105.761 -lemma nat_eq_add_iff1:
105.762 - "j <= (i::nat) ==> (i*u + m = j*u + n) = ((i-j)*u + m = n)"
105.763 -by (auto split add: nat_diff_split simp add: add_mult_distrib)
105.764 -
105.765 -lemma nat_eq_add_iff2:
105.766 - "i <= (j::nat) ==> (i*u + m = j*u + n) = (m = (j-i)*u + n)"
105.767 -by (auto split add: nat_diff_split simp add: add_mult_distrib)
105.768 -
105.769 -lemma nat_less_add_iff1:
105.770 - "j <= (i::nat) ==> (i*u + m < j*u + n) = ((i-j)*u + m < n)"
105.771 -by (auto split add: nat_diff_split simp add: add_mult_distrib)
105.772 -
105.773 -lemma nat_less_add_iff2:
105.774 - "i <= (j::nat) ==> (i*u + m < j*u + n) = (m < (j-i)*u + n)"
105.775 -by (auto split add: nat_diff_split simp add: add_mult_distrib)
105.776 -
105.777 -lemma nat_le_add_iff1:
105.778 - "j <= (i::nat) ==> (i*u + m <= j*u + n) = ((i-j)*u + m <= n)"
105.779 -by (auto split add: nat_diff_split simp add: add_mult_distrib)
105.780 -
105.781 -lemma nat_le_add_iff2:
105.782 - "i <= (j::nat) ==> (i*u + m <= j*u + n) = (m <= (j-i)*u + n)"
105.783 -by (auto split add: nat_diff_split simp add: add_mult_distrib)
105.784 -
105.785 -
105.786 -subsubsection{*For @{text cancel_numeral_factors} *}
105.787 -
105.788 -lemma nat_mult_le_cancel1: "(0::nat) < k ==> (k*m <= k*n) = (m<=n)"
105.789 -by auto
105.790 -
105.791 -lemma nat_mult_less_cancel1: "(0::nat) < k ==> (k*m < k*n) = (m<n)"
105.792 -by auto
105.793 -
105.794 -lemma nat_mult_eq_cancel1: "(0::nat) < k ==> (k*m = k*n) = (m=n)"
105.795 -by auto
105.796 -
105.797 -lemma nat_mult_div_cancel1: "(0::nat) < k ==> (k*m) div (k*n) = (m div n)"
105.798 -by auto
105.799 -
105.800 -lemma nat_mult_dvd_cancel_disj[simp]:
105.801 - "(k*m) dvd (k*n) = (k=0 | m dvd (n::nat))"
105.802 -by(auto simp: dvd_eq_mod_eq_0 mod_mult_distrib2[symmetric])
105.803 -
105.804 -lemma nat_mult_dvd_cancel1: "0 < k \<Longrightarrow> (k*m) dvd (k*n::nat) = (m dvd n)"
105.805 -by(auto)
105.806 -
105.807 -
105.808 -subsubsection{*For @{text cancel_factor} *}
105.809 -
105.810 -lemma nat_mult_le_cancel_disj: "(k*m <= k*n) = ((0::nat) < k --> m<=n)"
105.811 -by auto
105.812 -
105.813 -lemma nat_mult_less_cancel_disj: "(k*m < k*n) = ((0::nat) < k & m<n)"
105.814 -by auto
105.815 -
105.816 -lemma nat_mult_eq_cancel_disj: "(k*m = k*n) = (k = (0::nat) | m=n)"
105.817 -by auto
105.818 -
105.819 -lemma nat_mult_div_cancel_disj[simp]:
105.820 - "(k*m) div (k*n) = (if k = (0::nat) then 0 else m div n)"
105.821 -by (simp add: nat_mult_div_cancel1)
105.822 -
105.823 -
105.824 -subsection {* Simprocs for the Naturals *}
105.825 -
105.826 -use "Tools/nat_simprocs.ML"
105.827 -declaration {* K nat_simprocs_setup *}
105.828 -
105.829 -subsubsection{*For simplifying @{term "Suc m - K"} and @{term "K - Suc m"}*}
105.830 -
105.831 -text{*Where K above is a literal*}
105.832 -
105.833 -lemma Suc_diff_eq_diff_pred: "Numeral0 < n ==> Suc m - n = m - (n - Numeral1)"
105.834 -by (simp add: numeral_0_eq_0 numeral_1_eq_1 split add: nat_diff_split)
105.835 -
105.836 -text {*Now just instantiating @{text n} to @{text "number_of v"} does
105.837 - the right simplification, but with some redundant inequality
105.838 - tests.*}
105.839 -lemma neg_number_of_pred_iff_0:
105.840 - "neg (number_of (Int.pred v)::int) = (number_of v = (0::nat))"
105.841 -apply (subgoal_tac "neg (number_of (Int.pred v)) = (number_of v < Suc 0) ")
105.842 -apply (simp only: less_Suc_eq_le le_0_eq)
105.843 -apply (subst less_number_of_Suc, simp)
105.844 -done
105.845 -
105.846 -text{*No longer required as a simprule because of the @{text inverse_fold}
105.847 - simproc*}
105.848 -lemma Suc_diff_number_of:
105.849 - "Int.Pls < v ==>
105.850 - Suc m - (number_of v) = m - (number_of (Int.pred v))"
105.851 -apply (subst Suc_diff_eq_diff_pred)
105.852 -apply simp
105.853 -apply (simp del: nat_numeral_1_eq_1)
105.854 -apply (auto simp only: diff_nat_number_of less_0_number_of [symmetric]
105.855 - neg_number_of_pred_iff_0)
105.856 -done
105.857 -
105.858 -lemma diff_Suc_eq_diff_pred: "m - Suc n = (m - 1) - n"
105.859 -by (simp add: numerals split add: nat_diff_split)
105.860 -
105.861 -
105.862 -subsubsection{*For @{term nat_case} and @{term nat_rec}*}
105.863 -
105.864 -lemma nat_case_number_of [simp]:
105.865 - "nat_case a f (number_of v) =
105.866 - (let pv = number_of (Int.pred v) in
105.867 - if neg pv then a else f (nat pv))"
105.868 -by (simp split add: nat.split add: Let_def neg_number_of_pred_iff_0)
105.869 -
105.870 -lemma nat_case_add_eq_if [simp]:
105.871 - "nat_case a f ((number_of v) + n) =
105.872 - (let pv = number_of (Int.pred v) in
105.873 - if neg pv then nat_case a f n else f (nat pv + n))"
105.874 -apply (subst add_eq_if)
105.875 -apply (simp split add: nat.split
105.876 - del: nat_numeral_1_eq_1
105.877 - add: nat_numeral_1_eq_1 [symmetric]
105.878 - numeral_1_eq_Suc_0 [symmetric]
105.879 - neg_number_of_pred_iff_0)
105.880 -done
105.881 -
105.882 -lemma nat_rec_number_of [simp]:
105.883 - "nat_rec a f (number_of v) =
105.884 - (let pv = number_of (Int.pred v) in
105.885 - if neg pv then a else f (nat pv) (nat_rec a f (nat pv)))"
105.886 -apply (case_tac " (number_of v) ::nat")
105.887 -apply (simp_all (no_asm_simp) add: Let_def neg_number_of_pred_iff_0)
105.888 -apply (simp split add: split_if_asm)
105.889 -done
105.890 -
105.891 -lemma nat_rec_add_eq_if [simp]:
105.892 - "nat_rec a f (number_of v + n) =
105.893 - (let pv = number_of (Int.pred v) in
105.894 - if neg pv then nat_rec a f n
105.895 - else f (nat pv + n) (nat_rec a f (nat pv + n)))"
105.896 -apply (subst add_eq_if)
105.897 -apply (simp split add: nat.split
105.898 - del: nat_numeral_1_eq_1
105.899 - add: nat_numeral_1_eq_1 [symmetric]
105.900 - numeral_1_eq_Suc_0 [symmetric]
105.901 - neg_number_of_pred_iff_0)
105.902 -done
105.903 -
105.904 -
105.905 -subsubsection{*Various Other Lemmas*}
105.906 -
105.907 -text {*Evens and Odds, for Mutilated Chess Board*}
105.908 -
105.909 -text{*Lemmas for specialist use, NOT as default simprules*}
105.910 -lemma nat_mult_2: "2 * z = (z+z::nat)"
105.911 -proof -
105.912 - have "2*z = (1 + 1)*z" by simp
105.913 - also have "... = z+z" by (simp add: left_distrib)
105.914 - finally show ?thesis .
105.915 -qed
105.916 -
105.917 -lemma nat_mult_2_right: "z * 2 = (z+z::nat)"
105.918 -by (subst mult_commute, rule nat_mult_2)
105.919 -
105.920 -text{*Case analysis on @{term "n<2"}*}
105.921 -lemma less_2_cases: "(n::nat) < 2 ==> n = 0 | n = Suc 0"
105.922 -by arith
105.923 -
105.924 -lemma div2_Suc_Suc [simp]: "Suc(Suc m) div 2 = Suc (m div 2)"
105.925 -by arith
105.926 -
105.927 -lemma add_self_div_2 [simp]: "(m + m) div 2 = (m::nat)"
105.928 -by (simp add: nat_mult_2 [symmetric])
105.929 -
105.930 -lemma mod2_Suc_Suc [simp]: "Suc(Suc(m)) mod 2 = m mod 2"
105.931 -apply (subgoal_tac "m mod 2 < 2")
105.932 -apply (erule less_2_cases [THEN disjE])
105.933 -apply (simp_all (no_asm_simp) add: Let_def mod_Suc nat_1)
105.934 -done
105.935 -
105.936 -lemma mod2_gr_0 [simp]: "!!m::nat. (0 < m mod 2) = (m mod 2 = 1)"
105.937 -apply (subgoal_tac "m mod 2 < 2")
105.938 -apply (force simp del: mod_less_divisor, simp)
105.939 -done
105.940 -
105.941 -text{*Removal of Small Numerals: 0, 1 and (in additive positions) 2*}
105.942 -
105.943 -lemma add_2_eq_Suc [simp]: "2 + n = Suc (Suc n)"
105.944 -by simp
105.945 -
105.946 -lemma add_2_eq_Suc' [simp]: "n + 2 = Suc (Suc n)"
105.947 -by simp
105.948 -
105.949 -text{*Can be used to eliminate long strings of Sucs, but not by default*}
105.950 -lemma Suc3_eq_add_3: "Suc (Suc (Suc n)) = 3 + n"
105.951 -by simp
105.952 -
105.953 -
105.954 -text{*These lemmas collapse some needless occurrences of Suc:
105.955 - at least three Sucs, since two and fewer are rewritten back to Suc again!
105.956 - We already have some rules to simplify operands smaller than 3.*}
105.957 -
105.958 -lemma div_Suc_eq_div_add3 [simp]: "m div (Suc (Suc (Suc n))) = m div (3+n)"
105.959 -by (simp add: Suc3_eq_add_3)
105.960 -
105.961 -lemma mod_Suc_eq_mod_add3 [simp]: "m mod (Suc (Suc (Suc n))) = m mod (3+n)"
105.962 -by (simp add: Suc3_eq_add_3)
105.963 -
105.964 -lemma Suc_div_eq_add3_div: "(Suc (Suc (Suc m))) div n = (3+m) div n"
105.965 -by (simp add: Suc3_eq_add_3)
105.966 -
105.967 -lemma Suc_mod_eq_add3_mod: "(Suc (Suc (Suc m))) mod n = (3+m) mod n"
105.968 -by (simp add: Suc3_eq_add_3)
105.969 -
105.970 -lemmas Suc_div_eq_add3_div_number_of =
105.971 - Suc_div_eq_add3_div [of _ "number_of v", standard]
105.972 -declare Suc_div_eq_add3_div_number_of [simp]
105.973 -
105.974 -lemmas Suc_mod_eq_add3_mod_number_of =
105.975 - Suc_mod_eq_add3_mod [of _ "number_of v", standard]
105.976 -declare Suc_mod_eq_add3_mod_number_of [simp]
105.977 -
105.978 -end
106.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
106.2 +++ b/src/HOL/Nat_Numeral.thy Mon May 11 17:20:52 2009 +0200
106.3 @@ -0,0 +1,1059 @@
106.4 +(* Title: HOL/Nat_Numeral.thy
106.5 + Author: Lawrence C Paulson, Cambridge University Computer Laboratory
106.6 + Copyright 1999 University of Cambridge
106.7 +*)
106.8 +
106.9 +header {* Binary numerals for the natural numbers *}
106.10 +
106.11 +theory Nat_Numeral
106.12 +imports IntDiv
106.13 +uses ("Tools/nat_numeral_simprocs.ML")
106.14 +begin
106.15 +
106.16 +subsection {* Numerals for natural numbers *}
106.17 +
106.18 +text {*
106.19 + Arithmetic for naturals is reduced to that for the non-negative integers.
106.20 +*}
106.21 +
106.22 +instantiation nat :: number
106.23 +begin
106.24 +
106.25 +definition
106.26 + nat_number_of_def [code inline, code del]: "number_of v = nat (number_of v)"
106.27 +
106.28 +instance ..
106.29 +
106.30 +end
106.31 +
106.32 +lemma [code post]:
106.33 + "nat (number_of v) = number_of v"
106.34 + unfolding nat_number_of_def ..
106.35 +
106.36 +
106.37 +subsection {* Special case: squares and cubes *}
106.38 +
106.39 +lemma numeral_2_eq_2: "2 = Suc (Suc 0)"
106.40 + by (simp add: nat_number_of_def)
106.41 +
106.42 +lemma numeral_3_eq_3: "3 = Suc (Suc (Suc 0))"
106.43 + by (simp add: nat_number_of_def)
106.44 +
106.45 +context power
106.46 +begin
106.47 +
106.48 +abbreviation (xsymbols)
106.49 + power2 :: "'a \<Rightarrow> 'a" ("(_\<twosuperior>)" [1000] 999) where
106.50 + "x\<twosuperior> \<equiv> x ^ 2"
106.51 +
106.52 +notation (latex output)
106.53 + power2 ("(_\<twosuperior>)" [1000] 999)
106.54 +
106.55 +notation (HTML output)
106.56 + power2 ("(_\<twosuperior>)" [1000] 999)
106.57 +
106.58 +end
106.59 +
106.60 +context monoid_mult
106.61 +begin
106.62 +
106.63 +lemma power2_eq_square: "a\<twosuperior> = a * a"
106.64 + by (simp add: numeral_2_eq_2)
106.65 +
106.66 +lemma power3_eq_cube: "a ^ 3 = a * a * a"
106.67 + by (simp add: numeral_3_eq_3 mult_assoc)
106.68 +
106.69 +lemma power_even_eq:
106.70 + "a ^ (2*n) = (a ^ n) ^ 2"
106.71 + by (subst OrderedGroup.mult_commute) (simp add: power_mult)
106.72 +
106.73 +lemma power_odd_eq:
106.74 + "a ^ Suc (2*n) = a * (a ^ n) ^ 2"
106.75 + by (simp add: power_even_eq)
106.76 +
106.77 +end
106.78 +
106.79 +context semiring_1
106.80 +begin
106.81 +
106.82 +lemma zero_power2 [simp]: "0\<twosuperior> = 0"
106.83 + by (simp add: power2_eq_square)
106.84 +
106.85 +lemma one_power2 [simp]: "1\<twosuperior> = 1"
106.86 + by (simp add: power2_eq_square)
106.87 +
106.88 +end
106.89 +
106.90 +context comm_ring_1
106.91 +begin
106.92 +
106.93 +lemma power2_minus [simp]:
106.94 + "(- a)\<twosuperior> = a\<twosuperior>"
106.95 + by (simp add: power2_eq_square)
106.96 +
106.97 +text{*
106.98 + We cannot prove general results about the numeral @{term "-1"},
106.99 + so we have to use @{term "- 1"} instead.
106.100 +*}
106.101 +
106.102 +lemma power_minus1_even [simp]:
106.103 + "(- 1) ^ (2*n) = 1"
106.104 +proof (induct n)
106.105 + case 0 show ?case by simp
106.106 +next
106.107 + case (Suc n) then show ?case by (simp add: power_add)
106.108 +qed
106.109 +
106.110 +lemma power_minus1_odd:
106.111 + "(- 1) ^ Suc (2*n) = - 1"
106.112 + by simp
106.113 +
106.114 +lemma power_minus_even [simp]:
106.115 + "(-a) ^ (2*n) = a ^ (2*n)"
106.116 + by (simp add: power_minus [of a])
106.117 +
106.118 +end
106.119 +
106.120 +context ordered_ring_strict
106.121 +begin
106.122 +
106.123 +lemma sum_squares_ge_zero:
106.124 + "0 \<le> x * x + y * y"
106.125 + by (intro add_nonneg_nonneg zero_le_square)
106.126 +
106.127 +lemma not_sum_squares_lt_zero:
106.128 + "\<not> x * x + y * y < 0"
106.129 + by (simp add: not_less sum_squares_ge_zero)
106.130 +
106.131 +lemma sum_squares_eq_zero_iff:
106.132 + "x * x + y * y = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
106.133 + by (simp add: add_nonneg_eq_0_iff)
106.134 +
106.135 +lemma sum_squares_le_zero_iff:
106.136 + "x * x + y * y \<le> 0 \<longleftrightarrow> x = 0 \<and> y = 0"
106.137 + by (simp add: le_less not_sum_squares_lt_zero sum_squares_eq_zero_iff)
106.138 +
106.139 +lemma sum_squares_gt_zero_iff:
106.140 + "0 < x * x + y * y \<longleftrightarrow> x \<noteq> 0 \<or> y \<noteq> 0"
106.141 +proof -
106.142 + have "x * x + y * y \<noteq> 0 \<longleftrightarrow> x \<noteq> 0 \<or> y \<noteq> 0"
106.143 + by (simp add: sum_squares_eq_zero_iff)
106.144 + then have "0 \<noteq> x * x + y * y \<longleftrightarrow> x \<noteq> 0 \<or> y \<noteq> 0"
106.145 + by auto
106.146 + then show ?thesis
106.147 + by (simp add: less_le sum_squares_ge_zero)
106.148 +qed
106.149 +
106.150 +end
106.151 +
106.152 +context ordered_semidom
106.153 +begin
106.154 +
106.155 +lemma power2_le_imp_le:
106.156 + "x\<twosuperior> \<le> y\<twosuperior> \<Longrightarrow> 0 \<le> y \<Longrightarrow> x \<le> y"
106.157 + unfolding numeral_2_eq_2 by (rule power_le_imp_le_base)
106.158 +
106.159 +lemma power2_less_imp_less:
106.160 + "x\<twosuperior> < y\<twosuperior> \<Longrightarrow> 0 \<le> y \<Longrightarrow> x < y"
106.161 + by (rule power_less_imp_less_base)
106.162 +
106.163 +lemma power2_eq_imp_eq:
106.164 + "x\<twosuperior> = y\<twosuperior> \<Longrightarrow> 0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> x = y"
106.165 + unfolding numeral_2_eq_2 by (erule (2) power_eq_imp_eq_base) simp
106.166 +
106.167 +end
106.168 +
106.169 +context ordered_idom
106.170 +begin
106.171 +
106.172 +lemma zero_eq_power2 [simp]:
106.173 + "a\<twosuperior> = 0 \<longleftrightarrow> a = 0"
106.174 + by (force simp add: power2_eq_square)
106.175 +
106.176 +lemma zero_le_power2 [simp]:
106.177 + "0 \<le> a\<twosuperior>"
106.178 + by (simp add: power2_eq_square)
106.179 +
106.180 +lemma zero_less_power2 [simp]:
106.181 + "0 < a\<twosuperior> \<longleftrightarrow> a \<noteq> 0"
106.182 + by (force simp add: power2_eq_square zero_less_mult_iff linorder_neq_iff)
106.183 +
106.184 +lemma power2_less_0 [simp]:
106.185 + "\<not> a\<twosuperior> < 0"
106.186 + by (force simp add: power2_eq_square mult_less_0_iff)
106.187 +
106.188 +lemma abs_power2 [simp]:
106.189 + "abs (a\<twosuperior>) = a\<twosuperior>"
106.190 + by (simp add: power2_eq_square abs_mult abs_mult_self)
106.191 +
106.192 +lemma power2_abs [simp]:
106.193 + "(abs a)\<twosuperior> = a\<twosuperior>"
106.194 + by (simp add: power2_eq_square abs_mult_self)
106.195 +
106.196 +lemma odd_power_less_zero:
106.197 + "a < 0 \<Longrightarrow> a ^ Suc (2*n) < 0"
106.198 +proof (induct n)
106.199 + case 0
106.200 + then show ?case by simp
106.201 +next
106.202 + case (Suc n)
106.203 + have "a ^ Suc (2 * Suc n) = (a*a) * a ^ Suc(2*n)"
106.204 + by (simp add: mult_ac power_add power2_eq_square)
106.205 + thus ?case
106.206 + by (simp del: power_Suc add: Suc mult_less_0_iff mult_neg_neg)
106.207 +qed
106.208 +
106.209 +lemma odd_0_le_power_imp_0_le:
106.210 + "0 \<le> a ^ Suc (2*n) \<Longrightarrow> 0 \<le> a"
106.211 + using odd_power_less_zero [of a n]
106.212 + by (force simp add: linorder_not_less [symmetric])
106.213 +
106.214 +lemma zero_le_even_power'[simp]:
106.215 + "0 \<le> a ^ (2*n)"
106.216 +proof (induct n)
106.217 + case 0
106.218 + show ?case by (simp add: zero_le_one)
106.219 +next
106.220 + case (Suc n)
106.221 + have "a ^ (2 * Suc n) = (a*a) * a ^ (2*n)"
106.222 + by (simp add: mult_ac power_add power2_eq_square)
106.223 + thus ?case
106.224 + by (simp add: Suc zero_le_mult_iff)
106.225 +qed
106.226 +
106.227 +lemma sum_power2_ge_zero:
106.228 + "0 \<le> x\<twosuperior> + y\<twosuperior>"
106.229 + unfolding power2_eq_square by (rule sum_squares_ge_zero)
106.230 +
106.231 +lemma not_sum_power2_lt_zero:
106.232 + "\<not> x\<twosuperior> + y\<twosuperior> < 0"
106.233 + unfolding power2_eq_square by (rule not_sum_squares_lt_zero)
106.234 +
106.235 +lemma sum_power2_eq_zero_iff:
106.236 + "x\<twosuperior> + y\<twosuperior> = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
106.237 + unfolding power2_eq_square by (rule sum_squares_eq_zero_iff)
106.238 +
106.239 +lemma sum_power2_le_zero_iff:
106.240 + "x\<twosuperior> + y\<twosuperior> \<le> 0 \<longleftrightarrow> x = 0 \<and> y = 0"
106.241 + unfolding power2_eq_square by (rule sum_squares_le_zero_iff)
106.242 +
106.243 +lemma sum_power2_gt_zero_iff:
106.244 + "0 < x\<twosuperior> + y\<twosuperior> \<longleftrightarrow> x \<noteq> 0 \<or> y \<noteq> 0"
106.245 + unfolding power2_eq_square by (rule sum_squares_gt_zero_iff)
106.246 +
106.247 +end
106.248 +
106.249 +lemma power2_sum:
106.250 + fixes x y :: "'a::number_ring"
106.251 + shows "(x + y)\<twosuperior> = x\<twosuperior> + y\<twosuperior> + 2 * x * y"
106.252 + by (simp add: ring_distribs power2_eq_square)
106.253 +
106.254 +lemma power2_diff:
106.255 + fixes x y :: "'a::number_ring"
106.256 + shows "(x - y)\<twosuperior> = x\<twosuperior> + y\<twosuperior> - 2 * x * y"
106.257 + by (simp add: ring_distribs power2_eq_square)
106.258 +
106.259 +
106.260 +subsection {* Predicate for negative binary numbers *}
106.261 +
106.262 +definition neg :: "int \<Rightarrow> bool" where
106.263 + "neg Z \<longleftrightarrow> Z < 0"
106.264 +
106.265 +lemma not_neg_int [simp]: "~ neg (of_nat n)"
106.266 +by (simp add: neg_def)
106.267 +
106.268 +lemma neg_zminus_int [simp]: "neg (- (of_nat (Suc n)))"
106.269 +by (simp add: neg_def neg_less_0_iff_less del: of_nat_Suc)
106.270 +
106.271 +lemmas neg_eq_less_0 = neg_def
106.272 +
106.273 +lemma not_neg_eq_ge_0: "(~neg x) = (0 \<le> x)"
106.274 +by (simp add: neg_def linorder_not_less)
106.275 +
106.276 +text{*To simplify inequalities when Numeral1 can get simplified to 1*}
106.277 +
106.278 +lemma not_neg_0: "~ neg 0"
106.279 +by (simp add: One_int_def neg_def)
106.280 +
106.281 +lemma not_neg_1: "~ neg 1"
106.282 +by (simp add: neg_def linorder_not_less zero_le_one)
106.283 +
106.284 +lemma neg_nat: "neg z ==> nat z = 0"
106.285 +by (simp add: neg_def order_less_imp_le)
106.286 +
106.287 +lemma not_neg_nat: "~ neg z ==> of_nat (nat z) = z"
106.288 +by (simp add: linorder_not_less neg_def)
106.289 +
106.290 +text {*
106.291 + If @{term Numeral0} is rewritten to 0 then this rule can't be applied:
106.292 + @{term Numeral0} IS @{term "number_of Pls"}
106.293 +*}
106.294 +
106.295 +lemma not_neg_number_of_Pls: "~ neg (number_of Int.Pls)"
106.296 + by (simp add: neg_def)
106.297 +
106.298 +lemma neg_number_of_Min: "neg (number_of Int.Min)"
106.299 + by (simp add: neg_def)
106.300 +
106.301 +lemma neg_number_of_Bit0:
106.302 + "neg (number_of (Int.Bit0 w)) = neg (number_of w)"
106.303 + by (simp add: neg_def)
106.304 +
106.305 +lemma neg_number_of_Bit1:
106.306 + "neg (number_of (Int.Bit1 w)) = neg (number_of w)"
106.307 + by (simp add: neg_def)
106.308 +
106.309 +lemmas neg_simps [simp] =
106.310 + not_neg_0 not_neg_1
106.311 + not_neg_number_of_Pls neg_number_of_Min
106.312 + neg_number_of_Bit0 neg_number_of_Bit1
106.313 +
106.314 +
106.315 +subsection{*Function @{term nat}: Coercion from Type @{typ int} to @{typ nat}*}
106.316 +
106.317 +declare nat_0 [simp] nat_1 [simp]
106.318 +
106.319 +lemma nat_number_of [simp]: "nat (number_of w) = number_of w"
106.320 +by (simp add: nat_number_of_def)
106.321 +
106.322 +lemma nat_numeral_0_eq_0 [simp]: "Numeral0 = (0::nat)"
106.323 +by (simp add: nat_number_of_def)
106.324 +
106.325 +lemma nat_numeral_1_eq_1 [simp]: "Numeral1 = (1::nat)"
106.326 +by (simp add: nat_1 nat_number_of_def)
106.327 +
106.328 +lemma numeral_1_eq_Suc_0: "Numeral1 = Suc 0"
106.329 +by (simp add: nat_numeral_1_eq_1)
106.330 +
106.331 +
106.332 +subsection{*Function @{term int}: Coercion from Type @{typ nat} to @{typ int}*}
106.333 +
106.334 +lemma int_nat_number_of [simp]:
106.335 + "int (number_of v) =
106.336 + (if neg (number_of v :: int) then 0
106.337 + else (number_of v :: int))"
106.338 + unfolding nat_number_of_def number_of_is_id neg_def
106.339 + by simp
106.340 +
106.341 +
106.342 +subsubsection{*Successor *}
106.343 +
106.344 +lemma Suc_nat_eq_nat_zadd1: "(0::int) <= z ==> Suc (nat z) = nat (1 + z)"
106.345 +apply (rule sym)
106.346 +apply (simp add: nat_eq_iff int_Suc)
106.347 +done
106.348 +
106.349 +lemma Suc_nat_number_of_add:
106.350 + "Suc (number_of v + n) =
106.351 + (if neg (number_of v :: int) then 1+n else number_of (Int.succ v) + n)"
106.352 + unfolding nat_number_of_def number_of_is_id neg_def numeral_simps
106.353 + by (simp add: Suc_nat_eq_nat_zadd1 add_ac)
106.354 +
106.355 +lemma Suc_nat_number_of [simp]:
106.356 + "Suc (number_of v) =
106.357 + (if neg (number_of v :: int) then 1 else number_of (Int.succ v))"
106.358 +apply (cut_tac n = 0 in Suc_nat_number_of_add)
106.359 +apply (simp cong del: if_weak_cong)
106.360 +done
106.361 +
106.362 +
106.363 +subsubsection{*Addition *}
106.364 +
106.365 +lemma add_nat_number_of [simp]:
106.366 + "(number_of v :: nat) + number_of v' =
106.367 + (if v < Int.Pls then number_of v'
106.368 + else if v' < Int.Pls then number_of v
106.369 + else number_of (v + v'))"
106.370 + unfolding nat_number_of_def number_of_is_id numeral_simps
106.371 + by (simp add: nat_add_distrib)
106.372 +
106.373 +lemma nat_number_of_add_1 [simp]:
106.374 + "number_of v + (1::nat) =
106.375 + (if v < Int.Pls then 1 else number_of (Int.succ v))"
106.376 + unfolding nat_number_of_def number_of_is_id numeral_simps
106.377 + by (simp add: nat_add_distrib)
106.378 +
106.379 +lemma nat_1_add_number_of [simp]:
106.380 + "(1::nat) + number_of v =
106.381 + (if v < Int.Pls then 1 else number_of (Int.succ v))"
106.382 + unfolding nat_number_of_def number_of_is_id numeral_simps
106.383 + by (simp add: nat_add_distrib)
106.384 +
106.385 +lemma nat_1_add_1 [simp]: "1 + 1 = (2::nat)"
106.386 + by (rule int_int_eq [THEN iffD1]) simp
106.387 +
106.388 +
106.389 +subsubsection{*Subtraction *}
106.390 +
106.391 +lemma diff_nat_eq_if:
106.392 + "nat z - nat z' =
106.393 + (if neg z' then nat z
106.394 + else let d = z-z' in
106.395 + if neg d then 0 else nat d)"
106.396 +by (simp add: Let_def nat_diff_distrib [symmetric] neg_eq_less_0 not_neg_eq_ge_0)
106.397 +
106.398 +
106.399 +lemma diff_nat_number_of [simp]:
106.400 + "(number_of v :: nat) - number_of v' =
106.401 + (if v' < Int.Pls then number_of v
106.402 + else let d = number_of (v + uminus v') in
106.403 + if neg d then 0 else nat d)"
106.404 + unfolding nat_number_of_def number_of_is_id numeral_simps neg_def
106.405 + by auto
106.406 +
106.407 +lemma nat_number_of_diff_1 [simp]:
106.408 + "number_of v - (1::nat) =
106.409 + (if v \<le> Int.Pls then 0 else number_of (Int.pred v))"
106.410 + unfolding nat_number_of_def number_of_is_id numeral_simps
106.411 + by auto
106.412 +
106.413 +
106.414 +subsubsection{*Multiplication *}
106.415 +
106.416 +lemma mult_nat_number_of [simp]:
106.417 + "(number_of v :: nat) * number_of v' =
106.418 + (if v < Int.Pls then 0 else number_of (v * v'))"
106.419 + unfolding nat_number_of_def number_of_is_id numeral_simps
106.420 + by (simp add: nat_mult_distrib)
106.421 +
106.422 +
106.423 +subsubsection{*Quotient *}
106.424 +
106.425 +lemma div_nat_number_of [simp]:
106.426 + "(number_of v :: nat) div number_of v' =
106.427 + (if neg (number_of v :: int) then 0
106.428 + else nat (number_of v div number_of v'))"
106.429 + unfolding nat_number_of_def number_of_is_id neg_def
106.430 + by (simp add: nat_div_distrib)
106.431 +
106.432 +lemma one_div_nat_number_of [simp]:
106.433 + "Suc 0 div number_of v' = nat (1 div number_of v')"
106.434 +by (simp del: nat_numeral_1_eq_1 add: numeral_1_eq_Suc_0 [symmetric])
106.435 +
106.436 +
106.437 +subsubsection{*Remainder *}
106.438 +
106.439 +lemma mod_nat_number_of [simp]:
106.440 + "(number_of v :: nat) mod number_of v' =
106.441 + (if neg (number_of v :: int) then 0
106.442 + else if neg (number_of v' :: int) then number_of v
106.443 + else nat (number_of v mod number_of v'))"
106.444 + unfolding nat_number_of_def number_of_is_id neg_def
106.445 + by (simp add: nat_mod_distrib)
106.446 +
106.447 +lemma one_mod_nat_number_of [simp]:
106.448 + "Suc 0 mod number_of v' =
106.449 + (if neg (number_of v' :: int) then Suc 0
106.450 + else nat (1 mod number_of v'))"
106.451 +by (simp del: nat_numeral_1_eq_1 add: numeral_1_eq_Suc_0 [symmetric])
106.452 +
106.453 +
106.454 +subsubsection{* Divisibility *}
106.455 +
106.456 +lemmas dvd_eq_mod_eq_0_number_of =
106.457 + dvd_eq_mod_eq_0 [of "number_of x" "number_of y", standard]
106.458 +
106.459 +declare dvd_eq_mod_eq_0_number_of [simp]
106.460 +
106.461 +
106.462 +subsection{*Comparisons*}
106.463 +
106.464 +subsubsection{*Equals (=) *}
106.465 +
106.466 +lemma eq_nat_nat_iff:
106.467 + "[| (0::int) <= z; 0 <= z' |] ==> (nat z = nat z') = (z=z')"
106.468 +by (auto elim!: nonneg_eq_int)
106.469 +
106.470 +lemma eq_nat_number_of [simp]:
106.471 + "((number_of v :: nat) = number_of v') =
106.472 + (if neg (number_of v :: int) then (number_of v' :: int) \<le> 0
106.473 + else if neg (number_of v' :: int) then (number_of v :: int) = 0
106.474 + else v = v')"
106.475 + unfolding nat_number_of_def number_of_is_id neg_def
106.476 + by auto
106.477 +
106.478 +
106.479 +subsubsection{*Less-than (<) *}
106.480 +
106.481 +lemma less_nat_number_of [simp]:
106.482 + "(number_of v :: nat) < number_of v' \<longleftrightarrow>
106.483 + (if v < v' then Int.Pls < v' else False)"
106.484 + unfolding nat_number_of_def number_of_is_id numeral_simps
106.485 + by auto
106.486 +
106.487 +
106.488 +subsubsection{*Less-than-or-equal *}
106.489 +
106.490 +lemma le_nat_number_of [simp]:
106.491 + "(number_of v :: nat) \<le> number_of v' \<longleftrightarrow>
106.492 + (if v \<le> v' then True else v \<le> Int.Pls)"
106.493 + unfolding nat_number_of_def number_of_is_id numeral_simps
106.494 + by auto
106.495 +
106.496 +(*Maps #n to n for n = 0, 1, 2*)
106.497 +lemmas numerals = nat_numeral_0_eq_0 nat_numeral_1_eq_1 numeral_2_eq_2
106.498 +
106.499 +
106.500 +subsection{*Powers with Numeric Exponents*}
106.501 +
106.502 +text{*Squares of literal numerals will be evaluated.*}
106.503 +lemmas power2_eq_square_number_of [simp] =
106.504 + power2_eq_square [of "number_of w", standard]
106.505 +
106.506 +
106.507 +text{*Simprules for comparisons where common factors can be cancelled.*}
106.508 +lemmas zero_compare_simps =
106.509 + add_strict_increasing add_strict_increasing2 add_increasing
106.510 + zero_le_mult_iff zero_le_divide_iff
106.511 + zero_less_mult_iff zero_less_divide_iff
106.512 + mult_le_0_iff divide_le_0_iff
106.513 + mult_less_0_iff divide_less_0_iff
106.514 + zero_le_power2 power2_less_0
106.515 +
106.516 +subsubsection{*Nat *}
106.517 +
106.518 +lemma Suc_pred': "0 < n ==> n = Suc(n - 1)"
106.519 +by (simp add: numerals)
106.520 +
106.521 +(*Expresses a natural number constant as the Suc of another one.
106.522 + NOT suitable for rewriting because n recurs in the condition.*)
106.523 +lemmas expand_Suc = Suc_pred' [of "number_of v", standard]
106.524 +
106.525 +subsubsection{*Arith *}
106.526 +
106.527 +lemma Suc_eq_add_numeral_1: "Suc n = n + 1"
106.528 +by (simp add: numerals)
106.529 +
106.530 +lemma Suc_eq_add_numeral_1_left: "Suc n = 1 + n"
106.531 +by (simp add: numerals)
106.532 +
106.533 +(* These two can be useful when m = number_of... *)
106.534 +
106.535 +lemma add_eq_if: "(m::nat) + n = (if m=0 then n else Suc ((m - 1) + n))"
106.536 + unfolding One_nat_def by (cases m) simp_all
106.537 +
106.538 +lemma mult_eq_if: "(m::nat) * n = (if m=0 then 0 else n + ((m - 1) * n))"
106.539 + unfolding One_nat_def by (cases m) simp_all
106.540 +
106.541 +lemma power_eq_if: "(p ^ m :: nat) = (if m=0 then 1 else p * (p ^ (m - 1)))"
106.542 + unfolding One_nat_def by (cases m) simp_all
106.543 +
106.544 +
106.545 +subsection{*Comparisons involving (0::nat) *}
106.546 +
106.547 +text{*Simplification already does @{term "n<0"}, @{term "n\<le>0"} and @{term "0\<le>n"}.*}
106.548 +
106.549 +lemma eq_number_of_0 [simp]:
106.550 + "number_of v = (0::nat) \<longleftrightarrow> v \<le> Int.Pls"
106.551 + unfolding nat_number_of_def number_of_is_id numeral_simps
106.552 + by auto
106.553 +
106.554 +lemma eq_0_number_of [simp]:
106.555 + "(0::nat) = number_of v \<longleftrightarrow> v \<le> Int.Pls"
106.556 +by (rule trans [OF eq_sym_conv eq_number_of_0])
106.557 +
106.558 +lemma less_0_number_of [simp]:
106.559 + "(0::nat) < number_of v \<longleftrightarrow> Int.Pls < v"
106.560 + unfolding nat_number_of_def number_of_is_id numeral_simps
106.561 + by simp
106.562 +
106.563 +lemma neg_imp_number_of_eq_0: "neg (number_of v :: int) ==> number_of v = (0::nat)"
106.564 +by (simp del: nat_numeral_0_eq_0 add: nat_numeral_0_eq_0 [symmetric])
106.565 +
106.566 +
106.567 +
106.568 +subsection{*Comparisons involving @{term Suc} *}
106.569 +
106.570 +lemma eq_number_of_Suc [simp]:
106.571 + "(number_of v = Suc n) =
106.572 + (let pv = number_of (Int.pred v) in
106.573 + if neg pv then False else nat pv = n)"
106.574 +apply (simp only: simp_thms Let_def neg_eq_less_0 linorder_not_less
106.575 + number_of_pred nat_number_of_def
106.576 + split add: split_if)
106.577 +apply (rule_tac x = "number_of v" in spec)
106.578 +apply (auto simp add: nat_eq_iff)
106.579 +done
106.580 +
106.581 +lemma Suc_eq_number_of [simp]:
106.582 + "(Suc n = number_of v) =
106.583 + (let pv = number_of (Int.pred v) in
106.584 + if neg pv then False else nat pv = n)"
106.585 +by (rule trans [OF eq_sym_conv eq_number_of_Suc])
106.586 +
106.587 +lemma less_number_of_Suc [simp]:
106.588 + "(number_of v < Suc n) =
106.589 + (let pv = number_of (Int.pred v) in
106.590 + if neg pv then True else nat pv < n)"
106.591 +apply (simp only: simp_thms Let_def neg_eq_less_0 linorder_not_less
106.592 + number_of_pred nat_number_of_def
106.593 + split add: split_if)
106.594 +apply (rule_tac x = "number_of v" in spec)
106.595 +apply (auto simp add: nat_less_iff)
106.596 +done
106.597 +
106.598 +lemma less_Suc_number_of [simp]:
106.599 + "(Suc n < number_of v) =
106.600 + (let pv = number_of (Int.pred v) in
106.601 + if neg pv then False else n < nat pv)"
106.602 +apply (simp only: simp_thms Let_def neg_eq_less_0 linorder_not_less
106.603 + number_of_pred nat_number_of_def
106.604 + split add: split_if)
106.605 +apply (rule_tac x = "number_of v" in spec)
106.606 +apply (auto simp add: zless_nat_eq_int_zless)
106.607 +done
106.608 +
106.609 +lemma le_number_of_Suc [simp]:
106.610 + "(number_of v <= Suc n) =
106.611 + (let pv = number_of (Int.pred v) in
106.612 + if neg pv then True else nat pv <= n)"
106.613 +by (simp add: Let_def less_Suc_number_of linorder_not_less [symmetric])
106.614 +
106.615 +lemma le_Suc_number_of [simp]:
106.616 + "(Suc n <= number_of v) =
106.617 + (let pv = number_of (Int.pred v) in
106.618 + if neg pv then False else n <= nat pv)"
106.619 +by (simp add: Let_def less_number_of_Suc linorder_not_less [symmetric])
106.620 +
106.621 +
106.622 +lemma eq_number_of_Pls_Min: "(Numeral0 ::int) ~= number_of Int.Min"
106.623 +by auto
106.624 +
106.625 +
106.626 +
106.627 +subsection{*Max and Min Combined with @{term Suc} *}
106.628 +
106.629 +lemma max_number_of_Suc [simp]:
106.630 + "max (Suc n) (number_of v) =
106.631 + (let pv = number_of (Int.pred v) in
106.632 + if neg pv then Suc n else Suc(max n (nat pv)))"
106.633 +apply (simp only: Let_def neg_eq_less_0 number_of_pred nat_number_of_def
106.634 + split add: split_if nat.split)
106.635 +apply (rule_tac x = "number_of v" in spec)
106.636 +apply auto
106.637 +done
106.638 +
106.639 +lemma max_Suc_number_of [simp]:
106.640 + "max (number_of v) (Suc n) =
106.641 + (let pv = number_of (Int.pred v) in
106.642 + if neg pv then Suc n else Suc(max (nat pv) n))"
106.643 +apply (simp only: Let_def neg_eq_less_0 number_of_pred nat_number_of_def
106.644 + split add: split_if nat.split)
106.645 +apply (rule_tac x = "number_of v" in spec)
106.646 +apply auto
106.647 +done
106.648 +
106.649 +lemma min_number_of_Suc [simp]:
106.650 + "min (Suc n) (number_of v) =
106.651 + (let pv = number_of (Int.pred v) in
106.652 + if neg pv then 0 else Suc(min n (nat pv)))"
106.653 +apply (simp only: Let_def neg_eq_less_0 number_of_pred nat_number_of_def
106.654 + split add: split_if nat.split)
106.655 +apply (rule_tac x = "number_of v" in spec)
106.656 +apply auto
106.657 +done
106.658 +
106.659 +lemma min_Suc_number_of [simp]:
106.660 + "min (number_of v) (Suc n) =
106.661 + (let pv = number_of (Int.pred v) in
106.662 + if neg pv then 0 else Suc(min (nat pv) n))"
106.663 +apply (simp only: Let_def neg_eq_less_0 number_of_pred nat_number_of_def
106.664 + split add: split_if nat.split)
106.665 +apply (rule_tac x = "number_of v" in spec)
106.666 +apply auto
106.667 +done
106.668 +
106.669 +subsection{*Literal arithmetic involving powers*}
106.670 +
106.671 +lemma nat_power_eq: "(0::int) <= z ==> nat (z^n) = nat z ^ n"
106.672 +apply (induct "n")
106.673 +apply (simp_all (no_asm_simp) add: nat_mult_distrib)
106.674 +done
106.675 +
106.676 +lemma power_nat_number_of:
106.677 + "(number_of v :: nat) ^ n =
106.678 + (if neg (number_of v :: int) then 0^n else nat ((number_of v :: int) ^ n))"
106.679 +by (simp only: simp_thms neg_nat not_neg_eq_ge_0 nat_number_of_def nat_power_eq
106.680 + split add: split_if cong: imp_cong)
106.681 +
106.682 +
106.683 +lemmas power_nat_number_of_number_of = power_nat_number_of [of _ "number_of w", standard]
106.684 +declare power_nat_number_of_number_of [simp]
106.685 +
106.686 +
106.687 +
106.688 +text{*For arbitrary rings*}
106.689 +
106.690 +lemma power_number_of_even:
106.691 + fixes z :: "'a::number_ring"
106.692 + shows "z ^ number_of (Int.Bit0 w) = (let w = z ^ (number_of w) in w * w)"
106.693 +unfolding Let_def nat_number_of_def number_of_Bit0
106.694 +apply (rule_tac x = "number_of w" in spec, clarify)
106.695 +apply (case_tac " (0::int) <= x")
106.696 +apply (auto simp add: nat_mult_distrib power_even_eq power2_eq_square)
106.697 +done
106.698 +
106.699 +lemma power_number_of_odd:
106.700 + fixes z :: "'a::number_ring"
106.701 + shows "z ^ number_of (Int.Bit1 w) = (if (0::int) <= number_of w
106.702 + then (let w = z ^ (number_of w) in z * w * w) else 1)"
106.703 +unfolding Let_def nat_number_of_def number_of_Bit1
106.704 +apply (rule_tac x = "number_of w" in spec, auto)
106.705 +apply (simp only: nat_add_distrib nat_mult_distrib)
106.706 +apply simp
106.707 +apply (auto simp add: nat_add_distrib nat_mult_distrib power_even_eq power2_eq_square neg_nat power_Suc)
106.708 +done
106.709 +
106.710 +lemmas zpower_number_of_even = power_number_of_even [where 'a=int]
106.711 +lemmas zpower_number_of_odd = power_number_of_odd [where 'a=int]
106.712 +
106.713 +lemmas power_number_of_even_number_of [simp] =
106.714 + power_number_of_even [of "number_of v", standard]
106.715 +
106.716 +lemmas power_number_of_odd_number_of [simp] =
106.717 + power_number_of_odd [of "number_of v", standard]
106.718 +
106.719 +
106.720 +(* Enable arith to deal with div/mod k where k is a numeral: *)
106.721 +declare split_div[of _ _ "number_of k", standard, arith_split]
106.722 +declare split_mod[of _ _ "number_of k", standard, arith_split]
106.723 +
106.724 +lemma nat_number_of_Pls: "Numeral0 = (0::nat)"
106.725 + by (simp add: number_of_Pls nat_number_of_def)
106.726 +
106.727 +lemma nat_number_of_Min: "number_of Int.Min = (0::nat)"
106.728 + apply (simp only: number_of_Min nat_number_of_def nat_zminus_int)
106.729 + done
106.730 +
106.731 +lemma nat_number_of_Bit0:
106.732 + "number_of (Int.Bit0 w) = (let n::nat = number_of w in n + n)"
106.733 + unfolding nat_number_of_def number_of_is_id numeral_simps Let_def
106.734 + by auto
106.735 +
106.736 +lemma nat_number_of_Bit1:
106.737 + "number_of (Int.Bit1 w) =
106.738 + (if neg (number_of w :: int) then 0
106.739 + else let n = number_of w in Suc (n + n))"
106.740 + unfolding nat_number_of_def number_of_is_id numeral_simps neg_def Let_def
106.741 + by auto
106.742 +
106.743 +lemmas nat_number =
106.744 + nat_number_of_Pls nat_number_of_Min
106.745 + nat_number_of_Bit0 nat_number_of_Bit1
106.746 +
106.747 +lemma Let_Suc [simp]: "Let (Suc n) f == f (Suc n)"
106.748 + by (simp add: Let_def)
106.749 +
106.750 +lemma power_m1_even: "(-1) ^ (2*n) = (1::'a::{number_ring})"
106.751 + by (simp only: number_of_Min power_minus1_even)
106.752 +
106.753 +lemma power_m1_odd: "(-1) ^ Suc(2*n) = (-1::'a::{number_ring})"
106.754 + by (simp only: number_of_Min power_minus1_odd)
106.755 +
106.756 +
106.757 +subsection{*Literal arithmetic and @{term of_nat}*}
106.758 +
106.759 +lemma of_nat_double:
106.760 + "0 \<le> x ==> of_nat (nat (2 * x)) = of_nat (nat x) + of_nat (nat x)"
106.761 +by (simp only: mult_2 nat_add_distrib of_nat_add)
106.762 +
106.763 +lemma nat_numeral_m1_eq_0: "-1 = (0::nat)"
106.764 +by (simp only: nat_number_of_def)
106.765 +
106.766 +lemma of_nat_number_of_lemma:
106.767 + "of_nat (number_of v :: nat) =
106.768 + (if 0 \<le> (number_of v :: int)
106.769 + then (number_of v :: 'a :: number_ring)
106.770 + else 0)"
106.771 +by (simp add: int_number_of_def nat_number_of_def number_of_eq of_nat_nat);
106.772 +
106.773 +lemma of_nat_number_of_eq [simp]:
106.774 + "of_nat (number_of v :: nat) =
106.775 + (if neg (number_of v :: int) then 0
106.776 + else (number_of v :: 'a :: number_ring))"
106.777 +by (simp only: of_nat_number_of_lemma neg_def, simp)
106.778 +
106.779 +
106.780 +subsection {*Lemmas for the Combination and Cancellation Simprocs*}
106.781 +
106.782 +lemma nat_number_of_add_left:
106.783 + "number_of v + (number_of v' + (k::nat)) =
106.784 + (if neg (number_of v :: int) then number_of v' + k
106.785 + else if neg (number_of v' :: int) then number_of v + k
106.786 + else number_of (v + v') + k)"
106.787 + unfolding nat_number_of_def number_of_is_id neg_def
106.788 + by auto
106.789 +
106.790 +lemma nat_number_of_mult_left:
106.791 + "number_of v * (number_of v' * (k::nat)) =
106.792 + (if v < Int.Pls then 0
106.793 + else number_of (v * v') * k)"
106.794 +by simp
106.795 +
106.796 +
106.797 +subsubsection{*For @{text combine_numerals}*}
106.798 +
106.799 +lemma left_add_mult_distrib: "i*u + (j*u + k) = (i+j)*u + (k::nat)"
106.800 +by (simp add: add_mult_distrib)
106.801 +
106.802 +
106.803 +subsubsection{*For @{text cancel_numerals}*}
106.804 +
106.805 +lemma nat_diff_add_eq1:
106.806 + "j <= (i::nat) ==> ((i*u + m) - (j*u + n)) = (((i-j)*u + m) - n)"
106.807 +by (simp split add: nat_diff_split add: add_mult_distrib)
106.808 +
106.809 +lemma nat_diff_add_eq2:
106.810 + "i <= (j::nat) ==> ((i*u + m) - (j*u + n)) = (m - ((j-i)*u + n))"
106.811 +by (simp split add: nat_diff_split add: add_mult_distrib)
106.812 +
106.813 +lemma nat_eq_add_iff1:
106.814 + "j <= (i::nat) ==> (i*u + m = j*u + n) = ((i-j)*u + m = n)"
106.815 +by (auto split add: nat_diff_split simp add: add_mult_distrib)
106.816 +
106.817 +lemma nat_eq_add_iff2:
106.818 + "i <= (j::nat) ==> (i*u + m = j*u + n) = (m = (j-i)*u + n)"
106.819 +by (auto split add: nat_diff_split simp add: add_mult_distrib)
106.820 +
106.821 +lemma nat_less_add_iff1:
106.822 + "j <= (i::nat) ==> (i*u + m < j*u + n) = ((i-j)*u + m < n)"
106.823 +by (auto split add: nat_diff_split simp add: add_mult_distrib)
106.824 +
106.825 +lemma nat_less_add_iff2:
106.826 + "i <= (j::nat) ==> (i*u + m < j*u + n) = (m < (j-i)*u + n)"
106.827 +by (auto split add: nat_diff_split simp add: add_mult_distrib)
106.828 +
106.829 +lemma nat_le_add_iff1:
106.830 + "j <= (i::nat) ==> (i*u + m <= j*u + n) = ((i-j)*u + m <= n)"
106.831 +by (auto split add: nat_diff_split simp add: add_mult_distrib)
106.832 +
106.833 +lemma nat_le_add_iff2:
106.834 + "i <= (j::nat) ==> (i*u + m <= j*u + n) = (m <= (j-i)*u + n)"
106.835 +by (auto split add: nat_diff_split simp add: add_mult_distrib)
106.836 +
106.837 +
106.838 +subsubsection{*For @{text cancel_numeral_factors} *}
106.839 +
106.840 +lemma nat_mult_le_cancel1: "(0::nat) < k ==> (k*m <= k*n) = (m<=n)"
106.841 +by auto
106.842 +
106.843 +lemma nat_mult_less_cancel1: "(0::nat) < k ==> (k*m < k*n) = (m<n)"
106.844 +by auto
106.845 +
106.846 +lemma nat_mult_eq_cancel1: "(0::nat) < k ==> (k*m = k*n) = (m=n)"
106.847 +by auto
106.848 +
106.849 +lemma nat_mult_div_cancel1: "(0::nat) < k ==> (k*m) div (k*n) = (m div n)"
106.850 +by auto
106.851 +
106.852 +lemma nat_mult_dvd_cancel_disj[simp]:
106.853 + "(k*m) dvd (k*n) = (k=0 | m dvd (n::nat))"
106.854 +by(auto simp: dvd_eq_mod_eq_0 mod_mult_distrib2[symmetric])
106.855 +
106.856 +lemma nat_mult_dvd_cancel1: "0 < k \<Longrightarrow> (k*m) dvd (k*n::nat) = (m dvd n)"
106.857 +by(auto)
106.858 +
106.859 +
106.860 +subsubsection{*For @{text cancel_factor} *}
106.861 +
106.862 +lemma nat_mult_le_cancel_disj: "(k*m <= k*n) = ((0::nat) < k --> m<=n)"
106.863 +by auto
106.864 +
106.865 +lemma nat_mult_less_cancel_disj: "(k*m < k*n) = ((0::nat) < k & m<n)"
106.866 +by auto
106.867 +
106.868 +lemma nat_mult_eq_cancel_disj: "(k*m = k*n) = (k = (0::nat) | m=n)"
106.869 +by auto
106.870 +
106.871 +lemma nat_mult_div_cancel_disj[simp]:
106.872 + "(k*m) div (k*n) = (if k = (0::nat) then 0 else m div n)"
106.873 +by (simp add: nat_mult_div_cancel1)
106.874 +
106.875 +
106.876 +subsection {* Simprocs for the Naturals *}
106.877 +
106.878 +use "Tools/nat_numeral_simprocs.ML"
106.879 +
106.880 +declaration {*
106.881 +let
106.882 +
106.883 +val less_eq_rules = @{thms ring_distribs} @
106.884 + [@{thm Let_number_of}, @{thm Let_0}, @{thm Let_1}, @{thm nat_0}, @{thm nat_1},
106.885 + @{thm add_nat_number_of}, @{thm diff_nat_number_of}, @{thm mult_nat_number_of},
106.886 + @{thm eq_nat_number_of}, @{thm less_nat_number_of}, @{thm le_number_of_eq_not_less},
106.887 + @{thm le_Suc_number_of}, @{thm le_number_of_Suc},
106.888 + @{thm less_Suc_number_of}, @{thm less_number_of_Suc},
106.889 + @{thm Suc_eq_number_of}, @{thm eq_number_of_Suc},
106.890 + @{thm mult_Suc}, @{thm mult_Suc_right},
106.891 + @{thm add_Suc}, @{thm add_Suc_right},
106.892 + @{thm eq_number_of_0}, @{thm eq_0_number_of}, @{thm less_0_number_of},
106.893 + @{thm of_int_number_of_eq}, @{thm of_nat_number_of_eq}, @{thm nat_number_of}, @{thm if_True}, @{thm if_False}];
106.894 +
106.895 +val simprocs = Nat_Numeral_Simprocs.combine_numerals :: Nat_Numeral_Simprocs.cancel_numerals;
106.896 +
106.897 +in
106.898 +
106.899 +K (Lin_Arith.map_data (fn {add_mono_thms, mult_mono_thms, inj_thms, lessD, neqE, simpset} =>
106.900 + {add_mono_thms = add_mono_thms, mult_mono_thms = mult_mono_thms,
106.901 + inj_thms = inj_thms, lessD = lessD, neqE = neqE,
106.902 + simpset = simpset addsimps (@{thms neg_simps} @ [@{thm Suc_nat_number_of}, @{thm int_nat_number_of}])
106.903 + addsimps less_eq_rules
106.904 + addsimprocs simprocs}))
106.905 +
106.906 +end
106.907 +*}
106.908 +
106.909 +
106.910 +subsubsection{*For simplifying @{term "Suc m - K"} and @{term "K - Suc m"}*}
106.911 +
106.912 +text{*Where K above is a literal*}
106.913 +
106.914 +lemma Suc_diff_eq_diff_pred: "Numeral0 < n ==> Suc m - n = m - (n - Numeral1)"
106.915 +by (simp add: numeral_0_eq_0 numeral_1_eq_1 split add: nat_diff_split)
106.916 +
106.917 +text {*Now just instantiating @{text n} to @{text "number_of v"} does
106.918 + the right simplification, but with some redundant inequality
106.919 + tests.*}
106.920 +lemma neg_number_of_pred_iff_0:
106.921 + "neg (number_of (Int.pred v)::int) = (number_of v = (0::nat))"
106.922 +apply (subgoal_tac "neg (number_of (Int.pred v)) = (number_of v < Suc 0) ")
106.923 +apply (simp only: less_Suc_eq_le le_0_eq)
106.924 +apply (subst less_number_of_Suc, simp)
106.925 +done
106.926 +
106.927 +text{*No longer required as a simprule because of the @{text inverse_fold}
106.928 + simproc*}
106.929 +lemma Suc_diff_number_of:
106.930 + "Int.Pls < v ==>
106.931 + Suc m - (number_of v) = m - (number_of (Int.pred v))"
106.932 +apply (subst Suc_diff_eq_diff_pred)
106.933 +apply simp
106.934 +apply (simp del: nat_numeral_1_eq_1)
106.935 +apply (auto simp only: diff_nat_number_of less_0_number_of [symmetric]
106.936 + neg_number_of_pred_iff_0)
106.937 +done
106.938 +
106.939 +lemma diff_Suc_eq_diff_pred: "m - Suc n = (m - 1) - n"
106.940 +by (simp add: numerals split add: nat_diff_split)
106.941 +
106.942 +
106.943 +subsubsection{*For @{term nat_case} and @{term nat_rec}*}
106.944 +
106.945 +lemma nat_case_number_of [simp]:
106.946 + "nat_case a f (number_of v) =
106.947 + (let pv = number_of (Int.pred v) in
106.948 + if neg pv then a else f (nat pv))"
106.949 +by (simp split add: nat.split add: Let_def neg_number_of_pred_iff_0)
106.950 +
106.951 +lemma nat_case_add_eq_if [simp]:
106.952 + "nat_case a f ((number_of v) + n) =
106.953 + (let pv = number_of (Int.pred v) in
106.954 + if neg pv then nat_case a f n else f (nat pv + n))"
106.955 +apply (subst add_eq_if)
106.956 +apply (simp split add: nat.split
106.957 + del: nat_numeral_1_eq_1
106.958 + add: nat_numeral_1_eq_1 [symmetric]
106.959 + numeral_1_eq_Suc_0 [symmetric]
106.960 + neg_number_of_pred_iff_0)
106.961 +done
106.962 +
106.963 +lemma nat_rec_number_of [simp]:
106.964 + "nat_rec a f (number_of v) =
106.965 + (let pv = number_of (Int.pred v) in
106.966 + if neg pv then a else f (nat pv) (nat_rec a f (nat pv)))"
106.967 +apply (case_tac " (number_of v) ::nat")
106.968 +apply (simp_all (no_asm_simp) add: Let_def neg_number_of_pred_iff_0)
106.969 +apply (simp split add: split_if_asm)
106.970 +done
106.971 +
106.972 +lemma nat_rec_add_eq_if [simp]:
106.973 + "nat_rec a f (number_of v + n) =
106.974 + (let pv = number_of (Int.pred v) in
106.975 + if neg pv then nat_rec a f n
106.976 + else f (nat pv + n) (nat_rec a f (nat pv + n)))"
106.977 +apply (subst add_eq_if)
106.978 +apply (simp split add: nat.split
106.979 + del: nat_numeral_1_eq_1
106.980 + add: nat_numeral_1_eq_1 [symmetric]
106.981 + numeral_1_eq_Suc_0 [symmetric]
106.982 + neg_number_of_pred_iff_0)
106.983 +done
106.984 +
106.985 +
106.986 +subsubsection{*Various Other Lemmas*}
106.987 +
106.988 +lemma card_UNIV_bool[simp]: "card (UNIV :: bool set) = 2"
106.989 +by(simp add: UNIV_bool)
106.990 +
106.991 +text {*Evens and Odds, for Mutilated Chess Board*}
106.992 +
106.993 +text{*Lemmas for specialist use, NOT as default simprules*}
106.994 +lemma nat_mult_2: "2 * z = (z+z::nat)"
106.995 +proof -
106.996 + have "2*z = (1 + 1)*z" by simp
106.997 + also have "... = z+z" by (simp add: left_distrib)
106.998 + finally show ?thesis .
106.999 +qed
106.1000 +
106.1001 +lemma nat_mult_2_right: "z * 2 = (z+z::nat)"
106.1002 +by (subst mult_commute, rule nat_mult_2)
106.1003 +
106.1004 +text{*Case analysis on @{term "n<2"}*}
106.1005 +lemma less_2_cases: "(n::nat) < 2 ==> n = 0 | n = Suc 0"
106.1006 +by arith
106.1007 +
106.1008 +lemma div2_Suc_Suc [simp]: "Suc(Suc m) div 2 = Suc (m div 2)"
106.1009 +by arith
106.1010 +
106.1011 +lemma add_self_div_2 [simp]: "(m + m) div 2 = (m::nat)"
106.1012 +by (simp add: nat_mult_2 [symmetric])
106.1013 +
106.1014 +lemma mod2_Suc_Suc [simp]: "Suc(Suc(m)) mod 2 = m mod 2"
106.1015 +apply (subgoal_tac "m mod 2 < 2")
106.1016 +apply (erule less_2_cases [THEN disjE])
106.1017 +apply (simp_all (no_asm_simp) add: Let_def mod_Suc nat_1)
106.1018 +done
106.1019 +
106.1020 +lemma mod2_gr_0 [simp]: "!!m::nat. (0 < m mod 2) = (m mod 2 = 1)"
106.1021 +apply (subgoal_tac "m mod 2 < 2")
106.1022 +apply (force simp del: mod_less_divisor, simp)
106.1023 +done
106.1024 +
106.1025 +text{*Removal of Small Numerals: 0, 1 and (in additive positions) 2*}
106.1026 +
106.1027 +lemma add_2_eq_Suc [simp]: "2 + n = Suc (Suc n)"
106.1028 +by simp
106.1029 +
106.1030 +lemma add_2_eq_Suc' [simp]: "n + 2 = Suc (Suc n)"
106.1031 +by simp
106.1032 +
106.1033 +text{*Can be used to eliminate long strings of Sucs, but not by default*}
106.1034 +lemma Suc3_eq_add_3: "Suc (Suc (Suc n)) = 3 + n"
106.1035 +by simp
106.1036 +
106.1037 +
106.1038 +text{*These lemmas collapse some needless occurrences of Suc:
106.1039 + at least three Sucs, since two and fewer are rewritten back to Suc again!
106.1040 + We already have some rules to simplify operands smaller than 3.*}
106.1041 +
106.1042 +lemma div_Suc_eq_div_add3 [simp]: "m div (Suc (Suc (Suc n))) = m div (3+n)"
106.1043 +by (simp add: Suc3_eq_add_3)
106.1044 +
106.1045 +lemma mod_Suc_eq_mod_add3 [simp]: "m mod (Suc (Suc (Suc n))) = m mod (3+n)"
106.1046 +by (simp add: Suc3_eq_add_3)
106.1047 +
106.1048 +lemma Suc_div_eq_add3_div: "(Suc (Suc (Suc m))) div n = (3+m) div n"
106.1049 +by (simp add: Suc3_eq_add_3)
106.1050 +
106.1051 +lemma Suc_mod_eq_add3_mod: "(Suc (Suc (Suc m))) mod n = (3+m) mod n"
106.1052 +by (simp add: Suc3_eq_add_3)
106.1053 +
106.1054 +lemmas Suc_div_eq_add3_div_number_of =
106.1055 + Suc_div_eq_add3_div [of _ "number_of v", standard]
106.1056 +declare Suc_div_eq_add3_div_number_of [simp]
106.1057 +
106.1058 +lemmas Suc_mod_eq_add3_mod_number_of =
106.1059 + Suc_mod_eq_add3_mod [of _ "number_of v", standard]
106.1060 +declare Suc_mod_eq_add3_mod_number_of [simp]
106.1061 +
106.1062 +end
106.1063 \ No newline at end of file
107.1 --- a/src/HOL/Nominal/Examples/Fsub.thy Mon May 11 09:39:53 2009 +0200
107.2 +++ b/src/HOL/Nominal/Examples/Fsub.thy Mon May 11 17:20:52 2009 +0200
107.3 @@ -245,7 +245,7 @@
107.4 apply (simp add: dj_perm_forget[OF dj_tyvrs_vrs])
107.5 done
107.6
107.7 -lemma ty_vrs_fresh[fresh]:
107.8 +lemma ty_vrs_fresh:
107.9 fixes x::"vrs"
107.10 and T::"ty"
107.11 shows "x \<sharp> T"
107.12 @@ -422,7 +422,7 @@
107.13 by (nominal_induct T avoiding: X T' rule: ty.strong_induct)
107.14 (perm_simp add: fresh_left)+
107.15
107.16 -lemma type_subst_fresh[fresh]:
107.17 +lemma type_subst_fresh:
107.18 fixes X::"tyvrs"
107.19 assumes "X \<sharp> T" and "X \<sharp> P"
107.20 shows "X \<sharp> T[Y \<mapsto> P]\<^sub>\<tau>"
107.21 @@ -430,7 +430,7 @@
107.22 by (nominal_induct T avoiding: X Y P rule:ty.strong_induct)
107.23 (auto simp add: abs_fresh)
107.24
107.25 -lemma fresh_type_subst_fresh[fresh]:
107.26 +lemma fresh_type_subst_fresh:
107.27 assumes "X\<sharp>T'"
107.28 shows "X\<sharp>T[X \<mapsto> T']\<^sub>\<tau>"
107.29 using assms
107.30 @@ -458,18 +458,19 @@
107.31 | "(VarB X U)[Y \<mapsto> T]\<^sub>b = VarB X (U[Y \<mapsto> T]\<^sub>\<tau>)"
107.32 by auto
107.33
107.34 -lemma binding_subst_fresh[fresh]:
107.35 +lemma binding_subst_fresh:
107.36 fixes X::"tyvrs"
107.37 assumes "X \<sharp> a"
107.38 and "X \<sharp> P"
107.39 shows "X \<sharp> a[Y \<mapsto> P]\<^sub>b"
107.40 using assms
107.41 -by (nominal_induct a rule:binding.strong_induct)
107.42 - (auto simp add: freshs)
107.43 +by (nominal_induct a rule: binding.strong_induct)
107.44 + (auto simp add: type_subst_fresh)
107.45
107.46 -lemma binding_subst_identity: "X \<sharp> B \<Longrightarrow> B[X \<mapsto> U]\<^sub>b = B"
107.47 - by (induct B rule: binding.induct)
107.48 - (simp_all add: fresh_atm type_subst_identity)
107.49 +lemma binding_subst_identity:
107.50 + shows "X \<sharp> B \<Longrightarrow> B[X \<mapsto> U]\<^sub>b = B"
107.51 +by (induct B rule: binding.induct)
107.52 + (simp_all add: fresh_atm type_subst_identity)
107.53
107.54 consts
107.55 subst_tyc :: "env \<Rightarrow> tyvrs \<Rightarrow> ty \<Rightarrow> env" ("_[_ \<mapsto> _]\<^sub>e" [100,100,100] 100)
107.56 @@ -478,14 +479,14 @@
107.57 "([])[Y \<mapsto> T]\<^sub>e= []"
107.58 "(B#\<Gamma>)[Y \<mapsto> T]\<^sub>e = (B[Y \<mapsto> T]\<^sub>b)#(\<Gamma>[Y \<mapsto> T]\<^sub>e)"
107.59
107.60 -lemma ctxt_subst_fresh'[fresh]:
107.61 +lemma ctxt_subst_fresh':
107.62 fixes X::"tyvrs"
107.63 assumes "X \<sharp> \<Gamma>"
107.64 and "X \<sharp> P"
107.65 shows "X \<sharp> \<Gamma>[Y \<mapsto> P]\<^sub>e"
107.66 using assms
107.67 by (induct \<Gamma>)
107.68 - (auto simp add: fresh_list_cons freshs)
107.69 + (auto simp add: fresh_list_cons binding_subst_fresh)
107.70
107.71 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)"
107.72 by (induct \<Gamma>) auto
107.73 @@ -1188,8 +1189,8 @@
107.74 using assms by (induct, auto)
107.75
107.76 nominal_inductive typing
107.77 - by (auto dest!: typing_ok intro: closed_in_fresh fresh_domain
107.78 - simp: abs_fresh fresh_prod fresh_atm freshs valid_ty_domain_fresh fresh_trm_domain)
107.79 +by (auto dest!: typing_ok intro: closed_in_fresh fresh_domain type_subst_fresh
107.80 + simp: abs_fresh fresh_type_subst_fresh ty_vrs_fresh valid_ty_domain_fresh fresh_trm_domain)
107.81
107.82 lemma ok_imp_VarB_closed_in:
107.83 assumes ok: "\<turnstile> \<Gamma> ok"
108.1 --- a/src/HOL/Nominal/Nominal.thy Mon May 11 09:39:53 2009 +0200
108.2 +++ b/src/HOL/Nominal/Nominal.thy Mon May 11 17:20:52 2009 +0200
108.3 @@ -18,25 +18,98 @@
108.4 types
108.5 'x prm = "('x \<times> 'x) list"
108.6
108.7 -(* polymorphic operations for permutation and swapping *)
108.8 +(* polymorphic constants for permutation and swapping *)
108.9 consts
108.10 perm :: "'x prm \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<bullet>" 80)
108.11 swap :: "('x \<times> 'x) \<Rightarrow> 'x \<Rightarrow> 'x"
108.12
108.13 +(* a "private" copy of the option type used in the abstraction function *)
108.14 +datatype 'a noption = nSome 'a | nNone
108.15 +
108.16 +(* a "private" copy of the product type used in the nominal induct method *)
108.17 +datatype ('a,'b) nprod = nPair 'a 'b
108.18 +
108.19 (* an auxiliary constant for the decision procedure involving *)
108.20 -(* permutations (to avoid loops when using perm-composition) *)
108.21 +(* permutations (to avoid loops when using perm-compositions) *)
108.22 constdefs
108.23 "perm_aux pi x \<equiv> pi\<bullet>x"
108.24
108.25 -(* permutation on functions *)
108.26 -defs (unchecked overloaded)
108.27 - perm_fun_def: "pi\<bullet>(f::'a\<Rightarrow>'b) \<equiv> (\<lambda>x. pi\<bullet>f((rev pi)\<bullet>x))"
108.28 -
108.29 -(* permutation on bools *)
108.30 -primrec (unchecked perm_bool)
108.31 - true_eqvt: "pi\<bullet>True = True"
108.32 - false_eqvt: "pi\<bullet>False = False"
108.33 -
108.34 +(* overloaded permutation operations *)
108.35 +overloading
108.36 + perm_fun \<equiv> "perm :: 'x prm \<Rightarrow> ('a\<Rightarrow>'b) \<Rightarrow> ('a\<Rightarrow>'b)" (unchecked)
108.37 + perm_bool \<equiv> "perm :: 'x prm \<Rightarrow> bool \<Rightarrow> bool" (unchecked)
108.38 + perm_unit \<equiv> "perm :: 'x prm \<Rightarrow> unit \<Rightarrow> unit" (unchecked)
108.39 + perm_prod \<equiv> "perm :: 'x prm \<Rightarrow> ('a\<times>'b) \<Rightarrow> ('a\<times>'b)" (unchecked)
108.40 + perm_list \<equiv> "perm :: 'x prm \<Rightarrow> 'a list \<Rightarrow> 'a list" (unchecked)
108.41 + perm_option \<equiv> "perm :: 'x prm \<Rightarrow> 'a option \<Rightarrow> 'a option" (unchecked)
108.42 + perm_char \<equiv> "perm :: 'x prm \<Rightarrow> char \<Rightarrow> char" (unchecked)
108.43 + perm_nat \<equiv> "perm :: 'x prm \<Rightarrow> nat \<Rightarrow> nat" (unchecked)
108.44 + perm_int \<equiv> "perm :: 'x prm \<Rightarrow> int \<Rightarrow> int" (unchecked)
108.45 +
108.46 + perm_noption \<equiv> "perm :: 'x prm \<Rightarrow> 'a noption \<Rightarrow> 'a noption" (unchecked)
108.47 + perm_nprod \<equiv> "perm :: 'x prm \<Rightarrow> ('a, 'b) nprod \<Rightarrow> ('a, 'b) nprod" (unchecked)
108.48 +begin
108.49 +
108.50 +definition
108.51 + perm_fun_def: "perm_fun pi (f::'a\<Rightarrow>'b) \<equiv> (\<lambda>x. pi\<bullet>f((rev pi)\<bullet>x))"
108.52 +
108.53 +fun
108.54 + perm_bool :: "'x prm \<Rightarrow> bool \<Rightarrow> bool"
108.55 +where
108.56 + true_eqvt: "perm_bool pi True = True"
108.57 +| false_eqvt: "perm_bool pi False = False"
108.58 +
108.59 +fun
108.60 + perm_unit :: "'x prm \<Rightarrow> unit \<Rightarrow> unit"
108.61 +where
108.62 + "perm_unit pi () = ()"
108.63 +
108.64 +fun
108.65 + perm_prod :: "'x prm \<Rightarrow> ('a\<times>'b) \<Rightarrow> ('a\<times>'b)"
108.66 +where
108.67 + "perm_prod pi (x,y) = (pi\<bullet>x,pi\<bullet>y)"
108.68 +
108.69 +fun
108.70 + perm_list :: "'x prm \<Rightarrow> 'a list \<Rightarrow> 'a list"
108.71 +where
108.72 + nil_eqvt: "perm_list pi [] = []"
108.73 +| cons_eqvt: "perm_list pi (x#xs) = (pi\<bullet>x)#(pi\<bullet>xs)"
108.74 +
108.75 +fun
108.76 + perm_option :: "'x prm \<Rightarrow> 'a option \<Rightarrow> 'a option"
108.77 +where
108.78 + some_eqvt: "perm_option pi (Some x) = Some (pi\<bullet>x)"
108.79 +| none_eqvt: "perm_option pi None = None"
108.80 +
108.81 +definition
108.82 + perm_char :: "'x prm \<Rightarrow> char \<Rightarrow> char"
108.83 +where
108.84 + perm_char_def: "perm_char pi c \<equiv> c"
108.85 +
108.86 +definition
108.87 + perm_nat :: "'x prm \<Rightarrow> nat \<Rightarrow> nat"
108.88 +where
108.89 + perm_nat_def: "perm_nat pi i \<equiv> i"
108.90 +
108.91 +definition
108.92 + perm_int :: "'x prm \<Rightarrow> int \<Rightarrow> int"
108.93 +where
108.94 + perm_int_def: "perm_int pi i \<equiv> i"
108.95 +
108.96 +fun
108.97 + perm_noption :: "'x prm \<Rightarrow> 'a noption \<Rightarrow> 'a noption"
108.98 +where
108.99 + nsome_eqvt: "perm_noption pi (nSome x) = nSome (pi\<bullet>x)"
108.100 +| nnone_eqvt: "perm_noption pi nNone = nNone"
108.101 +
108.102 +fun
108.103 + perm_nprod :: "'x prm \<Rightarrow> ('a, 'b) nprod \<Rightarrow> ('a, 'b) nprod"
108.104 +where
108.105 + "perm_nprod pi (nPair x y) = nPair (pi\<bullet>x) (pi\<bullet>y)"
108.106 +end
108.107 +
108.108 +
108.109 +(* permutations on booleans *)
108.110 lemma perm_bool:
108.111 shows "pi\<bullet>(b::bool) = b"
108.112 by (cases b) auto
108.113 @@ -54,8 +127,7 @@
108.114 lemma if_eqvt:
108.115 fixes pi::"'a prm"
108.116 shows "pi\<bullet>(if b then c1 else c2) = (if (pi\<bullet>b) then (pi\<bullet>c1) else (pi\<bullet>c2))"
108.117 -apply(simp add: perm_fun_def)
108.118 -done
108.119 + by (simp add: perm_fun_def)
108.120
108.121 lemma imp_eqvt:
108.122 shows "pi\<bullet>(A\<longrightarrow>B) = ((pi\<bullet>A)\<longrightarrow>(pi\<bullet>B))"
108.123 @@ -82,13 +154,7 @@
108.124 shows "(pi\<bullet>(X\<union>Y)) = (pi\<bullet>X) \<union> (pi\<bullet>Y)"
108.125 by (simp add: perm_fun_def perm_bool Un_iff [unfolded mem_def] expand_fun_eq)
108.126
108.127 -(* permutation on units and products *)
108.128 -primrec (unchecked perm_unit)
108.129 - "pi\<bullet>() = ()"
108.130 -
108.131 -primrec (unchecked perm_prod)
108.132 - "pi\<bullet>(x,y) = (pi\<bullet>x,pi\<bullet>y)"
108.133 -
108.134 +(* permutations on products *)
108.135 lemma fst_eqvt:
108.136 "pi\<bullet>(fst x) = fst (pi\<bullet>x)"
108.137 by (cases x) simp
108.138 @@ -98,10 +164,6 @@
108.139 by (cases x) simp
108.140
108.141 (* permutation on lists *)
108.142 -primrec (unchecked perm_list)
108.143 - nil_eqvt: "pi\<bullet>[] = []"
108.144 - cons_eqvt: "pi\<bullet>(x#xs) = (pi\<bullet>x)#(pi\<bullet>xs)"
108.145 -
108.146 lemma append_eqvt:
108.147 fixes pi :: "'x prm"
108.148 and l1 :: "'a list"
108.149 @@ -115,41 +177,12 @@
108.150 shows "pi\<bullet>(rev l) = rev (pi\<bullet>l)"
108.151 by (induct l) (simp_all add: append_eqvt)
108.152
108.153 -(* permutation on options *)
108.154 -
108.155 -primrec (unchecked perm_option)
108.156 - some_eqvt: "pi\<bullet>Some(x) = Some(pi\<bullet>x)"
108.157 - none_eqvt: "pi\<bullet>None = None"
108.158 -
108.159 -(* a "private" copy of the option type used in the abstraction function *)
108.160 -datatype 'a noption = nSome 'a | nNone
108.161 -
108.162 -primrec (unchecked perm_noption)
108.163 - nSome_eqvt: "pi\<bullet>nSome(x) = nSome(pi\<bullet>x)"
108.164 - nNone_eqvt: "pi\<bullet>nNone = nNone"
108.165 -
108.166 -(* a "private" copy of the product type used in the nominal induct method *)
108.167 -datatype ('a,'b) nprod = nPair 'a 'b
108.168 -
108.169 -primrec (unchecked perm_nprod)
108.170 - perm_nProd_def: "pi\<bullet>(nPair x1 x2) = nPair (pi\<bullet>x1) (pi\<bullet>x2)"
108.171 -
108.172 -(* permutation on characters (used in strings) *)
108.173 -defs (unchecked overloaded)
108.174 - perm_char_def: "pi\<bullet>(c::char) \<equiv> c"
108.175 -
108.176 +(* permutation on characters and strings *)
108.177 lemma perm_string:
108.178 fixes s::"string"
108.179 shows "pi\<bullet>s = s"
108.180 -by (induct s)(auto simp add: perm_char_def)
108.181 -
108.182 -(* permutation on ints *)
108.183 -defs (unchecked overloaded)
108.184 - perm_int_def: "pi\<bullet>(i::int) \<equiv> i"
108.185 -
108.186 -(* permutation on nats *)
108.187 -defs (unchecked overloaded)
108.188 - perm_nat_def: "pi\<bullet>(i::nat) \<equiv> i"
108.189 + by (induct s)(auto simp add: perm_char_def)
108.190 +
108.191
108.192 section {* permutation equality *}
108.193 (*==============================*)
108.194 @@ -170,11 +203,12 @@
108.195 supports :: "'x set \<Rightarrow> 'a \<Rightarrow> bool" (infixl "supports" 80)
108.196 "S supports x \<equiv> \<forall>a b. (a\<notin>S \<and> b\<notin>S \<longrightarrow> [(a,b)]\<bullet>x=x)"
108.197
108.198 +(* lemmas about supp *)
108.199 lemma supp_fresh_iff:
108.200 fixes x :: "'a"
108.201 shows "(supp x) = {a::'x. \<not>a\<sharp>x}"
108.202 -apply(simp add: fresh_def)
108.203 -done
108.204 + by (simp add: fresh_def)
108.205 +
108.206
108.207 lemma supp_unit:
108.208 shows "supp () = {}"
108.209 @@ -205,14 +239,13 @@
108.210 fixes x :: "'a"
108.211 and xs :: "'a list"
108.212 shows "supp (x#xs) = (supp x)\<union>(supp xs)"
108.213 -apply(auto simp add: supp_def Collect_imp_eq Collect_neg_eq)
108.214 -done
108.215 + by (auto simp add: supp_def Collect_imp_eq Collect_neg_eq)
108.216
108.217 lemma supp_list_append:
108.218 fixes xs :: "'a list"
108.219 and ys :: "'a list"
108.220 shows "supp (xs@ys) = (supp xs)\<union>(supp ys)"
108.221 - by (induct xs, auto simp add: supp_list_nil supp_list_cons)
108.222 + by (induct xs) (auto simp add: supp_list_nil supp_list_cons)
108.223
108.224 lemma supp_list_rev:
108.225 fixes xs :: "'a list"
108.226 @@ -221,47 +254,40 @@
108.227
108.228 lemma supp_bool:
108.229 fixes x :: "bool"
108.230 - shows "supp (x) = {}"
108.231 - apply(case_tac "x")
108.232 - apply(simp_all add: supp_def)
108.233 -done
108.234 + shows "supp x = {}"
108.235 + by (cases "x") (simp_all add: supp_def)
108.236
108.237 lemma supp_some:
108.238 fixes x :: "'a"
108.239 shows "supp (Some x) = (supp x)"
108.240 - apply(simp add: supp_def)
108.241 - done
108.242 + by (simp add: supp_def)
108.243
108.244 lemma supp_none:
108.245 fixes x :: "'a"
108.246 shows "supp (None) = {}"
108.247 - apply(simp add: supp_def)
108.248 - done
108.249 + by (simp add: supp_def)
108.250
108.251 lemma supp_int:
108.252 fixes i::"int"
108.253 shows "supp (i) = {}"
108.254 - apply(simp add: supp_def perm_int_def)
108.255 - done
108.256 + by (simp add: supp_def perm_int_def)
108.257
108.258 lemma supp_nat:
108.259 fixes n::"nat"
108.260 - shows "supp (n) = {}"
108.261 - apply(simp add: supp_def perm_nat_def)
108.262 - done
108.263 + shows "(supp n) = {}"
108.264 + by (simp add: supp_def perm_nat_def)
108.265
108.266 lemma supp_char:
108.267 fixes c::"char"
108.268 - shows "supp (c) = {}"
108.269 - apply(simp add: supp_def perm_char_def)
108.270 - done
108.271 + shows "(supp c) = {}"
108.272 + by (simp add: supp_def perm_char_def)
108.273
108.274 lemma supp_string:
108.275 fixes s::"string"
108.276 - shows "supp (s) = {}"
108.277 -apply(simp add: supp_def perm_string)
108.278 -done
108.279 -
108.280 + shows "(supp s) = {}"
108.281 + by (simp add: supp_def perm_string)
108.282 +
108.283 +(* lemmas about freshness *)
108.284 lemma fresh_set_empty:
108.285 shows "a\<sharp>{}"
108.286 by (simp add: fresh_def supp_set_empty)
108.287 @@ -344,7 +370,6 @@
108.288 by (simp add: fresh_def supp_bool)
108.289
108.290 text {* Normalization of freshness results; cf.\ @{text nominal_induct} *}
108.291 -
108.292 lemma fresh_unit_elim:
108.293 shows "(a\<sharp>() \<Longrightarrow> PROP C) \<equiv> PROP C"
108.294 by (simp add: fresh_def supp_unit)
108.295 @@ -371,63 +396,6 @@
108.296 Simplifier.map_ss (fn ss => ss setmksimps (mksimps mksimps_pairs))
108.297 *}
108.298
108.299 -section {* generalisation of freshness to lists and sets of atoms *}
108.300 -(*================================================================*)
108.301 -
108.302 -consts
108.303 - fresh_star :: "'b \<Rightarrow> 'a \<Rightarrow> bool" ("_ \<sharp>* _" [100,100] 100)
108.304 -
108.305 -defs (overloaded)
108.306 - fresh_star_set: "xs\<sharp>*c \<equiv> \<forall>x\<in>xs. x\<sharp>c"
108.307 -
108.308 -defs (overloaded)
108.309 - fresh_star_list: "xs\<sharp>*c \<equiv> \<forall>x\<in>set xs. x\<sharp>c"
108.310 -
108.311 -lemmas fresh_star_def = fresh_star_list fresh_star_set
108.312 -
108.313 -lemma fresh_star_prod_set:
108.314 - fixes xs::"'a set"
108.315 - shows "xs\<sharp>*(a,b) = (xs\<sharp>*a \<and> xs\<sharp>*b)"
108.316 -by (auto simp add: fresh_star_def fresh_prod)
108.317 -
108.318 -lemma fresh_star_prod_list:
108.319 - fixes xs::"'a list"
108.320 - shows "xs\<sharp>*(a,b) = (xs\<sharp>*a \<and> xs\<sharp>*b)"
108.321 -by (auto simp add: fresh_star_def fresh_prod)
108.322 -
108.323 -lemmas fresh_star_prod = fresh_star_prod_list fresh_star_prod_set
108.324 -
108.325 -lemma fresh_star_set_eq: "set xs \<sharp>* c = xs \<sharp>* c"
108.326 - by (simp add: fresh_star_def)
108.327 -
108.328 -lemma fresh_star_Un_elim:
108.329 - "((S \<union> T) \<sharp>* c \<Longrightarrow> PROP C) \<equiv> (S \<sharp>* c \<Longrightarrow> T \<sharp>* c \<Longrightarrow> PROP C)"
108.330 - apply rule
108.331 - apply (simp_all add: fresh_star_def)
108.332 - apply (erule meta_mp)
108.333 - apply blast
108.334 - done
108.335 -
108.336 -lemma fresh_star_insert_elim:
108.337 - "(insert x S \<sharp>* c \<Longrightarrow> PROP C) \<equiv> (x \<sharp> c \<Longrightarrow> S \<sharp>* c \<Longrightarrow> PROP C)"
108.338 - by rule (simp_all add: fresh_star_def)
108.339 -
108.340 -lemma fresh_star_empty_elim:
108.341 - "({} \<sharp>* c \<Longrightarrow> PROP C) \<equiv> PROP C"
108.342 - by (simp add: fresh_star_def)
108.343 -
108.344 -text {* Normalization of freshness results; cf.\ @{text nominal_induct} *}
108.345 -
108.346 -lemma fresh_star_unit_elim:
108.347 - shows "((a::'a set)\<sharp>*() \<Longrightarrow> PROP C) \<equiv> PROP C"
108.348 - and "((b::'a list)\<sharp>*() \<Longrightarrow> PROP C) \<equiv> PROP C"
108.349 - by (simp_all add: fresh_star_def fresh_def supp_unit)
108.350 -
108.351 -lemma fresh_star_prod_elim:
108.352 - shows "((a::'a set)\<sharp>*(x,y) \<Longrightarrow> PROP C) \<equiv> (a\<sharp>*x \<Longrightarrow> a\<sharp>*y \<Longrightarrow> PROP C)"
108.353 - and "((b::'a list)\<sharp>*(x,y) \<Longrightarrow> PROP C) \<equiv> (b\<sharp>*x \<Longrightarrow> b\<sharp>*y \<Longrightarrow> PROP C)"
108.354 - by (rule, simp_all add: fresh_star_prod)+
108.355 -
108.356 section {* Abstract Properties for Permutations and Atoms *}
108.357 (*=========================================================*)
108.358
108.359 @@ -487,7 +455,7 @@
108.360 shows "swap (a,b) c = (if a=c then b else (if b=c then a else c))"
108.361 using a by (simp only: at_def)
108.362
108.363 -(* rules to calculate simple premutations *)
108.364 +(* rules to calculate simple permutations *)
108.365 lemmas at_calc = at2 at1 at3
108.366
108.367 lemma at_swap_simps:
108.368 @@ -682,7 +650,6 @@
108.369 shows "pi1 \<triangleq> pi2 \<Longrightarrow> (rev pi1) \<triangleq> (rev pi2)"
108.370 by (simp add: at_prm_rev_eq[OF at])
108.371
108.372 -
108.373 lemma at_ds1:
108.374 fixes a :: "'x"
108.375 assumes at: "at TYPE('x)"
108.376 @@ -838,15 +805,18 @@
108.377 by (auto intro: ex_in_inf[OF at, OF fs] simp add: fresh_def)
108.378
108.379 lemma at_finite_select:
108.380 - shows "at (TYPE('a)) \<Longrightarrow> finite (S::'a set) \<Longrightarrow> \<exists>x. x \<notin> S"
108.381 - apply (drule Diff_infinite_finite)
108.382 - apply (simp add: at_def)
108.383 - apply blast
108.384 - apply (subgoal_tac "UNIV - S \<noteq> {}")
108.385 - apply (simp only: ex_in_conv [symmetric])
108.386 - apply blast
108.387 - apply (rule notI)
108.388 - apply simp
108.389 + fixes S::"'a set"
108.390 + assumes a: "at TYPE('a)"
108.391 + and b: "finite S"
108.392 + shows "\<exists>x. x \<notin> S"
108.393 + using a b
108.394 + apply(drule_tac S="UNIV::'a set" in Diff_infinite_finite)
108.395 + apply(simp add: at_def)
108.396 + apply(subgoal_tac "UNIV - S \<noteq> {}")
108.397 + apply(simp only: ex_in_conv [symmetric])
108.398 + apply(blast)
108.399 + apply(rule notI)
108.400 + apply(simp)
108.401 done
108.402
108.403 lemma at_different:
108.404 @@ -1222,8 +1192,8 @@
108.405 assumes pt: "pt TYPE('a) TYPE('x)"
108.406 and at: "at TYPE('x)"
108.407 shows "pi\<bullet>(x=y) = (pi\<bullet>x = pi\<bullet>y)"
108.408 -using assms
108.409 -by (auto simp add: pt_bij perm_bool)
108.410 + using pt at
108.411 + by (auto simp add: pt_bij perm_bool)
108.412
108.413 lemma pt_bij3:
108.414 fixes pi :: "'x prm"
108.415 @@ -1231,7 +1201,7 @@
108.416 and y :: "'a"
108.417 assumes a: "x=y"
108.418 shows "(pi\<bullet>x = pi\<bullet>y)"
108.419 -using a by simp
108.420 + using a by simp
108.421
108.422 lemma pt_bij4:
108.423 fixes pi :: "'x prm"
108.424 @@ -1241,7 +1211,7 @@
108.425 and at: "at TYPE('x)"
108.426 and a: "pi\<bullet>x = pi\<bullet>y"
108.427 shows "x = y"
108.428 -using a by (simp add: pt_bij[OF pt, OF at])
108.429 + using a by (simp add: pt_bij[OF pt, OF at])
108.430
108.431 lemma pt_swap_bij:
108.432 fixes a :: "'x"
108.433 @@ -1574,35 +1544,6 @@
108.434 apply(simp add: pt_rev_pi[OF ptb, OF at])
108.435 done
108.436
108.437 -lemma pt_fresh_star_bij_ineq:
108.438 - fixes pi :: "'x prm"
108.439 - and x :: "'a"
108.440 - and a :: "'y set"
108.441 - and b :: "'y list"
108.442 - assumes pta: "pt TYPE('a) TYPE('x)"
108.443 - and ptb: "pt TYPE('y) TYPE('x)"
108.444 - and at: "at TYPE('x)"
108.445 - and cp: "cp TYPE('a) TYPE('x) TYPE('y)"
108.446 - shows "(pi\<bullet>a)\<sharp>*(pi\<bullet>x) = a\<sharp>*x"
108.447 - and "(pi\<bullet>b)\<sharp>*(pi\<bullet>x) = b\<sharp>*x"
108.448 -apply(unfold fresh_star_def)
108.449 -apply(auto)
108.450 -apply(drule_tac x="pi\<bullet>xa" in bspec)
108.451 -apply(rule pt_set_bij2[OF ptb, OF at])
108.452 -apply(assumption)
108.453 -apply(simp add: fresh_star_def pt_fresh_bij_ineq[OF pta, OF ptb, OF at, OF cp])
108.454 -apply(drule_tac x="(rev pi)\<bullet>xa" in bspec)
108.455 -apply(simp add: pt_set_bij1[OF ptb, OF at])
108.456 -apply(simp add: pt_fresh_left_ineq[OF pta, OF ptb, OF at, OF cp])
108.457 -apply(drule_tac x="pi\<bullet>xa" in bspec)
108.458 -apply(simp add: pt_set_bij1[OF ptb, OF at])
108.459 -apply(simp add: pt_set_eqvt [OF ptb at] pt_rev_pi[OF pt_list_inst[OF ptb], OF at])
108.460 -apply(simp add: pt_fresh_bij_ineq[OF pta, OF ptb, OF at, OF cp])
108.461 -apply(drule_tac x="(rev pi)\<bullet>xa" in bspec)
108.462 -apply(simp add: pt_set_bij1[OF ptb, OF at] pt_set_eqvt [OF ptb at])
108.463 -apply(simp add: pt_fresh_left_ineq[OF pta, OF ptb, OF at, OF cp])
108.464 -done
108.465 -
108.466 lemma pt_fresh_left:
108.467 fixes pi :: "'x prm"
108.468 and x :: "'a"
108.469 @@ -1651,56 +1592,6 @@
108.470 apply(rule at)
108.471 done
108.472
108.473 -lemma pt_fresh_star_bij:
108.474 - fixes pi :: "'x prm"
108.475 - and x :: "'a"
108.476 - and a :: "'x set"
108.477 - and b :: "'x list"
108.478 - assumes pt: "pt TYPE('a) TYPE('x)"
108.479 - and at: "at TYPE('x)"
108.480 - shows "(pi\<bullet>a)\<sharp>*(pi\<bullet>x) = a\<sharp>*x"
108.481 - and "(pi\<bullet>b)\<sharp>*(pi\<bullet>x) = b\<sharp>*x"
108.482 -apply(rule pt_fresh_star_bij_ineq(1))
108.483 -apply(rule pt)
108.484 -apply(rule at_pt_inst)
108.485 -apply(rule at)+
108.486 -apply(rule cp_pt_inst)
108.487 -apply(rule pt)
108.488 -apply(rule at)
108.489 -apply(rule pt_fresh_star_bij_ineq(2))
108.490 -apply(rule pt)
108.491 -apply(rule at_pt_inst)
108.492 -apply(rule at)+
108.493 -apply(rule cp_pt_inst)
108.494 -apply(rule pt)
108.495 -apply(rule at)
108.496 -done
108.497 -
108.498 -lemma pt_fresh_star_eqvt:
108.499 - fixes pi :: "'x prm"
108.500 - and x :: "'a"
108.501 - and a :: "'x set"
108.502 - and b :: "'x list"
108.503 - assumes pt: "pt TYPE('a) TYPE('x)"
108.504 - and at: "at TYPE('x)"
108.505 - shows "pi\<bullet>(a\<sharp>*x) = (pi\<bullet>a)\<sharp>*(pi\<bullet>x)"
108.506 - and "pi\<bullet>(b\<sharp>*x) = (pi\<bullet>b)\<sharp>*(pi\<bullet>x)"
108.507 - by (simp_all add: perm_bool pt_fresh_star_bij[OF pt, OF at])
108.508 -
108.509 -lemma pt_fresh_star_eqvt_ineq:
108.510 - fixes pi::"'x prm"
108.511 - and a::"'y set"
108.512 - and b::"'y list"
108.513 - and x::"'a"
108.514 - assumes pta: "pt TYPE('a) TYPE('x)"
108.515 - and ptb: "pt TYPE('y) TYPE('x)"
108.516 - and at: "at TYPE('x)"
108.517 - and cp: "cp TYPE('a) TYPE('x) TYPE('y)"
108.518 - and dj: "disjoint TYPE('y) TYPE('x)"
108.519 - shows "pi\<bullet>(a\<sharp>*x) = (pi\<bullet>a)\<sharp>*(pi\<bullet>x)"
108.520 - and "pi\<bullet>(b\<sharp>*x) = (pi\<bullet>b)\<sharp>*(pi\<bullet>x)"
108.521 - by (simp_all add: pt_fresh_star_bij_ineq[OF pta, OF ptb, OF at, OF cp] dj_perm_forget[OF dj] perm_bool)
108.522 -
108.523 lemma pt_fresh_bij1:
108.524 fixes pi :: "'x prm"
108.525 and x :: "'a"
108.526 @@ -1753,7 +1644,6 @@
108.527
108.528 (* the next two lemmas are needed in the proof *)
108.529 (* of the structural induction principle *)
108.530 -
108.531 lemma pt_fresh_aux:
108.532 fixes a::"'x"
108.533 and b::"'x"
108.534 @@ -1857,27 +1747,6 @@
108.535 thus ?thesis using eq3 by simp
108.536 qed
108.537
108.538 -lemma pt_freshs_freshs:
108.539 - assumes pt: "pt TYPE('a) TYPE('x)"
108.540 - and at: "at TYPE ('x)"
108.541 - and pi: "set (pi::'x prm) \<subseteq> Xs \<times> Ys"
108.542 - and Xs: "Xs \<sharp>* (x::'a)"
108.543 - and Ys: "Ys \<sharp>* x"
108.544 - shows "pi \<bullet> x = x"
108.545 - using pi
108.546 -proof (induct pi)
108.547 - case Nil
108.548 - show ?case by (simp add: pt1 [OF pt])
108.549 -next
108.550 - case (Cons p pi)
108.551 - obtain a b where p: "p = (a, b)" by (cases p)
108.552 - with Cons Xs Ys have "a \<sharp> x" "b \<sharp> x"
108.553 - by (simp_all add: fresh_star_def)
108.554 - with Cons p show ?case
108.555 - by (simp add: pt_fresh_fresh [OF pt at]
108.556 - pt2 [OF pt, of "[(a, b)]" pi, simplified])
108.557 -qed
108.558 -
108.559 lemma pt_pi_fresh_fresh:
108.560 fixes x :: "'a"
108.561 and pi :: "'x prm"
108.562 @@ -1943,8 +1812,7 @@
108.563 thus ?thesis by (simp add: pt2[OF pt])
108.564 qed
108.565
108.566 -section {* equivaraince for some connectives *}
108.567 -
108.568 +section {* equivariance for some connectives *}
108.569 lemma pt_all_eqvt:
108.570 fixes pi :: "'x prm"
108.571 and x :: "'a"
108.572 @@ -1990,8 +1858,6 @@
108.573 apply(rule theI'[OF unique])
108.574 done
108.575
108.576 -
108.577 -
108.578 section {* facts about supports *}
108.579 (*==============================*)
108.580
108.581 @@ -2160,6 +2026,7 @@
108.582 shows "(x \<sharp> X) = (x \<notin> X)"
108.583 by (simp add: at_fin_set_supp fresh_def at fs)
108.584
108.585 +
108.586 section {* Permutations acting on Functions *}
108.587 (*==========================================*)
108.588
108.589 @@ -2540,9 +2407,8 @@
108.590 and a1: "a\<sharp>x"
108.591 and a2: "a\<sharp>X"
108.592 shows "a\<sharp>(insert x X)"
108.593 -using a1 a2
108.594 -apply(simp add: fresh_fin_insert[OF pt, OF at, OF fs, OF f])
108.595 -done
108.596 + using a1 a2
108.597 + by (simp add: fresh_fin_insert[OF pt, OF at, OF fs, OF f])
108.598
108.599 lemma pt_list_set_supp:
108.600 fixes xs :: "'a list"
108.601 @@ -2571,14 +2437,191 @@
108.602 shows "a\<sharp>(set xs) = a\<sharp>xs"
108.603 by (simp add: fresh_def pt_list_set_supp[OF pt, OF at, OF fs])
108.604
108.605 +
108.606 +section {* generalisation of freshness to lists and sets of atoms *}
108.607 +(*================================================================*)
108.608 +
108.609 +consts
108.610 + fresh_star :: "'b \<Rightarrow> 'a \<Rightarrow> bool" ("_ \<sharp>* _" [100,100] 100)
108.611 +
108.612 +defs (overloaded)
108.613 + fresh_star_set: "xs\<sharp>*c \<equiv> \<forall>x\<in>xs. x\<sharp>c"
108.614 +
108.615 +defs (overloaded)
108.616 + fresh_star_list: "xs\<sharp>*c \<equiv> \<forall>x\<in>set xs. x\<sharp>c"
108.617 +
108.618 +lemmas fresh_star_def = fresh_star_list fresh_star_set
108.619 +
108.620 +lemma fresh_star_prod_set:
108.621 + fixes xs::"'a set"
108.622 + shows "xs\<sharp>*(a,b) = (xs\<sharp>*a \<and> xs\<sharp>*b)"
108.623 +by (auto simp add: fresh_star_def fresh_prod)
108.624 +
108.625 +lemma fresh_star_prod_list:
108.626 + fixes xs::"'a list"
108.627 + shows "xs\<sharp>*(a,b) = (xs\<sharp>*a \<and> xs\<sharp>*b)"
108.628 + by (auto simp add: fresh_star_def fresh_prod)
108.629 +
108.630 +lemmas fresh_star_prod = fresh_star_prod_list fresh_star_prod_set
108.631 +
108.632 +lemma fresh_star_set_eq: "set xs \<sharp>* c = xs \<sharp>* c"
108.633 + by (simp add: fresh_star_def)
108.634 +
108.635 +lemma fresh_star_Un_elim:
108.636 + "((S \<union> T) \<sharp>* c \<Longrightarrow> PROP C) \<equiv> (S \<sharp>* c \<Longrightarrow> T \<sharp>* c \<Longrightarrow> PROP C)"
108.637 + apply rule
108.638 + apply (simp_all add: fresh_star_def)
108.639 + apply (erule meta_mp)
108.640 + apply blast
108.641 + done
108.642 +
108.643 +lemma fresh_star_insert_elim:
108.644 + "(insert x S \<sharp>* c \<Longrightarrow> PROP C) \<equiv> (x \<sharp> c \<Longrightarrow> S \<sharp>* c \<Longrightarrow> PROP C)"
108.645 + by rule (simp_all add: fresh_star_def)
108.646 +
108.647 +lemma fresh_star_empty_elim:
108.648 + "({} \<sharp>* c \<Longrightarrow> PROP C) \<equiv> PROP C"
108.649 + by (simp add: fresh_star_def)
108.650 +
108.651 +text {* Normalization of freshness results; see \ @{text nominal_induct} *}
108.652 +
108.653 +lemma fresh_star_unit_elim:
108.654 + shows "((a::'a set)\<sharp>*() \<Longrightarrow> PROP C) \<equiv> PROP C"
108.655 + and "((b::'a list)\<sharp>*() \<Longrightarrow> PROP C) \<equiv> PROP C"
108.656 + by (simp_all add: fresh_star_def fresh_def supp_unit)
108.657 +
108.658 +lemma fresh_star_prod_elim:
108.659 + shows "((a::'a set)\<sharp>*(x,y) \<Longrightarrow> PROP C) \<equiv> (a\<sharp>*x \<Longrightarrow> a\<sharp>*y \<Longrightarrow> PROP C)"
108.660 + and "((b::'a list)\<sharp>*(x,y) \<Longrightarrow> PROP C) \<equiv> (b\<sharp>*x \<Longrightarrow> b\<sharp>*y \<Longrightarrow> PROP C)"
108.661 + by (rule, simp_all add: fresh_star_prod)+
108.662 +
108.663 +
108.664 +lemma pt_fresh_star_bij_ineq:
108.665 + fixes pi :: "'x prm"
108.666 + and x :: "'a"
108.667 + and a :: "'y set"
108.668 + and b :: "'y list"
108.669 + assumes pta: "pt TYPE('a) TYPE('x)"
108.670 + and ptb: "pt TYPE('y) TYPE('x)"
108.671 + and at: "at TYPE('x)"
108.672 + and cp: "cp TYPE('a) TYPE('x) TYPE('y)"
108.673 + shows "(pi\<bullet>a)\<sharp>*(pi\<bullet>x) = a\<sharp>*x"
108.674 + and "(pi\<bullet>b)\<sharp>*(pi\<bullet>x) = b\<sharp>*x"
108.675 +apply(unfold fresh_star_def)
108.676 +apply(auto)
108.677 +apply(drule_tac x="pi\<bullet>xa" in bspec)
108.678 +apply(erule pt_set_bij2[OF ptb, OF at])
108.679 +apply(simp add: fresh_star_def pt_fresh_bij_ineq[OF pta, OF ptb, OF at, OF cp])
108.680 +apply(drule_tac x="(rev pi)\<bullet>xa" in bspec)
108.681 +apply(simp add: pt_set_bij1[OF ptb, OF at])
108.682 +apply(simp add: pt_fresh_left_ineq[OF pta, OF ptb, OF at, OF cp])
108.683 +apply(drule_tac x="pi\<bullet>xa" in bspec)
108.684 +apply(simp add: pt_set_bij1[OF ptb, OF at])
108.685 +apply(simp add: pt_set_eqvt [OF ptb at] pt_rev_pi[OF pt_list_inst[OF ptb], OF at])
108.686 +apply(simp add: pt_fresh_bij_ineq[OF pta, OF ptb, OF at, OF cp])
108.687 +apply(drule_tac x="(rev pi)\<bullet>xa" in bspec)
108.688 +apply(simp add: pt_set_bij1[OF ptb, OF at] pt_set_eqvt [OF ptb at])
108.689 +apply(simp add: pt_fresh_left_ineq[OF pta, OF ptb, OF at, OF cp])
108.690 +done
108.691 +
108.692 +lemma pt_fresh_star_bij:
108.693 + fixes pi :: "'x prm"
108.694 + and x :: "'a"
108.695 + and a :: "'x set"
108.696 + and b :: "'x list"
108.697 + assumes pt: "pt TYPE('a) TYPE('x)"
108.698 + and at: "at TYPE('x)"
108.699 + shows "(pi\<bullet>a)\<sharp>*(pi\<bullet>x) = a\<sharp>*x"
108.700 + and "(pi\<bullet>b)\<sharp>*(pi\<bullet>x) = b\<sharp>*x"
108.701 +apply(rule pt_fresh_star_bij_ineq(1))
108.702 +apply(rule pt)
108.703 +apply(rule at_pt_inst)
108.704 +apply(rule at)+
108.705 +apply(rule cp_pt_inst)
108.706 +apply(rule pt)
108.707 +apply(rule at)
108.708 +apply(rule pt_fresh_star_bij_ineq(2))
108.709 +apply(rule pt)
108.710 +apply(rule at_pt_inst)
108.711 +apply(rule at)+
108.712 +apply(rule cp_pt_inst)
108.713 +apply(rule pt)
108.714 +apply(rule at)
108.715 +done
108.716 +
108.717 +lemma pt_fresh_star_eqvt:
108.718 + fixes pi :: "'x prm"
108.719 + and x :: "'a"
108.720 + and a :: "'x set"
108.721 + and b :: "'x list"
108.722 + assumes pt: "pt TYPE('a) TYPE('x)"
108.723 + and at: "at TYPE('x)"
108.724 + shows "pi\<bullet>(a\<sharp>*x) = (pi\<bullet>a)\<sharp>*(pi\<bullet>x)"
108.725 + and "pi\<bullet>(b\<sharp>*x) = (pi\<bullet>b)\<sharp>*(pi\<bullet>x)"
108.726 + by (simp_all add: perm_bool pt_fresh_star_bij[OF pt, OF at])
108.727 +
108.728 +lemma pt_fresh_star_eqvt_ineq:
108.729 + fixes pi::"'x prm"
108.730 + and a::"'y set"
108.731 + and b::"'y list"
108.732 + and x::"'a"
108.733 + assumes pta: "pt TYPE('a) TYPE('x)"
108.734 + and ptb: "pt TYPE('y) TYPE('x)"
108.735 + and at: "at TYPE('x)"
108.736 + and cp: "cp TYPE('a) TYPE('x) TYPE('y)"
108.737 + and dj: "disjoint TYPE('y) TYPE('x)"
108.738 + shows "pi\<bullet>(a\<sharp>*x) = (pi\<bullet>a)\<sharp>*(pi\<bullet>x)"
108.739 + and "pi\<bullet>(b\<sharp>*x) = (pi\<bullet>b)\<sharp>*(pi\<bullet>x)"
108.740 + by (simp_all add: pt_fresh_star_bij_ineq[OF pta, OF ptb, OF at, OF cp] dj_perm_forget[OF dj] perm_bool)
108.741 +
108.742 +lemma pt_freshs_freshs:
108.743 + assumes pt: "pt TYPE('a) TYPE('x)"
108.744 + and at: "at TYPE ('x)"
108.745 + and pi: "set (pi::'x prm) \<subseteq> Xs \<times> Ys"
108.746 + and Xs: "Xs \<sharp>* (x::'a)"
108.747 + and Ys: "Ys \<sharp>* x"
108.748 + shows "pi\<bullet>x = x"
108.749 + using pi
108.750 +proof (induct pi)
108.751 + case Nil
108.752 + show ?case by (simp add: pt1 [OF pt])
108.753 +next
108.754 + case (Cons p pi)
108.755 + obtain a b where p: "p = (a, b)" by (cases p)
108.756 + with Cons Xs Ys have "a \<sharp> x" "b \<sharp> x"
108.757 + by (simp_all add: fresh_star_def)
108.758 + with Cons p show ?case
108.759 + by (simp add: pt_fresh_fresh [OF pt at]
108.760 + pt2 [OF pt, of "[(a, b)]" pi, simplified])
108.761 +qed
108.762 +
108.763 +lemma pt_fresh_star_pi:
108.764 + fixes x::"'a"
108.765 + and pi::"'x prm"
108.766 + assumes pt: "pt TYPE('a) TYPE('x)"
108.767 + and at: "at TYPE('x)"
108.768 + and a: "((supp x)::'x set)\<sharp>* pi"
108.769 + shows "pi\<bullet>x = x"
108.770 +using a
108.771 +apply(induct pi)
108.772 +apply(auto simp add: fresh_star_def fresh_list_cons fresh_prod pt1[OF pt])
108.773 +apply(subgoal_tac "((a,b)#pi)\<bullet>x = ([(a,b)]@pi)\<bullet>x")
108.774 +apply(simp only: pt2[OF pt])
108.775 +apply(rule pt_fresh_fresh[OF pt at])
108.776 +apply(simp add: fresh_def at_supp[OF at])
108.777 +apply(blast)
108.778 +apply(simp add: fresh_def at_supp[OF at])
108.779 +apply(blast)
108.780 +apply(simp add: pt2[OF pt])
108.781 +done
108.782 +
108.783 section {* Infrastructure lemmas for strong rule inductions *}
108.784 (*==========================================================*)
108.785
108.786 -
108.787 text {*
108.788 For every set of atoms, there is another set of atoms
108.789 avoiding a finitely supported c and there is a permutation
108.790 - which make 'translates' between both sets.
108.791 + which 'translates' between both sets.
108.792 *}
108.793 lemma at_set_avoiding_aux:
108.794 fixes Xs::"'a set"
108.795 @@ -3365,7 +3408,6 @@
108.796
108.797 syntax ABS :: "type \<Rightarrow> type \<Rightarrow> type" ("\<guillemotleft>_\<guillemotright>_" [1000,1000] 1000)
108.798
108.799 -
108.800 section {* lemmas for deciding permutation equations *}
108.801 (*===================================================*)
108.802
108.803 @@ -3526,8 +3568,8 @@
108.804 shows "pi\<bullet>(x div y) = (pi\<bullet>x) div (pi\<bullet>y)"
108.805 by (simp add:perm_int_def)
108.806
108.807 -(*******************************************************************)
108.808 -(* Setup of the theorem attributes eqvt, eqvt_force, fresh and bij *)
108.809 +(*******************************************************)
108.810 +(* Setup of the theorem attributes eqvt and eqvt_force *)
108.811 use "nominal_thmdecls.ML"
108.812 setup "NominalThmDecls.setup"
108.813
109.1 --- a/src/HOL/Nominal/nominal_atoms.ML Mon May 11 09:39:53 2009 +0200
109.2 +++ b/src/HOL/Nominal/nominal_atoms.ML Mon May 11 17:20:52 2009 +0200
109.3 @@ -732,18 +732,18 @@
109.4
109.5 in
109.6 thy26
109.7 - |> discrete_pt_inst "nat" @{thm "perm_nat_def"}
109.8 - |> discrete_fs_inst "nat" @{thm "perm_nat_def"}
109.9 - |> discrete_cp_inst "nat" @{thm "perm_nat_def"}
109.10 - |> discrete_pt_inst "bool" @{thm "perm_bool"}
109.11 - |> discrete_fs_inst "bool" @{thm "perm_bool"}
109.12 - |> discrete_cp_inst "bool" @{thm "perm_bool"}
109.13 - |> discrete_pt_inst @{type_name "Int.int"} @{thm "perm_int_def"}
109.14 - |> discrete_fs_inst @{type_name "Int.int"} @{thm "perm_int_def"}
109.15 - |> discrete_cp_inst @{type_name "Int.int"} @{thm "perm_int_def"}
109.16 - |> discrete_pt_inst "List.char" @{thm "perm_char_def"}
109.17 - |> discrete_fs_inst "List.char" @{thm "perm_char_def"}
109.18 - |> discrete_cp_inst "List.char" @{thm "perm_char_def"}
109.19 + |> discrete_pt_inst @{type_name nat} @{thm "perm_nat_def"}
109.20 + |> discrete_fs_inst @{type_name nat} @{thm "perm_nat_def"}
109.21 + |> discrete_cp_inst @{type_name nat} @{thm "perm_nat_def"}
109.22 + |> discrete_pt_inst @{type_name bool} @{thm "perm_bool"}
109.23 + |> discrete_fs_inst @{type_name bool} @{thm "perm_bool"}
109.24 + |> discrete_cp_inst @{type_name bool} @{thm "perm_bool"}
109.25 + |> discrete_pt_inst @{type_name int} @{thm "perm_int_def"}
109.26 + |> discrete_fs_inst @{type_name int} @{thm "perm_int_def"}
109.27 + |> discrete_cp_inst @{type_name int} @{thm "perm_int_def"}
109.28 + |> discrete_pt_inst @{type_name char} @{thm "perm_char_def"}
109.29 + |> discrete_fs_inst @{type_name char} @{thm "perm_char_def"}
109.30 + |> discrete_cp_inst @{type_name char} @{thm "perm_char_def"}
109.31 end;
109.32
109.33
110.1 --- a/src/HOL/Nominal/nominal_thmdecls.ML Mon May 11 09:39:53 2009 +0200
110.2 +++ b/src/HOL/Nominal/nominal_thmdecls.ML Mon May 11 17:20:52 2009 +0200
110.3 @@ -1,12 +1,12 @@
110.4 (* Authors: Julien Narboux and Christian Urban
110.5
110.6 This file introduces the infrastructure for the lemma
110.7 - declaration "eqvts" "bijs" and "freshs".
110.8 + collection "eqvts".
110.9
110.10 - By attaching [eqvt] [bij] or [fresh] to a lemma, the lemma gets stored
110.11 - in a data-slot in the context. Possible modifiers
110.12 - are [attribute add] and [attribute del] for adding and deleting,
110.13 - respectively the lemma from the data-slot.
110.14 + By attaching [eqvt] or [eqvt_force] to a lemma, it will get
110.15 + stored in a data-slot in the context. Possible modifiers
110.16 + are [... add] and [... del] for adding and deleting,
110.17 + respectively, the lemma from the data-slot.
110.18 *)
110.19
110.20 signature NOMINAL_THMDECLS =
110.21 @@ -17,9 +17,6 @@
110.22 val eqvt_force_del: attribute
110.23 val setup: theory -> theory
110.24 val get_eqvt_thms: Proof.context -> thm list
110.25 - val get_fresh_thms: Proof.context -> thm list
110.26 - val get_bij_thms: Proof.context -> thm list
110.27 -
110.28
110.29 val NOMINAL_EQVT_DEBUG : bool ref
110.30 end;
110.31 @@ -29,13 +26,11 @@
110.32
110.33 structure Data = GenericDataFun
110.34 (
110.35 - type T = {eqvts:thm list, freshs:thm list, bijs:thm list};
110.36 - val empty = ({eqvts=[], freshs=[], bijs=[]}:T);
110.37 - val extend = I;
110.38 - fun merge _ (r1:T,r2:T) = {eqvts = Thm.merge_thms (#eqvts r1, #eqvts r2),
110.39 - freshs = Thm.merge_thms (#freshs r1, #freshs r2),
110.40 - bijs = Thm.merge_thms (#bijs r1, #bijs r2)}
110.41 -);
110.42 + type T = thm list
110.43 + val empty = []:T
110.44 + val extend = I
110.45 + fun merge _ (r1:T, r2:T) = Thm.merge_thms (r1, r2)
110.46 +)
110.47
110.48 (* Exception for when a theorem does not conform with form of an equivariance lemma. *)
110.49 (* There are two forms: one is an implication (for relations) and the other is an *)
110.50 @@ -46,72 +41,68 @@
110.51 (* the implicational case it is also checked that the variables and permutation fit *)
110.52 (* together, i.e. are of the right "pt_class", so that a stronger version of the *)
110.53 (* equality-lemma can be derived. *)
110.54 -exception EQVT_FORM of string;
110.55 +exception EQVT_FORM of string
110.56
110.57 -val get_eqvt_thms = Context.Proof #> Data.get #> #eqvts;
110.58 -val get_fresh_thms = Context.Proof #> Data.get #> #freshs;
110.59 -val get_bij_thms = Context.Proof #> Data.get #> #bijs;
110.60 +val NOMINAL_EQVT_DEBUG = ref false
110.61
110.62 -(* FIXME: should be a function in a library *)
110.63 -fun mk_permT T = HOLogic.listT (HOLogic.mk_prodT (T, T));
110.64 +fun tactic (msg, tac) =
110.65 + if !NOMINAL_EQVT_DEBUG
110.66 + then tac THEN' (K (print_tac ("after " ^ msg)))
110.67 + else tac
110.68
110.69 -val NOMINAL_EQVT_DEBUG = ref false;
110.70 -
110.71 -fun tactic (msg,tac) =
110.72 - if !NOMINAL_EQVT_DEBUG
110.73 - then tac THEN print_tac ("after "^msg)
110.74 - else tac
110.75 -
110.76 -fun tactic_eqvt ctx orig_thm pi pi' =
110.77 - let
110.78 - val mypi = Thm.cterm_of ctx pi
110.79 - val T = fastype_of pi'
110.80 - val mypifree = Thm.cterm_of ctx (Const ("List.rev", T --> T) $ pi')
110.81 - val perm_pi_simp = PureThy.get_thms ctx "perm_pi_simp"
110.82 - in
110.83 - EVERY [tactic ("iffI applied",rtac iffI 1),
110.84 - tactic ("remove pi with perm_boolE", (dtac @{thm perm_boolE} 1)),
110.85 - tactic ("solve with orig_thm", (etac orig_thm 1)),
110.86 - tactic ("applies orig_thm instantiated with rev pi",
110.87 - dtac (Drule.cterm_instantiate [(mypi,mypifree)] orig_thm) 1),
110.88 - tactic ("getting rid of the pi on the right",
110.89 - (rtac @{thm perm_boolI} 1)),
110.90 - tactic ("getting rid of all remaining perms",
110.91 - full_simp_tac (HOL_basic_ss addsimps perm_pi_simp) 1)]
110.92 - end;
110.93 +fun prove_eqvt_tac ctxt orig_thm pi pi' =
110.94 +let
110.95 + val mypi = Thm.cterm_of ctxt pi
110.96 + val T = fastype_of pi'
110.97 + val mypifree = Thm.cterm_of ctxt (Const (@{const_name "rev"}, T --> T) $ pi')
110.98 + val perm_pi_simp = PureThy.get_thms ctxt "perm_pi_simp"
110.99 +in
110.100 + EVERY1 [tactic ("iffI applied", rtac @{thm iffI}),
110.101 + tactic ("remove pi with perm_boolE", dtac @{thm perm_boolE}),
110.102 + tactic ("solve with orig_thm", etac orig_thm),
110.103 + tactic ("applies orig_thm instantiated with rev pi",
110.104 + dtac (Drule.cterm_instantiate [(mypi,mypifree)] orig_thm)),
110.105 + tactic ("getting rid of the pi on the right", rtac @{thm perm_boolI}),
110.106 + tactic ("getting rid of all remaining perms",
110.107 + full_simp_tac (HOL_basic_ss addsimps perm_pi_simp))]
110.108 +end;
110.109
110.110 fun get_derived_thm ctxt hyp concl orig_thm pi typi =
110.111 let
110.112 val thy = ProofContext.theory_of ctxt;
110.113 val pi' = Var (pi, typi);
110.114 - val lhs = Const ("Nominal.perm", typi --> HOLogic.boolT --> HOLogic.boolT) $ pi' $ hyp;
110.115 + val lhs = Const (@{const_name "perm"}, typi --> HOLogic.boolT --> HOLogic.boolT) $ pi' $ hyp;
110.116 val ([goal_term, pi''], ctxt') = Variable.import_terms false
110.117 [HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, concl)), pi'] ctxt
110.118 val _ = Display.print_cterm (cterm_of thy goal_term)
110.119 in
110.120 Goal.prove ctxt' [] [] goal_term
110.121 - (fn _ => tactic_eqvt thy orig_thm pi' pi'') |>
110.122 + (fn _ => prove_eqvt_tac thy orig_thm pi' pi'') |>
110.123 singleton (ProofContext.export ctxt' ctxt)
110.124 end
110.125
110.126 -(* replaces every variable x in t with pi o x *)
110.127 -fun apply_pi trm (pi,typi) =
110.128 - let
110.129 - fun only_vars t =
110.130 - (case t of
110.131 - Var (n,ty) => (Const ("Nominal.perm",typi --> ty --> ty) $ (Var (pi,typi)) $ (Var (n,ty)))
110.132 - | _ => t)
110.133 +(* replaces in t every variable, say x, with pi o x *)
110.134 +fun apply_pi trm (pi, typi) =
110.135 +let
110.136 + fun replace n ty =
110.137 + let
110.138 + val c = Const (@{const_name "perm"}, typi --> ty --> ty)
110.139 + val v1 = Var (pi, typi)
110.140 + val v2 = Var (n, ty)
110.141 in
110.142 - map_aterms only_vars trm
110.143 - end;
110.144 + c $ v1 $ v2
110.145 + end
110.146 +in
110.147 + map_aterms (fn Var (n, ty) => replace n ty | t => t) trm
110.148 +end
110.149
110.150 (* returns *the* pi which is in front of all variables, provided there *)
110.151 (* exists such a pi; otherwise raises EQVT_FORM *)
110.152 fun get_pi t thy =
110.153 let fun get_pi_aux s =
110.154 (case s of
110.155 - (Const ("Nominal.perm",typrm) $
110.156 - (Var (pi,typi as Type("List.list",[Type ("*",[Type (tyatm,[]),_])]))) $
110.157 + (Const (@{const_name "perm"} ,typrm) $
110.158 + (Var (pi,typi as Type(@{type_name "list"}, [Type ("*", [Type (tyatm,[]),_])]))) $
110.159 (Var (n,ty))) =>
110.160 let
110.161 (* FIXME: this should be an operation the library *)
110.162 @@ -130,7 +121,7 @@
110.163 (* to ensure that all pi's must have been the same, i.e. distinct returns *)
110.164 (* a singleton-list *)
110.165 (case (distinct (op =) (get_pi_aux t)) of
110.166 - [(pi,typi)] => (pi,typi)
110.167 + [(pi,typi)] => (pi, typi)
110.168 | _ => raise EQVT_FORM "All permutation should be the same")
110.169 end;
110.170
110.171 @@ -155,8 +146,8 @@
110.172 else raise EQVT_FORM "Type Implication"
110.173 end
110.174 (* case: eqvt-lemma is of the equational form *)
110.175 - | (Const ("Trueprop", _) $ (Const ("op =", _) $
110.176 - (Const ("Nominal.perm",typrm) $ Var (pi,typi) $ lhs) $ rhs)) =>
110.177 + | (Const (@{const_name "Trueprop"}, _) $ (Const (@{const_name "op ="}, _) $
110.178 + (Const (@{const_name "perm"},typrm) $ Var (pi,typi) $ lhs) $ rhs)) =>
110.179 (if (apply_pi lhs (pi,typi)) = rhs
110.180 then [orig_thm]
110.181 else raise EQVT_FORM "Type Equality")
110.182 @@ -165,38 +156,24 @@
110.183 fold (fn thm => Data.map (flag thm)) thms_to_be_added context
110.184 end
110.185 handle EQVT_FORM s =>
110.186 - error (Display.string_of_thm orig_thm ^ " does not comply with the form of an equivariance lemma ("^s^").")
110.187 + error (Display.string_of_thm orig_thm ^
110.188 + " does not comply with the form of an equivariance lemma (" ^ s ^").")
110.189
110.190 -(* in cases of bij- and freshness, we just add the lemmas to the *)
110.191 -(* data-slot *)
110.192
110.193 -fun eqvt_map f (r:Data.T) = {eqvts = f (#eqvts r), freshs = #freshs r, bijs = #bijs r};
110.194 -fun fresh_map f (r:Data.T) = {eqvts = #eqvts r, freshs = f (#freshs r), bijs = #bijs r};
110.195 -fun bij_map f (r:Data.T) = {eqvts = #eqvts r, freshs = #freshs r, bijs = f (#bijs r)};
110.196 +val eqvt_add = Thm.declaration_attribute (eqvt_add_del_aux (Thm.add_thm));
110.197 +val eqvt_del = Thm.declaration_attribute (eqvt_add_del_aux (Thm.del_thm));
110.198
110.199 -val eqvt_add = Thm.declaration_attribute (eqvt_add_del_aux (eqvt_map o Thm.add_thm));
110.200 -val eqvt_del = Thm.declaration_attribute (eqvt_add_del_aux (eqvt_map o Thm.del_thm));
110.201 +val eqvt_force_add = Thm.declaration_attribute (Data.map o Thm.add_thm);
110.202 +val eqvt_force_del = Thm.declaration_attribute (Data.map o Thm.del_thm);
110.203
110.204 -val eqvt_force_add = Thm.declaration_attribute (Data.map o eqvt_map o Thm.add_thm);
110.205 -val eqvt_force_del = Thm.declaration_attribute (Data.map o eqvt_map o Thm.del_thm);
110.206 -val bij_add = Thm.declaration_attribute (Data.map o bij_map o Thm.add_thm);
110.207 -val bij_del = Thm.declaration_attribute (Data.map o bij_map o Thm.del_thm);
110.208 -val fresh_add = Thm.declaration_attribute (Data.map o fresh_map o Thm.add_thm);
110.209 -val fresh_del = Thm.declaration_attribute (Data.map o fresh_map o Thm.del_thm);
110.210 -
110.211 -
110.212 +val get_eqvt_thms = Context.Proof #> Data.get;
110.213
110.214 val setup =
110.215 - Attrib.setup @{binding eqvt} (Attrib.add_del eqvt_add eqvt_del)
110.216 - "equivariance theorem declaration" #>
110.217 - Attrib.setup @{binding eqvt_force} (Attrib.add_del eqvt_force_add eqvt_force_del)
110.218 - "equivariance theorem declaration (without checking the form of the lemma)" #>
110.219 - Attrib.setup @{binding fresh} (Attrib.add_del fresh_add fresh_del)
110.220 - "freshness theorem declaration" #>
110.221 - Attrib.setup @{binding "bij"} (Attrib.add_del bij_add bij_del)
110.222 - "bijection theorem declaration" #>
110.223 - PureThy.add_thms_dynamic (Binding.name "eqvts", #eqvts o Data.get) #>
110.224 - PureThy.add_thms_dynamic (Binding.name "freshs", #freshs o Data.get) #>
110.225 - PureThy.add_thms_dynamic (Binding.name "bijs", #bijs o Data.get);
110.226 + Attrib.setup @{binding eqvt} (Attrib.add_del eqvt_add eqvt_del)
110.227 + "equivariance theorem declaration"
110.228 + #> Attrib.setup @{binding eqvt_force} (Attrib.add_del eqvt_force_add eqvt_force_del)
110.229 + "equivariance theorem declaration (without checking the form of the lemma)"
110.230 + #> PureThy.add_thms_dynamic (Binding.name "eqvts", Data.get)
110.231 +
110.232
110.233 end;
111.1 --- a/src/HOL/NthRoot.thy Mon May 11 09:39:53 2009 +0200
111.2 +++ b/src/HOL/NthRoot.thy Mon May 11 17:20:52 2009 +0200
111.3 @@ -565,16 +565,6 @@
111.4 lemma le_real_sqrt_sumsq [simp]: "x \<le> sqrt (x * x + y * y)"
111.5 by (simp add: power2_eq_square [symmetric])
111.6
111.7 -lemma power2_sum:
111.8 - fixes x y :: "'a::{number_ring,recpower}"
111.9 - shows "(x + y)\<twosuperior> = x\<twosuperior> + y\<twosuperior> + 2 * x * y"
111.10 -by (simp add: ring_distribs power2_eq_square)
111.11 -
111.12 -lemma power2_diff:
111.13 - fixes x y :: "'a::{number_ring,recpower}"
111.14 - shows "(x - y)\<twosuperior> = x\<twosuperior> + y\<twosuperior> - 2 * x * y"
111.15 -by (simp add: ring_distribs power2_eq_square)
111.16 -
111.17 lemma real_sqrt_sum_squares_triangle_ineq:
111.18 "sqrt ((a + c)\<twosuperior> + (b + d)\<twosuperior>) \<le> sqrt (a\<twosuperior> + b\<twosuperior>) + sqrt (c\<twosuperior> + d\<twosuperior>)"
111.19 apply (rule power2_le_imp_le, simp)
112.1 --- a/src/HOL/Option.thy Mon May 11 09:39:53 2009 +0200
112.2 +++ b/src/HOL/Option.thy Mon May 11 17:20:52 2009 +0200
112.3 @@ -20,6 +20,9 @@
112.4 only when applied to assumptions, in practice it seems better to give
112.5 them the uniform iff attribute. *}
112.6
112.7 +lemma inj_Some [simp]: "inj_on Some A"
112.8 +by (rule inj_onI) simp
112.9 +
112.10 lemma option_caseE:
112.11 assumes c: "(case x of None => P | Some y => Q y)"
112.12 obtains
112.13 @@ -27,14 +30,15 @@
112.14 | (Some) y where "x = Some y" and "Q y"
112.15 using c by (cases x) simp_all
112.16
112.17 -lemma insert_None_conv_UNIV: "insert None (range Some) = UNIV"
112.18 - by (rule set_ext, case_tac x) auto
112.19 +lemma UNIV_option_conv: "UNIV = insert None (range Some)"
112.20 +by(auto intro: classical)
112.21 +
112.22 +lemma finite_option_UNIV[simp]:
112.23 + "finite (UNIV :: 'a option set) = finite (UNIV :: 'a set)"
112.24 +by(auto simp add: UNIV_option_conv elim: finite_imageD intro: inj_Some)
112.25
112.26 instance option :: (finite) finite proof
112.27 -qed (simp add: insert_None_conv_UNIV [symmetric])
112.28 -
112.29 -lemma inj_Some [simp]: "inj_on Some A"
112.30 - by (rule inj_onI) simp
112.31 +qed (simp add: UNIV_option_conv)
112.32
112.33
112.34 subsubsection {* Operations *}
113.1 --- a/src/HOL/Orderings.thy Mon May 11 09:39:53 2009 +0200
113.2 +++ b/src/HOL/Orderings.thy Mon May 11 17:20:52 2009 +0200
113.3 @@ -5,7 +5,7 @@
113.4 header {* Abstract orderings *}
113.5
113.6 theory Orderings
113.7 -imports Code_Setup
113.8 +imports HOL
113.9 uses "~~/src/Provers/order.ML"
113.10 begin
113.11
114.1 --- a/src/HOL/Parity.thy Mon May 11 09:39:53 2009 +0200
114.2 +++ b/src/HOL/Parity.thy Mon May 11 17:20:52 2009 +0200
114.3 @@ -178,7 +178,7 @@
114.4 subsection {* Parity and powers *}
114.5
114.6 lemma minus_one_even_odd_power:
114.7 - "(even x --> (- 1::'a::{comm_ring_1,recpower})^x = 1) &
114.8 + "(even x --> (- 1::'a::{comm_ring_1})^x = 1) &
114.9 (odd x --> (- 1::'a)^x = - 1)"
114.10 apply (induct x)
114.11 apply (rule conjI)
114.12 @@ -188,37 +188,37 @@
114.13 done
114.14
114.15 lemma minus_one_even_power [simp]:
114.16 - "even x ==> (- 1::'a::{comm_ring_1,recpower})^x = 1"
114.17 + "even x ==> (- 1::'a::{comm_ring_1})^x = 1"
114.18 using minus_one_even_odd_power by blast
114.19
114.20 lemma minus_one_odd_power [simp]:
114.21 - "odd x ==> (- 1::'a::{comm_ring_1,recpower})^x = - 1"
114.22 + "odd x ==> (- 1::'a::{comm_ring_1})^x = - 1"
114.23 using minus_one_even_odd_power by blast
114.24
114.25 lemma neg_one_even_odd_power:
114.26 - "(even x --> (-1::'a::{number_ring,recpower})^x = 1) &
114.27 + "(even x --> (-1::'a::{number_ring})^x = 1) &
114.28 (odd x --> (-1::'a)^x = -1)"
114.29 apply (induct x)
114.30 apply (simp, simp add: power_Suc)
114.31 done
114.32
114.33 lemma neg_one_even_power [simp]:
114.34 - "even x ==> (-1::'a::{number_ring,recpower})^x = 1"
114.35 + "even x ==> (-1::'a::{number_ring})^x = 1"
114.36 using neg_one_even_odd_power by blast
114.37
114.38 lemma neg_one_odd_power [simp]:
114.39 - "odd x ==> (-1::'a::{number_ring,recpower})^x = -1"
114.40 + "odd x ==> (-1::'a::{number_ring})^x = -1"
114.41 using neg_one_even_odd_power by blast
114.42
114.43 lemma neg_power_if:
114.44 - "(-x::'a::{comm_ring_1,recpower}) ^ n =
114.45 + "(-x::'a::{comm_ring_1}) ^ n =
114.46 (if even n then (x ^ n) else -(x ^ n))"
114.47 apply (induct n)
114.48 apply (simp_all split: split_if_asm add: power_Suc)
114.49 done
114.50
114.51 lemma zero_le_even_power: "even n ==>
114.52 - 0 <= (x::'a::{recpower,ordered_ring_strict}) ^ n"
114.53 + 0 <= (x::'a::{ordered_ring_strict,monoid_mult}) ^ n"
114.54 apply (simp add: even_nat_equiv_def2)
114.55 apply (erule exE)
114.56 apply (erule ssubst)
114.57 @@ -227,12 +227,12 @@
114.58 done
114.59
114.60 lemma zero_le_odd_power: "odd n ==>
114.61 - (0 <= (x::'a::{recpower,ordered_idom}) ^ n) = (0 <= x)"
114.62 + (0 <= (x::'a::{ordered_idom}) ^ n) = (0 <= x)"
114.63 apply (auto simp: odd_nat_equiv_def2 power_Suc power_add zero_le_mult_iff)
114.64 apply (metis field_power_not_zero no_zero_divirors_neq0 order_antisym_conv zero_le_square)
114.65 done
114.66
114.67 -lemma zero_le_power_eq[presburger]: "(0 <= (x::'a::{recpower,ordered_idom}) ^ n) =
114.68 +lemma zero_le_power_eq[presburger]: "(0 <= (x::'a::{ordered_idom}) ^ n) =
114.69 (even n | (odd n & 0 <= x))"
114.70 apply auto
114.71 apply (subst zero_le_odd_power [symmetric])
114.72 @@ -240,19 +240,19 @@
114.73 apply (erule zero_le_even_power)
114.74 done
114.75
114.76 -lemma zero_less_power_eq[presburger]: "(0 < (x::'a::{recpower,ordered_idom}) ^ n) =
114.77 +lemma zero_less_power_eq[presburger]: "(0 < (x::'a::{ordered_idom}) ^ n) =
114.78 (n = 0 | (even n & x ~= 0) | (odd n & 0 < x))"
114.79
114.80 unfolding order_less_le zero_le_power_eq by auto
114.81
114.82 -lemma power_less_zero_eq[presburger]: "((x::'a::{recpower,ordered_idom}) ^ n < 0) =
114.83 +lemma power_less_zero_eq[presburger]: "((x::'a::{ordered_idom}) ^ n < 0) =
114.84 (odd n & x < 0)"
114.85 apply (subst linorder_not_le [symmetric])+
114.86 apply (subst zero_le_power_eq)
114.87 apply auto
114.88 done
114.89
114.90 -lemma power_le_zero_eq[presburger]: "((x::'a::{recpower,ordered_idom}) ^ n <= 0) =
114.91 +lemma power_le_zero_eq[presburger]: "((x::'a::{ordered_idom}) ^ n <= 0) =
114.92 (n ~= 0 & ((odd n & x <= 0) | (even n & x = 0)))"
114.93 apply (subst linorder_not_less [symmetric])+
114.94 apply (subst zero_less_power_eq)
114.95 @@ -260,7 +260,7 @@
114.96 done
114.97
114.98 lemma power_even_abs: "even n ==>
114.99 - (abs (x::'a::{recpower,ordered_idom}))^n = x^n"
114.100 + (abs (x::'a::{ordered_idom}))^n = x^n"
114.101 apply (subst power_abs [symmetric])
114.102 apply (simp add: zero_le_even_power)
114.103 done
114.104 @@ -269,18 +269,18 @@
114.105 by (induct n) auto
114.106
114.107 lemma power_minus_even [simp]: "even n ==>
114.108 - (- x)^n = (x^n::'a::{recpower,comm_ring_1})"
114.109 + (- x)^n = (x^n::'a::{comm_ring_1})"
114.110 apply (subst power_minus)
114.111 apply simp
114.112 done
114.113
114.114 lemma power_minus_odd [simp]: "odd n ==>
114.115 - (- x)^n = - (x^n::'a::{recpower,comm_ring_1})"
114.116 + (- x)^n = - (x^n::'a::{comm_ring_1})"
114.117 apply (subst power_minus)
114.118 apply simp
114.119 done
114.120
114.121 -lemma power_mono_even: fixes x y :: "'a :: {recpower, ordered_idom}"
114.122 +lemma power_mono_even: fixes x y :: "'a :: {ordered_idom}"
114.123 assumes "even n" and "\<bar>x\<bar> \<le> \<bar>y\<bar>"
114.124 shows "x^n \<le> y^n"
114.125 proof -
114.126 @@ -292,7 +292,7 @@
114.127
114.128 lemma odd_pos: "odd (n::nat) \<Longrightarrow> 0 < n" by presburger
114.129
114.130 -lemma power_mono_odd: fixes x y :: "'a :: {recpower, ordered_idom}"
114.131 +lemma power_mono_odd: fixes x y :: "'a :: {ordered_idom}"
114.132 assumes "odd n" and "x \<le> y"
114.133 shows "x^n \<le> y^n"
114.134 proof (cases "y < 0")
114.135 @@ -406,11 +406,11 @@
114.136 subsection {* An Equivalence for @{term [source] "0 \<le> a^n"} *}
114.137
114.138 lemma even_power_le_0_imp_0:
114.139 - "a ^ (2*k) \<le> (0::'a::{ordered_idom,recpower}) ==> a=0"
114.140 + "a ^ (2*k) \<le> (0::'a::{ordered_idom}) ==> a=0"
114.141 by (induct k) (auto simp add: zero_le_mult_iff mult_le_0_iff power_Suc)
114.142
114.143 lemma zero_le_power_iff[presburger]:
114.144 - "(0 \<le> a^n) = (0 \<le> (a::'a::{ordered_idom,recpower}) | even n)"
114.145 + "(0 \<le> a^n) = (0 \<le> (a::'a::{ordered_idom}) | even n)"
114.146 proof cases
114.147 assume even: "even n"
114.148 then obtain k where "n = 2*k"
115.1 --- a/src/HOL/Power.thy Mon May 11 09:39:53 2009 +0200
115.2 +++ b/src/HOL/Power.thy Mon May 11 17:20:52 2009 +0200
115.3 @@ -1,95 +1,179 @@
115.4 (* Title: HOL/Power.thy
115.5 - ID: $Id$
115.6 Author: Lawrence C Paulson, Cambridge University Computer Laboratory
115.7 Copyright 1997 University of Cambridge
115.8 -
115.9 *)
115.10
115.11 -header{*Exponentiation*}
115.12 +header {* Exponentiation *}
115.13
115.14 theory Power
115.15 imports Nat
115.16 begin
115.17
115.18 -class power =
115.19 - fixes power :: "'a \<Rightarrow> nat \<Rightarrow> 'a" (infixr "^" 80)
115.20 +subsection {* Powers for Arbitrary Monoids *}
115.21
115.22 -subsection{*Powers for Arbitrary Monoids*}
115.23 +class power = one + times
115.24 +begin
115.25
115.26 -class recpower = monoid_mult + power +
115.27 - assumes power_0 [simp]: "a ^ 0 = 1"
115.28 - assumes power_Suc [simp]: "a ^ Suc n = a * (a ^ n)"
115.29 +primrec power :: "'a \<Rightarrow> nat \<Rightarrow> 'a" (infixr "^" 80) where
115.30 + power_0: "a ^ 0 = 1"
115.31 + | power_Suc: "a ^ Suc n = a * a ^ n"
115.32
115.33 -lemma power_0_Suc [simp]: "(0::'a::{recpower,semiring_0}) ^ (Suc n) = 0"
115.34 +notation (latex output)
115.35 + power ("(_\<^bsup>_\<^esup>)" [1000] 1000)
115.36 +
115.37 +notation (HTML output)
115.38 + power ("(_\<^bsup>_\<^esup>)" [1000] 1000)
115.39 +
115.40 +end
115.41 +
115.42 +context monoid_mult
115.43 +begin
115.44 +
115.45 +subclass power ..
115.46 +
115.47 +lemma power_one [simp]:
115.48 + "1 ^ n = 1"
115.49 + by (induct n) simp_all
115.50 +
115.51 +lemma power_one_right [simp]:
115.52 + "a ^ 1 = a"
115.53 by simp
115.54
115.55 -text{*It looks plausible as a simprule, but its effect can be strange.*}
115.56 -lemma power_0_left: "0^n = (if n=0 then 1 else (0::'a::{recpower,semiring_0}))"
115.57 - by (induct n) simp_all
115.58 -
115.59 -lemma power_one [simp]: "1^n = (1::'a::recpower)"
115.60 - by (induct n) simp_all
115.61 -
115.62 -lemma power_one_right [simp]: "(a::'a::recpower) ^ 1 = a"
115.63 - unfolding One_nat_def by simp
115.64 -
115.65 -lemma power_commutes: "(a::'a::recpower) ^ n * a = a * a ^ n"
115.66 +lemma power_commutes:
115.67 + "a ^ n * a = a * a ^ n"
115.68 by (induct n) (simp_all add: mult_assoc)
115.69
115.70 -lemma power_Suc2: "(a::'a::recpower) ^ Suc n = a ^ n * a"
115.71 +lemma power_Suc2:
115.72 + "a ^ Suc n = a ^ n * a"
115.73 by (simp add: power_commutes)
115.74
115.75 -lemma power_add: "(a::'a::recpower) ^ (m+n) = (a^m) * (a^n)"
115.76 - by (induct m) (simp_all add: mult_ac)
115.77 +lemma power_add:
115.78 + "a ^ (m + n) = a ^ m * a ^ n"
115.79 + by (induct m) (simp_all add: algebra_simps)
115.80
115.81 -lemma power_mult: "(a::'a::recpower) ^ (m*n) = (a^m) ^ n"
115.82 +lemma power_mult:
115.83 + "a ^ (m * n) = (a ^ m) ^ n"
115.84 by (induct n) (simp_all add: power_add)
115.85
115.86 -lemma power_mult_distrib: "((a::'a::{recpower,comm_monoid_mult}) * b) ^ n = (a^n) * (b^n)"
115.87 +end
115.88 +
115.89 +context comm_monoid_mult
115.90 +begin
115.91 +
115.92 +lemma power_mult_distrib:
115.93 + "(a * b) ^ n = (a ^ n) * (b ^ n)"
115.94 by (induct n) (simp_all add: mult_ac)
115.95
115.96 -lemma zero_less_power[simp]:
115.97 - "0 < (a::'a::{ordered_semidom,recpower}) ==> 0 < a^n"
115.98 -by (induct n) (simp_all add: mult_pos_pos)
115.99 +end
115.100
115.101 -lemma zero_le_power[simp]:
115.102 - "0 \<le> (a::'a::{ordered_semidom,recpower}) ==> 0 \<le> a^n"
115.103 -by (induct n) (simp_all add: mult_nonneg_nonneg)
115.104 +context semiring_1
115.105 +begin
115.106 +
115.107 +lemma of_nat_power:
115.108 + "of_nat (m ^ n) = of_nat m ^ n"
115.109 + by (induct n) (simp_all add: of_nat_mult)
115.110 +
115.111 +end
115.112 +
115.113 +context comm_semiring_1
115.114 +begin
115.115 +
115.116 +text {* The divides relation *}
115.117 +
115.118 +lemma le_imp_power_dvd:
115.119 + assumes "m \<le> n" shows "a ^ m dvd a ^ n"
115.120 +proof
115.121 + have "a ^ n = a ^ (m + (n - m))"
115.122 + using `m \<le> n` by simp
115.123 + also have "\<dots> = a ^ m * a ^ (n - m)"
115.124 + by (rule power_add)
115.125 + finally show "a ^ n = a ^ m * a ^ (n - m)" .
115.126 +qed
115.127 +
115.128 +lemma power_le_dvd:
115.129 + "a ^ n dvd b \<Longrightarrow> m \<le> n \<Longrightarrow> a ^ m dvd b"
115.130 + by (rule dvd_trans [OF le_imp_power_dvd])
115.131 +
115.132 +lemma dvd_power_same:
115.133 + "x dvd y \<Longrightarrow> x ^ n dvd y ^ n"
115.134 + by (induct n) (auto simp add: mult_dvd_mono)
115.135 +
115.136 +lemma dvd_power_le:
115.137 + "x dvd y \<Longrightarrow> m \<ge> n \<Longrightarrow> x ^ n dvd y ^ m"
115.138 + by (rule power_le_dvd [OF dvd_power_same])
115.139 +
115.140 +lemma dvd_power [simp]:
115.141 + assumes "n > (0::nat) \<or> x = 1"
115.142 + shows "x dvd (x ^ n)"
115.143 +using assms proof
115.144 + assume "0 < n"
115.145 + then have "x ^ n = x ^ Suc (n - 1)" by simp
115.146 + then show "x dvd (x ^ n)" by simp
115.147 +next
115.148 + assume "x = 1"
115.149 + then show "x dvd (x ^ n)" by simp
115.150 +qed
115.151 +
115.152 +end
115.153 +
115.154 +context ring_1
115.155 +begin
115.156 +
115.157 +lemma power_minus:
115.158 + "(- a) ^ n = (- 1) ^ n * a ^ n"
115.159 +proof (induct n)
115.160 + case 0 show ?case by simp
115.161 +next
115.162 + case (Suc n) then show ?case
115.163 + by (simp del: power_Suc add: power_Suc2 mult_assoc)
115.164 +qed
115.165 +
115.166 +end
115.167 +
115.168 +context ordered_semidom
115.169 +begin
115.170 +
115.171 +lemma zero_less_power [simp]:
115.172 + "0 < a \<Longrightarrow> 0 < a ^ n"
115.173 + by (induct n) (simp_all add: mult_pos_pos)
115.174 +
115.175 +lemma zero_le_power [simp]:
115.176 + "0 \<le> a \<Longrightarrow> 0 \<le> a ^ n"
115.177 + by (induct n) (simp_all add: mult_nonneg_nonneg)
115.178
115.179 lemma one_le_power[simp]:
115.180 - "1 \<le> (a::'a::{ordered_semidom,recpower}) ==> 1 \<le> a^n"
115.181 -apply (induct "n")
115.182 -apply simp_all
115.183 -apply (rule order_trans [OF _ mult_mono [of 1 _ 1]])
115.184 -apply (simp_all add: order_trans [OF zero_le_one])
115.185 -done
115.186 -
115.187 -lemma gt1_imp_ge0: "1 < a ==> 0 \<le> (a::'a::ordered_semidom)"
115.188 - by (simp add: order_trans [OF zero_le_one order_less_imp_le])
115.189 + "1 \<le> a \<Longrightarrow> 1 \<le> a ^ n"
115.190 + apply (induct n)
115.191 + apply simp_all
115.192 + apply (rule order_trans [OF _ mult_mono [of 1 _ 1]])
115.193 + apply (simp_all add: order_trans [OF zero_le_one])
115.194 + done
115.195
115.196 lemma power_gt1_lemma:
115.197 - assumes gt1: "1 < (a::'a::{ordered_semidom,recpower})"
115.198 - shows "1 < a * a^n"
115.199 + assumes gt1: "1 < a"
115.200 + shows "1 < a * a ^ n"
115.201 proof -
115.202 - have "1*1 < a*1" using gt1 by simp
115.203 - also have "\<dots> \<le> a * a^n" using gt1
115.204 - by (simp only: mult_mono gt1_imp_ge0 one_le_power order_less_imp_le
115.205 + from gt1 have "0 \<le> a"
115.206 + by (fact order_trans [OF zero_le_one less_imp_le])
115.207 + have "1 * 1 < a * 1" using gt1 by simp
115.208 + also have "\<dots> \<le> a * a ^ n" using gt1
115.209 + by (simp only: mult_mono `0 \<le> a` one_le_power order_less_imp_le
115.210 zero_le_one order_refl)
115.211 finally show ?thesis by simp
115.212 qed
115.213
115.214 -lemma one_less_power[simp]:
115.215 - "\<lbrakk>1 < (a::'a::{ordered_semidom,recpower}); 0 < n\<rbrakk> \<Longrightarrow> 1 < a ^ n"
115.216 -by (cases n, simp_all add: power_gt1_lemma)
115.217 +lemma power_gt1:
115.218 + "1 < a \<Longrightarrow> 1 < a ^ Suc n"
115.219 + by (simp add: power_gt1_lemma)
115.220
115.221 -lemma power_gt1:
115.222 - "1 < (a::'a::{ordered_semidom,recpower}) ==> 1 < a ^ (Suc n)"
115.223 -by (simp add: power_gt1_lemma)
115.224 +lemma one_less_power [simp]:
115.225 + "1 < a \<Longrightarrow> 0 < n \<Longrightarrow> 1 < a ^ n"
115.226 + by (cases n) (simp_all add: power_gt1_lemma)
115.227
115.228 lemma power_le_imp_le_exp:
115.229 - assumes gt1: "(1::'a::{recpower,ordered_semidom}) < a"
115.230 - shows "!!n. a^m \<le> a^n ==> m \<le> n"
115.231 -proof (induct m)
115.232 + assumes gt1: "1 < a"
115.233 + shows "a ^ m \<le> a ^ n \<Longrightarrow> m \<le> n"
115.234 +proof (induct m arbitrary: n)
115.235 case 0
115.236 show ?case by simp
115.237 next
115.238 @@ -97,212 +181,128 @@
115.239 show ?case
115.240 proof (cases n)
115.241 case 0
115.242 - from prems have "a * a^m \<le> 1" by simp
115.243 + with Suc.prems Suc.hyps have "a * a ^ m \<le> 1" by simp
115.244 with gt1 show ?thesis
115.245 by (force simp only: power_gt1_lemma
115.246 - linorder_not_less [symmetric])
115.247 + not_less [symmetric])
115.248 next
115.249 case (Suc n)
115.250 - from prems show ?thesis
115.251 + with Suc.prems Suc.hyps show ?thesis
115.252 by (force dest: mult_left_le_imp_le
115.253 - simp add: order_less_trans [OF zero_less_one gt1])
115.254 + simp add: less_trans [OF zero_less_one gt1])
115.255 qed
115.256 qed
115.257
115.258 text{*Surely we can strengthen this? It holds for @{text "0<a<1"} too.*}
115.259 lemma power_inject_exp [simp]:
115.260 - "1 < (a::'a::{ordered_semidom,recpower}) ==> (a^m = a^n) = (m=n)"
115.261 + "1 < a \<Longrightarrow> a ^ m = a ^ n \<longleftrightarrow> m = n"
115.262 by (force simp add: order_antisym power_le_imp_le_exp)
115.263
115.264 text{*Can relax the first premise to @{term "0<a"} in the case of the
115.265 natural numbers.*}
115.266 lemma power_less_imp_less_exp:
115.267 - "[| (1::'a::{recpower,ordered_semidom}) < a; a^m < a^n |] ==> m < n"
115.268 -by (simp add: order_less_le [of m n] order_less_le [of "a^m" "a^n"]
115.269 - power_le_imp_le_exp)
115.270 -
115.271 + "1 < a \<Longrightarrow> a ^ m < a ^ n \<Longrightarrow> m < n"
115.272 + by (simp add: order_less_le [of m n] less_le [of "a^m" "a^n"]
115.273 + power_le_imp_le_exp)
115.274
115.275 lemma power_mono:
115.276 - "[|a \<le> b; (0::'a::{recpower,ordered_semidom}) \<le> a|] ==> a^n \<le> b^n"
115.277 -apply (induct "n")
115.278 -apply simp_all
115.279 -apply (auto intro: mult_mono order_trans [of 0 a b])
115.280 -done
115.281 + "a \<le> b \<Longrightarrow> 0 \<le> a \<Longrightarrow> a ^ n \<le> b ^ n"
115.282 + by (induct n)
115.283 + (auto intro: mult_mono order_trans [of 0 a b])
115.284
115.285 lemma power_strict_mono [rule_format]:
115.286 - "[|a < b; (0::'a::{recpower,ordered_semidom}) \<le> a|]
115.287 - ==> 0 < n --> a^n < b^n"
115.288 -apply (induct "n")
115.289 -apply (auto simp add: mult_strict_mono order_le_less_trans [of 0 a b])
115.290 -done
115.291 -
115.292 -lemma power_eq_0_iff [simp]:
115.293 - "(a^n = 0) \<longleftrightarrow>
115.294 - (a = (0::'a::{mult_zero,zero_neq_one,no_zero_divisors,recpower}) & n\<noteq>0)"
115.295 -apply (induct "n")
115.296 -apply (auto simp add: no_zero_divisors)
115.297 -done
115.298 -
115.299 -
115.300 -lemma field_power_not_zero:
115.301 - "a \<noteq> (0::'a::{ring_1_no_zero_divisors,recpower}) ==> a^n \<noteq> 0"
115.302 -by force
115.303 -
115.304 -lemma nonzero_power_inverse:
115.305 - fixes a :: "'a::{division_ring,recpower}"
115.306 - shows "a \<noteq> 0 ==> inverse (a ^ n) = (inverse a) ^ n"
115.307 -apply (induct "n")
115.308 -apply (auto simp add: nonzero_inverse_mult_distrib power_commutes)
115.309 -done (* TODO: reorient or rename to nonzero_inverse_power *)
115.310 -
115.311 -text{*Perhaps these should be simprules.*}
115.312 -lemma power_inverse:
115.313 - fixes a :: "'a::{division_ring,division_by_zero,recpower}"
115.314 - shows "inverse (a ^ n) = (inverse a) ^ n"
115.315 -apply (cases "a = 0")
115.316 -apply (simp add: power_0_left)
115.317 -apply (simp add: nonzero_power_inverse)
115.318 -done (* TODO: reorient or rename to inverse_power *)
115.319 -
115.320 -lemma power_one_over: "1 / (a::'a::{field,division_by_zero,recpower})^n =
115.321 - (1 / a)^n"
115.322 -apply (simp add: divide_inverse)
115.323 -apply (rule power_inverse)
115.324 -done
115.325 -
115.326 -lemma nonzero_power_divide:
115.327 - "b \<noteq> 0 ==> (a/b) ^ n = ((a::'a::{field,recpower}) ^ n) / (b ^ n)"
115.328 -by (simp add: divide_inverse power_mult_distrib nonzero_power_inverse)
115.329 -
115.330 -lemma power_divide:
115.331 - "(a/b) ^ n = ((a::'a::{field,division_by_zero,recpower}) ^ n / b ^ n)"
115.332 -apply (case_tac "b=0", simp add: power_0_left)
115.333 -apply (rule nonzero_power_divide)
115.334 -apply assumption
115.335 -done
115.336 -
115.337 -lemma power_abs: "abs(a ^ n) = abs(a::'a::{ordered_idom,recpower}) ^ n"
115.338 -apply (induct "n")
115.339 -apply (auto simp add: abs_mult)
115.340 -done
115.341 -
115.342 -lemma abs_power_minus [simp]:
115.343 - fixes a:: "'a::{ordered_idom,recpower}" shows "abs((-a) ^ n) = abs(a ^ n)"
115.344 - by (simp add: abs_minus_cancel power_abs)
115.345 -
115.346 -lemma zero_less_power_abs_iff [simp,noatp]:
115.347 - "(0 < (abs a)^n) = (a \<noteq> (0::'a::{ordered_idom,recpower}) | n=0)"
115.348 -proof (induct "n")
115.349 - case 0
115.350 - show ?case by simp
115.351 -next
115.352 - case (Suc n)
115.353 - show ?case by (auto simp add: prems zero_less_mult_iff)
115.354 -qed
115.355 -
115.356 -lemma zero_le_power_abs [simp]:
115.357 - "(0::'a::{ordered_idom,recpower}) \<le> (abs a)^n"
115.358 -by (rule zero_le_power [OF abs_ge_zero])
115.359 -
115.360 -lemma power_minus: "(-a) ^ n = (- 1)^n * (a::'a::{ring_1,recpower}) ^ n"
115.361 -proof (induct n)
115.362 - case 0 show ?case by simp
115.363 -next
115.364 - case (Suc n) then show ?case
115.365 - by (simp del: power_Suc add: power_Suc2 mult_assoc)
115.366 -qed
115.367 + "a < b \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 < n \<longrightarrow> a ^ n < b ^ n"
115.368 + by (induct n)
115.369 + (auto simp add: mult_strict_mono le_less_trans [of 0 a b])
115.370
115.371 text{*Lemma for @{text power_strict_decreasing}*}
115.372 lemma power_Suc_less:
115.373 - "[|(0::'a::{ordered_semidom,recpower}) < a; a < 1|]
115.374 - ==> a * a^n < a^n"
115.375 -apply (induct n)
115.376 -apply (auto simp add: mult_strict_left_mono)
115.377 -done
115.378 + "0 < a \<Longrightarrow> a < 1 \<Longrightarrow> a * a ^ n < a ^ n"
115.379 + by (induct n)
115.380 + (auto simp add: mult_strict_left_mono)
115.381
115.382 -lemma power_strict_decreasing:
115.383 - "[|n < N; 0 < a; a < (1::'a::{ordered_semidom,recpower})|]
115.384 - ==> a^N < a^n"
115.385 -apply (erule rev_mp)
115.386 -apply (induct "N")
115.387 -apply (auto simp add: power_Suc_less less_Suc_eq)
115.388 -apply (rename_tac m)
115.389 -apply (subgoal_tac "a * a^m < 1 * a^n", simp)
115.390 -apply (rule mult_strict_mono)
115.391 -apply (auto simp add: order_less_imp_le)
115.392 -done
115.393 +lemma power_strict_decreasing [rule_format]:
115.394 + "n < N \<Longrightarrow> 0 < a \<Longrightarrow> a < 1 \<longrightarrow> a ^ N < a ^ n"
115.395 +proof (induct N)
115.396 + case 0 then show ?case by simp
115.397 +next
115.398 + case (Suc N) then show ?case
115.399 + apply (auto simp add: power_Suc_less less_Suc_eq)
115.400 + apply (subgoal_tac "a * a^N < 1 * a^n")
115.401 + apply simp
115.402 + apply (rule mult_strict_mono) apply auto
115.403 + done
115.404 +qed
115.405
115.406 text{*Proof resembles that of @{text power_strict_decreasing}*}
115.407 -lemma power_decreasing:
115.408 - "[|n \<le> N; 0 \<le> a; a \<le> (1::'a::{ordered_semidom,recpower})|]
115.409 - ==> a^N \<le> a^n"
115.410 -apply (erule rev_mp)
115.411 -apply (induct "N")
115.412 -apply (auto simp add: le_Suc_eq)
115.413 -apply (rename_tac m)
115.414 -apply (subgoal_tac "a * a^m \<le> 1 * a^n", simp)
115.415 -apply (rule mult_mono)
115.416 -apply auto
115.417 -done
115.418 +lemma power_decreasing [rule_format]:
115.419 + "n \<le> N \<Longrightarrow> 0 \<le> a \<Longrightarrow> a \<le> 1 \<longrightarrow> a ^ N \<le> a ^ n"
115.420 +proof (induct N)
115.421 + case 0 then show ?case by simp
115.422 +next
115.423 + case (Suc N) then show ?case
115.424 + apply (auto simp add: le_Suc_eq)
115.425 + apply (subgoal_tac "a * a^N \<le> 1 * a^n", simp)
115.426 + apply (rule mult_mono) apply auto
115.427 + done
115.428 +qed
115.429
115.430 lemma power_Suc_less_one:
115.431 - "[| 0 < a; a < (1::'a::{ordered_semidom,recpower}) |] ==> a ^ Suc n < 1"
115.432 -apply (insert power_strict_decreasing [of 0 "Suc n" a], simp)
115.433 -done
115.434 + "0 < a \<Longrightarrow> a < 1 \<Longrightarrow> a ^ Suc n < 1"
115.435 + using power_strict_decreasing [of 0 "Suc n" a] by simp
115.436
115.437 text{*Proof again resembles that of @{text power_strict_decreasing}*}
115.438 -lemma power_increasing:
115.439 - "[|n \<le> N; (1::'a::{ordered_semidom,recpower}) \<le> a|] ==> a^n \<le> a^N"
115.440 -apply (erule rev_mp)
115.441 -apply (induct "N")
115.442 -apply (auto simp add: le_Suc_eq)
115.443 -apply (rename_tac m)
115.444 -apply (subgoal_tac "1 * a^n \<le> a * a^m", simp)
115.445 -apply (rule mult_mono)
115.446 -apply (auto simp add: order_trans [OF zero_le_one])
115.447 -done
115.448 +lemma power_increasing [rule_format]:
115.449 + "n \<le> N \<Longrightarrow> 1 \<le> a \<Longrightarrow> a ^ n \<le> a ^ N"
115.450 +proof (induct N)
115.451 + case 0 then show ?case by simp
115.452 +next
115.453 + case (Suc N) then show ?case
115.454 + apply (auto simp add: le_Suc_eq)
115.455 + apply (subgoal_tac "1 * a^n \<le> a * a^N", simp)
115.456 + apply (rule mult_mono) apply (auto simp add: order_trans [OF zero_le_one])
115.457 + done
115.458 +qed
115.459
115.460 text{*Lemma for @{text power_strict_increasing}*}
115.461 lemma power_less_power_Suc:
115.462 - "(1::'a::{ordered_semidom,recpower}) < a ==> a^n < a * a^n"
115.463 -apply (induct n)
115.464 -apply (auto simp add: mult_strict_left_mono order_less_trans [OF zero_less_one])
115.465 -done
115.466 + "1 < a \<Longrightarrow> a ^ n < a * a ^ n"
115.467 + by (induct n) (auto simp add: mult_strict_left_mono less_trans [OF zero_less_one])
115.468
115.469 -lemma power_strict_increasing:
115.470 - "[|n < N; (1::'a::{ordered_semidom,recpower}) < a|] ==> a^n < a^N"
115.471 -apply (erule rev_mp)
115.472 -apply (induct "N")
115.473 -apply (auto simp add: power_less_power_Suc less_Suc_eq)
115.474 -apply (rename_tac m)
115.475 -apply (subgoal_tac "1 * a^n < a * a^m", simp)
115.476 -apply (rule mult_strict_mono)
115.477 -apply (auto simp add: order_less_trans [OF zero_less_one] order_less_imp_le)
115.478 -done
115.479 +lemma power_strict_increasing [rule_format]:
115.480 + "n < N \<Longrightarrow> 1 < a \<longrightarrow> a ^ n < a ^ N"
115.481 +proof (induct N)
115.482 + case 0 then show ?case by simp
115.483 +next
115.484 + case (Suc N) then show ?case
115.485 + apply (auto simp add: power_less_power_Suc less_Suc_eq)
115.486 + apply (subgoal_tac "1 * a^n < a * a^N", simp)
115.487 + apply (rule mult_strict_mono) apply (auto simp add: less_trans [OF zero_less_one] less_imp_le)
115.488 + done
115.489 +qed
115.490
115.491 lemma power_increasing_iff [simp]:
115.492 - "1 < (b::'a::{ordered_semidom,recpower}) ==> (b ^ x \<le> b ^ y) = (x \<le> y)"
115.493 -by (blast intro: power_le_imp_le_exp power_increasing order_less_imp_le)
115.494 + "1 < b \<Longrightarrow> b ^ x \<le> b ^ y \<longleftrightarrow> x \<le> y"
115.495 + by (blast intro: power_le_imp_le_exp power_increasing less_imp_le)
115.496
115.497 lemma power_strict_increasing_iff [simp]:
115.498 - "1 < (b::'a::{ordered_semidom,recpower}) ==> (b ^ x < b ^ y) = (x < y)"
115.499 + "1 < b \<Longrightarrow> b ^ x < b ^ y \<longleftrightarrow> x < y"
115.500 by (blast intro: power_less_imp_less_exp power_strict_increasing)
115.501
115.502 lemma power_le_imp_le_base:
115.503 -assumes le: "a ^ Suc n \<le> b ^ Suc n"
115.504 - and ynonneg: "(0::'a::{ordered_semidom,recpower}) \<le> b"
115.505 -shows "a \<le> b"
115.506 + assumes le: "a ^ Suc n \<le> b ^ Suc n"
115.507 + and ynonneg: "0 \<le> b"
115.508 + shows "a \<le> b"
115.509 proof (rule ccontr)
115.510 assume "~ a \<le> b"
115.511 then have "b < a" by (simp only: linorder_not_le)
115.512 then have "b ^ Suc n < a ^ Suc n"
115.513 by (simp only: prems power_strict_mono)
115.514 - from le and this show "False"
115.515 + from le and this show False
115.516 by (simp add: linorder_not_less [symmetric])
115.517 qed
115.518
115.519 lemma power_less_imp_less_base:
115.520 - fixes a b :: "'a::{ordered_semidom,recpower}"
115.521 assumes less: "a ^ n < b ^ n"
115.522 assumes nonneg: "0 \<le> b"
115.523 shows "a < b"
115.524 @@ -310,98 +310,140 @@
115.525 assume "~ a < b"
115.526 hence "b \<le> a" by (simp only: linorder_not_less)
115.527 hence "b ^ n \<le> a ^ n" using nonneg by (rule power_mono)
115.528 - thus "~ a ^ n < b ^ n" by (simp only: linorder_not_less)
115.529 + thus "\<not> a ^ n < b ^ n" by (simp only: linorder_not_less)
115.530 qed
115.531
115.532 lemma power_inject_base:
115.533 - "[| a ^ Suc n = b ^ Suc n; 0 \<le> a; 0 \<le> b |]
115.534 - ==> a = (b::'a::{ordered_semidom,recpower})"
115.535 -by (blast intro: power_le_imp_le_base order_antisym order_eq_refl sym)
115.536 + "a ^ Suc n = b ^ Suc n \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> a = b"
115.537 +by (blast intro: power_le_imp_le_base antisym eq_refl sym)
115.538
115.539 lemma power_eq_imp_eq_base:
115.540 - fixes a b :: "'a::{ordered_semidom,recpower}"
115.541 - shows "\<lbrakk>a ^ n = b ^ n; 0 \<le> a; 0 \<le> b; 0 < n\<rbrakk> \<Longrightarrow> a = b"
115.542 -by (cases n, simp_all del: power_Suc, rule power_inject_base)
115.543 -
115.544 -text {* The divides relation *}
115.545 -
115.546 -lemma le_imp_power_dvd:
115.547 - fixes a :: "'a::{comm_semiring_1,recpower}"
115.548 - assumes "m \<le> n" shows "a^m dvd a^n"
115.549 -proof
115.550 - have "a^n = a^(m + (n - m))"
115.551 - using `m \<le> n` by simp
115.552 - also have "\<dots> = a^m * a^(n - m)"
115.553 - by (rule power_add)
115.554 - finally show "a^n = a^m * a^(n - m)" .
115.555 -qed
115.556 -
115.557 -lemma power_le_dvd:
115.558 - fixes a b :: "'a::{comm_semiring_1,recpower}"
115.559 - shows "a^n dvd b \<Longrightarrow> m \<le> n \<Longrightarrow> a^m dvd b"
115.560 - by (rule dvd_trans [OF le_imp_power_dvd])
115.561 -
115.562 -
115.563 -lemma dvd_power_same:
115.564 - "(x::'a::{comm_semiring_1,recpower}) dvd y \<Longrightarrow> x^n dvd y^n"
115.565 -by (induct n) (auto simp add: mult_dvd_mono)
115.566 -
115.567 -lemma dvd_power_le:
115.568 - "(x::'a::{comm_semiring_1,recpower}) dvd y \<Longrightarrow> m >= n \<Longrightarrow> x^n dvd y^m"
115.569 -by(rule power_le_dvd[OF dvd_power_same])
115.570 -
115.571 -lemma dvd_power [simp]:
115.572 - "n > 0 | (x::'a::{comm_semiring_1,recpower}) = 1 \<Longrightarrow> x dvd x^n"
115.573 -apply (erule disjE)
115.574 - apply (subgoal_tac "x ^ n = x^(Suc (n - 1))")
115.575 - apply (erule ssubst)
115.576 - apply (subst power_Suc)
115.577 - apply auto
115.578 -done
115.579 -
115.580 -
115.581 -subsection{*Exponentiation for the Natural Numbers*}
115.582 -
115.583 -instantiation nat :: recpower
115.584 -begin
115.585 -
115.586 -primrec power_nat where
115.587 - "p ^ 0 = (1\<Colon>nat)"
115.588 - | "p ^ (Suc n) = (p\<Colon>nat) * (p ^ n)"
115.589 -
115.590 -instance proof
115.591 - fix z n :: nat
115.592 - show "z^0 = 1" by simp
115.593 - show "z^(Suc n) = z * (z^n)" by simp
115.594 -qed
115.595 -
115.596 -declare power_nat.simps [simp del]
115.597 + "a ^ n = b ^ n \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> 0 < n \<Longrightarrow> a = b"
115.598 + by (cases n) (simp_all del: power_Suc, rule power_inject_base)
115.599
115.600 end
115.601
115.602 -lemma of_nat_power:
115.603 - "of_nat (m ^ n) = (of_nat m::'a::{semiring_1,recpower}) ^ n"
115.604 -by (induct n, simp_all add: of_nat_mult)
115.605 +context ordered_idom
115.606 +begin
115.607
115.608 -lemma nat_one_le_power [simp]: "Suc 0 \<le> i ==> Suc 0 \<le> i^n"
115.609 -by (rule one_le_power [of i n, unfolded One_nat_def])
115.610 +lemma power_abs:
115.611 + "abs (a ^ n) = abs a ^ n"
115.612 + by (induct n) (auto simp add: abs_mult)
115.613
115.614 -lemma nat_zero_less_power_iff [simp]: "(x^n > 0) = (x > (0::nat) | n=0)"
115.615 -by (induct "n", auto)
115.616 +lemma abs_power_minus [simp]:
115.617 + "abs ((-a) ^ n) = abs (a ^ n)"
115.618 + by (simp add: abs_minus_cancel power_abs)
115.619 +
115.620 +lemma zero_less_power_abs_iff [simp, noatp]:
115.621 + "0 < abs a ^ n \<longleftrightarrow> a \<noteq> 0 \<or> n = 0"
115.622 +proof (induct n)
115.623 + case 0 show ?case by simp
115.624 +next
115.625 + case (Suc n) show ?case by (auto simp add: Suc zero_less_mult_iff)
115.626 +qed
115.627 +
115.628 +lemma zero_le_power_abs [simp]:
115.629 + "0 \<le> abs a ^ n"
115.630 + by (rule zero_le_power [OF abs_ge_zero])
115.631 +
115.632 +end
115.633 +
115.634 +context ring_1_no_zero_divisors
115.635 +begin
115.636 +
115.637 +lemma field_power_not_zero:
115.638 + "a \<noteq> 0 \<Longrightarrow> a ^ n \<noteq> 0"
115.639 + by (induct n) auto
115.640 +
115.641 +end
115.642 +
115.643 +context division_ring
115.644 +begin
115.645 +
115.646 +text {* FIXME reorient or rename to @{text nonzero_inverse_power} *}
115.647 +lemma nonzero_power_inverse:
115.648 + "a \<noteq> 0 \<Longrightarrow> inverse (a ^ n) = (inverse a) ^ n"
115.649 + by (induct n)
115.650 + (simp_all add: nonzero_inverse_mult_distrib power_commutes field_power_not_zero)
115.651 +
115.652 +end
115.653 +
115.654 +context field
115.655 +begin
115.656 +
115.657 +lemma nonzero_power_divide:
115.658 + "b \<noteq> 0 \<Longrightarrow> (a / b) ^ n = a ^ n / b ^ n"
115.659 + by (simp add: divide_inverse power_mult_distrib nonzero_power_inverse)
115.660 +
115.661 +end
115.662 +
115.663 +lemma power_0_Suc [simp]:
115.664 + "(0::'a::{power, semiring_0}) ^ Suc n = 0"
115.665 + by simp
115.666 +
115.667 +text{*It looks plausible as a simprule, but its effect can be strange.*}
115.668 +lemma power_0_left:
115.669 + "0 ^ n = (if n = 0 then 1 else (0::'a::{power, semiring_0}))"
115.670 + by (induct n) simp_all
115.671 +
115.672 +lemma power_eq_0_iff [simp]:
115.673 + "a ^ n = 0 \<longleftrightarrow>
115.674 + a = (0::'a::{mult_zero,zero_neq_one,no_zero_divisors,power}) \<and> n \<noteq> 0"
115.675 + by (induct n)
115.676 + (auto simp add: no_zero_divisors elim: contrapos_pp)
115.677 +
115.678 +lemma power_diff:
115.679 + fixes a :: "'a::field"
115.680 + assumes nz: "a \<noteq> 0"
115.681 + shows "n \<le> m \<Longrightarrow> a ^ (m - n) = a ^ m / a ^ n"
115.682 + by (induct m n rule: diff_induct) (simp_all add: nz)
115.683 +
115.684 +text{*Perhaps these should be simprules.*}
115.685 +lemma power_inverse:
115.686 + fixes a :: "'a::{division_ring,division_by_zero,power}"
115.687 + shows "inverse (a ^ n) = (inverse a) ^ n"
115.688 +apply (cases "a = 0")
115.689 +apply (simp add: power_0_left)
115.690 +apply (simp add: nonzero_power_inverse)
115.691 +done (* TODO: reorient or rename to inverse_power *)
115.692 +
115.693 +lemma power_one_over:
115.694 + "1 / (a::'a::{field,division_by_zero, power}) ^ n = (1 / a) ^ n"
115.695 + by (simp add: divide_inverse) (rule power_inverse)
115.696 +
115.697 +lemma power_divide:
115.698 + "(a / b) ^ n = (a::'a::{field,division_by_zero}) ^ n / b ^ n"
115.699 +apply (cases "b = 0")
115.700 +apply (simp add: power_0_left)
115.701 +apply (rule nonzero_power_divide)
115.702 +apply assumption
115.703 +done
115.704 +
115.705 +
115.706 +subsection {* Exponentiation for the Natural Numbers *}
115.707 +
115.708 +lemma nat_one_le_power [simp]:
115.709 + "Suc 0 \<le> i \<Longrightarrow> Suc 0 \<le> i ^ n"
115.710 + by (rule one_le_power [of i n, unfolded One_nat_def])
115.711 +
115.712 +lemma nat_zero_less_power_iff [simp]:
115.713 + "x ^ n > 0 \<longleftrightarrow> x > (0::nat) \<or> n = 0"
115.714 + by (induct n) auto
115.715
115.716 lemma nat_power_eq_Suc_0_iff [simp]:
115.717 - "((x::nat)^m = Suc 0) = (m = 0 | x = Suc 0)"
115.718 -by (induct_tac m, auto)
115.719 + "x ^ m = Suc 0 \<longleftrightarrow> m = 0 \<or> x = Suc 0"
115.720 + by (induct m) auto
115.721
115.722 -lemma power_Suc_0[simp]: "(Suc 0)^n = Suc 0"
115.723 -by simp
115.724 +lemma power_Suc_0 [simp]:
115.725 + "Suc 0 ^ n = Suc 0"
115.726 + by simp
115.727
115.728 text{*Valid for the naturals, but what if @{text"0<i<1"}?
115.729 Premises cannot be weakened: consider the case where @{term "i=0"},
115.730 @{term "m=1"} and @{term "n=0"}.*}
115.731 lemma nat_power_less_imp_less:
115.732 assumes nonneg: "0 < (i\<Colon>nat)"
115.733 - assumes less: "i^m < i^n"
115.734 + assumes less: "i ^ m < i ^ n"
115.735 shows "m < n"
115.736 proof (cases "i = 1")
115.737 case True with less power_one [where 'a = nat] show ?thesis by simp
115.738 @@ -410,10 +452,4 @@
115.739 from power_strict_increasing_iff [OF this] less show ?thesis ..
115.740 qed
115.741
115.742 -lemma power_diff:
115.743 - assumes nz: "a ~= 0"
115.744 - shows "n <= m ==> (a::'a::{recpower, field}) ^ (m-n) = (a^m) / (a^n)"
115.745 - by (induct m n rule: diff_induct)
115.746 - (simp_all add: nonzero_mult_divide_cancel_left nz)
115.747 -
115.748 end
116.1 --- a/src/HOL/Predicate.thy Mon May 11 09:39:53 2009 +0200
116.2 +++ b/src/HOL/Predicate.thy Mon May 11 17:20:52 2009 +0200
116.3 @@ -625,7 +625,56 @@
116.4 inductive eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where "eq x x"
116.5
116.6 lemma eq_is_eq: "eq x y \<equiv> (x = y)"
116.7 -by (rule eq_reflection) (auto intro: eq.intros elim: eq.cases)
116.8 + by (rule eq_reflection) (auto intro: eq.intros elim: eq.cases)
116.9 +
116.10 +ML {*
116.11 +signature PREDICATE =
116.12 +sig
116.13 + datatype 'a pred = Seq of (unit -> 'a seq)
116.14 + and 'a seq = Empty | Insert of 'a * 'a pred | Join of 'a pred * 'a seq
116.15 + val yield: 'a pred -> ('a * 'a pred) option
116.16 + val yieldn: int -> 'a pred -> 'a list * 'a pred
116.17 +end;
116.18 +
116.19 +structure Predicate : PREDICATE =
116.20 +struct
116.21 +
116.22 +@{code_datatype pred = Seq};
116.23 +@{code_datatype seq = Empty | Insert | Join};
116.24 +
116.25 +fun yield (Seq f) = next (f ())
116.26 +and next @{code Empty} = NONE
116.27 + | next (@{code Insert} (x, P)) = SOME (x, P)
116.28 + | next (@{code Join} (P, xq)) = (case yield P
116.29 + of NONE => next xq
116.30 + | SOME (x, Q) => SOME (x, @{code Seq} (fn _ => @{code Join} (Q, xq))))
116.31 +
116.32 +fun anamorph f k x = (if k = 0 then ([], x)
116.33 + else case f x
116.34 + of NONE => ([], x)
116.35 + | SOME (v, y) => let
116.36 + val (vs, z) = anamorph f (k - 1) y
116.37 + in (v :: vs, z) end)
116.38 +
116.39 +fun yieldn P = anamorph yield P;
116.40 +
116.41 +end;
116.42 +*}
116.43 +
116.44 +code_reserved Eval Predicate
116.45 +
116.46 +code_type pred and seq
116.47 + (Eval "_/ Predicate.pred" and "_/ Predicate.seq")
116.48 +
116.49 +code_const Seq and Empty and Insert and Join
116.50 + (Eval "Predicate.Seq" and "Predicate.Empty" and "Predicate.Insert/ (_,/ _)" and "Predicate.Join/ (_,/ _)")
116.51 +
116.52 +text {* dummy setup for code_pred keyword *}
116.53 +
116.54 +ML {*
116.55 +OuterSyntax.local_theory_to_proof "code_pred" "sets up goal for cases rule from given introduction rules and compiles predicate"
116.56 + OuterKeyword.thy_goal (OuterParse.term_group >> (K (Proof.theorem_i NONE (K I) [[]])))
116.57 +*}
116.58
116.59 no_notation
116.60 inf (infixl "\<sqinter>" 70) and
116.61 @@ -640,12 +689,4 @@
116.62 hide (open) const Pred eval single bind if_pred not_pred
116.63 Empty Insert Join Seq member pred_of_seq "apply" adjunct eq
116.64
116.65 -text {* dummy setup for code_pred keyword *}
116.66 -
116.67 -ML {*
116.68 -OuterSyntax.local_theory_to_proof "code_pred" "sets up goal for cases rule from given introduction rules and compiles predicate"
116.69 - OuterKeyword.thy_goal (OuterParse.term_group >> (K (Proof.theorem_i NONE (K I) [[]])))
116.70 -*}
116.71 -
116.72 -
116.73 end
117.1 --- a/src/HOL/Product_Type.thy Mon May 11 09:39:53 2009 +0200
117.2 +++ b/src/HOL/Product_Type.thy Mon May 11 17:20:52 2009 +0200
117.3 @@ -84,6 +84,14 @@
117.4 lemma unit_abs_eta_conv [simp,noatp]: "(%u::unit. f ()) = f"
117.5 by (rule ext) simp
117.6
117.7 +instantiation unit :: default
117.8 +begin
117.9 +
117.10 +definition "default = ()"
117.11 +
117.12 +instance ..
117.13 +
117.14 +end
117.15
117.16 text {* code generator setup *}
117.17
118.1 --- a/src/HOL/Rational.thy Mon May 11 09:39:53 2009 +0200
118.2 +++ b/src/HOL/Rational.thy Mon May 11 17:20:52 2009 +0200
118.3 @@ -90,7 +90,7 @@
118.4 and "\<And>a c. Fract 0 a = Fract 0 c"
118.5 by (simp_all add: Fract_def)
118.6
118.7 -instantiation rat :: "{comm_ring_1, recpower}"
118.8 +instantiation rat :: comm_ring_1
118.9 begin
118.10
118.11 definition
118.12 @@ -156,11 +156,6 @@
118.13 then show ?thesis by (simp add: mult_rat [symmetric])
118.14 qed
118.15
118.16 -primrec power_rat
118.17 -where
118.18 - "q ^ 0 = (1\<Colon>rat)"
118.19 -| "q ^ Suc n = (q\<Colon>rat) * (q ^ n)"
118.20 -
118.21 instance proof
118.22 fix q r s :: rat show "(q * r) * s = q * (r * s)"
118.23 by (cases q, cases r, cases s) (simp add: eq_rat)
118.24 @@ -190,18 +185,8 @@
118.25 by (cases q, cases r, cases s) (simp add: eq_rat algebra_simps)
118.26 next
118.27 show "(0::rat) \<noteq> 1" by (simp add: Zero_rat_def One_rat_def eq_rat)
118.28 -next
118.29 - fix q :: rat show "q * 1 = q"
118.30 - by (cases q) (simp add: One_rat_def eq_rat)
118.31 -next
118.32 - fix q :: rat
118.33 - fix n :: nat
118.34 - show "q ^ 0 = 1" by simp
118.35 - show "q ^ (Suc n) = q * (q ^ n)" by simp
118.36 qed
118.37
118.38 -declare power_rat.simps [simp del]
118.39 -
118.40 end
118.41
118.42 lemma of_nat_rat: "of_nat k = Fract (of_nat k) 1"
118.43 @@ -222,7 +207,8 @@
118.44 definition
118.45 rat_number_of_def [code del]: "number_of w = Fract w 1"
118.46
118.47 -instance by intro_classes (simp add: rat_number_of_def of_int_rat)
118.48 +instance proof
118.49 +qed (simp add: rat_number_of_def of_int_rat)
118.50
118.51 end
118.52
118.53 @@ -667,7 +653,7 @@
118.54 by (cases "b = 0") (simp_all add: nonzero_of_rat_divide)
118.55
118.56 lemma of_rat_power:
118.57 - "(of_rat (a ^ n)::'a::{field_char_0,recpower}) = of_rat a ^ n"
118.58 + "(of_rat (a ^ n)::'a::field_char_0) = of_rat a ^ n"
118.59 by (induct n) (simp_all add: of_rat_mult)
118.60
118.61 lemma of_rat_eq_iff [simp]: "(of_rat a = of_rat b) = (a = b)"
118.62 @@ -827,7 +813,7 @@
118.63 done
118.64
118.65 lemma Rats_power [simp]:
118.66 - fixes a :: "'a::{field_char_0,recpower}"
118.67 + fixes a :: "'a::field_char_0"
118.68 shows "a \<in> Rats \<Longrightarrow> a ^ n \<in> Rats"
118.69 apply (auto simp add: Rats_def)
118.70 apply (rule range_eqI)
119.1 --- a/src/HOL/RealPow.thy Mon May 11 09:39:53 2009 +0200
119.2 +++ b/src/HOL/RealPow.thy Mon May 11 17:20:52 2009 +0200
119.3 @@ -12,25 +12,6 @@
119.4
119.5 declare abs_mult_self [simp]
119.6
119.7 -instantiation real :: recpower
119.8 -begin
119.9 -
119.10 -primrec power_real where
119.11 - "r ^ 0 = (1\<Colon>real)"
119.12 -| "r ^ Suc n = (r\<Colon>real) * r ^ n"
119.13 -
119.14 -instance proof
119.15 - fix z :: real
119.16 - fix n :: nat
119.17 - show "z^0 = 1" by simp
119.18 - show "z^(Suc n) = z * (z^n)" by simp
119.19 -qed
119.20 -
119.21 -declare power_real.simps [simp del]
119.22 -
119.23 -end
119.24 -
119.25 -
119.26 lemma two_realpow_ge_one [simp]: "(1::real) \<le> 2 ^ n"
119.27 by simp
119.28
119.29 @@ -47,7 +28,6 @@
119.30
119.31 lemma realpow_minus_mult [rule_format]:
119.32 "0 < n --> (x::real) ^ (n - 1) * x = x ^ n"
119.33 -unfolding One_nat_def
119.34 apply (simp split add: nat_diff_split)
119.35 done
119.36
119.37 @@ -101,75 +81,6 @@
119.38 declare power_real_number_of [of _ "number_of w", standard, simp]
119.39
119.40
119.41 -subsection {* Properties of Squares *}
119.42 -
119.43 -lemma sum_squares_ge_zero:
119.44 - fixes x y :: "'a::ordered_ring_strict"
119.45 - shows "0 \<le> x * x + y * y"
119.46 -by (intro add_nonneg_nonneg zero_le_square)
119.47 -
119.48 -lemma not_sum_squares_lt_zero:
119.49 - fixes x y :: "'a::ordered_ring_strict"
119.50 - shows "\<not> x * x + y * y < 0"
119.51 -by (simp add: linorder_not_less sum_squares_ge_zero)
119.52 -
119.53 -lemma sum_nonneg_eq_zero_iff:
119.54 - fixes x y :: "'a::pordered_ab_group_add"
119.55 - assumes x: "0 \<le> x" and y: "0 \<le> y"
119.56 - shows "(x + y = 0) = (x = 0 \<and> y = 0)"
119.57 -proof (auto)
119.58 - from y have "x + 0 \<le> x + y" by (rule add_left_mono)
119.59 - also assume "x + y = 0"
119.60 - finally have "x \<le> 0" by simp
119.61 - thus "x = 0" using x by (rule order_antisym)
119.62 -next
119.63 - from x have "0 + y \<le> x + y" by (rule add_right_mono)
119.64 - also assume "x + y = 0"
119.65 - finally have "y \<le> 0" by simp
119.66 - thus "y = 0" using y by (rule order_antisym)
119.67 -qed
119.68 -
119.69 -lemma sum_squares_eq_zero_iff:
119.70 - fixes x y :: "'a::ordered_ring_strict"
119.71 - shows "(x * x + y * y = 0) = (x = 0 \<and> y = 0)"
119.72 -by (simp add: sum_nonneg_eq_zero_iff)
119.73 -
119.74 -lemma sum_squares_le_zero_iff:
119.75 - fixes x y :: "'a::ordered_ring_strict"
119.76 - shows "(x * x + y * y \<le> 0) = (x = 0 \<and> y = 0)"
119.77 -by (simp add: order_le_less not_sum_squares_lt_zero sum_squares_eq_zero_iff)
119.78 -
119.79 -lemma sum_squares_gt_zero_iff:
119.80 - fixes x y :: "'a::ordered_ring_strict"
119.81 - shows "(0 < x * x + y * y) = (x \<noteq> 0 \<or> y \<noteq> 0)"
119.82 -by (simp add: order_less_le sum_squares_ge_zero sum_squares_eq_zero_iff)
119.83 -
119.84 -lemma sum_power2_ge_zero:
119.85 - fixes x y :: "'a::{ordered_idom,recpower}"
119.86 - shows "0 \<le> x\<twosuperior> + y\<twosuperior>"
119.87 -unfolding power2_eq_square by (rule sum_squares_ge_zero)
119.88 -
119.89 -lemma not_sum_power2_lt_zero:
119.90 - fixes x y :: "'a::{ordered_idom,recpower}"
119.91 - shows "\<not> x\<twosuperior> + y\<twosuperior> < 0"
119.92 -unfolding power2_eq_square by (rule not_sum_squares_lt_zero)
119.93 -
119.94 -lemma sum_power2_eq_zero_iff:
119.95 - fixes x y :: "'a::{ordered_idom,recpower}"
119.96 - shows "(x\<twosuperior> + y\<twosuperior> = 0) = (x = 0 \<and> y = 0)"
119.97 -unfolding power2_eq_square by (rule sum_squares_eq_zero_iff)
119.98 -
119.99 -lemma sum_power2_le_zero_iff:
119.100 - fixes x y :: "'a::{ordered_idom,recpower}"
119.101 - shows "(x\<twosuperior> + y\<twosuperior> \<le> 0) = (x = 0 \<and> y = 0)"
119.102 -unfolding power2_eq_square by (rule sum_squares_le_zero_iff)
119.103 -
119.104 -lemma sum_power2_gt_zero_iff:
119.105 - fixes x y :: "'a::{ordered_idom,recpower}"
119.106 - shows "(0 < x\<twosuperior> + y\<twosuperior>) = (x \<noteq> 0 \<or> y \<noteq> 0)"
119.107 -unfolding power2_eq_square by (rule sum_squares_gt_zero_iff)
119.108 -
119.109 -
119.110 subsection{* Squares of Reals *}
119.111
119.112 lemma real_two_squares_add_zero_iff [simp]:
120.1 --- a/src/HOL/RealVector.thy Mon May 11 09:39:53 2009 +0200
120.2 +++ b/src/HOL/RealVector.thy Mon May 11 17:20:52 2009 +0200
120.3 @@ -259,7 +259,7 @@
120.4 by (simp add: divide_inverse)
120.5
120.6 lemma of_real_power [simp]:
120.7 - "of_real (x ^ n) = (of_real x :: 'a::{real_algebra_1,recpower}) ^ n"
120.8 + "of_real (x ^ n) = (of_real x :: 'a::{real_algebra_1}) ^ n"
120.9 by (induct n) simp_all
120.10
120.11 lemma of_real_eq_iff [simp]: "(of_real x = of_real y) = (x = y)"
120.12 @@ -389,7 +389,7 @@
120.13 done
120.14
120.15 lemma Reals_power [simp]:
120.16 - fixes a :: "'a::{real_algebra_1,recpower}"
120.17 + fixes a :: "'a::{real_algebra_1}"
120.18 shows "a \<in> Reals \<Longrightarrow> a ^ n \<in> Reals"
120.19 apply (auto simp add: Reals_def)
120.20 apply (rule range_eqI)
120.21 @@ -613,7 +613,7 @@
120.22 by (simp add: divide_inverse norm_mult norm_inverse)
120.23
120.24 lemma norm_power_ineq:
120.25 - fixes x :: "'a::{real_normed_algebra_1,recpower}"
120.26 + fixes x :: "'a::{real_normed_algebra_1}"
120.27 shows "norm (x ^ n) \<le> norm x ^ n"
120.28 proof (induct n)
120.29 case 0 show "norm (x ^ 0) \<le> norm x ^ 0" by simp
120.30 @@ -628,7 +628,7 @@
120.31 qed
120.32
120.33 lemma norm_power:
120.34 - fixes x :: "'a::{real_normed_div_algebra,recpower}"
120.35 + fixes x :: "'a::{real_normed_div_algebra}"
120.36 shows "norm (x ^ n) = norm x ^ n"
120.37 by (induct n) (simp_all add: norm_mult)
120.38
121.1 --- a/src/HOL/Relation.thy Mon May 11 09:39:53 2009 +0200
121.2 +++ b/src/HOL/Relation.thy Mon May 11 17:20:52 2009 +0200
121.3 @@ -6,7 +6,8 @@
121.4 header {* Relations *}
121.5
121.6 theory Relation
121.7 -imports Datatype Finite_Set
121.8 +imports Finite_Set Datatype
121.9 + (*FIXME order is important, otherwise merge problem for canonical interpretation of class monoid_mult wrt. power!*)
121.10 begin
121.11
121.12 subsection {* Definitions *}
122.1 --- a/src/HOL/Relation_Power.thy Mon May 11 09:39:53 2009 +0200
122.2 +++ b/src/HOL/Relation_Power.thy Mon May 11 17:20:52 2009 +0200
122.3 @@ -9,132 +9,124 @@
122.4 imports Power Transitive_Closure Plain
122.5 begin
122.6
122.7 -instance
122.8 - "fun" :: (type, type) power ..
122.9 - --{* only type @{typ "'a => 'a"} should be in class @{text power}!*}
122.10 +consts funpower :: "('a \<Rightarrow> 'b) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'b" (infixr "^^" 80)
122.11
122.12 overloading
122.13 - relpow \<equiv> "power \<Colon> ('a \<times> 'a) set \<Rightarrow> nat \<Rightarrow> ('a \<times> 'a) set" (unchecked)
122.14 + relpow \<equiv> "funpower \<Colon> ('a \<times> 'a) set \<Rightarrow> nat \<Rightarrow> ('a \<times> 'a) set"
122.15 begin
122.16
122.17 -text {* @{text "R ^ n = R O ... O R"}, the n-fold composition of @{text R} *}
122.18 +text {* @{text "R ^^ n = R O ... O R"}, the n-fold composition of @{text R} *}
122.19
122.20 primrec relpow where
122.21 - "(R \<Colon> ('a \<times> 'a) set) ^ 0 = Id"
122.22 - | "(R \<Colon> ('a \<times> 'a) set) ^ Suc n = R O (R ^ n)"
122.23 + "(R \<Colon> ('a \<times> 'a) set) ^^ 0 = Id"
122.24 + | "(R \<Colon> ('a \<times> 'a) set) ^^ Suc n = R O (R ^^ n)"
122.25
122.26 end
122.27
122.28 overloading
122.29 - funpow \<equiv> "power \<Colon> ('a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a" (unchecked)
122.30 + funpow \<equiv> "funpower \<Colon> ('a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a"
122.31 begin
122.32
122.33 -text {* @{text "f ^ n = f o ... o f"}, the n-fold composition of @{text f} *}
122.34 +text {* @{text "f ^^ n = f o ... o f"}, the n-fold composition of @{text f} *}
122.35
122.36 primrec funpow where
122.37 - "(f \<Colon> 'a \<Rightarrow> 'a) ^ 0 = id"
122.38 - | "(f \<Colon> 'a \<Rightarrow> 'a) ^ Suc n = f o (f ^ n)"
122.39 + "(f \<Colon> 'a \<Rightarrow> 'a) ^^ 0 = id"
122.40 + | "(f \<Colon> 'a \<Rightarrow> 'a) ^^ Suc n = f o (f ^^ n)"
122.41
122.42 end
122.43
122.44 -text{*WARNING: due to the limits of Isabelle's type classes, exponentiation on
122.45 -functions and relations has too general a domain, namely @{typ "('a * 'b)set"}
122.46 -and @{typ "'a => 'b"}. Explicit type constraints may therefore be necessary.
122.47 -For example, @{term "range(f^n) = A"} and @{term "Range(R^n) = B"} need
122.48 -constraints.*}
122.49 -
122.50 -text {*
122.51 - Circumvent this problem for code generation:
122.52 -*}
122.53 -
122.54 -primrec
122.55 - fun_pow :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a"
122.56 -where
122.57 - "fun_pow 0 f = id"
122.58 +primrec fun_pow :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" where
122.59 + "fun_pow 0 f = id"
122.60 | "fun_pow (Suc n) f = f o fun_pow n f"
122.61
122.62 -lemma funpow_fun_pow [code unfold]: "f ^ n = fun_pow n f"
122.63 +lemma funpow_fun_pow [code unfold]:
122.64 + "f ^^ n = fun_pow n f"
122.65 unfolding funpow_def fun_pow_def ..
122.66
122.67 -lemma funpow_add: "f ^ (m+n) = f^m o f^n"
122.68 +lemma funpow_add:
122.69 + "f ^^ (m + n) = f ^^ m o f ^^ n"
122.70 by (induct m) simp_all
122.71
122.72 -lemma funpow_swap1: "f((f^n) x) = (f^n)(f x)"
122.73 +lemma funpow_swap1:
122.74 + "f ((f ^^ n) x) = (f ^^ n) (f x)"
122.75 proof -
122.76 - have "f((f^n) x) = (f^(n+1)) x" unfolding One_nat_def by simp
122.77 - also have "\<dots> = (f^n o f^1) x" by (simp only: funpow_add)
122.78 - also have "\<dots> = (f^n)(f x)" unfolding One_nat_def by simp
122.79 + have "f ((f ^^ n) x) = (f ^^ (n+1)) x" unfolding One_nat_def by simp
122.80 + also have "\<dots> = (f ^^ n o f ^^ 1) x" by (simp only: funpow_add)
122.81 + also have "\<dots> = (f ^^ n) (f x)" unfolding One_nat_def by simp
122.82 finally show ?thesis .
122.83 qed
122.84
122.85 lemma rel_pow_1 [simp]:
122.86 - fixes R :: "('a*'a)set"
122.87 - shows "R^1 = R"
122.88 - unfolding One_nat_def by simp
122.89 -
122.90 -lemma rel_pow_0_I: "(x,x) : R^0"
122.91 + fixes R :: "('a * 'a) set"
122.92 + shows "R ^^ 1 = R"
122.93 by simp
122.94
122.95 -lemma rel_pow_Suc_I: "[| (x,y) : R^n; (y,z):R |] ==> (x,z):R^(Suc n)"
122.96 +lemma rel_pow_0_I:
122.97 + "(x, x) \<in> R ^^ 0"
122.98 + by simp
122.99 +
122.100 +lemma rel_pow_Suc_I:
122.101 + "(x, y) \<in> R ^^ n \<Longrightarrow> (y, z) \<in> R \<Longrightarrow> (x, z) \<in> R ^^ Suc n"
122.102 by auto
122.103
122.104 lemma rel_pow_Suc_I2:
122.105 - "(x, y) : R \<Longrightarrow> (y, z) : R^n \<Longrightarrow> (x,z) : R^(Suc n)"
122.106 - apply (induct n arbitrary: z)
122.107 - apply simp
122.108 - apply fastsimp
122.109 - done
122.110 + "(x, y) \<in> R \<Longrightarrow> (y, z) \<in> R ^^ n \<Longrightarrow> (x, z) \<in> R ^^ Suc n"
122.111 + by (induct n arbitrary: z) (simp, fastsimp)
122.112
122.113 -lemma rel_pow_0_E: "[| (x,y) : R^0; x=y ==> P |] ==> P"
122.114 +lemma rel_pow_0_E:
122.115 + "(x, y) \<in> R ^^ 0 \<Longrightarrow> (x = y \<Longrightarrow> P) \<Longrightarrow> P"
122.116 by simp
122.117
122.118 lemma rel_pow_Suc_E:
122.119 - "[| (x,z) : R^(Suc n); !!y. [| (x,y) : R^n; (y,z) : R |] ==> P |] ==> P"
122.120 + "(x, z) \<in> R ^^ Suc n \<Longrightarrow> (\<And>y. (x, y) \<in> R ^^ n \<Longrightarrow> (y, z) \<in> R \<Longrightarrow> P) \<Longrightarrow> P"
122.121 by auto
122.122
122.123 lemma rel_pow_E:
122.124 - "[| (x,z) : R^n; [| n=0; x = z |] ==> P;
122.125 - !!y m. [| n = Suc m; (x,y) : R^m; (y,z) : R |] ==> P
122.126 - |] ==> P"
122.127 + "(x, z) \<in> R ^^ n \<Longrightarrow> (n = 0 \<Longrightarrow> x = z \<Longrightarrow> P)
122.128 + \<Longrightarrow> (\<And>y m. n = Suc m \<Longrightarrow> (x, y) \<in> R ^^ m \<Longrightarrow> (y, z) \<in> R \<Longrightarrow> P)
122.129 + \<Longrightarrow> P"
122.130 by (cases n) auto
122.131
122.132 lemma rel_pow_Suc_D2:
122.133 - "(x, z) : R^(Suc n) \<Longrightarrow> (\<exists>y. (x,y) : R & (y,z) : R^n)"
122.134 + "(x, z) \<in> R ^^ Suc n \<Longrightarrow> (\<exists>y. (x, y) \<in> R \<and> (y, z) \<in> R ^^ n)"
122.135 apply (induct n arbitrary: x z)
122.136 apply (blast intro: rel_pow_0_I elim: rel_pow_0_E rel_pow_Suc_E)
122.137 apply (blast intro: rel_pow_Suc_I elim: rel_pow_0_E rel_pow_Suc_E)
122.138 done
122.139
122.140 lemma rel_pow_Suc_D2':
122.141 - "\<forall>x y z. (x,y) : R^n & (y,z) : R --> (\<exists>w. (x,w) : R & (w,z) : R^n)"
122.142 + "\<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)"
122.143 by (induct n) (simp_all, blast)
122.144
122.145 lemma rel_pow_E2:
122.146 - "[| (x,z) : R^n; [| n=0; x = z |] ==> P;
122.147 - !!y m. [| n = Suc m; (x,y) : R; (y,z) : R^m |] ==> P
122.148 - |] ==> P"
122.149 - apply (case_tac n, simp)
122.150 + "(x, z) \<in> R ^^ n \<Longrightarrow> (n = 0 \<Longrightarrow> x = z \<Longrightarrow> P)
122.151 + \<Longrightarrow> (\<And>y m. n = Suc m \<Longrightarrow> (x, y) \<in> R \<Longrightarrow> (y, z) \<in> R ^^ m \<Longrightarrow> P)
122.152 + \<Longrightarrow> P"
122.153 + apply (cases n, simp)
122.154 apply (cut_tac n=nat and R=R in rel_pow_Suc_D2', simp, blast)
122.155 done
122.156
122.157 -lemma rtrancl_imp_UN_rel_pow: "!!p. p:R^* ==> p : (UN n. R^n)"
122.158 - apply (simp only: split_tupled_all)
122.159 +lemma rtrancl_imp_UN_rel_pow:
122.160 + "p \<in> R^* \<Longrightarrow> p \<in> (\<Union>n. R ^^ n)"
122.161 + apply (cases p) apply (simp only:)
122.162 apply (erule rtrancl_induct)
122.163 apply (blast intro: rel_pow_0_I rel_pow_Suc_I)+
122.164 done
122.165
122.166 -lemma rel_pow_imp_rtrancl: "!!p. p:R^n ==> p:R^*"
122.167 - apply (simp only: split_tupled_all)
122.168 - apply (induct n)
122.169 +lemma rel_pow_imp_rtrancl:
122.170 + "p \<in> R ^^ n \<Longrightarrow> p \<in> R^*"
122.171 + apply (induct n arbitrary: p)
122.172 + apply (simp_all only: split_tupled_all)
122.173 apply (blast intro: rtrancl_refl elim: rel_pow_0_E)
122.174 apply (blast elim: rel_pow_Suc_E intro: rtrancl_into_rtrancl)
122.175 done
122.176
122.177 -lemma rtrancl_is_UN_rel_pow: "R^* = (UN n. R^n)"
122.178 +lemma rtrancl_is_UN_rel_pow:
122.179 + "R^* = (UN n. R ^^ n)"
122.180 by (blast intro: rtrancl_imp_UN_rel_pow rel_pow_imp_rtrancl)
122.181
122.182 lemma trancl_power:
122.183 - "x \<in> r^+ = (\<exists>n > 0. x \<in> r^n)"
122.184 + "x \<in> r^+ = (\<exists>n > 0. x \<in> r ^^ n)"
122.185 apply (cases x)
122.186 apply simp
122.187 apply (rule iffI)
122.188 @@ -151,30 +143,12 @@
122.189 done
122.190
122.191 lemma single_valued_rel_pow:
122.192 - "!!r::('a * 'a)set. single_valued r ==> single_valued (r^n)"
122.193 + fixes R :: "('a * 'a) set"
122.194 + shows "single_valued R \<Longrightarrow> single_valued (R ^^ n)"
122.195 + apply (induct n arbitrary: R)
122.196 + apply simp_all
122.197 apply (rule single_valuedI)
122.198 - apply (induct n)
122.199 - apply simp
122.200 apply (fast dest: single_valuedD elim: rel_pow_Suc_E)
122.201 done
122.202
122.203 -ML
122.204 -{*
122.205 -val funpow_add = thm "funpow_add";
122.206 -val rel_pow_1 = thm "rel_pow_1";
122.207 -val rel_pow_0_I = thm "rel_pow_0_I";
122.208 -val rel_pow_Suc_I = thm "rel_pow_Suc_I";
122.209 -val rel_pow_Suc_I2 = thm "rel_pow_Suc_I2";
122.210 -val rel_pow_0_E = thm "rel_pow_0_E";
122.211 -val rel_pow_Suc_E = thm "rel_pow_Suc_E";
122.212 -val rel_pow_E = thm "rel_pow_E";
122.213 -val rel_pow_Suc_D2 = thm "rel_pow_Suc_D2";
122.214 -val rel_pow_Suc_D2 = thm "rel_pow_Suc_D2";
122.215 -val rel_pow_E2 = thm "rel_pow_E2";
122.216 -val rtrancl_imp_UN_rel_pow = thm "rtrancl_imp_UN_rel_pow";
122.217 -val rel_pow_imp_rtrancl = thm "rel_pow_imp_rtrancl";
122.218 -val rtrancl_is_UN_rel_pow = thm "rtrancl_is_UN_rel_pow";
122.219 -val single_valued_rel_pow = thm "single_valued_rel_pow";
122.220 -*}
122.221 -
122.222 end
123.1 --- a/src/HOL/Ring_and_Field.thy Mon May 11 09:39:53 2009 +0200
123.2 +++ b/src/HOL/Ring_and_Field.thy Mon May 11 17:20:52 2009 +0200
123.3 @@ -2226,15 +2226,21 @@
123.4 qed
123.5 qed
123.6
123.7 -instance ordered_idom \<subseteq> pordered_ring_abs
123.8 -by default (auto simp add: abs_if not_less
123.9 - equal_neg_zero neg_equal_zero mult_less_0_iff)
123.10 -
123.11 -lemma abs_mult: "abs (a * b) = abs a * abs (b::'a::ordered_idom)"
123.12 -by (simp add: abs_eq_mult linorder_linear)
123.13 -
123.14 -lemma abs_mult_self: "abs a * abs a = a * (a::'a::ordered_idom)"
123.15 -by (simp add: abs_if)
123.16 +context ordered_idom
123.17 +begin
123.18 +
123.19 +subclass pordered_ring_abs proof
123.20 +qed (auto simp add: abs_if not_less equal_neg_zero neg_equal_zero mult_less_0_iff)
123.21 +
123.22 +lemma abs_mult:
123.23 + "abs (a * b) = abs a * abs b"
123.24 + by (rule abs_eq_mult) auto
123.25 +
123.26 +lemma abs_mult_self:
123.27 + "abs a * abs a = a * a"
123.28 + by (simp add: abs_if)
123.29 +
123.30 +end
123.31
123.32 lemma nonzero_abs_inverse:
123.33 "a \<noteq> 0 ==> abs (inverse (a::'a::ordered_field)) = inverse (abs a)"
124.1 --- a/src/HOL/SEQ.thy Mon May 11 09:39:53 2009 +0200
124.2 +++ b/src/HOL/SEQ.thy Mon May 11 17:20:52 2009 +0200
124.3 @@ -487,7 +487,7 @@
124.4 by (simp add: LIMSEQ_mult LIMSEQ_inverse divide_inverse)
124.5
124.6 lemma LIMSEQ_pow:
124.7 - fixes a :: "'a::{real_normed_algebra,recpower}"
124.8 + fixes a :: "'a::{power, real_normed_algebra}"
124.9 shows "X ----> a \<Longrightarrow> (\<lambda>n. (X n) ^ m) ----> a ^ m"
124.10 by (induct m) (simp_all add: LIMSEQ_const LIMSEQ_mult)
124.11
124.12 @@ -1394,7 +1394,7 @@
124.13 qed
124.14
124.15 lemma LIMSEQ_power_zero:
124.16 - fixes x :: "'a::{real_normed_algebra_1,recpower}"
124.17 + fixes x :: "'a::{real_normed_algebra_1}"
124.18 shows "norm x < 1 \<Longrightarrow> (\<lambda>n. x ^ n) ----> 0"
124.19 apply (drule LIMSEQ_realpow_zero [OF norm_ge_zero])
124.20 apply (simp only: LIMSEQ_Zseq_iff, erule Zseq_le)
125.1 --- a/src/HOL/Series.thy Mon May 11 09:39:53 2009 +0200
125.2 +++ b/src/HOL/Series.thy Mon May 11 17:20:52 2009 +0200
125.3 @@ -331,7 +331,7 @@
125.4 lemmas sumr_geometric = geometric_sum [where 'a = real]
125.5
125.6 lemma geometric_sums:
125.7 - fixes x :: "'a::{real_normed_field,recpower}"
125.8 + fixes x :: "'a::{real_normed_field}"
125.9 shows "norm x < 1 \<Longrightarrow> (\<lambda>n. x ^ n) sums (1 / (1 - x))"
125.10 proof -
125.11 assume less_1: "norm x < 1"
125.12 @@ -348,7 +348,7 @@
125.13 qed
125.14
125.15 lemma summable_geometric:
125.16 - fixes x :: "'a::{real_normed_field,recpower}"
125.17 + fixes x :: "'a::{real_normed_field}"
125.18 shows "norm x < 1 \<Longrightarrow> summable (\<lambda>n. x ^ n)"
125.19 by (rule geometric_sums [THEN sums_summable])
125.20
125.21 @@ -434,7 +434,7 @@
125.22 text{*Summability of geometric series for real algebras*}
125.23
125.24 lemma complete_algebra_summable_geometric:
125.25 - fixes x :: "'a::{real_normed_algebra_1,banach,recpower}"
125.26 + fixes x :: "'a::{real_normed_algebra_1,banach}"
125.27 shows "norm x < 1 \<Longrightarrow> summable (\<lambda>n. x ^ n)"
125.28 proof (rule summable_comparison_test)
125.29 show "\<exists>N. \<forall>n\<ge>N. norm (x ^ n) \<le> norm x ^ n"
126.1 --- a/src/HOL/SetInterval.thy Mon May 11 09:39:53 2009 +0200
126.2 +++ b/src/HOL/SetInterval.thy Mon May 11 17:20:52 2009 +0200
126.3 @@ -397,6 +397,22 @@
126.4 apply (rule_tac [2] finite_lessThan, auto)
126.5 done
126.6
126.7 +text {* A set of natural numbers is finite iff it is bounded. *}
126.8 +lemma finite_nat_set_iff_bounded:
126.9 + "finite(N::nat set) = (EX m. ALL n:N. n<m)" (is "?F = ?B")
126.10 +proof
126.11 + assume f:?F show ?B
126.12 + using Max_ge[OF `?F`, simplified less_Suc_eq_le[symmetric]] by blast
126.13 +next
126.14 + assume ?B show ?F using `?B` by(blast intro:bounded_nat_set_is_finite)
126.15 +qed
126.16 +
126.17 +lemma finite_nat_set_iff_bounded_le:
126.18 + "finite(N::nat set) = (EX m. ALL n:N. n<=m)"
126.19 +apply(simp add:finite_nat_set_iff_bounded)
126.20 +apply(blast dest:less_imp_le_nat le_imp_less_Suc)
126.21 +done
126.22 +
126.23 lemma finite_less_ub:
126.24 "!!f::nat=>nat. (!!n. n \<le> f n) ==> finite {n. f n \<le> u}"
126.25 by (rule_tac B="{..u}" in finite_subset, auto intro: order_trans)
126.26 @@ -855,7 +871,7 @@
126.27
126.28 lemma geometric_sum:
126.29 "x ~= 1 ==> (\<Sum>i=0..<n. x ^ i) =
126.30 - (x ^ n - 1) / (x - 1::'a::{field, recpower})"
126.31 + (x ^ n - 1) / (x - 1::'a::{field})"
126.32 by (induct "n") (simp_all add:field_simps power_Suc)
126.33
126.34 subsection {* The formula for arithmetic sums *}
127.1 --- a/src/HOL/SizeChange/Graphs.thy Mon May 11 09:39:53 2009 +0200
127.2 +++ b/src/HOL/SizeChange/Graphs.thy Mon May 11 17:20:52 2009 +0200
127.3 @@ -228,18 +228,8 @@
127.4 qed
127.5 qed
127.6
127.7 -instantiation graph :: (type, monoid_mult) "{semiring_1, idem_add, recpower, star}"
127.8 -begin
127.9 -
127.10 -primrec power_graph :: "('a\<Colon>type, 'b\<Colon>monoid_mult) graph \<Rightarrow> nat => ('a, 'b) graph"
127.11 -where
127.12 - "(A \<Colon> ('a, 'b) graph) ^ 0 = 1"
127.13 -| "(A \<Colon> ('a, 'b) graph) ^ Suc n = A * (A ^ n)"
127.14 -
127.15 -definition
127.16 - graph_star_def: "star (G \<Colon> ('a, 'b) graph) = (SUP n. G ^ n)"
127.17 -
127.18 -instance proof
127.19 +instance graph :: (type, monoid_mult) "{semiring_1, idem_add}"
127.20 +proof
127.21 fix a b c :: "('a, 'b) graph"
127.22
127.23 show "1 * a = a"
127.24 @@ -258,10 +248,16 @@
127.25
127.26 show "a + a = a" unfolding graph_plus_def by simp
127.27
127.28 - show "a ^ 0 = 1" "\<And>n. a ^ (Suc n) = a * a ^ n"
127.29 - by simp_all
127.30 qed
127.31
127.32 +instantiation graph :: (type, monoid_mult) star
127.33 +begin
127.34 +
127.35 +definition
127.36 + graph_star_def: "star (G \<Colon> ('a, 'b) graph) = (SUP n. G ^ n)"
127.37 +
127.38 +instance ..
127.39 +
127.40 end
127.41
127.42 lemma graph_leqI:
127.43 @@ -351,7 +347,7 @@
127.44
127.45 lemma in_tcl:
127.46 "has_edge (tcl G) a x b = (\<exists>n>0. has_edge (G ^ n) a x b)"
127.47 - apply (auto simp: tcl_is_SUP in_SUP simp del: power_graph.simps power_Suc)
127.48 + apply (auto simp: tcl_is_SUP in_SUP simp del: power.simps power_Suc)
127.49 apply (rule_tac x = "n - 1" in exI, auto)
127.50 done
127.51
128.1 --- a/src/HOL/SizeChange/Interpretation.thy Mon May 11 09:39:53 2009 +0200
128.2 +++ b/src/HOL/SizeChange/Interpretation.thy Mon May 11 17:20:52 2009 +0200
128.3 @@ -35,7 +35,7 @@
128.4 and nia: "\<And>x. \<not>accp R x \<Longrightarrow> \<not>accp R (f x)"
128.5 by blast
128.6
128.7 - let ?s = "\<lambda>i. (f ^ i) x"
128.8 + let ?s = "\<lambda>i. (f ^^ i) x"
128.9
128.10 {
128.11 fix i
129.1 --- a/src/HOL/SizeChange/Kleene_Algebras.thy Mon May 11 09:39:53 2009 +0200
129.2 +++ b/src/HOL/SizeChange/Kleene_Algebras.thy Mon May 11 17:20:52 2009 +0200
129.3 @@ -97,7 +97,7 @@
129.4 and star4: "x * a \<le> x \<Longrightarrow> x * star a \<le> x"
129.5
129.6 class kleene_by_complete_lattice = pre_kleene
129.7 - + complete_lattice + recpower + star +
129.8 + + complete_lattice + power + star +
129.9 assumes star_cont: "a * star b * c = SUPR UNIV (\<lambda>n. a * b ^ n * c)"
129.10 begin
129.11
130.1 --- a/src/HOL/SizeChange/Size_Change_Termination.thy Mon May 11 09:39:53 2009 +0200
130.2 +++ b/src/HOL/SizeChange/Size_Change_Termination.thy Mon May 11 17:20:52 2009 +0200
130.3 @@ -1,5 +1,4 @@
130.4 (* Title: HOL/Library/Size_Change_Termination.thy
130.5 - ID: $Id$
130.6 Author: Alexander Krauss, TU Muenchen
130.7 *)
130.8
131.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
131.2 +++ b/src/HOL/String.thy Mon May 11 17:20:52 2009 +0200
131.3 @@ -0,0 +1,150 @@
131.4 +(* Author: Tobias Nipkow, Florian Haftmann, TU Muenchen *)
131.5 +
131.6 +header {* Character and string types *}
131.7 +
131.8 +theory String
131.9 +imports List
131.10 +uses
131.11 + "Tools/string_syntax.ML"
131.12 + ("Tools/string_code.ML")
131.13 +begin
131.14 +
131.15 +subsection {* Characters *}
131.16 +
131.17 +datatype nibble =
131.18 + Nibble0 | Nibble1 | Nibble2 | Nibble3 | Nibble4 | Nibble5 | Nibble6 | Nibble7
131.19 + | Nibble8 | Nibble9 | NibbleA | NibbleB | NibbleC | NibbleD | NibbleE | NibbleF
131.20 +
131.21 +lemma UNIV_nibble:
131.22 + "UNIV = {Nibble0, Nibble1, Nibble2, Nibble3, Nibble4, Nibble5, Nibble6, Nibble7,
131.23 + Nibble8, Nibble9, NibbleA, NibbleB, NibbleC, NibbleD, NibbleE, NibbleF}" (is "_ = ?A")
131.24 +proof (rule UNIV_eq_I)
131.25 + fix x show "x \<in> ?A" by (cases x) simp_all
131.26 +qed
131.27 +
131.28 +instance nibble :: finite
131.29 + by default (simp add: UNIV_nibble)
131.30 +
131.31 +datatype char = Char nibble nibble
131.32 + -- "Note: canonical order of character encoding coincides with standard term ordering"
131.33 +
131.34 +lemma UNIV_char:
131.35 + "UNIV = image (split Char) (UNIV \<times> UNIV)"
131.36 +proof (rule UNIV_eq_I)
131.37 + fix x show "x \<in> image (split Char) (UNIV \<times> UNIV)" by (cases x) auto
131.38 +qed
131.39 +
131.40 +instance char :: finite
131.41 + by default (simp add: UNIV_char)
131.42 +
131.43 +lemma size_char [code, simp]:
131.44 + "size (c::char) = 0" by (cases c) simp
131.45 +
131.46 +lemma char_size [code, simp]:
131.47 + "char_size (c::char) = 0" by (cases c) simp
131.48 +
131.49 +primrec nibble_pair_of_char :: "char \<Rightarrow> nibble \<times> nibble" where
131.50 + "nibble_pair_of_char (Char n m) = (n, m)"
131.51 +
131.52 +declare nibble_pair_of_char.simps [code del]
131.53 +
131.54 +setup {*
131.55 +let
131.56 + val nibbles = map (Thm.cterm_of @{theory} o HOLogic.mk_nibble) (0 upto 15);
131.57 + val thms = map_product
131.58 + (fn n => fn m => Drule.instantiate' [] [SOME n, SOME m] @{thm nibble_pair_of_char.simps})
131.59 + nibbles nibbles;
131.60 +in
131.61 + PureThy.note_thmss Thm.lemmaK [((Binding.name "nibble_pair_of_char_simps", []), [(thms, [])])]
131.62 + #-> (fn [(_, thms)] => fold_rev Code.add_eqn thms)
131.63 +end
131.64 +*}
131.65 +
131.66 +lemma char_case_nibble_pair [code, code inline]:
131.67 + "char_case f = split f o nibble_pair_of_char"
131.68 + by (simp add: expand_fun_eq split: char.split)
131.69 +
131.70 +lemma char_rec_nibble_pair [code, code inline]:
131.71 + "char_rec f = split f o nibble_pair_of_char"
131.72 + unfolding char_case_nibble_pair [symmetric]
131.73 + by (simp add: expand_fun_eq split: char.split)
131.74 +
131.75 +syntax
131.76 + "_Char" :: "xstr => char" ("CHR _")
131.77 +
131.78 +
131.79 +subsection {* Strings *}
131.80 +
131.81 +types string = "char list"
131.82 +
131.83 +syntax
131.84 + "_String" :: "xstr => string" ("_")
131.85 +
131.86 +setup StringSyntax.setup
131.87 +
131.88 +
131.89 +subsection {* Strings as dedicated datatype *}
131.90 +
131.91 +datatype message_string = STR string
131.92 +
131.93 +lemmas [code del] =
131.94 + message_string.recs message_string.cases
131.95 +
131.96 +lemma [code]: "size (s\<Colon>message_string) = 0"
131.97 + by (cases s) simp_all
131.98 +
131.99 +lemma [code]: "message_string_size (s\<Colon>message_string) = 0"
131.100 + by (cases s) simp_all
131.101 +
131.102 +
131.103 +subsection {* Code generator *}
131.104 +
131.105 +use "Tools/string_code.ML"
131.106 +
131.107 +code_type message_string
131.108 + (SML "string")
131.109 + (OCaml "string")
131.110 + (Haskell "String")
131.111 +
131.112 +setup {*
131.113 + fold String_Code.add_literal_message ["SML", "OCaml", "Haskell"]
131.114 +*}
131.115 +
131.116 +code_instance message_string :: eq
131.117 + (Haskell -)
131.118 +
131.119 +code_const "eq_class.eq \<Colon> message_string \<Rightarrow> message_string \<Rightarrow> bool"
131.120 + (SML "!((_ : string) = _)")
131.121 + (OCaml "!((_ : string) = _)")
131.122 + (Haskell infixl 4 "==")
131.123 +
131.124 +code_reserved SML string
131.125 +code_reserved OCaml string
131.126 +
131.127 +
131.128 +types_code
131.129 + "char" ("string")
131.130 +attach (term_of) {*
131.131 +val term_of_char = HOLogic.mk_char o ord;
131.132 +*}
131.133 +attach (test) {*
131.134 +fun gen_char i =
131.135 + let val j = random_range (ord "a") (Int.min (ord "a" + i, ord "z"))
131.136 + in (chr j, fn () => HOLogic.mk_char j) end;
131.137 +*}
131.138 +
131.139 +setup {*
131.140 +let
131.141 +
131.142 +fun char_codegen thy defs dep thyname b t gr =
131.143 + let
131.144 + val i = HOLogic.dest_char t;
131.145 + val (_, gr') = Codegen.invoke_tycodegen thy defs dep thyname false
131.146 + (fastype_of t) gr;
131.147 + in SOME (Codegen.str (ML_Syntax.print_string (chr i)), gr')
131.148 + end handle TERM _ => NONE;
131.149 +
131.150 +in Codegen.add_codegen "char_codegen" char_codegen end
131.151 +*}
131.152 +
131.153 +end
131.154 \ No newline at end of file
132.1 --- a/src/HOL/Sum_Type.thy Mon May 11 09:39:53 2009 +0200
132.2 +++ b/src/HOL/Sum_Type.thy Mon May 11 17:20:52 2009 +0200
132.3 @@ -157,6 +157,8 @@
132.4 apply auto
132.5 done
132.6
132.7 +lemma Plus_eq_empty_conv[simp]: "A <+> B = {} \<longleftrightarrow> A = {} \<and> B = {}"
132.8 +by(auto)
132.9
132.10 subsection{*The @{term Part} Primitive*}
132.11
133.1 --- a/src/HOL/Tools/Qelim/presburger.ML Mon May 11 09:39:53 2009 +0200
133.2 +++ b/src/HOL/Tools/Qelim/presburger.ML Mon May 11 17:20:52 2009 +0200
133.3 @@ -131,7 +131,7 @@
133.4 @{thm "div_0"}, @{thm "mod_0"}, @{thm "div_by_1"}, @{thm "mod_by_1"}, @{thm "div_1"},
133.5 @{thm "mod_1"}, @{thm "Suc_plus1"}]
133.6 @ @{thms add_ac}
133.7 - addsimprocs [cancel_div_mod_proc]
133.8 + addsimprocs [cancel_div_mod_nat_proc, cancel_div_mod_int_proc]
133.9 val splits_ss = comp_ss addsimps [@{thm "mod_div_equality'"}] addsplits
133.10 [@{thm "split_zdiv"}, @{thm "split_zmod"}, @{thm "split_div'"},
133.11 @{thm "split_min"}, @{thm "split_max"}, @{thm "abs_split"}]
134.1 --- a/src/HOL/Tools/atp_manager.ML Mon May 11 09:39:53 2009 +0200
134.2 +++ b/src/HOL/Tools/atp_manager.ML Mon May 11 17:20:52 2009 +0200
134.3 @@ -19,9 +19,11 @@
134.4 val kill: unit -> unit
134.5 val info: unit -> unit
134.6 val messages: int option -> unit
134.7 - type prover = int -> int -> Proof.context * (thm list * thm) -> bool * string
134.8 + type prover = int -> (thm * (string * int)) list option -> string -> int ->
134.9 + Proof.context * (thm list * thm) -> bool * string * string * string vector
134.10 val add_prover: string -> prover -> theory -> theory
134.11 val print_provers: theory -> unit
134.12 + val get_prover: string -> theory -> prover option
134.13 val sledgehammer: string list -> Proof.state -> unit
134.14 end;
134.15
134.16 @@ -51,15 +53,17 @@
134.17 fun set_timeout time = CRITICAL (fn () => timeout := time);
134.18
134.19 val _ =
134.20 - ProofGeneralPgip.add_preference "Proof"
134.21 + ProofGeneralPgip.add_preference Preferences.category_proof
134.22 (Preferences.string_pref atps
134.23 "ATP: provers" "Default automatic provers (separated by whitespace)");
134.24
134.25 -val _ = ProofGeneralPgip.add_preference "Proof"
134.26 +val _ =
134.27 + ProofGeneralPgip.add_preference Preferences.category_proof
134.28 (Preferences.int_pref max_atps
134.29 "ATP: maximum number" "How many provers may run in parallel");
134.30
134.31 -val _ = ProofGeneralPgip.add_preference "Proof"
134.32 +val _ =
134.33 + ProofGeneralPgip.add_preference Preferences.category_proof
134.34 (Preferences.int_pref timeout
134.35 "ATP: timeout" "ATPs will be interrupted after this time (in seconds)");
134.36
134.37 @@ -284,7 +288,8 @@
134.38
134.39 (* named provers *)
134.40
134.41 -type prover = int -> int -> Proof.context * (thm list * thm) -> bool * string;
134.42 +type prover = int -> (thm * (string * int)) list option -> string -> int ->
134.43 + Proof.context * (thm list * thm) -> bool * string * string * string vector
134.44
134.45 fun err_dup_prover name = error ("Duplicate prover: " ^ quote name);
134.46
134.47 @@ -305,13 +310,16 @@
134.48 fun print_provers thy = Pretty.writeln
134.49 (Pretty.strs ("external provers:" :: sort_strings (Symtab.keys (Provers.get thy))));
134.50
134.51 +fun get_prover name thy = case Symtab.lookup (Provers.get thy) name of
134.52 + NONE => NONE
134.53 +| SOME (prover, _) => SOME prover;
134.54
134.55 (* start prover thread *)
134.56
134.57 fun start_prover name birthtime deadtime i proof_state =
134.58 - (case Symtab.lookup (Provers.get (Proof.theory_of proof_state)) name of
134.59 + (case get_prover name (Proof.theory_of proof_state) of
134.60 NONE => warning ("Unknown external prover: " ^ quote name)
134.61 - | SOME (prover, _) =>
134.62 + | SOME prover =>
134.63 let
134.64 val (ctxt, (_, goal)) = Proof.get_goal proof_state
134.65 val desc =
134.66 @@ -320,7 +328,10 @@
134.67 val _ = SimpleThread.fork true (fn () =>
134.68 let
134.69 val _ = register birthtime deadtime (Thread.self (), desc)
134.70 - val result = prover (get_timeout ()) i (Proof.get_goal proof_state)
134.71 + val result =
134.72 + let val (success, message, _, _) =
134.73 + prover (get_timeout ()) NONE name i (Proof.get_goal proof_state)
134.74 + in (success, message) end
134.75 handle ResHolClause.TOO_TRIVIAL
134.76 => (true, "Empty clause: Try this command: " ^ Markup.markup Markup.sendback "apply metis")
134.77 | ERROR msg
135.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
135.2 +++ b/src/HOL/Tools/atp_minimal.ML Mon May 11 17:20:52 2009 +0200
135.3 @@ -0,0 +1,201 @@
135.4 +(* Title: HOL/Tools/atp_minimal.ML
135.5 + Author: Philipp Meyer, TU Muenchen
135.6 +
135.7 +Minimalization of theorem list for metis by using an external automated theorem prover
135.8 +*)
135.9 +
135.10 +structure AtpMinimal =
135.11 +struct
135.12 +
135.13 + (* output control *)
135.14 + fun debug str = Output.debug (fn () => str)
135.15 + fun debug_fn f = if !Output.debugging then f() else ()
135.16 + fun answer str = Output.writeln str
135.17 + fun println str = Output.priority str
135.18 +
135.19 + fun order_unique name_list = OrdList.make (String.collate Char.compare) name_list
135.20 + fun length_string namelist = Int.toString (length namelist)
135.21 +
135.22 + fun print_names name_thms_pairs =
135.23 + let
135.24 + val names = (map fst name_thms_pairs)
135.25 + val ordered = order_unique names
135.26 + in
135.27 + app (fn name => (debug (" " ^ name))) ordered
135.28 + end
135.29 +
135.30 + (* minimalization algorithm *)
135.31 + local
135.32 + fun isplit (l,r) [] = (l,r)
135.33 + | isplit (l,r) (h::[]) = (h::l, r)
135.34 + | isplit (l,r) (h1::h2::t) = isplit (h1::l, h2::r) t
135.35 + in
135.36 + fun split lst = isplit ([],[]) lst
135.37 + end
135.38 +
135.39 + local
135.40 + fun min p sup [] = raise Empty
135.41 + | min p sup [s0] = [s0]
135.42 + | min p sup s =
135.43 + let
135.44 + val (l0, r0) = split s
135.45 + in
135.46 + if p(sup @ l0)
135.47 + then min p sup l0
135.48 + else
135.49 + if p(sup @ r0)
135.50 + then min p sup r0
135.51 + else
135.52 + let
135.53 + val l = min p (sup @ r0) l0
135.54 + val r = min p (sup @ l) r0
135.55 + in
135.56 + l @ r
135.57 + end
135.58 + end
135.59 + in
135.60 + (* return a minimal subset v of s that satisfies p
135.61 + @pre p(s) & ~p([]) & monotone(p)
135.62 + @post v subset s & p(v) &
135.63 + forall e in v. ~p(v \ e)
135.64 + *)
135.65 + fun minimal p s = min p [] s
135.66 + end
135.67 +
135.68 + (* failure check and producing answer*)
135.69 + datatype 'a prove_result = Success of 'a | Failure | Timeout | Error
135.70 +
135.71 + val string_of_result = fn
135.72 + Success _ => "Success"
135.73 + | Failure => "Failure"
135.74 + | Timeout => "Timeout"
135.75 + | Error => "Error"
135.76 +
135.77 + val failure_strings =
135.78 + [("SPASS beiseite: Ran out of time.", Timeout),
135.79 + ("Timeout", Timeout),
135.80 + ("time limit exceeded", Timeout),
135.81 + ("# Cannot determine problem status within resource limit", Timeout),
135.82 + ("Error", Error)]
135.83 +
135.84 + fun produce_answer (success, message, result_string, thm_name_vec) =
135.85 + if success then
135.86 + (Success (Vector.foldr op:: [] thm_name_vec), result_string)
135.87 + else
135.88 + let
135.89 + val failure = get_first (fn (s, t) => if String.isSubstring s result_string then SOME (t, result_string) else NONE) failure_strings
135.90 + in
135.91 + if is_some failure then
135.92 + the failure
135.93 + else
135.94 + (Failure, result_string)
135.95 + end
135.96 +
135.97 + (* wrapper for calling external prover *)
135.98 + fun sh_test_thms prover prover_name time_limit subgoalno state name_thms_pairs =
135.99 + let
135.100 + val _ = println ("Testing " ^ (length_string name_thms_pairs) ^ " theorems... ")
135.101 + val name_thm_pairs = flat (map (fn (n, ths) => map_index (fn (i, th) => (n, th)) ths) name_thms_pairs)
135.102 + val _ = debug_fn (fn () => print_names name_thm_pairs)
135.103 + val axclauses = ResAxioms.cnf_rules_pairs (Proof.theory_of state) name_thm_pairs
135.104 + val (result, proof) =
135.105 + (produce_answer (prover time_limit (SOME axclauses) prover_name subgoalno (Proof.get_goal state)))
135.106 + val _ = println (string_of_result result)
135.107 + val _ = debug proof
135.108 + in
135.109 + (result, proof)
135.110 + end
135.111 +
135.112 + (* minimalization of thms *)
135.113 + fun minimalize prover prover_name time_limit state name_thms_pairs =
135.114 + let
135.115 + val _ = println ("Minimize called with " ^ (length_string name_thms_pairs) ^ " theorems, prover: "
135.116 + ^ prover_name ^ ", time limit: " ^ (Int.toString time_limit) ^ " seconds")
135.117 + val _ = debug_fn (fn () => app (fn (n, tl) => (debug n; app (fn t => debug (" " ^ Display.string_of_thm t)) tl)) name_thms_pairs)
135.118 + val test_thms_fun = sh_test_thms prover prover_name time_limit 1 state
135.119 + fun test_thms thms = case test_thms_fun thms of (Success _, _) => true | _ => false
135.120 + in
135.121 + (* try proove first to check result and get used theorems *)
135.122 + (case test_thms_fun name_thms_pairs of
135.123 + (Success used, _) =>
135.124 + let
135.125 + val ordered_used = order_unique used
135.126 + val to_use =
135.127 + if length ordered_used < length name_thms_pairs then
135.128 + filter (fn (name1, _) => List.exists (equal name1) ordered_used) name_thms_pairs
135.129 + else
135.130 + name_thms_pairs
135.131 + val min_thms = (minimal test_thms to_use)
135.132 + val min_names = order_unique (map fst min_thms)
135.133 + val _ = println ("Minimal " ^ (length_string min_thms) ^ " theorems")
135.134 + val _ = debug_fn (fn () => print_names min_thms)
135.135 + in
135.136 + answer ("Try this command: " ^ Markup.markup Markup.sendback ("apply (metis " ^ (space_implode " " min_names) ^ ")"))
135.137 + end
135.138 + | (Timeout, _) =>
135.139 + answer ("Timeout: You may need to increase the time limit of " ^ (Int.toString time_limit) ^ " seconds. Call atp_minimize [time=...] ")
135.140 + | (Error, msg) =>
135.141 + answer ("Error in prover: " ^ msg)
135.142 + | (Failure, _) =>
135.143 + answer "Failure: No proof with the theorems supplied")
135.144 + handle ResHolClause.TOO_TRIVIAL =>
135.145 + answer ("Trivial: Try this command: " ^ Markup.markup Markup.sendback "apply metis")
135.146 + | ERROR msg =>
135.147 + answer ("Error: " ^ msg)
135.148 + end
135.149 +
135.150 + (* isar command and parsing input *)
135.151 +
135.152 + local structure K = OuterKeyword and P = OuterParse and T = OuterLex in
135.153 +
135.154 + fun get_thms context =
135.155 + map (fn (name, interval) =>
135.156 + let
135.157 + val thmref = Facts.Named ((name, Position.none), interval)
135.158 + val ths = ProofContext.get_fact context thmref
135.159 + val name' = Facts.string_of_ref thmref
135.160 + in
135.161 + (name', ths)
135.162 + end)
135.163 +
135.164 + val default_prover = "remote_vampire"
135.165 + val default_time_limit = 5
135.166 +
135.167 + fun get_time_limit_arg time_string =
135.168 + (case Int.fromString time_string of
135.169 + SOME t => t
135.170 + | NONE => error ("Invalid time limit: " ^ quote time_string))
135.171 +
135.172 + val get_options =
135.173 + let
135.174 + val def = (default_prover, default_time_limit)
135.175 + in
135.176 + foldl (fn ((name, a), (p, t)) => (case name of
135.177 + "time" => (p, (get_time_limit_arg a))
135.178 + | "atp" => (a, t)
135.179 + | n => error ("Invalid argument: " ^ n))) def
135.180 + end
135.181 +
135.182 + fun sh_min_command args thm_names state =
135.183 + let
135.184 + val (prover_name, time_limit) = get_options args
135.185 + val prover =
135.186 + case AtpManager.get_prover prover_name (Proof.theory_of state) of
135.187 + SOME prover => prover
135.188 + | NONE => error ("Unknown prover: " ^ quote prover_name)
135.189 + val name_thms_pairs = get_thms (Proof.context_of state) thm_names
135.190 + in
135.191 + minimalize prover prover_name time_limit state name_thms_pairs
135.192 + end
135.193 +
135.194 + val parse_args = Scan.optional (Args.bracks (P.list (P.xname --| P.$$$ "=" -- P.xname) )) []
135.195 + val parse_thm_names = Scan.repeat (P.xname -- Scan.option Attrib.thm_sel)
135.196 +
135.197 + val _ =
135.198 + OuterSyntax.command "atp_minimize" "minimize theorem list with external prover" K.diag
135.199 + (parse_args -- parse_thm_names >> (fn (args, thm_names) =>
135.200 + Toplevel.no_timing o Toplevel.unknown_proof o Toplevel.keep ((sh_min_command args thm_names) o Toplevel.proof_of)))
135.201 +
135.202 + end
135.203 +end
135.204 +
136.1 --- a/src/HOL/Tools/atp_wrapper.ML Mon May 11 09:39:53 2009 +0200
136.2 +++ b/src/HOL/Tools/atp_wrapper.ML Mon May 11 17:20:52 2009 +0200
136.3 @@ -1,5 +1,4 @@
136.4 (* Title: HOL/Tools/atp_wrapper.ML
136.5 - ID: $Id$
136.6 Author: Fabian Immler, TU Muenchen
136.7
136.8 Wrapper functions for external ATPs.
136.9 @@ -10,10 +9,10 @@
136.10 val destdir: string ref
136.11 val problem_name: string ref
136.12 val external_prover:
136.13 - (thm * (string * int)) list ->
136.14 + (unit -> (thm * (string * int)) list) ->
136.15 (Path.T -> thm -> int -> (thm * (string * int)) list -> theory -> string vector) ->
136.16 Path.T * string -> (string -> string option) ->
136.17 - (string * string vector * Proof.context * thm * int -> string) ->
136.18 + (string -> string * string vector * Proof.context * thm * int -> string) ->
136.19 AtpManager.prover
136.20 val tptp_prover_opts_full: int -> bool -> bool -> Path.T * string -> AtpManager.prover
136.21 val tptp_prover_opts: int -> bool -> Path.T * string -> AtpManager.prover
136.22 @@ -47,7 +46,8 @@
136.23
136.24 (* basic template *)
136.25
136.26 -fun external_prover axiom_clauses write_problem_file (cmd, args) find_failure produce_answer timeout subgoalno goal =
136.27 +fun external_prover relevance_filter write_problem_file (cmd, args) find_failure produce_answer
136.28 + timeout axiom_clauses name subgoalno goal =
136.29 let
136.30 (* path to unique problem file *)
136.31 val destdir' = ! destdir
136.32 @@ -66,7 +66,8 @@
136.33 val chain_ths = map (Thm.put_name_hint ResReconstruct.chained_hint) chain_ths
136.34 val probfile = prob_pathname subgoalno
136.35 val fname = File.platform_path probfile
136.36 - val thm_names = write_problem_file probfile th subgoalno axiom_clauses thy
136.37 + val the_ax_clauses = case axiom_clauses of NONE => relevance_filter () | SOME axcls => axcls
136.38 + val thm_names = write_problem_file probfile th subgoalno the_ax_clauses thy
136.39 val cmdline =
136.40 if File.exists cmd then "exec " ^ File.shell_path cmd ^ " " ^ args
136.41 else error ("Bad executable: " ^ Path.implode cmd)
136.42 @@ -81,7 +82,7 @@
136.43 val message =
136.44 if is_some failure then "External prover failed."
136.45 else if rc <> 0 then "External prover failed: " ^ proof
136.46 - else "Try this command: " ^ produce_answer (proof, thm_names, ctxt, th, subgoalno)
136.47 + else "Try this command: " ^ produce_answer name (proof, thm_names, ctxt, th, subgoalno)
136.48
136.49 val _ =
136.50 if is_some failure
136.51 @@ -91,7 +92,7 @@
136.52 if rc <> 0
136.53 then Output.debug (fn () => "Sledgehammer exited with return code " ^ string_of_int rc ^ ":\n" ^ proof)
136.54 else ()
136.55 - in (success, message) end;
136.56 + in (success, message, proof, thm_names) end;
136.57
136.58
136.59
136.60 @@ -99,14 +100,14 @@
136.61
136.62 (* generic TPTP-based provers *)
136.63
136.64 -fun tptp_prover_opts_full max_new theory_const full command timeout n goal =
136.65 +fun tptp_prover_opts_full max_new theory_const full command timeout ax_clauses name n goal =
136.66 external_prover
136.67 - (ResAtp.get_relevant max_new theory_const goal n)
136.68 + (fn () => ResAtp.get_relevant max_new theory_const goal n)
136.69 (ResAtp.write_problem_file false)
136.70 command
136.71 ResReconstruct.find_failure
136.72 (if full then ResReconstruct.structured_proof else ResReconstruct.lemma_list_tstp)
136.73 - timeout n goal;
136.74 + timeout ax_clauses name n goal;
136.75
136.76 (*arbitrary ATP with TPTP input/output and problemfile as last argument*)
136.77 fun tptp_prover_opts max_new theory_const =
136.78 @@ -163,14 +164,14 @@
136.79
136.80 (* SPASS *)
136.81
136.82 -fun spass_opts max_new theory_const timeout n goal = external_prover
136.83 - (ResAtp.get_relevant max_new theory_const goal n)
136.84 +fun spass_opts max_new theory_const timeout ax_clauses name n goal = external_prover
136.85 + (fn () => ResAtp.get_relevant max_new theory_const goal n)
136.86 (ResAtp.write_problem_file true)
136.87 (Path.explode "$SPASS_HOME/SPASS",
136.88 "-Auto -SOS=1 -PGiven=0 -PProblem=0 -Splits=0 -FullRed=0 -DocProof -TimeLimit=" ^ string_of_int timeout)
136.89 ResReconstruct.find_failure
136.90 ResReconstruct.lemma_list_dfg
136.91 - timeout n goal;
136.92 + timeout ax_clauses name n goal;
136.93
136.94 val spass = spass_opts 40 true;
136.95
136.96 @@ -179,7 +180,7 @@
136.97
136.98 fun remote_prover_opts max_new theory_const args timeout =
136.99 tptp_prover_opts max_new theory_const
136.100 - (Path.explode "$ISABELLE_HOME/contrib/SystemOnTPTP/remote", args ^ " -t " ^ string_of_int timeout)
136.101 + (Path.explode "$ISABELLE_HOME/lib/scripts/SystemOnTPTP", args ^ " -t " ^ string_of_int timeout)
136.102 timeout;
136.103
136.104 val remote_prover = remote_prover_opts 60 false;
137.1 --- a/src/HOL/Tools/hologic.ML Mon May 11 09:39:53 2009 +0200
137.2 +++ b/src/HOL/Tools/hologic.ML Mon May 11 17:20:52 2009 +0200
137.3 @@ -116,6 +116,9 @@
137.4 val stringT: typ
137.5 val mk_string: string -> term
137.6 val dest_string: term -> string
137.7 + val message_stringT: typ
137.8 + val mk_message_string: string -> term
137.9 + val dest_message_string: term -> string
137.10 end;
137.11
137.12 structure HOLogic: HOLOGIC =
137.13 @@ -510,44 +513,6 @@
137.14 val realT = Type ("RealDef.real", []);
137.15
137.16
137.17 -(* nibble *)
137.18 -
137.19 -val nibbleT = Type ("List.nibble", []);
137.20 -
137.21 -fun mk_nibble n =
137.22 - let val s =
137.23 - if 0 <= n andalso n <= 9 then chr (n + ord "0")
137.24 - else if 10 <= n andalso n <= 15 then chr (n + ord "A" - 10)
137.25 - else raise TERM ("mk_nibble", [])
137.26 - in Const ("List.nibble.Nibble" ^ s, nibbleT) end;
137.27 -
137.28 -fun dest_nibble t =
137.29 - let fun err () = raise TERM ("dest_nibble", [t]) in
137.30 - (case try (unprefix "List.nibble.Nibble" o fst o Term.dest_Const) t of
137.31 - NONE => err ()
137.32 - | SOME c =>
137.33 - if size c <> 1 then err ()
137.34 - else if "0" <= c andalso c <= "9" then ord c - ord "0"
137.35 - else if "A" <= c andalso c <= "F" then ord c - ord "A" + 10
137.36 - else err ())
137.37 - end;
137.38 -
137.39 -
137.40 -(* char *)
137.41 -
137.42 -val charT = Type ("List.char", []);
137.43 -
137.44 -fun mk_char n =
137.45 - if 0 <= n andalso n <= 255 then
137.46 - Const ("List.char.Char", nibbleT --> nibbleT --> charT) $
137.47 - mk_nibble (n div 16) $ mk_nibble (n mod 16)
137.48 - else raise TERM ("mk_char", []);
137.49 -
137.50 -fun dest_char (Const ("List.char.Char", _) $ t $ u) =
137.51 - dest_nibble t * 16 + dest_nibble u
137.52 - | dest_char t = raise TERM ("dest_char", [t]);
137.53 -
137.54 -
137.55 (* list *)
137.56
137.57 fun listT T = Type ("List.list", [T]);
137.58 @@ -570,11 +535,60 @@
137.59 | dest_list t = raise TERM ("dest_list", [t]);
137.60
137.61
137.62 +(* nibble *)
137.63 +
137.64 +val nibbleT = Type ("String.nibble", []);
137.65 +
137.66 +fun mk_nibble n =
137.67 + let val s =
137.68 + if 0 <= n andalso n <= 9 then chr (n + ord "0")
137.69 + else if 10 <= n andalso n <= 15 then chr (n + ord "A" - 10)
137.70 + else raise TERM ("mk_nibble", [])
137.71 + in Const ("String.nibble.Nibble" ^ s, nibbleT) end;
137.72 +
137.73 +fun dest_nibble t =
137.74 + let fun err () = raise TERM ("dest_nibble", [t]) in
137.75 + (case try (unprefix "String.nibble.Nibble" o fst o Term.dest_Const) t of
137.76 + NONE => err ()
137.77 + | SOME c =>
137.78 + if size c <> 1 then err ()
137.79 + else if "0" <= c andalso c <= "9" then ord c - ord "0"
137.80 + else if "A" <= c andalso c <= "F" then ord c - ord "A" + 10
137.81 + else err ())
137.82 + end;
137.83 +
137.84 +
137.85 +(* char *)
137.86 +
137.87 +val charT = Type ("String.char", []);
137.88 +
137.89 +fun mk_char n =
137.90 + if 0 <= n andalso n <= 255 then
137.91 + Const ("String.char.Char", nibbleT --> nibbleT --> charT) $
137.92 + mk_nibble (n div 16) $ mk_nibble (n mod 16)
137.93 + else raise TERM ("mk_char", []);
137.94 +
137.95 +fun dest_char (Const ("String.char.Char", _) $ t $ u) =
137.96 + dest_nibble t * 16 + dest_nibble u
137.97 + | dest_char t = raise TERM ("dest_char", [t]);
137.98 +
137.99 +
137.100 (* string *)
137.101
137.102 -val stringT = Type ("List.string", []);
137.103 +val stringT = Type ("String.string", []);
137.104
137.105 val mk_string = mk_list charT o map (mk_char o ord) o explode;
137.106 val dest_string = implode o map (chr o dest_char) o dest_list;
137.107
137.108 +
137.109 +(* message_string *)
137.110 +
137.111 +val message_stringT = Type ("String.message_string", []);
137.112 +
137.113 +fun mk_message_string s = Const ("String.message_string.STR", stringT --> message_stringT)
137.114 + $ mk_string s;
137.115 +fun dest_message_string (Const ("String.message_string.STR", _) $ t) =
137.116 + dest_string t
137.117 + | dest_message_string t = raise TERM ("dest_message_string", [t]);
137.118 +
137.119 end;
138.1 --- a/src/HOL/Tools/int_arith.ML Mon May 11 09:39:53 2009 +0200
138.2 +++ b/src/HOL/Tools/int_arith.ML Mon May 11 17:20:52 2009 +0200
138.3 @@ -1,442 +1,15 @@
138.4 -(* Authors: Larry Paulson and Tobias Nipkow
138.5 +(* Author: Tobias Nipkow
138.6
138.7 -Simprocs and decision procedure for numerals and linear arithmetic.
138.8 -*)
138.9 -
138.10 -structure Int_Numeral_Simprocs =
138.11 -struct
138.12 -
138.13 -(*reorientation simprules using ==, for the following simproc*)
138.14 -val meta_zero_reorient = @{thm zero_reorient} RS eq_reflection
138.15 -val meta_one_reorient = @{thm one_reorient} RS eq_reflection
138.16 -val meta_number_of_reorient = @{thm number_of_reorient} RS eq_reflection
138.17 -
138.18 -(*reorientation simplification procedure: reorients (polymorphic)
138.19 - 0 = x, 1 = x, nnn = x provided x isn't 0, 1 or a Int.*)
138.20 -fun reorient_proc sg _ (_ $ t $ u) =
138.21 - case u of
138.22 - Const(@{const_name HOL.zero}, _) => NONE
138.23 - | Const(@{const_name HOL.one}, _) => NONE
138.24 - | Const(@{const_name Int.number_of}, _) $ _ => NONE
138.25 - | _ => SOME (case t of
138.26 - Const(@{const_name HOL.zero}, _) => meta_zero_reorient
138.27 - | Const(@{const_name HOL.one}, _) => meta_one_reorient
138.28 - | Const(@{const_name Int.number_of}, _) $ _ => meta_number_of_reorient)
138.29 -
138.30 -val reorient_simproc =
138.31 - Arith_Data.prep_simproc ("reorient_simproc", ["0=x", "1=x", "number_of w = x"], reorient_proc);
138.32 -
138.33 -
138.34 -(** Utilities **)
138.35 -
138.36 -fun mk_number T n = HOLogic.number_of_const T $ HOLogic.mk_numeral n;
138.37 -
138.38 -fun find_first_numeral past (t::terms) =
138.39 - ((snd (HOLogic.dest_number t), rev past @ terms)
138.40 - handle TERM _ => find_first_numeral (t::past) terms)
138.41 - | find_first_numeral past [] = raise TERM("find_first_numeral", []);
138.42 -
138.43 -val mk_plus = HOLogic.mk_binop @{const_name HOL.plus};
138.44 -
138.45 -fun mk_minus t =
138.46 - let val T = Term.fastype_of t
138.47 - in Const (@{const_name HOL.uminus}, T --> T) $ t end;
138.48 -
138.49 -(*Thus mk_sum[t] yields t+0; longer sums don't have a trailing zero*)
138.50 -fun mk_sum T [] = mk_number T 0
138.51 - | mk_sum T [t,u] = mk_plus (t, u)
138.52 - | mk_sum T (t :: ts) = mk_plus (t, mk_sum T ts);
138.53 -
138.54 -(*this version ALWAYS includes a trailing zero*)
138.55 -fun long_mk_sum T [] = mk_number T 0
138.56 - | long_mk_sum T (t :: ts) = mk_plus (t, mk_sum T ts);
138.57 -
138.58 -val dest_plus = HOLogic.dest_bin @{const_name HOL.plus} Term.dummyT;
138.59 -
138.60 -(*decompose additions AND subtractions as a sum*)
138.61 -fun dest_summing (pos, Const (@{const_name HOL.plus}, _) $ t $ u, ts) =
138.62 - dest_summing (pos, t, dest_summing (pos, u, ts))
138.63 - | dest_summing (pos, Const (@{const_name HOL.minus}, _) $ t $ u, ts) =
138.64 - dest_summing (pos, t, dest_summing (not pos, u, ts))
138.65 - | dest_summing (pos, t, ts) =
138.66 - if pos then t::ts else mk_minus t :: ts;
138.67 -
138.68 -fun dest_sum t = dest_summing (true, t, []);
138.69 -
138.70 -val mk_diff = HOLogic.mk_binop @{const_name HOL.minus};
138.71 -val dest_diff = HOLogic.dest_bin @{const_name HOL.minus} Term.dummyT;
138.72 -
138.73 -val mk_times = HOLogic.mk_binop @{const_name HOL.times};
138.74 -
138.75 -fun one_of T = Const(@{const_name HOL.one},T);
138.76 -
138.77 -(* build product with trailing 1 rather than Numeral 1 in order to avoid the
138.78 - unnecessary restriction to type class number_ring
138.79 - which is not required for cancellation of common factors in divisions.
138.80 -*)
138.81 -fun mk_prod T =
138.82 - let val one = one_of T
138.83 - fun mk [] = one
138.84 - | mk [t] = t
138.85 - | mk (t :: ts) = if t = one then mk ts else mk_times (t, mk ts)
138.86 - in mk end;
138.87 -
138.88 -(*This version ALWAYS includes a trailing one*)
138.89 -fun long_mk_prod T [] = one_of T
138.90 - | long_mk_prod T (t :: ts) = mk_times (t, mk_prod T ts);
138.91 -
138.92 -val dest_times = HOLogic.dest_bin @{const_name HOL.times} Term.dummyT;
138.93 -
138.94 -fun dest_prod t =
138.95 - let val (t,u) = dest_times t
138.96 - in dest_prod t @ dest_prod u end
138.97 - handle TERM _ => [t];
138.98 -
138.99 -(*DON'T do the obvious simplifications; that would create special cases*)
138.100 -fun mk_coeff (k, t) = mk_times (mk_number (Term.fastype_of t) k, t);
138.101 -
138.102 -(*Express t as a product of (possibly) a numeral with other sorted terms*)
138.103 -fun dest_coeff sign (Const (@{const_name HOL.uminus}, _) $ t) = dest_coeff (~sign) t
138.104 - | dest_coeff sign t =
138.105 - let val ts = sort TermOrd.term_ord (dest_prod t)
138.106 - val (n, ts') = find_first_numeral [] ts
138.107 - handle TERM _ => (1, ts)
138.108 - in (sign*n, mk_prod (Term.fastype_of t) ts') end;
138.109 -
138.110 -(*Find first coefficient-term THAT MATCHES u*)
138.111 -fun find_first_coeff past u [] = raise TERM("find_first_coeff", [])
138.112 - | find_first_coeff past u (t::terms) =
138.113 - let val (n,u') = dest_coeff 1 t
138.114 - in if u aconv u' then (n, rev past @ terms)
138.115 - else find_first_coeff (t::past) u terms
138.116 - end
138.117 - handle TERM _ => find_first_coeff (t::past) u terms;
138.118 -
138.119 -(*Fractions as pairs of ints. Can't use Rat.rat because the representation
138.120 - needs to preserve negative values in the denominator.*)
138.121 -fun mk_frac (p, q) = if q = 0 then raise Div else (p, q);
138.122 -
138.123 -(*Don't reduce fractions; sums must be proved by rule add_frac_eq.
138.124 - Fractions are reduced later by the cancel_numeral_factor simproc.*)
138.125 -fun add_frac ((p1, q1), (p2, q2)) = (p1 * q2 + p2 * q1, q1 * q2);
138.126 -
138.127 -val mk_divide = HOLogic.mk_binop @{const_name HOL.divide};
138.128 -
138.129 -(*Build term (p / q) * t*)
138.130 -fun mk_fcoeff ((p, q), t) =
138.131 - let val T = Term.fastype_of t
138.132 - in mk_times (mk_divide (mk_number T p, mk_number T q), t) end;
138.133 -
138.134 -(*Express t as a product of a fraction with other sorted terms*)
138.135 -fun dest_fcoeff sign (Const (@{const_name HOL.uminus}, _) $ t) = dest_fcoeff (~sign) t
138.136 - | dest_fcoeff sign (Const (@{const_name HOL.divide}, _) $ t $ u) =
138.137 - let val (p, t') = dest_coeff sign t
138.138 - val (q, u') = dest_coeff 1 u
138.139 - in (mk_frac (p, q), mk_divide (t', u')) end
138.140 - | dest_fcoeff sign t =
138.141 - let val (p, t') = dest_coeff sign t
138.142 - val T = Term.fastype_of t
138.143 - in (mk_frac (p, 1), mk_divide (t', one_of T)) end;
138.144 -
138.145 -
138.146 -(** New term ordering so that AC-rewriting brings numerals to the front **)
138.147 -
138.148 -(*Order integers by absolute value and then by sign. The standard integer
138.149 - ordering is not well-founded.*)
138.150 -fun num_ord (i,j) =
138.151 - (case int_ord (abs i, abs j) of
138.152 - EQUAL => int_ord (Int.sign i, Int.sign j)
138.153 - | ord => ord);
138.154 -
138.155 -(*This resembles TermOrd.term_ord, but it puts binary numerals before other
138.156 - non-atomic terms.*)
138.157 -local open Term
138.158 -in
138.159 -fun numterm_ord (Abs (_, T, t), Abs(_, U, u)) =
138.160 - (case numterm_ord (t, u) of EQUAL => TermOrd.typ_ord (T, U) | ord => ord)
138.161 - | numterm_ord
138.162 - (Const(@{const_name Int.number_of}, _) $ v, Const(@{const_name Int.number_of}, _) $ w) =
138.163 - num_ord (HOLogic.dest_numeral v, HOLogic.dest_numeral w)
138.164 - | numterm_ord (Const(@{const_name Int.number_of}, _) $ _, _) = LESS
138.165 - | numterm_ord (_, Const(@{const_name Int.number_of}, _) $ _) = GREATER
138.166 - | numterm_ord (t, u) =
138.167 - (case int_ord (size_of_term t, size_of_term u) of
138.168 - EQUAL =>
138.169 - let val (f, ts) = strip_comb t and (g, us) = strip_comb u in
138.170 - (case TermOrd.hd_ord (f, g) of EQUAL => numterms_ord (ts, us) | ord => ord)
138.171 - end
138.172 - | ord => ord)
138.173 -and numterms_ord (ts, us) = list_ord numterm_ord (ts, us)
138.174 -end;
138.175 -
138.176 -fun numtermless tu = (numterm_ord tu = LESS);
138.177 -
138.178 -val num_ss = HOL_ss settermless numtermless;
138.179 -
138.180 -(*Maps 0 to Numeral0 and 1 to Numeral1 so that arithmetic isn't complicated by the abstract 0 and 1.*)
138.181 -val numeral_syms = [@{thm numeral_0_eq_0} RS sym, @{thm numeral_1_eq_1} RS sym];
138.182 -
138.183 -(*Simplify Numeral0+n, n+Numeral0, Numeral1*n, n*Numeral1, 1*x, x*1, x/1 *)
138.184 -val add_0s = @{thms add_0s};
138.185 -val mult_1s = @{thms mult_1s mult_1_left mult_1_right divide_1};
138.186 -
138.187 -(*Simplify inverse Numeral1, a/Numeral1*)
138.188 -val inverse_1s = [@{thm inverse_numeral_1}];
138.189 -val divide_1s = [@{thm divide_numeral_1}];
138.190 -
138.191 -(*To perform binary arithmetic. The "left" rewriting handles patterns
138.192 - created by the Int_Numeral_Simprocs, such as 3 * (5 * x). *)
138.193 -val simps = [@{thm numeral_0_eq_0} RS sym, @{thm numeral_1_eq_1} RS sym,
138.194 - @{thm add_number_of_left}, @{thm mult_number_of_left}] @
138.195 - @{thms arith_simps} @ @{thms rel_simps};
138.196 -
138.197 -(*Binary arithmetic BUT NOT ADDITION since it may collapse adjacent terms
138.198 - during re-arrangement*)
138.199 -val non_add_simps =
138.200 - subtract Thm.eq_thm [@{thm add_number_of_left}, @{thm number_of_add} RS sym] simps;
138.201 -
138.202 -(*To evaluate binary negations of coefficients*)
138.203 -val minus_simps = [@{thm numeral_m1_eq_minus_1} RS sym, @{thm number_of_minus} RS sym] @
138.204 - @{thms minus_bin_simps} @ @{thms pred_bin_simps};
138.205 -
138.206 -(*To let us treat subtraction as addition*)
138.207 -val diff_simps = [@{thm diff_minus}, @{thm minus_add_distrib}, @{thm minus_minus}];
138.208 -
138.209 -(*To let us treat division as multiplication*)
138.210 -val divide_simps = [@{thm divide_inverse}, @{thm inverse_mult_distrib}, @{thm inverse_inverse_eq}];
138.211 -
138.212 -(*push the unary minus down: - x * y = x * - y *)
138.213 -val minus_mult_eq_1_to_2 =
138.214 - [@{thm mult_minus_left}, @{thm minus_mult_right}] MRS trans |> standard;
138.215 -
138.216 -(*to extract again any uncancelled minuses*)
138.217 -val minus_from_mult_simps =
138.218 - [@{thm minus_minus}, @{thm mult_minus_left}, @{thm mult_minus_right}];
138.219 -
138.220 -(*combine unary minus with numeric literals, however nested within a product*)
138.221 -val mult_minus_simps =
138.222 - [@{thm mult_assoc}, @{thm minus_mult_left}, minus_mult_eq_1_to_2];
138.223 -
138.224 -val norm_ss1 = num_ss addsimps numeral_syms @ add_0s @ mult_1s @
138.225 - diff_simps @ minus_simps @ @{thms add_ac}
138.226 -val norm_ss2 = num_ss addsimps non_add_simps @ mult_minus_simps
138.227 -val norm_ss3 = num_ss addsimps minus_from_mult_simps @ @{thms add_ac} @ @{thms mult_ac}
138.228 -
138.229 -structure CancelNumeralsCommon =
138.230 - struct
138.231 - val mk_sum = mk_sum
138.232 - val dest_sum = dest_sum
138.233 - val mk_coeff = mk_coeff
138.234 - val dest_coeff = dest_coeff 1
138.235 - val find_first_coeff = find_first_coeff []
138.236 - val trans_tac = K Arith_Data.trans_tac
138.237 -
138.238 - fun norm_tac ss =
138.239 - ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1))
138.240 - THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2))
138.241 - THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss3))
138.242 -
138.243 - val numeral_simp_ss = HOL_ss addsimps add_0s @ simps
138.244 - fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss))
138.245 - val simplify_meta_eq = Arith_Data.simplify_meta_eq (add_0s @ mult_1s)
138.246 - end;
138.247 -
138.248 -
138.249 -structure EqCancelNumerals = CancelNumeralsFun
138.250 - (open CancelNumeralsCommon
138.251 - val prove_conv = Arith_Data.prove_conv
138.252 - val mk_bal = HOLogic.mk_eq
138.253 - val dest_bal = HOLogic.dest_bin "op =" Term.dummyT
138.254 - val bal_add1 = @{thm eq_add_iff1} RS trans
138.255 - val bal_add2 = @{thm eq_add_iff2} RS trans
138.256 -);
138.257 -
138.258 -structure LessCancelNumerals = CancelNumeralsFun
138.259 - (open CancelNumeralsCommon
138.260 - val prove_conv = Arith_Data.prove_conv
138.261 - val mk_bal = HOLogic.mk_binrel @{const_name HOL.less}
138.262 - val dest_bal = HOLogic.dest_bin @{const_name HOL.less} Term.dummyT
138.263 - val bal_add1 = @{thm less_add_iff1} RS trans
138.264 - val bal_add2 = @{thm less_add_iff2} RS trans
138.265 -);
138.266 -
138.267 -structure LeCancelNumerals = CancelNumeralsFun
138.268 - (open CancelNumeralsCommon
138.269 - val prove_conv = Arith_Data.prove_conv
138.270 - val mk_bal = HOLogic.mk_binrel @{const_name HOL.less_eq}
138.271 - val dest_bal = HOLogic.dest_bin @{const_name HOL.less_eq} Term.dummyT
138.272 - val bal_add1 = @{thm le_add_iff1} RS trans
138.273 - val bal_add2 = @{thm le_add_iff2} RS trans
138.274 -);
138.275 -
138.276 -val cancel_numerals =
138.277 - map Arith_Data.prep_simproc
138.278 - [("inteq_cancel_numerals",
138.279 - ["(l::'a::number_ring) + m = n",
138.280 - "(l::'a::number_ring) = m + n",
138.281 - "(l::'a::number_ring) - m = n",
138.282 - "(l::'a::number_ring) = m - n",
138.283 - "(l::'a::number_ring) * m = n",
138.284 - "(l::'a::number_ring) = m * n"],
138.285 - K EqCancelNumerals.proc),
138.286 - ("intless_cancel_numerals",
138.287 - ["(l::'a::{ordered_idom,number_ring}) + m < n",
138.288 - "(l::'a::{ordered_idom,number_ring}) < m + n",
138.289 - "(l::'a::{ordered_idom,number_ring}) - m < n",
138.290 - "(l::'a::{ordered_idom,number_ring}) < m - n",
138.291 - "(l::'a::{ordered_idom,number_ring}) * m < n",
138.292 - "(l::'a::{ordered_idom,number_ring}) < m * n"],
138.293 - K LessCancelNumerals.proc),
138.294 - ("intle_cancel_numerals",
138.295 - ["(l::'a::{ordered_idom,number_ring}) + m <= n",
138.296 - "(l::'a::{ordered_idom,number_ring}) <= m + n",
138.297 - "(l::'a::{ordered_idom,number_ring}) - m <= n",
138.298 - "(l::'a::{ordered_idom,number_ring}) <= m - n",
138.299 - "(l::'a::{ordered_idom,number_ring}) * m <= n",
138.300 - "(l::'a::{ordered_idom,number_ring}) <= m * n"],
138.301 - K LeCancelNumerals.proc)];
138.302 -
138.303 -
138.304 -structure CombineNumeralsData =
138.305 - struct
138.306 - type coeff = int
138.307 - val iszero = (fn x => x = 0)
138.308 - val add = op +
138.309 - val mk_sum = long_mk_sum (*to work for e.g. 2*x + 3*x *)
138.310 - val dest_sum = dest_sum
138.311 - val mk_coeff = mk_coeff
138.312 - val dest_coeff = dest_coeff 1
138.313 - val left_distrib = @{thm combine_common_factor} RS trans
138.314 - val prove_conv = Arith_Data.prove_conv_nohyps
138.315 - val trans_tac = K Arith_Data.trans_tac
138.316 -
138.317 - fun norm_tac ss =
138.318 - ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1))
138.319 - THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2))
138.320 - THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss3))
138.321 -
138.322 - val numeral_simp_ss = HOL_ss addsimps add_0s @ simps
138.323 - fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss))
138.324 - val simplify_meta_eq = Arith_Data.simplify_meta_eq (add_0s @ mult_1s)
138.325 - end;
138.326 -
138.327 -structure CombineNumerals = CombineNumeralsFun(CombineNumeralsData);
138.328 -
138.329 -(*Version for fields, where coefficients can be fractions*)
138.330 -structure FieldCombineNumeralsData =
138.331 - struct
138.332 - type coeff = int * int
138.333 - val iszero = (fn (p, q) => p = 0)
138.334 - val add = add_frac
138.335 - val mk_sum = long_mk_sum
138.336 - val dest_sum = dest_sum
138.337 - val mk_coeff = mk_fcoeff
138.338 - val dest_coeff = dest_fcoeff 1
138.339 - val left_distrib = @{thm combine_common_factor} RS trans
138.340 - val prove_conv = Arith_Data.prove_conv_nohyps
138.341 - val trans_tac = K Arith_Data.trans_tac
138.342 -
138.343 - val norm_ss1a = norm_ss1 addsimps inverse_1s @ divide_simps
138.344 - fun norm_tac ss =
138.345 - ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1a))
138.346 - THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2))
138.347 - THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss3))
138.348 -
138.349 - val numeral_simp_ss = HOL_ss addsimps add_0s @ simps @ [@{thm add_frac_eq}]
138.350 - fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss))
138.351 - val simplify_meta_eq = Arith_Data.simplify_meta_eq (add_0s @ mult_1s @ divide_1s)
138.352 - end;
138.353 -
138.354 -structure FieldCombineNumerals = CombineNumeralsFun(FieldCombineNumeralsData);
138.355 -
138.356 -val combine_numerals =
138.357 - Arith_Data.prep_simproc
138.358 - ("int_combine_numerals",
138.359 - ["(i::'a::number_ring) + j", "(i::'a::number_ring) - j"],
138.360 - K CombineNumerals.proc);
138.361 -
138.362 -val field_combine_numerals =
138.363 - Arith_Data.prep_simproc
138.364 - ("field_combine_numerals",
138.365 - ["(i::'a::{number_ring,field,division_by_zero}) + j",
138.366 - "(i::'a::{number_ring,field,division_by_zero}) - j"],
138.367 - K FieldCombineNumerals.proc);
138.368 -
138.369 -(** Constant folding for multiplication in semirings **)
138.370 -
138.371 -(*We do not need folding for addition: combine_numerals does the same thing*)
138.372 -
138.373 -structure Semiring_Times_Assoc_Data : ASSOC_FOLD_DATA =
138.374 -struct
138.375 - val assoc_ss = HOL_ss addsimps @{thms mult_ac}
138.376 - val eq_reflection = eq_reflection
138.377 - fun is_numeral (Const(@{const_name Int.number_of}, _) $ _) = true
138.378 - | is_numeral _ = false;
138.379 -end;
138.380 -
138.381 -structure Semiring_Times_Assoc = Assoc_Fold (Semiring_Times_Assoc_Data);
138.382 -
138.383 -val assoc_fold_simproc =
138.384 - Arith_Data.prep_simproc
138.385 - ("semiring_assoc_fold", ["(a::'a::comm_semiring_1_cancel) * b"],
138.386 - K Semiring_Times_Assoc.proc);
138.387 -
138.388 -end;
138.389 -
138.390 -Addsimprocs [Int_Numeral_Simprocs.reorient_simproc];
138.391 -Addsimprocs Int_Numeral_Simprocs.cancel_numerals;
138.392 -Addsimprocs [Int_Numeral_Simprocs.combine_numerals];
138.393 -Addsimprocs [Int_Numeral_Simprocs.field_combine_numerals];
138.394 -Addsimprocs [Int_Numeral_Simprocs.assoc_fold_simproc];
138.395 -
138.396 -(*examples:
138.397 -print_depth 22;
138.398 -set timing;
138.399 -set trace_simp;
138.400 -fun test s = (Goal s, by (Simp_tac 1));
138.401 -
138.402 -test "l + 2 + 2 + 2 + (l + 2) + (oo + 2) = (uu::int)";
138.403 -
138.404 -test "2*u = (u::int)";
138.405 -test "(i + j + 12 + (k::int)) - 15 = y";
138.406 -test "(i + j + 12 + (k::int)) - 5 = y";
138.407 -
138.408 -test "y - b < (b::int)";
138.409 -test "y - (3*b + c) < (b::int) - 2*c";
138.410 -
138.411 -test "(2*x - (u*v) + y) - v*3*u = (w::int)";
138.412 -test "(2*x*u*v + (u*v)*4 + y) - v*u*4 = (w::int)";
138.413 -test "(2*x*u*v + (u*v)*4 + y) - v*u = (w::int)";
138.414 -test "u*v - (x*u*v + (u*v)*4 + y) = (w::int)";
138.415 -
138.416 -test "(i + j + 12 + (k::int)) = u + 15 + y";
138.417 -test "(i + j*2 + 12 + (k::int)) = j + 5 + y";
138.418 -
138.419 -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)";
138.420 -
138.421 -test "a + -(b+c) + b = (d::int)";
138.422 -test "a + -(b+c) - b = (d::int)";
138.423 -
138.424 -(*negative numerals*)
138.425 -test "(i + j + -2 + (k::int)) - (u + 5 + y) = zz";
138.426 -test "(i + j + -3 + (k::int)) < u + 5 + y";
138.427 -test "(i + j + 3 + (k::int)) < u + -6 + y";
138.428 -test "(i + j + -12 + (k::int)) - 15 = y";
138.429 -test "(i + j + 12 + (k::int)) - -15 = y";
138.430 -test "(i + j + -12 + (k::int)) - -15 = y";
138.431 -*)
138.432 -
138.433 -(*** decision procedure for linear arithmetic ***)
138.434 -
138.435 -(*---------------------------------------------------------------------------*)
138.436 -(* Linear arithmetic *)
138.437 -(*---------------------------------------------------------------------------*)
138.438 -
138.439 -(*
138.440 Instantiation of the generic linear arithmetic package for int.
138.441 *)
138.442
138.443 -structure Int_Arith =
138.444 +signature INT_ARITH =
138.445 +sig
138.446 + val fast_int_arith_simproc: simproc
138.447 + val setup: Context.generic -> Context.generic
138.448 +end
138.449 +
138.450 +structure Int_Arith : INT_ARITH =
138.451 struct
138.452
138.453 (* Update parameters of arithmetic prover *)
138.454 @@ -513,22 +86,21 @@
138.455
138.456 val nat_inj_thms = [@{thm zle_int} RS iffD2, @{thm int_int_eq} RS iffD2]
138.457
138.458 -val int_numeral_base_simprocs = Int_Numeral_Simprocs.assoc_fold_simproc :: zero_one_idom_simproc
138.459 - :: Int_Numeral_Simprocs.combine_numerals
138.460 - :: Int_Numeral_Simprocs.cancel_numerals;
138.461 +val numeral_base_simprocs = Numeral_Simprocs.assoc_fold_simproc :: zero_one_idom_simproc
138.462 + :: Numeral_Simprocs.combine_numerals
138.463 + :: Numeral_Simprocs.cancel_numerals;
138.464
138.465 val setup =
138.466 Lin_Arith.map_data (fn {add_mono_thms, mult_mono_thms, inj_thms, lessD, neqE, simpset} =>
138.467 {add_mono_thms = add_mono_thms,
138.468 - mult_mono_thms = @{thm mult_strict_left_mono} :: @{thm mult_left_mono} :: mult_mono_thms,
138.469 + mult_mono_thms = (*@{thm mult_strict_left_mono} :: @{thm mult_left_mono} :: *)mult_mono_thms,
138.470 inj_thms = nat_inj_thms @ inj_thms,
138.471 lessD = lessD @ [@{thm zless_imp_add1_zle}],
138.472 neqE = neqE,
138.473 simpset = simpset addsimps add_rules
138.474 - addsimprocs int_numeral_base_simprocs
138.475 - addcongs [if_weak_cong]}) #>
138.476 - arith_inj_const (@{const_name of_nat}, HOLogic.natT --> HOLogic.intT) #>
138.477 - arith_discrete @{type_name Int.int}
138.478 + addsimprocs numeral_base_simprocs}) #>
138.479 + Lin_Arith.add_inj_const (@{const_name of_nat}, HOLogic.natT --> HOLogic.intT) #>
138.480 + Lin_Arith.add_discrete_type @{type_name Int.int}
138.481
138.482 val fast_int_arith_simproc =
138.483 Simplifier.simproc (the_context ())
139.1 --- a/src/HOL/Tools/int_factor_simprocs.ML Mon May 11 09:39:53 2009 +0200
139.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
139.3 @@ -1,390 +0,0 @@
139.4 -(* Title: HOL/int_factor_simprocs.ML
139.5 - ID: $Id$
139.6 - Author: Lawrence C Paulson, Cambridge University Computer Laboratory
139.7 - Copyright 2000 University of Cambridge
139.8 -
139.9 -Factor cancellation simprocs for the integers (and for fields).
139.10 -
139.11 -This file can't be combined with int_arith1 because it requires IntDiv.thy.
139.12 -*)
139.13 -
139.14 -
139.15 -(*To quote from Provers/Arith/cancel_numeral_factor.ML:
139.16 -
139.17 -Cancels common coefficients in balanced expressions:
139.18 -
139.19 - u*#m ~~ u'*#m' == #n*u ~~ #n'*u'
139.20 -
139.21 -where ~~ is an appropriate balancing operation (e.g. =, <=, <, div, /)
139.22 -and d = gcd(m,m') and n=m/d and n'=m'/d.
139.23 -*)
139.24 -
139.25 -val rel_number_of = [@{thm eq_number_of_eq}, @{thm less_number_of}, @{thm le_number_of}];
139.26 -
139.27 -local
139.28 - open Int_Numeral_Simprocs
139.29 -in
139.30 -
139.31 -structure CancelNumeralFactorCommon =
139.32 - struct
139.33 - val mk_coeff = mk_coeff
139.34 - val dest_coeff = dest_coeff 1
139.35 - val trans_tac = K Arith_Data.trans_tac
139.36 -
139.37 - val norm_ss1 = HOL_ss addsimps minus_from_mult_simps @ mult_1s
139.38 - val norm_ss2 = HOL_ss addsimps simps @ mult_minus_simps
139.39 - val norm_ss3 = HOL_ss addsimps @{thms mult_ac}
139.40 - fun norm_tac ss =
139.41 - ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1))
139.42 - THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2))
139.43 - THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss3))
139.44 -
139.45 - val numeral_simp_ss = HOL_ss addsimps rel_number_of @ simps
139.46 - fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss))
139.47 - val simplify_meta_eq = Arith_Data.simplify_meta_eq
139.48 - [@{thm add_0}, @{thm add_0_right}, @{thm mult_zero_left},
139.49 - @{thm mult_zero_right}, @{thm mult_Bit1}, @{thm mult_1_right}];
139.50 - end
139.51 -
139.52 -(*Version for integer division*)
139.53 -structure IntDivCancelNumeralFactor = CancelNumeralFactorFun
139.54 - (open CancelNumeralFactorCommon
139.55 - val prove_conv = Arith_Data.prove_conv
139.56 - val mk_bal = HOLogic.mk_binop @{const_name Divides.div}
139.57 - val dest_bal = HOLogic.dest_bin @{const_name Divides.div} HOLogic.intT
139.58 - val cancel = @{thm zdiv_zmult_zmult1} RS trans
139.59 - val neg_exchanges = false
139.60 -)
139.61 -
139.62 -(*Version for fields*)
139.63 -structure DivideCancelNumeralFactor = CancelNumeralFactorFun
139.64 - (open CancelNumeralFactorCommon
139.65 - val prove_conv = Arith_Data.prove_conv
139.66 - val mk_bal = HOLogic.mk_binop @{const_name HOL.divide}
139.67 - val dest_bal = HOLogic.dest_bin @{const_name HOL.divide} Term.dummyT
139.68 - val cancel = @{thm mult_divide_mult_cancel_left} RS trans
139.69 - val neg_exchanges = false
139.70 -)
139.71 -
139.72 -structure EqCancelNumeralFactor = CancelNumeralFactorFun
139.73 - (open CancelNumeralFactorCommon
139.74 - val prove_conv = Arith_Data.prove_conv
139.75 - val mk_bal = HOLogic.mk_eq
139.76 - val dest_bal = HOLogic.dest_bin "op =" Term.dummyT
139.77 - val cancel = @{thm mult_cancel_left} RS trans
139.78 - val neg_exchanges = false
139.79 -)
139.80 -
139.81 -structure LessCancelNumeralFactor = CancelNumeralFactorFun
139.82 - (open CancelNumeralFactorCommon
139.83 - val prove_conv = Arith_Data.prove_conv
139.84 - val mk_bal = HOLogic.mk_binrel @{const_name HOL.less}
139.85 - val dest_bal = HOLogic.dest_bin @{const_name HOL.less} Term.dummyT
139.86 - val cancel = @{thm mult_less_cancel_left} RS trans
139.87 - val neg_exchanges = true
139.88 -)
139.89 -
139.90 -structure LeCancelNumeralFactor = CancelNumeralFactorFun
139.91 - (open CancelNumeralFactorCommon
139.92 - val prove_conv = Arith_Data.prove_conv
139.93 - val mk_bal = HOLogic.mk_binrel @{const_name HOL.less_eq}
139.94 - val dest_bal = HOLogic.dest_bin @{const_name HOL.less_eq} Term.dummyT
139.95 - val cancel = @{thm mult_le_cancel_left} RS trans
139.96 - val neg_exchanges = true
139.97 -)
139.98 -
139.99 -val cancel_numeral_factors =
139.100 - map Arith_Data.prep_simproc
139.101 - [("ring_eq_cancel_numeral_factor",
139.102 - ["(l::'a::{idom,number_ring}) * m = n",
139.103 - "(l::'a::{idom,number_ring}) = m * n"],
139.104 - K EqCancelNumeralFactor.proc),
139.105 - ("ring_less_cancel_numeral_factor",
139.106 - ["(l::'a::{ordered_idom,number_ring}) * m < n",
139.107 - "(l::'a::{ordered_idom,number_ring}) < m * n"],
139.108 - K LessCancelNumeralFactor.proc),
139.109 - ("ring_le_cancel_numeral_factor",
139.110 - ["(l::'a::{ordered_idom,number_ring}) * m <= n",
139.111 - "(l::'a::{ordered_idom,number_ring}) <= m * n"],
139.112 - K LeCancelNumeralFactor.proc),
139.113 - ("int_div_cancel_numeral_factors",
139.114 - ["((l::int) * m) div n", "(l::int) div (m * n)"],
139.115 - K IntDivCancelNumeralFactor.proc),
139.116 - ("divide_cancel_numeral_factor",
139.117 - ["((l::'a::{division_by_zero,field,number_ring}) * m) / n",
139.118 - "(l::'a::{division_by_zero,field,number_ring}) / (m * n)",
139.119 - "((number_of v)::'a::{division_by_zero,field,number_ring}) / (number_of w)"],
139.120 - K DivideCancelNumeralFactor.proc)];
139.121 -
139.122 -(* referenced by rat_arith.ML *)
139.123 -val field_cancel_numeral_factors =
139.124 - map Arith_Data.prep_simproc
139.125 - [("field_eq_cancel_numeral_factor",
139.126 - ["(l::'a::{field,number_ring}) * m = n",
139.127 - "(l::'a::{field,number_ring}) = m * n"],
139.128 - K EqCancelNumeralFactor.proc),
139.129 - ("field_cancel_numeral_factor",
139.130 - ["((l::'a::{division_by_zero,field,number_ring}) * m) / n",
139.131 - "(l::'a::{division_by_zero,field,number_ring}) / (m * n)",
139.132 - "((number_of v)::'a::{division_by_zero,field,number_ring}) / (number_of w)"],
139.133 - K DivideCancelNumeralFactor.proc)]
139.134 -
139.135 -end;
139.136 -
139.137 -Addsimprocs cancel_numeral_factors;
139.138 -
139.139 -(*examples:
139.140 -print_depth 22;
139.141 -set timing;
139.142 -set trace_simp;
139.143 -fun test s = (Goal s; by (Simp_tac 1));
139.144 -
139.145 -test "9*x = 12 * (y::int)";
139.146 -test "(9*x) div (12 * (y::int)) = z";
139.147 -test "9*x < 12 * (y::int)";
139.148 -test "9*x <= 12 * (y::int)";
139.149 -
139.150 -test "-99*x = 132 * (y::int)";
139.151 -test "(-99*x) div (132 * (y::int)) = z";
139.152 -test "-99*x < 132 * (y::int)";
139.153 -test "-99*x <= 132 * (y::int)";
139.154 -
139.155 -test "999*x = -396 * (y::int)";
139.156 -test "(999*x) div (-396 * (y::int)) = z";
139.157 -test "999*x < -396 * (y::int)";
139.158 -test "999*x <= -396 * (y::int)";
139.159 -
139.160 -test "-99*x = -81 * (y::int)";
139.161 -test "(-99*x) div (-81 * (y::int)) = z";
139.162 -test "-99*x <= -81 * (y::int)";
139.163 -test "-99*x < -81 * (y::int)";
139.164 -
139.165 -test "-2 * x = -1 * (y::int)";
139.166 -test "-2 * x = -(y::int)";
139.167 -test "(-2 * x) div (-1 * (y::int)) = z";
139.168 -test "-2 * x < -(y::int)";
139.169 -test "-2 * x <= -1 * (y::int)";
139.170 -test "-x < -23 * (y::int)";
139.171 -test "-x <= -23 * (y::int)";
139.172 -*)
139.173 -
139.174 -(*And the same examples for fields such as rat or real:
139.175 -test "0 <= (y::rat) * -2";
139.176 -test "9*x = 12 * (y::rat)";
139.177 -test "(9*x) / (12 * (y::rat)) = z";
139.178 -test "9*x < 12 * (y::rat)";
139.179 -test "9*x <= 12 * (y::rat)";
139.180 -
139.181 -test "-99*x = 132 * (y::rat)";
139.182 -test "(-99*x) / (132 * (y::rat)) = z";
139.183 -test "-99*x < 132 * (y::rat)";
139.184 -test "-99*x <= 132 * (y::rat)";
139.185 -
139.186 -test "999*x = -396 * (y::rat)";
139.187 -test "(999*x) / (-396 * (y::rat)) = z";
139.188 -test "999*x < -396 * (y::rat)";
139.189 -test "999*x <= -396 * (y::rat)";
139.190 -
139.191 -test "(- ((2::rat) * x) <= 2 * y)";
139.192 -test "-99*x = -81 * (y::rat)";
139.193 -test "(-99*x) / (-81 * (y::rat)) = z";
139.194 -test "-99*x <= -81 * (y::rat)";
139.195 -test "-99*x < -81 * (y::rat)";
139.196 -
139.197 -test "-2 * x = -1 * (y::rat)";
139.198 -test "-2 * x = -(y::rat)";
139.199 -test "(-2 * x) / (-1 * (y::rat)) = z";
139.200 -test "-2 * x < -(y::rat)";
139.201 -test "-2 * x <= -1 * (y::rat)";
139.202 -test "-x < -23 * (y::rat)";
139.203 -test "-x <= -23 * (y::rat)";
139.204 -*)
139.205 -
139.206 -
139.207 -(** Declarations for ExtractCommonTerm **)
139.208 -
139.209 -local
139.210 - open Int_Numeral_Simprocs
139.211 -in
139.212 -
139.213 -(*Find first term that matches u*)
139.214 -fun find_first_t past u [] = raise TERM ("find_first_t", [])
139.215 - | find_first_t past u (t::terms) =
139.216 - if u aconv t then (rev past @ terms)
139.217 - else find_first_t (t::past) u terms
139.218 - handle TERM _ => find_first_t (t::past) u terms;
139.219 -
139.220 -(** Final simplification for the CancelFactor simprocs **)
139.221 -val simplify_one = Arith_Data.simplify_meta_eq
139.222 - [@{thm mult_1_left}, @{thm mult_1_right}, @{thm div_by_1}, @{thm numeral_1_eq_1}];
139.223 -
139.224 -fun cancel_simplify_meta_eq ss cancel_th th =
139.225 - simplify_one ss (([th, cancel_th]) MRS trans);
139.226 -
139.227 -local
139.228 - val Tp_Eq = Thm.reflexive(Thm.cterm_of (@{theory HOL}) HOLogic.Trueprop)
139.229 - fun Eq_True_elim Eq =
139.230 - Thm.equal_elim (Thm.combination Tp_Eq (Thm.symmetric Eq)) @{thm TrueI}
139.231 -in
139.232 -fun sign_conv pos_th neg_th ss t =
139.233 - let val T = fastype_of t;
139.234 - val zero = Const(@{const_name HOL.zero}, T);
139.235 - val less = Const(@{const_name HOL.less}, [T,T] ---> HOLogic.boolT);
139.236 - val pos = less $ zero $ t and neg = less $ t $ zero
139.237 - fun prove p =
139.238 - Option.map Eq_True_elim (Lin_Arith.lin_arith_simproc ss p)
139.239 - handle THM _ => NONE
139.240 - in case prove pos of
139.241 - SOME th => SOME(th RS pos_th)
139.242 - | NONE => (case prove neg of
139.243 - SOME th => SOME(th RS neg_th)
139.244 - | NONE => NONE)
139.245 - end;
139.246 -end
139.247 -
139.248 -structure CancelFactorCommon =
139.249 - struct
139.250 - val mk_sum = long_mk_prod
139.251 - val dest_sum = dest_prod
139.252 - val mk_coeff = mk_coeff
139.253 - val dest_coeff = dest_coeff
139.254 - val find_first = find_first_t []
139.255 - val trans_tac = K Arith_Data.trans_tac
139.256 - val norm_ss = HOL_ss addsimps mult_1s @ @{thms mult_ac}
139.257 - fun norm_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss))
139.258 - val simplify_meta_eq = cancel_simplify_meta_eq
139.259 - end;
139.260 -
139.261 -(*mult_cancel_left requires a ring with no zero divisors.*)
139.262 -structure EqCancelFactor = ExtractCommonTermFun
139.263 - (open CancelFactorCommon
139.264 - val prove_conv = Arith_Data.prove_conv
139.265 - val mk_bal = HOLogic.mk_eq
139.266 - val dest_bal = HOLogic.dest_bin "op =" Term.dummyT
139.267 - val simp_conv = K (K (SOME @{thm mult_cancel_left}))
139.268 -);
139.269 -
139.270 -(*for ordered rings*)
139.271 -structure LeCancelFactor = ExtractCommonTermFun
139.272 - (open CancelFactorCommon
139.273 - val prove_conv = Arith_Data.prove_conv
139.274 - val mk_bal = HOLogic.mk_binrel @{const_name HOL.less_eq}
139.275 - val dest_bal = HOLogic.dest_bin @{const_name HOL.less_eq} Term.dummyT
139.276 - val simp_conv = sign_conv
139.277 - @{thm mult_le_cancel_left_pos} @{thm mult_le_cancel_left_neg}
139.278 -);
139.279 -
139.280 -(*for ordered rings*)
139.281 -structure LessCancelFactor = ExtractCommonTermFun
139.282 - (open CancelFactorCommon
139.283 - val prove_conv = Arith_Data.prove_conv
139.284 - val mk_bal = HOLogic.mk_binrel @{const_name HOL.less}
139.285 - val dest_bal = HOLogic.dest_bin @{const_name HOL.less} Term.dummyT
139.286 - val simp_conv = sign_conv
139.287 - @{thm mult_less_cancel_left_pos} @{thm mult_less_cancel_left_neg}
139.288 -);
139.289 -
139.290 -(*zdiv_zmult_zmult1_if is for integer division (div).*)
139.291 -structure IntDivCancelFactor = ExtractCommonTermFun
139.292 - (open CancelFactorCommon
139.293 - val prove_conv = Arith_Data.prove_conv
139.294 - val mk_bal = HOLogic.mk_binop @{const_name Divides.div}
139.295 - val dest_bal = HOLogic.dest_bin @{const_name Divides.div} HOLogic.intT
139.296 - val simp_conv = K (K (SOME @{thm zdiv_zmult_zmult1_if}))
139.297 -);
139.298 -
139.299 -structure IntModCancelFactor = ExtractCommonTermFun
139.300 - (open CancelFactorCommon
139.301 - val prove_conv = Arith_Data.prove_conv
139.302 - val mk_bal = HOLogic.mk_binop @{const_name Divides.mod}
139.303 - val dest_bal = HOLogic.dest_bin @{const_name Divides.mod} HOLogic.intT
139.304 - val simp_conv = K (K (SOME @{thm zmod_zmult_zmult1}))
139.305 -);
139.306 -
139.307 -structure IntDvdCancelFactor = ExtractCommonTermFun
139.308 - (open CancelFactorCommon
139.309 - val prove_conv = Arith_Data.prove_conv
139.310 - val mk_bal = HOLogic.mk_binrel @{const_name Ring_and_Field.dvd}
139.311 - val dest_bal = HOLogic.dest_bin @{const_name Ring_and_Field.dvd} Term.dummyT
139.312 - val simp_conv = K (K (SOME @{thm dvd_mult_cancel_left}))
139.313 -);
139.314 -
139.315 -(*Version for all fields, including unordered ones (type complex).*)
139.316 -structure DivideCancelFactor = ExtractCommonTermFun
139.317 - (open CancelFactorCommon
139.318 - val prove_conv = Arith_Data.prove_conv
139.319 - val mk_bal = HOLogic.mk_binop @{const_name HOL.divide}
139.320 - val dest_bal = HOLogic.dest_bin @{const_name HOL.divide} Term.dummyT
139.321 - val simp_conv = K (K (SOME @{thm mult_divide_mult_cancel_left_if}))
139.322 -);
139.323 -
139.324 -val cancel_factors =
139.325 - map Arith_Data.prep_simproc
139.326 - [("ring_eq_cancel_factor",
139.327 - ["(l::'a::{idom}) * m = n",
139.328 - "(l::'a::{idom}) = m * n"],
139.329 - K EqCancelFactor.proc),
139.330 - ("ordered_ring_le_cancel_factor",
139.331 - ["(l::'a::ordered_ring) * m <= n",
139.332 - "(l::'a::ordered_ring) <= m * n"],
139.333 - K LeCancelFactor.proc),
139.334 - ("ordered_ring_less_cancel_factor",
139.335 - ["(l::'a::ordered_ring) * m < n",
139.336 - "(l::'a::ordered_ring) < m * n"],
139.337 - K LessCancelFactor.proc),
139.338 - ("int_div_cancel_factor",
139.339 - ["((l::int) * m) div n", "(l::int) div (m * n)"],
139.340 - K IntDivCancelFactor.proc),
139.341 - ("int_mod_cancel_factor",
139.342 - ["((l::int) * m) mod n", "(l::int) mod (m * n)"],
139.343 - K IntModCancelFactor.proc),
139.344 - ("dvd_cancel_factor",
139.345 - ["((l::'a::idom) * m) dvd n", "(l::'a::idom) dvd (m * n)"],
139.346 - K IntDvdCancelFactor.proc),
139.347 - ("divide_cancel_factor",
139.348 - ["((l::'a::{division_by_zero,field}) * m) / n",
139.349 - "(l::'a::{division_by_zero,field}) / (m * n)"],
139.350 - K DivideCancelFactor.proc)];
139.351 -
139.352 -end;
139.353 -
139.354 -Addsimprocs cancel_factors;
139.355 -
139.356 -
139.357 -(*examples:
139.358 -print_depth 22;
139.359 -set timing;
139.360 -set trace_simp;
139.361 -fun test s = (Goal s; by (Asm_simp_tac 1));
139.362 -
139.363 -test "x*k = k*(y::int)";
139.364 -test "k = k*(y::int)";
139.365 -test "a*(b*c) = (b::int)";
139.366 -test "a*(b*c) = d*(b::int)*(x*a)";
139.367 -
139.368 -test "(x*k) div (k*(y::int)) = (uu::int)";
139.369 -test "(k) div (k*(y::int)) = (uu::int)";
139.370 -test "(a*(b*c)) div ((b::int)) = (uu::int)";
139.371 -test "(a*(b*c)) div (d*(b::int)*(x*a)) = (uu::int)";
139.372 -*)
139.373 -
139.374 -(*And the same examples for fields such as rat or real:
139.375 -print_depth 22;
139.376 -set timing;
139.377 -set trace_simp;
139.378 -fun test s = (Goal s; by (Asm_simp_tac 1));
139.379 -
139.380 -test "x*k = k*(y::rat)";
139.381 -test "k = k*(y::rat)";
139.382 -test "a*(b*c) = (b::rat)";
139.383 -test "a*(b*c) = d*(b::rat)*(x*a)";
139.384 -
139.385 -
139.386 -test "(x*k) / (k*(y::rat)) = (uu::rat)";
139.387 -test "(k) / (k*(y::rat)) = (uu::rat)";
139.388 -test "(a*(b*c)) / ((b::rat)) = (uu::rat)";
139.389 -test "(a*(b*c)) / (d*(b::rat)*(x*a)) = (uu::rat)";
139.390 -
139.391 -(*FIXME: what do we do about this?*)
139.392 -test "a*(b*c)/(y*z) = d*(b::rat)*(x*a)/z";
139.393 -*)
140.1 --- a/src/HOL/Tools/lin_arith.ML Mon May 11 09:39:53 2009 +0200
140.2 +++ b/src/HOL/Tools/lin_arith.ML Mon May 11 17:20:52 2009 +0200
140.3 @@ -7,14 +7,9 @@
140.4 signature BASIC_LIN_ARITH =
140.5 sig
140.6 val arith_split_add: attribute
140.7 - val arith_discrete: string -> Context.generic -> Context.generic
140.8 - val arith_inj_const: string * typ -> Context.generic -> Context.generic
140.9 - val fast_arith_split_limit: int Config.T
140.10 - val fast_arith_neq_limit: int Config.T
140.11 val lin_arith_pre_tac: Proof.context -> int -> tactic
140.12 val fast_arith_tac: Proof.context -> int -> tactic
140.13 val fast_ex_arith_tac: Proof.context -> bool -> int -> tactic
140.14 - val trace_arith: bool ref
140.15 val lin_arith_simproc: simpset -> term -> thm option
140.16 val fast_nat_arith_simproc: simproc
140.17 val linear_arith_tac: Proof.context -> int -> tactic
140.18 @@ -23,14 +18,19 @@
140.19 signature LIN_ARITH =
140.20 sig
140.21 include BASIC_LIN_ARITH
140.22 + val add_discrete_type: string -> Context.generic -> Context.generic
140.23 + val add_inj_const: string * typ -> Context.generic -> Context.generic
140.24 val map_data:
140.25 ({add_mono_thms: thm list, mult_mono_thms: thm list, inj_thms: thm list,
140.26 lessD: thm list, neqE: thm list, simpset: Simplifier.simpset} ->
140.27 {add_mono_thms: thm list, mult_mono_thms: thm list, inj_thms: thm list,
140.28 lessD: thm list, neqE: thm list, simpset: Simplifier.simpset}) ->
140.29 Context.generic -> Context.generic
140.30 + val setup: Context.generic -> Context.generic
140.31 + val split_limit: int Config.T
140.32 + val neq_limit: int Config.T
140.33 val warning_count: int ref
140.34 - val setup: Context.generic -> Context.generic
140.35 + val trace: bool ref
140.36 end;
140.37
140.38 structure Lin_Arith: LIN_ARITH =
140.39 @@ -99,23 +99,23 @@
140.40 {splits = update Thm.eq_thm_prop thm splits,
140.41 inj_consts = inj_consts, discrete = discrete}));
140.42
140.43 -fun arith_discrete d = ArithContextData.map (fn {splits, inj_consts, discrete} =>
140.44 +fun add_discrete_type d = ArithContextData.map (fn {splits, inj_consts, discrete} =>
140.45 {splits = splits, inj_consts = inj_consts,
140.46 discrete = update (op =) d discrete});
140.47
140.48 -fun arith_inj_const c = ArithContextData.map (fn {splits, inj_consts, discrete} =>
140.49 +fun add_inj_const c = ArithContextData.map (fn {splits, inj_consts, discrete} =>
140.50 {splits = splits, inj_consts = update (op =) c inj_consts,
140.51 discrete = discrete});
140.52
140.53 -val (fast_arith_split_limit, setup1) = Attrib.config_int "fast_arith_split_limit" 9;
140.54 -val (fast_arith_neq_limit, setup2) = Attrib.config_int "fast_arith_neq_limit" 9;
140.55 +val (split_limit, setup1) = Attrib.config_int "linarith_split_limit" 9;
140.56 +val (neq_limit, setup2) = Attrib.config_int "linarith_neq_limit" 9;
140.57 val setup_options = setup1 #> setup2;
140.58
140.59
140.60 structure LA_Data_Ref =
140.61 struct
140.62
140.63 -val fast_arith_neq_limit = fast_arith_neq_limit;
140.64 +val fast_arith_neq_limit = neq_limit;
140.65
140.66
140.67 (* Decomposition of terms *)
140.68 @@ -358,10 +358,10 @@
140.69 val split_thms = filter is_split_thm (#splits (get_arith_data ctxt))
140.70 val cmap = Splitter.cmap_of_split_thms split_thms
140.71 val splits = Splitter.split_posns cmap thy Ts (REPEAT_DETERM_etac_rev_mp terms)
140.72 - val split_limit = Config.get ctxt fast_arith_split_limit
140.73 + val split_limit = Config.get ctxt split_limit
140.74 in
140.75 if length splits > split_limit then
140.76 - (tracing ("fast_arith_split_limit exceeded (current value is " ^
140.77 + (tracing ("linarith_split_limit exceeded (current value is " ^
140.78 string_of_int split_limit ^ ")"); NONE)
140.79 else (
140.80 case splits of [] =>
140.81 @@ -696,7 +696,7 @@
140.82 (* disjunctions and existential quantifiers from the premises, possibly (in *)
140.83 (* the case of disjunctions) resulting in several new subgoals, each of the *)
140.84 (* general form [| Q1; ...; Qm |] ==> False. Fails if more than *)
140.85 -(* !fast_arith_split_limit splits are possible. *)
140.86 +(* !split_limit splits are possible. *)
140.87
140.88 local
140.89 val nnf_simpset =
140.90 @@ -717,7 +717,7 @@
140.91 val concl = HOLogic.dest_Trueprop (Logic.strip_assums_concl subgoal)
140.92 val cmap = Splitter.cmap_of_split_thms split_thms
140.93 val splits = Splitter.split_posns cmap thy Ts concl
140.94 - val split_limit = Config.get ctxt fast_arith_split_limit
140.95 + val split_limit = Config.get ctxt split_limit
140.96 in
140.97 if length splits > split_limit then no_tac
140.98 else split_tac split_thms i
140.99 @@ -767,7 +767,7 @@
140.100
140.101 fun fast_arith_tac ctxt = Fast_Arith.lin_arith_tac ctxt false;
140.102 val fast_ex_arith_tac = Fast_Arith.lin_arith_tac;
140.103 -val trace_arith = Fast_Arith.trace;
140.104 +val trace = Fast_Arith.trace;
140.105 val warning_count = Fast_Arith.warning_count;
140.106
140.107 (* reduce contradictory <= to False.
140.108 @@ -775,11 +775,10 @@
140.109
140.110 val init_arith_data =
140.111 map_data (fn {add_mono_thms, mult_mono_thms, inj_thms, lessD, ...} =>
140.112 - {add_mono_thms = add_mono_thms @
140.113 - @{thms add_mono_thms_ordered_semiring} @ @{thms add_mono_thms_ordered_field},
140.114 - mult_mono_thms = mult_mono_thms,
140.115 + {add_mono_thms = @{thms add_mono_thms_ordered_semiring} @ @{thms add_mono_thms_ordered_field} @ add_mono_thms,
140.116 + mult_mono_thms = @{thm mult_strict_left_mono} :: @{thm mult_left_mono} :: mult_mono_thms,
140.117 inj_thms = inj_thms,
140.118 - lessD = lessD @ [thm "Suc_leI"],
140.119 + lessD = lessD @ [@{thm "Suc_leI"}],
140.120 neqE = [@{thm linorder_neqE_nat}, @{thm linorder_neqE_ordered_idom}],
140.121 simpset = HOL_basic_ss
140.122 addsimps
140.123 @@ -791,8 +790,9 @@
140.124 @{thm "not_one_less_zero"}]
140.125 addsimprocs [ab_group_add_cancel.sum_conv, ab_group_add_cancel.rel_conv]
140.126 (*abel_cancel helps it work in abstract algebraic domains*)
140.127 - addsimprocs Nat_Arith.nat_cancel_sums_add}) #>
140.128 - arith_discrete "nat";
140.129 + addsimprocs Nat_Arith.nat_cancel_sums_add
140.130 + addcongs [if_weak_cong]}) #>
140.131 + add_discrete_type @{type_name nat};
140.132
140.133 fun add_arith_facts ss =
140.134 add_prems (Arith_Data.get_arith_facts (MetaSimplifier.the_context ss)) ss;
140.135 @@ -869,7 +869,7 @@
140.136 (* Splitting is also done inside fast_arith_tac, but not completely -- *)
140.137 (* split_tac may use split theorems that have not been implemented in *)
140.138 (* fast_arith_tac (cf. pre_decomp and split_once_items above), and *)
140.139 - (* fast_arith_split_limit may trigger. *)
140.140 + (* split_limit may trigger. *)
140.141 (* Therefore splitting outside of fast_arith_tac may allow us to prove *)
140.142 (* some goals that fast_arith_tac alone would fail on. *)
140.143 (REPEAT_DETERM o split_tac (#splits (get_arith_data ctxt)))
141.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
141.2 +++ b/src/HOL/Tools/list_code.ML Mon May 11 17:20:52 2009 +0200
141.3 @@ -0,0 +1,52 @@
141.4 +(* Author: Florian Haftmann, TU Muenchen
141.5 +
141.6 +Code generation for list literals.
141.7 +*)
141.8 +
141.9 +signature LIST_CODE =
141.10 +sig
141.11 + val implode_list: string -> string -> Code_Thingol.iterm -> Code_Thingol.iterm list option
141.12 + val default_list: int * string
141.13 + -> (Code_Printer.fixity -> Code_Thingol.iterm -> Pretty.T)
141.14 + -> Code_Printer.fixity -> Code_Thingol.iterm -> Code_Thingol.iterm -> Pretty.T
141.15 + val add_literal_list: string -> theory -> theory
141.16 +end;
141.17 +
141.18 +structure List_Code : LIST_CODE =
141.19 +struct
141.20 +
141.21 +open Basic_Code_Thingol;
141.22 +
141.23 +fun implode_list nil' cons' t =
141.24 + let
141.25 + fun dest_cons (IConst (c, _) `$ t1 `$ t2) =
141.26 + if c = cons'
141.27 + then SOME (t1, t2)
141.28 + else NONE
141.29 + | dest_cons _ = NONE;
141.30 + val (ts, t') = Code_Thingol.unfoldr dest_cons t;
141.31 + in case t'
141.32 + of IConst (c, _) => if c = nil' then SOME ts else NONE
141.33 + | _ => NONE
141.34 + end;
141.35 +
141.36 +fun default_list (target_fxy, target_cons) pr fxy t1 t2 =
141.37 + Code_Printer.brackify_infix (target_fxy, Code_Printer.R) fxy [
141.38 + pr (Code_Printer.INFX (target_fxy, Code_Printer.X)) t1,
141.39 + Code_Printer.str target_cons,
141.40 + pr (Code_Printer.INFX (target_fxy, Code_Printer.R)) t2
141.41 + ];
141.42 +
141.43 +fun add_literal_list target =
141.44 + let
141.45 + fun pretty literals [nil', cons'] pr thm vars fxy [(t1, _), (t2, _)] =
141.46 + case Option.map (cons t1) (implode_list nil' cons' t2)
141.47 + of SOME ts =>
141.48 + Code_Printer.literal_list literals (map (pr vars Code_Printer.NOBR) ts)
141.49 + | NONE =>
141.50 + default_list (Code_Printer.infix_cons literals) (pr vars) fxy t1 t2;
141.51 + in Code_Target.add_syntax_const target
141.52 + @{const_name Cons} (SOME (2, ([@{const_name Nil}, @{const_name Cons}], pretty)))
141.53 + end
141.54 +
141.55 +end;
142.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
142.2 +++ b/src/HOL/Tools/nat_numeral_simprocs.ML Mon May 11 17:20:52 2009 +0200
142.3 @@ -0,0 +1,538 @@
142.4 +(* Author: Lawrence C Paulson, Cambridge University Computer Laboratory
142.5 +
142.6 +Simprocs for nat numerals.
142.7 +*)
142.8 +
142.9 +signature NAT_NUMERAL_SIMPROCS =
142.10 +sig
142.11 + val combine_numerals: simproc
142.12 + val cancel_numerals: simproc list
142.13 + val cancel_factors: simproc list
142.14 + val cancel_numeral_factors: simproc list
142.15 +end;
142.16 +
142.17 +structure Nat_Numeral_Simprocs =
142.18 +struct
142.19 +
142.20 +(*Maps n to #n for n = 0, 1, 2*)
142.21 +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];
142.22 +val numeral_sym_ss = HOL_ss addsimps numeral_syms;
142.23 +
142.24 +fun rename_numerals th =
142.25 + simplify numeral_sym_ss (Thm.transfer (the_context ()) th);
142.26 +
142.27 +(*Utilities*)
142.28 +
142.29 +fun mk_number n = HOLogic.number_of_const HOLogic.natT $ HOLogic.mk_numeral n;
142.30 +fun dest_number t = Int.max (0, snd (HOLogic.dest_number t));
142.31 +
142.32 +fun find_first_numeral past (t::terms) =
142.33 + ((dest_number t, t, rev past @ terms)
142.34 + handle TERM _ => find_first_numeral (t::past) terms)
142.35 + | find_first_numeral past [] = raise TERM("find_first_numeral", []);
142.36 +
142.37 +val zero = mk_number 0;
142.38 +val mk_plus = HOLogic.mk_binop @{const_name HOL.plus};
142.39 +
142.40 +(*Thus mk_sum[t] yields t+0; longer sums don't have a trailing zero*)
142.41 +fun mk_sum [] = zero
142.42 + | mk_sum [t,u] = mk_plus (t, u)
142.43 + | mk_sum (t :: ts) = mk_plus (t, mk_sum ts);
142.44 +
142.45 +(*this version ALWAYS includes a trailing zero*)
142.46 +fun long_mk_sum [] = HOLogic.zero
142.47 + | long_mk_sum (t :: ts) = mk_plus (t, mk_sum ts);
142.48 +
142.49 +val dest_plus = HOLogic.dest_bin @{const_name HOL.plus} HOLogic.natT;
142.50 +
142.51 +
142.52 +(** Other simproc items **)
142.53 +
142.54 +val bin_simps =
142.55 + [@{thm nat_numeral_0_eq_0} RS sym, @{thm nat_numeral_1_eq_1} RS sym,
142.56 + @{thm add_nat_number_of}, @{thm nat_number_of_add_left},
142.57 + @{thm diff_nat_number_of}, @{thm le_number_of_eq_not_less},
142.58 + @{thm mult_nat_number_of}, @{thm nat_number_of_mult_left},
142.59 + @{thm less_nat_number_of},
142.60 + @{thm Let_number_of}, @{thm nat_number_of}] @
142.61 + @{thms arith_simps} @ @{thms rel_simps} @ @{thms neg_simps};
142.62 +
142.63 +
142.64 +(*** CancelNumerals simprocs ***)
142.65 +
142.66 +val one = mk_number 1;
142.67 +val mk_times = HOLogic.mk_binop @{const_name HOL.times};
142.68 +
142.69 +fun mk_prod [] = one
142.70 + | mk_prod [t] = t
142.71 + | mk_prod (t :: ts) = if t = one then mk_prod ts
142.72 + else mk_times (t, mk_prod ts);
142.73 +
142.74 +val dest_times = HOLogic.dest_bin @{const_name HOL.times} HOLogic.natT;
142.75 +
142.76 +fun dest_prod t =
142.77 + let val (t,u) = dest_times t
142.78 + in dest_prod t @ dest_prod u end
142.79 + handle TERM _ => [t];
142.80 +
142.81 +(*DON'T do the obvious simplifications; that would create special cases*)
142.82 +fun mk_coeff (k,t) = mk_times (mk_number k, t);
142.83 +
142.84 +(*Express t as a product of (possibly) a numeral with other factors, sorted*)
142.85 +fun dest_coeff t =
142.86 + let val ts = sort TermOrd.term_ord (dest_prod t)
142.87 + val (n, _, ts') = find_first_numeral [] ts
142.88 + handle TERM _ => (1, one, ts)
142.89 + in (n, mk_prod ts') end;
142.90 +
142.91 +(*Find first coefficient-term THAT MATCHES u*)
142.92 +fun find_first_coeff past u [] = raise TERM("find_first_coeff", [])
142.93 + | find_first_coeff past u (t::terms) =
142.94 + let val (n,u') = dest_coeff t
142.95 + in if u aconv u' then (n, rev past @ terms)
142.96 + else find_first_coeff (t::past) u terms
142.97 + end
142.98 + handle TERM _ => find_first_coeff (t::past) u terms;
142.99 +
142.100 +
142.101 +(*Split up a sum into the list of its constituent terms, on the way removing any
142.102 + Sucs and counting them.*)
142.103 +fun dest_Suc_sum (Const ("Suc", _) $ t, (k,ts)) = dest_Suc_sum (t, (k+1,ts))
142.104 + | dest_Suc_sum (t, (k,ts)) =
142.105 + let val (t1,t2) = dest_plus t
142.106 + in dest_Suc_sum (t1, dest_Suc_sum (t2, (k,ts))) end
142.107 + handle TERM _ => (k, t::ts);
142.108 +
142.109 +(*Code for testing whether numerals are already used in the goal*)
142.110 +fun is_numeral (Const(@{const_name Int.number_of}, _) $ w) = true
142.111 + | is_numeral _ = false;
142.112 +
142.113 +fun prod_has_numeral t = exists is_numeral (dest_prod t);
142.114 +
142.115 +(*The Sucs found in the term are converted to a binary numeral. If relaxed is false,
142.116 + an exception is raised unless the original expression contains at least one
142.117 + numeral in a coefficient position. This prevents nat_combine_numerals from
142.118 + introducing numerals to goals.*)
142.119 +fun dest_Sucs_sum relaxed t =
142.120 + let val (k,ts) = dest_Suc_sum (t,(0,[]))
142.121 + in
142.122 + if relaxed orelse exists prod_has_numeral ts then
142.123 + if k=0 then ts
142.124 + else mk_number k :: ts
142.125 + else raise TERM("Nat_Numeral_Simprocs.dest_Sucs_sum", [t])
142.126 + end;
142.127 +
142.128 +
142.129 +(*Simplify 1*n and n*1 to n*)
142.130 +val add_0s = map rename_numerals [@{thm add_0}, @{thm add_0_right}];
142.131 +val mult_1s = map rename_numerals [@{thm nat_mult_1}, @{thm nat_mult_1_right}];
142.132 +
142.133 +(*Final simplification: cancel + and *; replace Numeral0 by 0 and Numeral1 by 1*)
142.134 +
142.135 +(*And these help the simproc return False when appropriate, which helps
142.136 + the arith prover.*)
142.137 +val contra_rules = [@{thm add_Suc}, @{thm add_Suc_right}, @{thm Zero_not_Suc},
142.138 + @{thm Suc_not_Zero}, @{thm le_0_eq}];
142.139 +
142.140 +val simplify_meta_eq =
142.141 + Arith_Data.simplify_meta_eq
142.142 + ([@{thm nat_numeral_0_eq_0}, @{thm numeral_1_eq_Suc_0}, @{thm add_0}, @{thm add_0_right},
142.143 + @{thm mult_0}, @{thm mult_0_right}, @{thm mult_1}, @{thm mult_1_right}] @ contra_rules);
142.144 +
142.145 +
142.146 +(*** Applying CancelNumeralsFun ***)
142.147 +
142.148 +structure CancelNumeralsCommon =
142.149 + struct
142.150 + val mk_sum = (fn T:typ => mk_sum)
142.151 + val dest_sum = dest_Sucs_sum true
142.152 + val mk_coeff = mk_coeff
142.153 + val dest_coeff = dest_coeff
142.154 + val find_first_coeff = find_first_coeff []
142.155 + val trans_tac = K Arith_Data.trans_tac
142.156 +
142.157 + val norm_ss1 = Numeral_Simprocs.num_ss addsimps numeral_syms @ add_0s @ mult_1s @
142.158 + [@{thm Suc_eq_add_numeral_1_left}] @ @{thms add_ac}
142.159 + val norm_ss2 = Numeral_Simprocs.num_ss addsimps bin_simps @ @{thms add_ac} @ @{thms mult_ac}
142.160 + fun norm_tac ss =
142.161 + ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1))
142.162 + THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2))
142.163 +
142.164 + val numeral_simp_ss = HOL_ss addsimps add_0s @ bin_simps;
142.165 + fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss));
142.166 + val simplify_meta_eq = simplify_meta_eq
142.167 + end;
142.168 +
142.169 +
142.170 +structure EqCancelNumerals = CancelNumeralsFun
142.171 + (open CancelNumeralsCommon
142.172 + val prove_conv = Arith_Data.prove_conv
142.173 + val mk_bal = HOLogic.mk_eq
142.174 + val dest_bal = HOLogic.dest_bin "op =" HOLogic.natT
142.175 + val bal_add1 = @{thm nat_eq_add_iff1} RS trans
142.176 + val bal_add2 = @{thm nat_eq_add_iff2} RS trans
142.177 +);
142.178 +
142.179 +structure LessCancelNumerals = CancelNumeralsFun
142.180 + (open CancelNumeralsCommon
142.181 + val prove_conv = Arith_Data.prove_conv
142.182 + val mk_bal = HOLogic.mk_binrel @{const_name HOL.less}
142.183 + val dest_bal = HOLogic.dest_bin @{const_name HOL.less} HOLogic.natT
142.184 + val bal_add1 = @{thm nat_less_add_iff1} RS trans
142.185 + val bal_add2 = @{thm nat_less_add_iff2} RS trans
142.186 +);
142.187 +
142.188 +structure LeCancelNumerals = CancelNumeralsFun
142.189 + (open CancelNumeralsCommon
142.190 + val prove_conv = Arith_Data.prove_conv
142.191 + val mk_bal = HOLogic.mk_binrel @{const_name HOL.less_eq}
142.192 + val dest_bal = HOLogic.dest_bin @{const_name HOL.less_eq} HOLogic.natT
142.193 + val bal_add1 = @{thm nat_le_add_iff1} RS trans
142.194 + val bal_add2 = @{thm nat_le_add_iff2} RS trans
142.195 +);
142.196 +
142.197 +structure DiffCancelNumerals = CancelNumeralsFun
142.198 + (open CancelNumeralsCommon
142.199 + val prove_conv = Arith_Data.prove_conv
142.200 + val mk_bal = HOLogic.mk_binop @{const_name HOL.minus}
142.201 + val dest_bal = HOLogic.dest_bin @{const_name HOL.minus} HOLogic.natT
142.202 + val bal_add1 = @{thm nat_diff_add_eq1} RS trans
142.203 + val bal_add2 = @{thm nat_diff_add_eq2} RS trans
142.204 +);
142.205 +
142.206 +
142.207 +val cancel_numerals =
142.208 + map Arith_Data.prep_simproc
142.209 + [("nateq_cancel_numerals",
142.210 + ["(l::nat) + m = n", "(l::nat) = m + n",
142.211 + "(l::nat) * m = n", "(l::nat) = m * n",
142.212 + "Suc m = n", "m = Suc n"],
142.213 + K EqCancelNumerals.proc),
142.214 + ("natless_cancel_numerals",
142.215 + ["(l::nat) + m < n", "(l::nat) < m + n",
142.216 + "(l::nat) * m < n", "(l::nat) < m * n",
142.217 + "Suc m < n", "m < Suc n"],
142.218 + K LessCancelNumerals.proc),
142.219 + ("natle_cancel_numerals",
142.220 + ["(l::nat) + m <= n", "(l::nat) <= m + n",
142.221 + "(l::nat) * m <= n", "(l::nat) <= m * n",
142.222 + "Suc m <= n", "m <= Suc n"],
142.223 + K LeCancelNumerals.proc),
142.224 + ("natdiff_cancel_numerals",
142.225 + ["((l::nat) + m) - n", "(l::nat) - (m + n)",
142.226 + "(l::nat) * m - n", "(l::nat) - m * n",
142.227 + "Suc m - n", "m - Suc n"],
142.228 + K DiffCancelNumerals.proc)];
142.229 +
142.230 +
142.231 +(*** Applying CombineNumeralsFun ***)
142.232 +
142.233 +structure CombineNumeralsData =
142.234 + struct
142.235 + type coeff = int
142.236 + val iszero = (fn x => x = 0)
142.237 + val add = op +
142.238 + val mk_sum = (fn T:typ => long_mk_sum) (*to work for 2*x + 3*x *)
142.239 + val dest_sum = dest_Sucs_sum false
142.240 + val mk_coeff = mk_coeff
142.241 + val dest_coeff = dest_coeff
142.242 + val left_distrib = @{thm left_add_mult_distrib} RS trans
142.243 + val prove_conv = Arith_Data.prove_conv_nohyps
142.244 + val trans_tac = K Arith_Data.trans_tac
142.245 +
142.246 + val norm_ss1 = Numeral_Simprocs.num_ss addsimps numeral_syms @ add_0s @ mult_1s @ [@{thm Suc_eq_add_numeral_1}] @ @{thms add_ac}
142.247 + val norm_ss2 = Numeral_Simprocs.num_ss addsimps bin_simps @ @{thms add_ac} @ @{thms mult_ac}
142.248 + fun norm_tac ss =
142.249 + ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1))
142.250 + THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2))
142.251 +
142.252 + val numeral_simp_ss = HOL_ss addsimps add_0s @ bin_simps;
142.253 + fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss))
142.254 + val simplify_meta_eq = simplify_meta_eq
142.255 + end;
142.256 +
142.257 +structure CombineNumerals = CombineNumeralsFun(CombineNumeralsData);
142.258 +
142.259 +val combine_numerals =
142.260 + Arith_Data.prep_simproc ("nat_combine_numerals", ["(i::nat) + j", "Suc (i + j)"], K CombineNumerals.proc);
142.261 +
142.262 +
142.263 +(*** Applying CancelNumeralFactorFun ***)
142.264 +
142.265 +structure CancelNumeralFactorCommon =
142.266 + struct
142.267 + val mk_coeff = mk_coeff
142.268 + val dest_coeff = dest_coeff
142.269 + val trans_tac = K Arith_Data.trans_tac
142.270 +
142.271 + val norm_ss1 = Numeral_Simprocs.num_ss addsimps
142.272 + numeral_syms @ add_0s @ mult_1s @ [@{thm Suc_eq_add_numeral_1_left}] @ @{thms add_ac}
142.273 + val norm_ss2 = Numeral_Simprocs.num_ss addsimps bin_simps @ @{thms add_ac} @ @{thms mult_ac}
142.274 + fun norm_tac ss =
142.275 + ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1))
142.276 + THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2))
142.277 +
142.278 + val numeral_simp_ss = HOL_ss addsimps bin_simps
142.279 + fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss))
142.280 + val simplify_meta_eq = simplify_meta_eq
142.281 + end
142.282 +
142.283 +structure DivCancelNumeralFactor = CancelNumeralFactorFun
142.284 + (open CancelNumeralFactorCommon
142.285 + val prove_conv = Arith_Data.prove_conv
142.286 + val mk_bal = HOLogic.mk_binop @{const_name Divides.div}
142.287 + val dest_bal = HOLogic.dest_bin @{const_name Divides.div} HOLogic.natT
142.288 + val cancel = @{thm nat_mult_div_cancel1} RS trans
142.289 + val neg_exchanges = false
142.290 +)
142.291 +
142.292 +structure DvdCancelNumeralFactor = CancelNumeralFactorFun
142.293 + (open CancelNumeralFactorCommon
142.294 + val prove_conv = Arith_Data.prove_conv
142.295 + val mk_bal = HOLogic.mk_binrel @{const_name Ring_and_Field.dvd}
142.296 + val dest_bal = HOLogic.dest_bin @{const_name Ring_and_Field.dvd} HOLogic.natT
142.297 + val cancel = @{thm nat_mult_dvd_cancel1} RS trans
142.298 + val neg_exchanges = false
142.299 +)
142.300 +
142.301 +structure EqCancelNumeralFactor = CancelNumeralFactorFun
142.302 + (open CancelNumeralFactorCommon
142.303 + val prove_conv = Arith_Data.prove_conv
142.304 + val mk_bal = HOLogic.mk_eq
142.305 + val dest_bal = HOLogic.dest_bin "op =" HOLogic.natT
142.306 + val cancel = @{thm nat_mult_eq_cancel1} RS trans
142.307 + val neg_exchanges = false
142.308 +)
142.309 +
142.310 +structure LessCancelNumeralFactor = CancelNumeralFactorFun
142.311 + (open CancelNumeralFactorCommon
142.312 + val prove_conv = Arith_Data.prove_conv
142.313 + val mk_bal = HOLogic.mk_binrel @{const_name HOL.less}
142.314 + val dest_bal = HOLogic.dest_bin @{const_name HOL.less} HOLogic.natT
142.315 + val cancel = @{thm nat_mult_less_cancel1} RS trans
142.316 + val neg_exchanges = true
142.317 +)
142.318 +
142.319 +structure LeCancelNumeralFactor = CancelNumeralFactorFun
142.320 + (open CancelNumeralFactorCommon
142.321 + val prove_conv = Arith_Data.prove_conv
142.322 + val mk_bal = HOLogic.mk_binrel @{const_name HOL.less_eq}
142.323 + val dest_bal = HOLogic.dest_bin @{const_name HOL.less_eq} HOLogic.natT
142.324 + val cancel = @{thm nat_mult_le_cancel1} RS trans
142.325 + val neg_exchanges = true
142.326 +)
142.327 +
142.328 +val cancel_numeral_factors =
142.329 + map Arith_Data.prep_simproc
142.330 + [("nateq_cancel_numeral_factors",
142.331 + ["(l::nat) * m = n", "(l::nat) = m * n"],
142.332 + K EqCancelNumeralFactor.proc),
142.333 + ("natless_cancel_numeral_factors",
142.334 + ["(l::nat) * m < n", "(l::nat) < m * n"],
142.335 + K LessCancelNumeralFactor.proc),
142.336 + ("natle_cancel_numeral_factors",
142.337 + ["(l::nat) * m <= n", "(l::nat) <= m * n"],
142.338 + K LeCancelNumeralFactor.proc),
142.339 + ("natdiv_cancel_numeral_factors",
142.340 + ["((l::nat) * m) div n", "(l::nat) div (m * n)"],
142.341 + K DivCancelNumeralFactor.proc),
142.342 + ("natdvd_cancel_numeral_factors",
142.343 + ["((l::nat) * m) dvd n", "(l::nat) dvd (m * n)"],
142.344 + K DvdCancelNumeralFactor.proc)];
142.345 +
142.346 +
142.347 +
142.348 +(*** Applying ExtractCommonTermFun ***)
142.349 +
142.350 +(*this version ALWAYS includes a trailing one*)
142.351 +fun long_mk_prod [] = one
142.352 + | long_mk_prod (t :: ts) = mk_times (t, mk_prod ts);
142.353 +
142.354 +(*Find first term that matches u*)
142.355 +fun find_first_t past u [] = raise TERM("find_first_t", [])
142.356 + | find_first_t past u (t::terms) =
142.357 + if u aconv t then (rev past @ terms)
142.358 + else find_first_t (t::past) u terms
142.359 + handle TERM _ => find_first_t (t::past) u terms;
142.360 +
142.361 +(** Final simplification for the CancelFactor simprocs **)
142.362 +val simplify_one = Arith_Data.simplify_meta_eq
142.363 + [@{thm mult_1_left}, @{thm mult_1_right}, @{thm div_1}, @{thm numeral_1_eq_Suc_0}];
142.364 +
142.365 +fun cancel_simplify_meta_eq ss cancel_th th =
142.366 + simplify_one ss (([th, cancel_th]) MRS trans);
142.367 +
142.368 +structure CancelFactorCommon =
142.369 + struct
142.370 + val mk_sum = (fn T:typ => long_mk_prod)
142.371 + val dest_sum = dest_prod
142.372 + val mk_coeff = mk_coeff
142.373 + val dest_coeff = dest_coeff
142.374 + val find_first = find_first_t []
142.375 + val trans_tac = K Arith_Data.trans_tac
142.376 + val norm_ss = HOL_ss addsimps mult_1s @ @{thms mult_ac}
142.377 + fun norm_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss))
142.378 + val simplify_meta_eq = cancel_simplify_meta_eq
142.379 + end;
142.380 +
142.381 +structure EqCancelFactor = ExtractCommonTermFun
142.382 + (open CancelFactorCommon
142.383 + val prove_conv = Arith_Data.prove_conv
142.384 + val mk_bal = HOLogic.mk_eq
142.385 + val dest_bal = HOLogic.dest_bin "op =" HOLogic.natT
142.386 + val simp_conv = K(K (SOME @{thm nat_mult_eq_cancel_disj}))
142.387 +);
142.388 +
142.389 +structure LessCancelFactor = ExtractCommonTermFun
142.390 + (open CancelFactorCommon
142.391 + val prove_conv = Arith_Data.prove_conv
142.392 + val mk_bal = HOLogic.mk_binrel @{const_name HOL.less}
142.393 + val dest_bal = HOLogic.dest_bin @{const_name HOL.less} HOLogic.natT
142.394 + val simp_conv = K(K (SOME @{thm nat_mult_less_cancel_disj}))
142.395 +);
142.396 +
142.397 +structure LeCancelFactor = ExtractCommonTermFun
142.398 + (open CancelFactorCommon
142.399 + val prove_conv = Arith_Data.prove_conv
142.400 + val mk_bal = HOLogic.mk_binrel @{const_name HOL.less_eq}
142.401 + val dest_bal = HOLogic.dest_bin @{const_name HOL.less_eq} HOLogic.natT
142.402 + val simp_conv = K(K (SOME @{thm nat_mult_le_cancel_disj}))
142.403 +);
142.404 +
142.405 +structure DivideCancelFactor = ExtractCommonTermFun
142.406 + (open CancelFactorCommon
142.407 + val prove_conv = Arith_Data.prove_conv
142.408 + val mk_bal = HOLogic.mk_binop @{const_name Divides.div}
142.409 + val dest_bal = HOLogic.dest_bin @{const_name Divides.div} HOLogic.natT
142.410 + val simp_conv = K(K (SOME @{thm nat_mult_div_cancel_disj}))
142.411 +);
142.412 +
142.413 +structure DvdCancelFactor = ExtractCommonTermFun
142.414 + (open CancelFactorCommon
142.415 + val prove_conv = Arith_Data.prove_conv
142.416 + val mk_bal = HOLogic.mk_binrel @{const_name Ring_and_Field.dvd}
142.417 + val dest_bal = HOLogic.dest_bin @{const_name Ring_and_Field.dvd} HOLogic.natT
142.418 + val simp_conv = K(K (SOME @{thm nat_mult_dvd_cancel_disj}))
142.419 +);
142.420 +
142.421 +val cancel_factor =
142.422 + map Arith_Data.prep_simproc
142.423 + [("nat_eq_cancel_factor",
142.424 + ["(l::nat) * m = n", "(l::nat) = m * n"],
142.425 + K EqCancelFactor.proc),
142.426 + ("nat_less_cancel_factor",
142.427 + ["(l::nat) * m < n", "(l::nat) < m * n"],
142.428 + K LessCancelFactor.proc),
142.429 + ("nat_le_cancel_factor",
142.430 + ["(l::nat) * m <= n", "(l::nat) <= m * n"],
142.431 + K LeCancelFactor.proc),
142.432 + ("nat_divide_cancel_factor",
142.433 + ["((l::nat) * m) div n", "(l::nat) div (m * n)"],
142.434 + K DivideCancelFactor.proc),
142.435 + ("nat_dvd_cancel_factor",
142.436 + ["((l::nat) * m) dvd n", "(l::nat) dvd (m * n)"],
142.437 + K DvdCancelFactor.proc)];
142.438 +
142.439 +end;
142.440 +
142.441 +
142.442 +Addsimprocs Nat_Numeral_Simprocs.cancel_numerals;
142.443 +Addsimprocs [Nat_Numeral_Simprocs.combine_numerals];
142.444 +Addsimprocs Nat_Numeral_Simprocs.cancel_numeral_factors;
142.445 +Addsimprocs Nat_Numeral_Simprocs.cancel_factor;
142.446 +
142.447 +
142.448 +(*examples:
142.449 +print_depth 22;
142.450 +set timing;
142.451 +set trace_simp;
142.452 +fun test s = (Goal s; by (Simp_tac 1));
142.453 +
142.454 +(*cancel_numerals*)
142.455 +test "l +( 2) + (2) + 2 + (l + 2) + (oo + 2) = (uu::nat)";
142.456 +test "(2*length xs < 2*length xs + j)";
142.457 +test "(2*length xs < length xs * 2 + j)";
142.458 +test "2*u = (u::nat)";
142.459 +test "2*u = Suc (u)";
142.460 +test "(i + j + 12 + (k::nat)) - 15 = y";
142.461 +test "(i + j + 12 + (k::nat)) - 5 = y";
142.462 +test "Suc u - 2 = y";
142.463 +test "Suc (Suc (Suc u)) - 2 = y";
142.464 +test "(i + j + 2 + (k::nat)) - 1 = y";
142.465 +test "(i + j + 1 + (k::nat)) - 2 = y";
142.466 +
142.467 +test "(2*x + (u*v) + y) - v*3*u = (w::nat)";
142.468 +test "(2*x*u*v + 5 + (u*v)*4 + y) - v*u*4 = (w::nat)";
142.469 +test "(2*x*u*v + (u*v)*4 + y) - v*u = (w::nat)";
142.470 +test "Suc (Suc (2*x*u*v + u*4 + y)) - u = w";
142.471 +test "Suc ((u*v)*4) - v*3*u = w";
142.472 +test "Suc (Suc ((u*v)*3)) - v*3*u = w";
142.473 +
142.474 +test "(i + j + 12 + (k::nat)) = u + 15 + y";
142.475 +test "(i + j + 32 + (k::nat)) - (u + 15 + y) = zz";
142.476 +test "(i + j + 12 + (k::nat)) = u + 5 + y";
142.477 +(*Suc*)
142.478 +test "(i + j + 12 + k) = Suc (u + y)";
142.479 +test "Suc (Suc (Suc (Suc (Suc (u + y))))) <= ((i + j) + 41 + k)";
142.480 +test "(i + j + 5 + k) < Suc (Suc (Suc (Suc (Suc (u + y)))))";
142.481 +test "Suc (Suc (Suc (Suc (Suc (u + y))))) - 5 = v";
142.482 +test "(i + j + 5 + k) = Suc (Suc (Suc (Suc (Suc (Suc (Suc (u + y)))))))";
142.483 +test "2*y + 3*z + 2*u = Suc (u)";
142.484 +test "2*y + 3*z + 6*w + 2*y + 3*z + 2*u = Suc (u)";
142.485 +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)";
142.486 +test "6 + 2*y + 3*z + 4*u = Suc (vv + 2*u + z)";
142.487 +test "(2*n*m) < (3*(m*n)) + (u::nat)";
142.488 +
142.489 +test "(Suc (Suc (Suc (Suc (Suc (Suc (case length (f c) of 0 => 0 | Suc k => k)))))) <= Suc 0)";
142.490 +
142.491 +test "Suc (Suc (Suc (Suc (Suc (Suc (length l1 + length l2)))))) <= length l1";
142.492 +
142.493 +test "( (Suc (Suc (Suc (Suc (Suc (length (compT P E A ST mxr e) + length l3)))))) <= length (compT P E A ST mxr e))";
142.494 +
142.495 +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))";
142.496 +
142.497 +
142.498 +(*negative numerals: FAIL*)
142.499 +test "(i + j + -23 + (k::nat)) < u + 15 + y";
142.500 +test "(i + j + 3 + (k::nat)) < u + -15 + y";
142.501 +test "(i + j + -12 + (k::nat)) - 15 = y";
142.502 +test "(i + j + 12 + (k::nat)) - -15 = y";
142.503 +test "(i + j + -12 + (k::nat)) - -15 = y";
142.504 +
142.505 +(*combine_numerals*)
142.506 +test "k + 3*k = (u::nat)";
142.507 +test "Suc (i + 3) = u";
142.508 +test "Suc (i + j + 3 + k) = u";
142.509 +test "k + j + 3*k + j = (u::nat)";
142.510 +test "Suc (j*i + i + k + 5 + 3*k + i*j*4) = (u::nat)";
142.511 +test "(2*n*m) + (3*(m*n)) = (u::nat)";
142.512 +(*negative numerals: FAIL*)
142.513 +test "Suc (i + j + -3 + k) = u";
142.514 +
142.515 +(*cancel_numeral_factors*)
142.516 +test "9*x = 12 * (y::nat)";
142.517 +test "(9*x) div (12 * (y::nat)) = z";
142.518 +test "9*x < 12 * (y::nat)";
142.519 +test "9*x <= 12 * (y::nat)";
142.520 +
142.521 +(*cancel_factor*)
142.522 +test "x*k = k*(y::nat)";
142.523 +test "k = k*(y::nat)";
142.524 +test "a*(b*c) = (b::nat)";
142.525 +test "a*(b*c) = d*(b::nat)*(x*a)";
142.526 +
142.527 +test "x*k < k*(y::nat)";
142.528 +test "k < k*(y::nat)";
142.529 +test "a*(b*c) < (b::nat)";
142.530 +test "a*(b*c) < d*(b::nat)*(x*a)";
142.531 +
142.532 +test "x*k <= k*(y::nat)";
142.533 +test "k <= k*(y::nat)";
142.534 +test "a*(b*c) <= (b::nat)";
142.535 +test "a*(b*c) <= d*(b::nat)*(x*a)";
142.536 +
142.537 +test "(x*k) div (k*(y::nat)) = (uu::nat)";
142.538 +test "(k) div (k*(y::nat)) = (uu::nat)";
142.539 +test "(a*(b*c)) div ((b::nat)) = (uu::nat)";
142.540 +test "(a*(b*c)) div (d*(b::nat)*(x*a)) = (uu::nat)";
142.541 +*)
143.1 --- a/src/HOL/Tools/nat_simprocs.ML Mon May 11 09:39:53 2009 +0200
143.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
143.3 @@ -1,574 +0,0 @@
143.4 -(* Title: HOL/Tools/nat_simprocs.ML
143.5 - Author: Lawrence C Paulson, Cambridge University Computer Laboratory
143.6 -
143.7 -Simprocs for nat numerals.
143.8 -*)
143.9 -
143.10 -structure Nat_Numeral_Simprocs =
143.11 -struct
143.12 -
143.13 -(*Maps n to #n for n = 0, 1, 2*)
143.14 -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];
143.15 -val numeral_sym_ss = HOL_ss addsimps numeral_syms;
143.16 -
143.17 -fun rename_numerals th =
143.18 - simplify numeral_sym_ss (Thm.transfer (the_context ()) th);
143.19 -
143.20 -(*Utilities*)
143.21 -
143.22 -fun mk_number n = HOLogic.number_of_const HOLogic.natT $ HOLogic.mk_numeral n;
143.23 -fun dest_number t = Int.max (0, snd (HOLogic.dest_number t));
143.24 -
143.25 -fun find_first_numeral past (t::terms) =
143.26 - ((dest_number t, t, rev past @ terms)
143.27 - handle TERM _ => find_first_numeral (t::past) terms)
143.28 - | find_first_numeral past [] = raise TERM("find_first_numeral", []);
143.29 -
143.30 -val zero = mk_number 0;
143.31 -val mk_plus = HOLogic.mk_binop @{const_name HOL.plus};
143.32 -
143.33 -(*Thus mk_sum[t] yields t+0; longer sums don't have a trailing zero*)
143.34 -fun mk_sum [] = zero
143.35 - | mk_sum [t,u] = mk_plus (t, u)
143.36 - | mk_sum (t :: ts) = mk_plus (t, mk_sum ts);
143.37 -
143.38 -(*this version ALWAYS includes a trailing zero*)
143.39 -fun long_mk_sum [] = HOLogic.zero
143.40 - | long_mk_sum (t :: ts) = mk_plus (t, mk_sum ts);
143.41 -
143.42 -val dest_plus = HOLogic.dest_bin @{const_name HOL.plus} HOLogic.natT;
143.43 -
143.44 -
143.45 -(** Other simproc items **)
143.46 -
143.47 -val bin_simps =
143.48 - [@{thm nat_numeral_0_eq_0} RS sym, @{thm nat_numeral_1_eq_1} RS sym,
143.49 - @{thm add_nat_number_of}, @{thm nat_number_of_add_left},
143.50 - @{thm diff_nat_number_of}, @{thm le_number_of_eq_not_less},
143.51 - @{thm mult_nat_number_of}, @{thm nat_number_of_mult_left},
143.52 - @{thm less_nat_number_of},
143.53 - @{thm Let_number_of}, @{thm nat_number_of}] @
143.54 - @{thms arith_simps} @ @{thms rel_simps} @ @{thms neg_simps};
143.55 -
143.56 -
143.57 -(*** CancelNumerals simprocs ***)
143.58 -
143.59 -val one = mk_number 1;
143.60 -val mk_times = HOLogic.mk_binop @{const_name HOL.times};
143.61 -
143.62 -fun mk_prod [] = one
143.63 - | mk_prod [t] = t
143.64 - | mk_prod (t :: ts) = if t = one then mk_prod ts
143.65 - else mk_times (t, mk_prod ts);
143.66 -
143.67 -val dest_times = HOLogic.dest_bin @{const_name HOL.times} HOLogic.natT;
143.68 -
143.69 -fun dest_prod t =
143.70 - let val (t,u) = dest_times t
143.71 - in dest_prod t @ dest_prod u end
143.72 - handle TERM _ => [t];
143.73 -
143.74 -(*DON'T do the obvious simplifications; that would create special cases*)
143.75 -fun mk_coeff (k,t) = mk_times (mk_number k, t);
143.76 -
143.77 -(*Express t as a product of (possibly) a numeral with other factors, sorted*)
143.78 -fun dest_coeff t =
143.79 - let val ts = sort TermOrd.term_ord (dest_prod t)
143.80 - val (n, _, ts') = find_first_numeral [] ts
143.81 - handle TERM _ => (1, one, ts)
143.82 - in (n, mk_prod ts') end;
143.83 -
143.84 -(*Find first coefficient-term THAT MATCHES u*)
143.85 -fun find_first_coeff past u [] = raise TERM("find_first_coeff", [])
143.86 - | find_first_coeff past u (t::terms) =
143.87 - let val (n,u') = dest_coeff t
143.88 - in if u aconv u' then (n, rev past @ terms)
143.89 - else find_first_coeff (t::past) u terms
143.90 - end
143.91 - handle TERM _ => find_first_coeff (t::past) u terms;
143.92 -
143.93 -
143.94 -(*Split up a sum into the list of its constituent terms, on the way removing any
143.95 - Sucs and counting them.*)
143.96 -fun dest_Suc_sum (Const ("Suc", _) $ t, (k,ts)) = dest_Suc_sum (t, (k+1,ts))
143.97 - | dest_Suc_sum (t, (k,ts)) =
143.98 - let val (t1,t2) = dest_plus t
143.99 - in dest_Suc_sum (t1, dest_Suc_sum (t2, (k,ts))) end
143.100 - handle TERM _ => (k, t::ts);
143.101 -
143.102 -(*Code for testing whether numerals are already used in the goal*)
143.103 -fun is_numeral (Const(@{const_name Int.number_of}, _) $ w) = true
143.104 - | is_numeral _ = false;
143.105 -
143.106 -fun prod_has_numeral t = exists is_numeral (dest_prod t);
143.107 -
143.108 -(*The Sucs found in the term are converted to a binary numeral. If relaxed is false,
143.109 - an exception is raised unless the original expression contains at least one
143.110 - numeral in a coefficient position. This prevents nat_combine_numerals from
143.111 - introducing numerals to goals.*)
143.112 -fun dest_Sucs_sum relaxed t =
143.113 - let val (k,ts) = dest_Suc_sum (t,(0,[]))
143.114 - in
143.115 - if relaxed orelse exists prod_has_numeral ts then
143.116 - if k=0 then ts
143.117 - else mk_number k :: ts
143.118 - else raise TERM("Nat_Numeral_Simprocs.dest_Sucs_sum", [t])
143.119 - end;
143.120 -
143.121 -
143.122 -(*Simplify 1*n and n*1 to n*)
143.123 -val add_0s = map rename_numerals [@{thm add_0}, @{thm add_0_right}];
143.124 -val mult_1s = map rename_numerals [@{thm nat_mult_1}, @{thm nat_mult_1_right}];
143.125 -
143.126 -(*Final simplification: cancel + and *; replace Numeral0 by 0 and Numeral1 by 1*)
143.127 -
143.128 -(*And these help the simproc return False when appropriate, which helps
143.129 - the arith prover.*)
143.130 -val contra_rules = [@{thm add_Suc}, @{thm add_Suc_right}, @{thm Zero_not_Suc},
143.131 - @{thm Suc_not_Zero}, @{thm le_0_eq}];
143.132 -
143.133 -val simplify_meta_eq =
143.134 - Arith_Data.simplify_meta_eq
143.135 - ([@{thm nat_numeral_0_eq_0}, @{thm numeral_1_eq_Suc_0}, @{thm add_0}, @{thm add_0_right},
143.136 - @{thm mult_0}, @{thm mult_0_right}, @{thm mult_1}, @{thm mult_1_right}] @ contra_rules);
143.137 -
143.138 -
143.139 -(*** Applying CancelNumeralsFun ***)
143.140 -
143.141 -structure CancelNumeralsCommon =
143.142 - struct
143.143 - val mk_sum = (fn T:typ => mk_sum)
143.144 - val dest_sum = dest_Sucs_sum true
143.145 - val mk_coeff = mk_coeff
143.146 - val dest_coeff = dest_coeff
143.147 - val find_first_coeff = find_first_coeff []
143.148 - val trans_tac = K Arith_Data.trans_tac
143.149 -
143.150 - val norm_ss1 = Int_Numeral_Simprocs.num_ss addsimps numeral_syms @ add_0s @ mult_1s @
143.151 - [@{thm Suc_eq_add_numeral_1_left}] @ @{thms add_ac}
143.152 - val norm_ss2 = Int_Numeral_Simprocs.num_ss addsimps bin_simps @ @{thms add_ac} @ @{thms mult_ac}
143.153 - fun norm_tac ss =
143.154 - ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1))
143.155 - THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2))
143.156 -
143.157 - val numeral_simp_ss = HOL_ss addsimps add_0s @ bin_simps;
143.158 - fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss));
143.159 - val simplify_meta_eq = simplify_meta_eq
143.160 - end;
143.161 -
143.162 -
143.163 -structure EqCancelNumerals = CancelNumeralsFun
143.164 - (open CancelNumeralsCommon
143.165 - val prove_conv = Arith_Data.prove_conv
143.166 - val mk_bal = HOLogic.mk_eq
143.167 - val dest_bal = HOLogic.dest_bin "op =" HOLogic.natT
143.168 - val bal_add1 = @{thm nat_eq_add_iff1} RS trans
143.169 - val bal_add2 = @{thm nat_eq_add_iff2} RS trans
143.170 -);
143.171 -
143.172 -structure LessCancelNumerals = CancelNumeralsFun
143.173 - (open CancelNumeralsCommon
143.174 - val prove_conv = Arith_Data.prove_conv
143.175 - val mk_bal = HOLogic.mk_binrel @{const_name HOL.less}
143.176 - val dest_bal = HOLogic.dest_bin @{const_name HOL.less} HOLogic.natT
143.177 - val bal_add1 = @{thm nat_less_add_iff1} RS trans
143.178 - val bal_add2 = @{thm nat_less_add_iff2} RS trans
143.179 -);
143.180 -
143.181 -structure LeCancelNumerals = CancelNumeralsFun
143.182 - (open CancelNumeralsCommon
143.183 - val prove_conv = Arith_Data.prove_conv
143.184 - val mk_bal = HOLogic.mk_binrel @{const_name HOL.less_eq}
143.185 - val dest_bal = HOLogic.dest_bin @{const_name HOL.less_eq} HOLogic.natT
143.186 - val bal_add1 = @{thm nat_le_add_iff1} RS trans
143.187 - val bal_add2 = @{thm nat_le_add_iff2} RS trans
143.188 -);
143.189 -
143.190 -structure DiffCancelNumerals = CancelNumeralsFun
143.191 - (open CancelNumeralsCommon
143.192 - val prove_conv = Arith_Data.prove_conv
143.193 - val mk_bal = HOLogic.mk_binop @{const_name HOL.minus}
143.194 - val dest_bal = HOLogic.dest_bin @{const_name HOL.minus} HOLogic.natT
143.195 - val bal_add1 = @{thm nat_diff_add_eq1} RS trans
143.196 - val bal_add2 = @{thm nat_diff_add_eq2} RS trans
143.197 -);
143.198 -
143.199 -
143.200 -val cancel_numerals =
143.201 - map Arith_Data.prep_simproc
143.202 - [("nateq_cancel_numerals",
143.203 - ["(l::nat) + m = n", "(l::nat) = m + n",
143.204 - "(l::nat) * m = n", "(l::nat) = m * n",
143.205 - "Suc m = n", "m = Suc n"],
143.206 - K EqCancelNumerals.proc),
143.207 - ("natless_cancel_numerals",
143.208 - ["(l::nat) + m < n", "(l::nat) < m + n",
143.209 - "(l::nat) * m < n", "(l::nat) < m * n",
143.210 - "Suc m < n", "m < Suc n"],
143.211 - K LessCancelNumerals.proc),
143.212 - ("natle_cancel_numerals",
143.213 - ["(l::nat) + m <= n", "(l::nat) <= m + n",
143.214 - "(l::nat) * m <= n", "(l::nat) <= m * n",
143.215 - "Suc m <= n", "m <= Suc n"],
143.216 - K LeCancelNumerals.proc),
143.217 - ("natdiff_cancel_numerals",
143.218 - ["((l::nat) + m) - n", "(l::nat) - (m + n)",
143.219 - "(l::nat) * m - n", "(l::nat) - m * n",
143.220 - "Suc m - n", "m - Suc n"],
143.221 - K DiffCancelNumerals.proc)];
143.222 -
143.223 -
143.224 -(*** Applying CombineNumeralsFun ***)
143.225 -
143.226 -structure CombineNumeralsData =
143.227 - struct
143.228 - type coeff = int
143.229 - val iszero = (fn x => x = 0)
143.230 - val add = op +
143.231 - val mk_sum = (fn T:typ => long_mk_sum) (*to work for 2*x + 3*x *)
143.232 - val dest_sum = dest_Sucs_sum false
143.233 - val mk_coeff = mk_coeff
143.234 - val dest_coeff = dest_coeff
143.235 - val left_distrib = @{thm left_add_mult_distrib} RS trans
143.236 - val prove_conv = Arith_Data.prove_conv_nohyps
143.237 - val trans_tac = K Arith_Data.trans_tac
143.238 -
143.239 - val norm_ss1 = Int_Numeral_Simprocs.num_ss addsimps numeral_syms @ add_0s @ mult_1s @ [@{thm Suc_eq_add_numeral_1}] @ @{thms add_ac}
143.240 - val norm_ss2 = Int_Numeral_Simprocs.num_ss addsimps bin_simps @ @{thms add_ac} @ @{thms mult_ac}
143.241 - fun norm_tac ss =
143.242 - ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1))
143.243 - THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2))
143.244 -
143.245 - val numeral_simp_ss = HOL_ss addsimps add_0s @ bin_simps;
143.246 - fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss))
143.247 - val simplify_meta_eq = simplify_meta_eq
143.248 - end;
143.249 -
143.250 -structure CombineNumerals = CombineNumeralsFun(CombineNumeralsData);
143.251 -
143.252 -val combine_numerals =
143.253 - Arith_Data.prep_simproc ("nat_combine_numerals", ["(i::nat) + j", "Suc (i + j)"], K CombineNumerals.proc);
143.254 -
143.255 -
143.256 -(*** Applying CancelNumeralFactorFun ***)
143.257 -
143.258 -structure CancelNumeralFactorCommon =
143.259 - struct
143.260 - val mk_coeff = mk_coeff
143.261 - val dest_coeff = dest_coeff
143.262 - val trans_tac = K Arith_Data.trans_tac
143.263 -
143.264 - val norm_ss1 = Int_Numeral_Simprocs.num_ss addsimps
143.265 - numeral_syms @ add_0s @ mult_1s @ [@{thm Suc_eq_add_numeral_1_left}] @ @{thms add_ac}
143.266 - val norm_ss2 = Int_Numeral_Simprocs.num_ss addsimps bin_simps @ @{thms add_ac} @ @{thms mult_ac}
143.267 - fun norm_tac ss =
143.268 - ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1))
143.269 - THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2))
143.270 -
143.271 - val numeral_simp_ss = HOL_ss addsimps bin_simps
143.272 - fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss))
143.273 - val simplify_meta_eq = simplify_meta_eq
143.274 - end
143.275 -
143.276 -structure DivCancelNumeralFactor = CancelNumeralFactorFun
143.277 - (open CancelNumeralFactorCommon
143.278 - val prove_conv = Arith_Data.prove_conv
143.279 - val mk_bal = HOLogic.mk_binop @{const_name Divides.div}
143.280 - val dest_bal = HOLogic.dest_bin @{const_name Divides.div} HOLogic.natT
143.281 - val cancel = @{thm nat_mult_div_cancel1} RS trans
143.282 - val neg_exchanges = false
143.283 -)
143.284 -
143.285 -structure DvdCancelNumeralFactor = CancelNumeralFactorFun
143.286 - (open CancelNumeralFactorCommon
143.287 - val prove_conv = Arith_Data.prove_conv
143.288 - val mk_bal = HOLogic.mk_binrel @{const_name Ring_and_Field.dvd}
143.289 - val dest_bal = HOLogic.dest_bin @{const_name Ring_and_Field.dvd} HOLogic.natT
143.290 - val cancel = @{thm nat_mult_dvd_cancel1} RS trans
143.291 - val neg_exchanges = false
143.292 -)
143.293 -
143.294 -structure EqCancelNumeralFactor = CancelNumeralFactorFun
143.295 - (open CancelNumeralFactorCommon
143.296 - val prove_conv = Arith_Data.prove_conv
143.297 - val mk_bal = HOLogic.mk_eq
143.298 - val dest_bal = HOLogic.dest_bin "op =" HOLogic.natT
143.299 - val cancel = @{thm nat_mult_eq_cancel1} RS trans
143.300 - val neg_exchanges = false
143.301 -)
143.302 -
143.303 -structure LessCancelNumeralFactor = CancelNumeralFactorFun
143.304 - (open CancelNumeralFactorCommon
143.305 - val prove_conv = Arith_Data.prove_conv
143.306 - val mk_bal = HOLogic.mk_binrel @{const_name HOL.less}
143.307 - val dest_bal = HOLogic.dest_bin @{const_name HOL.less} HOLogic.natT
143.308 - val cancel = @{thm nat_mult_less_cancel1} RS trans
143.309 - val neg_exchanges = true
143.310 -)
143.311 -
143.312 -structure LeCancelNumeralFactor = CancelNumeralFactorFun
143.313 - (open CancelNumeralFactorCommon
143.314 - val prove_conv = Arith_Data.prove_conv
143.315 - val mk_bal = HOLogic.mk_binrel @{const_name HOL.less_eq}
143.316 - val dest_bal = HOLogic.dest_bin @{const_name HOL.less_eq} HOLogic.natT
143.317 - val cancel = @{thm nat_mult_le_cancel1} RS trans
143.318 - val neg_exchanges = true
143.319 -)
143.320 -
143.321 -val cancel_numeral_factors =
143.322 - map Arith_Data.prep_simproc
143.323 - [("nateq_cancel_numeral_factors",
143.324 - ["(l::nat) * m = n", "(l::nat) = m * n"],
143.325 - K EqCancelNumeralFactor.proc),
143.326 - ("natless_cancel_numeral_factors",
143.327 - ["(l::nat) * m < n", "(l::nat) < m * n"],
143.328 - K LessCancelNumeralFactor.proc),
143.329 - ("natle_cancel_numeral_factors",
143.330 - ["(l::nat) * m <= n", "(l::nat) <= m * n"],
143.331 - K LeCancelNumeralFactor.proc),
143.332 - ("natdiv_cancel_numeral_factors",
143.333 - ["((l::nat) * m) div n", "(l::nat) div (m * n)"],
143.334 - K DivCancelNumeralFactor.proc),
143.335 - ("natdvd_cancel_numeral_factors",
143.336 - ["((l::nat) * m) dvd n", "(l::nat) dvd (m * n)"],
143.337 - K DvdCancelNumeralFactor.proc)];
143.338 -
143.339 -
143.340 -
143.341 -(*** Applying ExtractCommonTermFun ***)
143.342 -
143.343 -(*this version ALWAYS includes a trailing one*)
143.344 -fun long_mk_prod [] = one
143.345 - | long_mk_prod (t :: ts) = mk_times (t, mk_prod ts);
143.346 -
143.347 -(*Find first term that matches u*)
143.348 -fun find_first_t past u [] = raise TERM("find_first_t", [])
143.349 - | find_first_t past u (t::terms) =
143.350 - if u aconv t then (rev past @ terms)
143.351 - else find_first_t (t::past) u terms
143.352 - handle TERM _ => find_first_t (t::past) u terms;
143.353 -
143.354 -(** Final simplification for the CancelFactor simprocs **)
143.355 -val simplify_one = Arith_Data.simplify_meta_eq
143.356 - [@{thm mult_1_left}, @{thm mult_1_right}, @{thm div_1}, @{thm numeral_1_eq_Suc_0}];
143.357 -
143.358 -fun cancel_simplify_meta_eq ss cancel_th th =
143.359 - simplify_one ss (([th, cancel_th]) MRS trans);
143.360 -
143.361 -structure CancelFactorCommon =
143.362 - struct
143.363 - val mk_sum = (fn T:typ => long_mk_prod)
143.364 - val dest_sum = dest_prod
143.365 - val mk_coeff = mk_coeff
143.366 - val dest_coeff = dest_coeff
143.367 - val find_first = find_first_t []
143.368 - val trans_tac = K Arith_Data.trans_tac
143.369 - val norm_ss = HOL_ss addsimps mult_1s @ @{thms mult_ac}
143.370 - fun norm_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss))
143.371 - val simplify_meta_eq = cancel_simplify_meta_eq
143.372 - end;
143.373 -
143.374 -structure EqCancelFactor = ExtractCommonTermFun
143.375 - (open CancelFactorCommon
143.376 - val prove_conv = Arith_Data.prove_conv
143.377 - val mk_bal = HOLogic.mk_eq
143.378 - val dest_bal = HOLogic.dest_bin "op =" HOLogic.natT
143.379 - val simp_conv = K(K (SOME @{thm nat_mult_eq_cancel_disj}))
143.380 -);
143.381 -
143.382 -structure LessCancelFactor = ExtractCommonTermFun
143.383 - (open CancelFactorCommon
143.384 - val prove_conv = Arith_Data.prove_conv
143.385 - val mk_bal = HOLogic.mk_binrel @{const_name HOL.less}
143.386 - val dest_bal = HOLogic.dest_bin @{const_name HOL.less} HOLogic.natT
143.387 - val simp_conv = K(K (SOME @{thm nat_mult_less_cancel_disj}))
143.388 -);
143.389 -
143.390 -structure LeCancelFactor = ExtractCommonTermFun
143.391 - (open CancelFactorCommon
143.392 - val prove_conv = Arith_Data.prove_conv
143.393 - val mk_bal = HOLogic.mk_binrel @{const_name HOL.less_eq}
143.394 - val dest_bal = HOLogic.dest_bin @{const_name HOL.less_eq} HOLogic.natT
143.395 - val simp_conv = K(K (SOME @{thm nat_mult_le_cancel_disj}))
143.396 -);
143.397 -
143.398 -structure DivideCancelFactor = ExtractCommonTermFun
143.399 - (open CancelFactorCommon
143.400 - val prove_conv = Arith_Data.prove_conv
143.401 - val mk_bal = HOLogic.mk_binop @{const_name Divides.div}
143.402 - val dest_bal = HOLogic.dest_bin @{const_name Divides.div} HOLogic.natT
143.403 - val simp_conv = K(K (SOME @{thm nat_mult_div_cancel_disj}))
143.404 -);
143.405 -
143.406 -structure DvdCancelFactor = ExtractCommonTermFun
143.407 - (open CancelFactorCommon
143.408 - val prove_conv = Arith_Data.prove_conv
143.409 - val mk_bal = HOLogic.mk_binrel @{const_name Ring_and_Field.dvd}
143.410 - val dest_bal = HOLogic.dest_bin @{const_name Ring_and_Field.dvd} HOLogic.natT
143.411 - val simp_conv = K(K (SOME @{thm nat_mult_dvd_cancel_disj}))
143.412 -);
143.413 -
143.414 -val cancel_factor =
143.415 - map Arith_Data.prep_simproc
143.416 - [("nat_eq_cancel_factor",
143.417 - ["(l::nat) * m = n", "(l::nat) = m * n"],
143.418 - K EqCancelFactor.proc),
143.419 - ("nat_less_cancel_factor",
143.420 - ["(l::nat) * m < n", "(l::nat) < m * n"],
143.421 - K LessCancelFactor.proc),
143.422 - ("nat_le_cancel_factor",
143.423 - ["(l::nat) * m <= n", "(l::nat) <= m * n"],
143.424 - K LeCancelFactor.proc),
143.425 - ("nat_divide_cancel_factor",
143.426 - ["((l::nat) * m) div n", "(l::nat) div (m * n)"],
143.427 - K DivideCancelFactor.proc),
143.428 - ("nat_dvd_cancel_factor",
143.429 - ["((l::nat) * m) dvd n", "(l::nat) dvd (m * n)"],
143.430 - K DvdCancelFactor.proc)];
143.431 -
143.432 -end;
143.433 -
143.434 -
143.435 -Addsimprocs Nat_Numeral_Simprocs.cancel_numerals;
143.436 -Addsimprocs [Nat_Numeral_Simprocs.combine_numerals];
143.437 -Addsimprocs Nat_Numeral_Simprocs.cancel_numeral_factors;
143.438 -Addsimprocs Nat_Numeral_Simprocs.cancel_factor;
143.439 -
143.440 -
143.441 -(*examples:
143.442 -print_depth 22;
143.443 -set timing;
143.444 -set trace_simp;
143.445 -fun test s = (Goal s; by (Simp_tac 1));
143.446 -
143.447 -(*cancel_numerals*)
143.448 -test "l +( 2) + (2) + 2 + (l + 2) + (oo + 2) = (uu::nat)";
143.449 -test "(2*length xs < 2*length xs + j)";
143.450 -test "(2*length xs < length xs * 2 + j)";
143.451 -test "2*u = (u::nat)";
143.452 -test "2*u = Suc (u)";
143.453 -test "(i + j + 12 + (k::nat)) - 15 = y";
143.454 -test "(i + j + 12 + (k::nat)) - 5 = y";
143.455 -test "Suc u - 2 = y";
143.456 -test "Suc (Suc (Suc u)) - 2 = y";
143.457 -test "(i + j + 2 + (k::nat)) - 1 = y";
143.458 -test "(i + j + 1 + (k::nat)) - 2 = y";
143.459 -
143.460 -test "(2*x + (u*v) + y) - v*3*u = (w::nat)";
143.461 -test "(2*x*u*v + 5 + (u*v)*4 + y) - v*u*4 = (w::nat)";
143.462 -test "(2*x*u*v + (u*v)*4 + y) - v*u = (w::nat)";
143.463 -test "Suc (Suc (2*x*u*v + u*4 + y)) - u = w";
143.464 -test "Suc ((u*v)*4) - v*3*u = w";
143.465 -test "Suc (Suc ((u*v)*3)) - v*3*u = w";
143.466 -
143.467 -test "(i + j + 12 + (k::nat)) = u + 15 + y";
143.468 -test "(i + j + 32 + (k::nat)) - (u + 15 + y) = zz";
143.469 -test "(i + j + 12 + (k::nat)) = u + 5 + y";
143.470 -(*Suc*)
143.471 -test "(i + j + 12 + k) = Suc (u + y)";
143.472 -test "Suc (Suc (Suc (Suc (Suc (u + y))))) <= ((i + j) + 41 + k)";
143.473 -test "(i + j + 5 + k) < Suc (Suc (Suc (Suc (Suc (u + y)))))";
143.474 -test "Suc (Suc (Suc (Suc (Suc (u + y))))) - 5 = v";
143.475 -test "(i + j + 5 + k) = Suc (Suc (Suc (Suc (Suc (Suc (Suc (u + y)))))))";
143.476 -test "2*y + 3*z + 2*u = Suc (u)";
143.477 -test "2*y + 3*z + 6*w + 2*y + 3*z + 2*u = Suc (u)";
143.478 -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)";
143.479 -test "6 + 2*y + 3*z + 4*u = Suc (vv + 2*u + z)";
143.480 -test "(2*n*m) < (3*(m*n)) + (u::nat)";
143.481 -
143.482 -test "(Suc (Suc (Suc (Suc (Suc (Suc (case length (f c) of 0 => 0 | Suc k => k)))))) <= Suc 0)";
143.483 -
143.484 -test "Suc (Suc (Suc (Suc (Suc (Suc (length l1 + length l2)))))) <= length l1";
143.485 -
143.486 -test "( (Suc (Suc (Suc (Suc (Suc (length (compT P E A ST mxr e) + length l3)))))) <= length (compT P E A ST mxr e))";
143.487 -
143.488 -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))";
143.489 -
143.490 -
143.491 -(*negative numerals: FAIL*)
143.492 -test "(i + j + -23 + (k::nat)) < u + 15 + y";
143.493 -test "(i + j + 3 + (k::nat)) < u + -15 + y";
143.494 -test "(i + j + -12 + (k::nat)) - 15 = y";
143.495 -test "(i + j + 12 + (k::nat)) - -15 = y";
143.496 -test "(i + j + -12 + (k::nat)) - -15 = y";
143.497 -
143.498 -(*combine_numerals*)
143.499 -test "k + 3*k = (u::nat)";
143.500 -test "Suc (i + 3) = u";
143.501 -test "Suc (i + j + 3 + k) = u";
143.502 -test "k + j + 3*k + j = (u::nat)";
143.503 -test "Suc (j*i + i + k + 5 + 3*k + i*j*4) = (u::nat)";
143.504 -test "(2*n*m) + (3*(m*n)) = (u::nat)";
143.505 -(*negative numerals: FAIL*)
143.506 -test "Suc (i + j + -3 + k) = u";
143.507 -
143.508 -(*cancel_numeral_factors*)
143.509 -test "9*x = 12 * (y::nat)";
143.510 -test "(9*x) div (12 * (y::nat)) = z";
143.511 -test "9*x < 12 * (y::nat)";
143.512 -test "9*x <= 12 * (y::nat)";
143.513 -
143.514 -(*cancel_factor*)
143.515 -test "x*k = k*(y::nat)";
143.516 -test "k = k*(y::nat)";
143.517 -test "a*(b*c) = (b::nat)";
143.518 -test "a*(b*c) = d*(b::nat)*(x*a)";
143.519 -
143.520 -test "x*k < k*(y::nat)";
143.521 -test "k < k*(y::nat)";
143.522 -test "a*(b*c) < (b::nat)";
143.523 -test "a*(b*c) < d*(b::nat)*(x*a)";
143.524 -
143.525 -test "x*k <= k*(y::nat)";
143.526 -test "k <= k*(y::nat)";
143.527 -test "a*(b*c) <= (b::nat)";
143.528 -test "a*(b*c) <= d*(b::nat)*(x*a)";
143.529 -
143.530 -test "(x*k) div (k*(y::nat)) = (uu::nat)";
143.531 -test "(k) div (k*(y::nat)) = (uu::nat)";
143.532 -test "(a*(b*c)) div ((b::nat)) = (uu::nat)";
143.533 -test "(a*(b*c)) div (d*(b::nat)*(x*a)) = (uu::nat)";
143.534 -*)
143.535 -
143.536 -
143.537 -(*** Prepare linear arithmetic for nat numerals ***)
143.538 -
143.539 -local
143.540 -
143.541 -(* reduce contradictory <= to False *)
143.542 -val add_rules = @{thms ring_distribs} @
143.543 - [@{thm Let_number_of}, @{thm Let_0}, @{thm Let_1}, @{thm nat_0}, @{thm nat_1},
143.544 - @{thm add_nat_number_of}, @{thm diff_nat_number_of}, @{thm mult_nat_number_of},
143.545 - @{thm eq_nat_number_of}, @{thm less_nat_number_of}, @{thm le_number_of_eq_not_less},
143.546 - @{thm le_Suc_number_of}, @{thm le_number_of_Suc},
143.547 - @{thm less_Suc_number_of}, @{thm less_number_of_Suc},
143.548 - @{thm Suc_eq_number_of}, @{thm eq_number_of_Suc},
143.549 - @{thm mult_Suc}, @{thm mult_Suc_right},
143.550 - @{thm add_Suc}, @{thm add_Suc_right},
143.551 - @{thm eq_number_of_0}, @{thm eq_0_number_of}, @{thm less_0_number_of},
143.552 - @{thm of_int_number_of_eq}, @{thm of_nat_number_of_eq}, @{thm nat_number_of}, @{thm if_True}, @{thm if_False}];
143.553 -
143.554 -(* Products are multiplied out during proof (re)construction via
143.555 -ring_distribs. Ideally they should remain atomic. But that is
143.556 -currently not possible because 1 is replaced by Suc 0, and then some
143.557 -simprocs start to mess around with products like (n+1)*m. The rule
143.558 -1 == Suc 0 is necessary for early parts of HOL where numerals and
143.559 -simprocs are not yet available. But then it is difficult to remove
143.560 -that rule later on, because it may find its way back in when theories
143.561 -(and thus lin-arith simpsets) are merged. Otherwise one could turn the
143.562 -rule around (Suc n = n+1) and see if that helps products being left
143.563 -alone. *)
143.564 -
143.565 -val simprocs = Nat_Numeral_Simprocs.combine_numerals
143.566 - :: Nat_Numeral_Simprocs.cancel_numerals;
143.567 -
143.568 -in
143.569 -
143.570 -val nat_simprocs_setup =
143.571 - Lin_Arith.map_data (fn {add_mono_thms, mult_mono_thms, inj_thms, lessD, neqE, simpset} =>
143.572 - {add_mono_thms = add_mono_thms, mult_mono_thms = mult_mono_thms,
143.573 - inj_thms = inj_thms, lessD = lessD, neqE = neqE,
143.574 - simpset = simpset addsimps add_rules
143.575 - addsimprocs simprocs});
143.576 -
143.577 -end;
144.1 --- a/src/HOL/Tools/numeral.ML Mon May 11 09:39:53 2009 +0200
144.2 +++ b/src/HOL/Tools/numeral.ML Mon May 11 17:20:52 2009 +0200
144.3 @@ -1,5 +1,4 @@
144.4 (* Title: HOL/Tools/numeral.ML
144.5 - ID: $Id$
144.6 Author: Makarius
144.7
144.8 Logical operations on numerals (see also HOL/hologic.ML).
144.9 @@ -59,13 +58,8 @@
144.10
144.11 fun add_code number_of negative unbounded target thy =
144.12 let
144.13 - val pr_numeral = (Code_Printer.literal_numeral o Code_Target.the_literals thy) target;
144.14 - fun dest_numeral naming thm =
144.15 + fun dest_numeral pls' min' bit0' bit1' thm =
144.16 let
144.17 - val SOME pls' = Code_Thingol.lookup_const naming @{const_name Int.Pls};
144.18 - val SOME min' = Code_Thingol.lookup_const naming @{const_name Int.Min};
144.19 - val SOME bit0' = Code_Thingol.lookup_const naming @{const_name Int.Bit0};
144.20 - val SOME bit1' = Code_Thingol.lookup_const naming @{const_name Int.Bit1};
144.21 fun dest_bit (IConst (c, _)) = if c = bit0' then 0
144.22 else if c = bit1' then 1
144.23 else Code_Printer.nerror thm "Illegal numeral expression: illegal bit"
144.24 @@ -79,11 +73,12 @@
144.25 in case n of SOME n => SOME (2 * n + b) | NONE => NONE end
144.26 | dest_num _ = Code_Printer.nerror thm "Illegal numeral expression: illegal term";
144.27 in dest_num end;
144.28 - fun pretty _ naming thm _ _ [(t, _)] =
144.29 - (Code_Printer.str o pr_numeral unbounded o the_default 0 o dest_numeral naming thm) t;
144.30 + fun pretty literals [pls', min', bit0', bit1'] _ thm _ _ [(t, _)] =
144.31 + (Code_Printer.str o Code_Printer.literal_numeral literals unbounded
144.32 + o the_default 0 o dest_numeral pls' min' bit0' bit1' thm) t;
144.33 in
144.34 - thy
144.35 - |> Code_Target.add_syntax_const target number_of (SOME (1, pretty))
144.36 + thy |> Code_Target.add_syntax_const target number_of
144.37 + (SOME (1, ([@{const_name Int.Pls}, @{const_name Int.Min}, @{const_name Int.Bit0}, @{const_name Int.Bit1}], pretty)))
144.38 end;
144.39
144.40 end; (*local*)
145.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
145.2 +++ b/src/HOL/Tools/numeral_simprocs.ML Mon May 11 17:20:52 2009 +0200
145.3 @@ -0,0 +1,786 @@
145.4 +(* Author: Lawrence C Paulson, Cambridge University Computer Laboratory
145.5 + Copyright 2000 University of Cambridge
145.6 +
145.7 +Simprocs for the integer numerals.
145.8 +*)
145.9 +
145.10 +(*To quote from Provers/Arith/cancel_numeral_factor.ML:
145.11 +
145.12 +Cancels common coefficients in balanced expressions:
145.13 +
145.14 + u*#m ~~ u'*#m' == #n*u ~~ #n'*u'
145.15 +
145.16 +where ~~ is an appropriate balancing operation (e.g. =, <=, <, div, /)
145.17 +and d = gcd(m,m') and n=m/d and n'=m'/d.
145.18 +*)
145.19 +
145.20 +signature NUMERAL_SIMPROCS =
145.21 +sig
145.22 + val mk_sum: typ -> term list -> term
145.23 + val dest_sum: term -> term list
145.24 +
145.25 + val assoc_fold_simproc: simproc
145.26 + val combine_numerals: simproc
145.27 + val cancel_numerals: simproc list
145.28 + val cancel_factors: simproc list
145.29 + val cancel_numeral_factors: simproc list
145.30 + val field_combine_numerals: simproc
145.31 + val field_cancel_numeral_factors: simproc list
145.32 + val num_ss: simpset
145.33 +end;
145.34 +
145.35 +structure Numeral_Simprocs : NUMERAL_SIMPROCS =
145.36 +struct
145.37 +
145.38 +fun mk_number T n = HOLogic.number_of_const T $ HOLogic.mk_numeral n;
145.39 +
145.40 +fun find_first_numeral past (t::terms) =
145.41 + ((snd (HOLogic.dest_number t), rev past @ terms)
145.42 + handle TERM _ => find_first_numeral (t::past) terms)
145.43 + | find_first_numeral past [] = raise TERM("find_first_numeral", []);
145.44 +
145.45 +val mk_plus = HOLogic.mk_binop @{const_name HOL.plus};
145.46 +
145.47 +fun mk_minus t =
145.48 + let val T = Term.fastype_of t
145.49 + in Const (@{const_name HOL.uminus}, T --> T) $ t end;
145.50 +
145.51 +(*Thus mk_sum[t] yields t+0; longer sums don't have a trailing zero*)
145.52 +fun mk_sum T [] = mk_number T 0
145.53 + | mk_sum T [t,u] = mk_plus (t, u)
145.54 + | mk_sum T (t :: ts) = mk_plus (t, mk_sum T ts);
145.55 +
145.56 +(*this version ALWAYS includes a trailing zero*)
145.57 +fun long_mk_sum T [] = mk_number T 0
145.58 + | long_mk_sum T (t :: ts) = mk_plus (t, mk_sum T ts);
145.59 +
145.60 +val dest_plus = HOLogic.dest_bin @{const_name HOL.plus} Term.dummyT;
145.61 +
145.62 +(*decompose additions AND subtractions as a sum*)
145.63 +fun dest_summing (pos, Const (@{const_name HOL.plus}, _) $ t $ u, ts) =
145.64 + dest_summing (pos, t, dest_summing (pos, u, ts))
145.65 + | dest_summing (pos, Const (@{const_name HOL.minus}, _) $ t $ u, ts) =
145.66 + dest_summing (pos, t, dest_summing (not pos, u, ts))
145.67 + | dest_summing (pos, t, ts) =
145.68 + if pos then t::ts else mk_minus t :: ts;
145.69 +
145.70 +fun dest_sum t = dest_summing (true, t, []);
145.71 +
145.72 +val mk_diff = HOLogic.mk_binop @{const_name HOL.minus};
145.73 +val dest_diff = HOLogic.dest_bin @{const_name HOL.minus} Term.dummyT;
145.74 +
145.75 +val mk_times = HOLogic.mk_binop @{const_name HOL.times};
145.76 +
145.77 +fun one_of T = Const(@{const_name HOL.one},T);
145.78 +
145.79 +(* build product with trailing 1 rather than Numeral 1 in order to avoid the
145.80 + unnecessary restriction to type class number_ring
145.81 + which is not required for cancellation of common factors in divisions.
145.82 +*)
145.83 +fun mk_prod T =
145.84 + let val one = one_of T
145.85 + fun mk [] = one
145.86 + | mk [t] = t
145.87 + | mk (t :: ts) = if t = one then mk ts else mk_times (t, mk ts)
145.88 + in mk end;
145.89 +
145.90 +(*This version ALWAYS includes a trailing one*)
145.91 +fun long_mk_prod T [] = one_of T
145.92 + | long_mk_prod T (t :: ts) = mk_times (t, mk_prod T ts);
145.93 +
145.94 +val dest_times = HOLogic.dest_bin @{const_name HOL.times} Term.dummyT;
145.95 +
145.96 +fun dest_prod t =
145.97 + let val (t,u) = dest_times t
145.98 + in dest_prod t @ dest_prod u end
145.99 + handle TERM _ => [t];
145.100 +
145.101 +(*DON'T do the obvious simplifications; that would create special cases*)
145.102 +fun mk_coeff (k, t) = mk_times (mk_number (Term.fastype_of t) k, t);
145.103 +
145.104 +(*Express t as a product of (possibly) a numeral with other sorted terms*)
145.105 +fun dest_coeff sign (Const (@{const_name HOL.uminus}, _) $ t) = dest_coeff (~sign) t
145.106 + | dest_coeff sign t =
145.107 + let val ts = sort TermOrd.term_ord (dest_prod t)
145.108 + val (n, ts') = find_first_numeral [] ts
145.109 + handle TERM _ => (1, ts)
145.110 + in (sign*n, mk_prod (Term.fastype_of t) ts') end;
145.111 +
145.112 +(*Find first coefficient-term THAT MATCHES u*)
145.113 +fun find_first_coeff past u [] = raise TERM("find_first_coeff", [])
145.114 + | find_first_coeff past u (t::terms) =
145.115 + let val (n,u') = dest_coeff 1 t
145.116 + in if u aconv u' then (n, rev past @ terms)
145.117 + else find_first_coeff (t::past) u terms
145.118 + end
145.119 + handle TERM _ => find_first_coeff (t::past) u terms;
145.120 +
145.121 +(*Fractions as pairs of ints. Can't use Rat.rat because the representation
145.122 + needs to preserve negative values in the denominator.*)
145.123 +fun mk_frac (p, q) = if q = 0 then raise Div else (p, q);
145.124 +
145.125 +(*Don't reduce fractions; sums must be proved by rule add_frac_eq.
145.126 + Fractions are reduced later by the cancel_numeral_factor simproc.*)
145.127 +fun add_frac ((p1, q1), (p2, q2)) = (p1 * q2 + p2 * q1, q1 * q2);
145.128 +
145.129 +val mk_divide = HOLogic.mk_binop @{const_name HOL.divide};
145.130 +
145.131 +(*Build term (p / q) * t*)
145.132 +fun mk_fcoeff ((p, q), t) =
145.133 + let val T = Term.fastype_of t
145.134 + in mk_times (mk_divide (mk_number T p, mk_number T q), t) end;
145.135 +
145.136 +(*Express t as a product of a fraction with other sorted terms*)
145.137 +fun dest_fcoeff sign (Const (@{const_name HOL.uminus}, _) $ t) = dest_fcoeff (~sign) t
145.138 + | dest_fcoeff sign (Const (@{const_name HOL.divide}, _) $ t $ u) =
145.139 + let val (p, t') = dest_coeff sign t
145.140 + val (q, u') = dest_coeff 1 u
145.141 + in (mk_frac (p, q), mk_divide (t', u')) end
145.142 + | dest_fcoeff sign t =
145.143 + let val (p, t') = dest_coeff sign t
145.144 + val T = Term.fastype_of t
145.145 + in (mk_frac (p, 1), mk_divide (t', one_of T)) end;
145.146 +
145.147 +
145.148 +(** New term ordering so that AC-rewriting brings numerals to the front **)
145.149 +
145.150 +(*Order integers by absolute value and then by sign. The standard integer
145.151 + ordering is not well-founded.*)
145.152 +fun num_ord (i,j) =
145.153 + (case int_ord (abs i, abs j) of
145.154 + EQUAL => int_ord (Int.sign i, Int.sign j)
145.155 + | ord => ord);
145.156 +
145.157 +(*This resembles TermOrd.term_ord, but it puts binary numerals before other
145.158 + non-atomic terms.*)
145.159 +local open Term
145.160 +in
145.161 +fun numterm_ord (Abs (_, T, t), Abs(_, U, u)) =
145.162 + (case numterm_ord (t, u) of EQUAL => TermOrd.typ_ord (T, U) | ord => ord)
145.163 + | numterm_ord
145.164 + (Const(@{const_name Int.number_of}, _) $ v, Const(@{const_name Int.number_of}, _) $ w) =
145.165 + num_ord (HOLogic.dest_numeral v, HOLogic.dest_numeral w)
145.166 + | numterm_ord (Const(@{const_name Int.number_of}, _) $ _, _) = LESS
145.167 + | numterm_ord (_, Const(@{const_name Int.number_of}, _) $ _) = GREATER
145.168 + | numterm_ord (t, u) =
145.169 + (case int_ord (size_of_term t, size_of_term u) of
145.170 + EQUAL =>
145.171 + let val (f, ts) = strip_comb t and (g, us) = strip_comb u in
145.172 + (case TermOrd.hd_ord (f, g) of EQUAL => numterms_ord (ts, us) | ord => ord)
145.173 + end
145.174 + | ord => ord)
145.175 +and numterms_ord (ts, us) = list_ord numterm_ord (ts, us)
145.176 +end;
145.177 +
145.178 +fun numtermless tu = (numterm_ord tu = LESS);
145.179 +
145.180 +val num_ss = HOL_ss settermless numtermless;
145.181 +
145.182 +(*Maps 0 to Numeral0 and 1 to Numeral1 so that arithmetic isn't complicated by the abstract 0 and 1.*)
145.183 +val numeral_syms = [@{thm numeral_0_eq_0} RS sym, @{thm numeral_1_eq_1} RS sym];
145.184 +
145.185 +(*Simplify Numeral0+n, n+Numeral0, Numeral1*n, n*Numeral1, 1*x, x*1, x/1 *)
145.186 +val add_0s = @{thms add_0s};
145.187 +val mult_1s = @{thms mult_1s mult_1_left mult_1_right divide_1};
145.188 +
145.189 +(*Simplify inverse Numeral1, a/Numeral1*)
145.190 +val inverse_1s = [@{thm inverse_numeral_1}];
145.191 +val divide_1s = [@{thm divide_numeral_1}];
145.192 +
145.193 +(*To perform binary arithmetic. The "left" rewriting handles patterns
145.194 + created by the Numeral_Simprocs, such as 3 * (5 * x). *)
145.195 +val simps = [@{thm numeral_0_eq_0} RS sym, @{thm numeral_1_eq_1} RS sym,
145.196 + @{thm add_number_of_left}, @{thm mult_number_of_left}] @
145.197 + @{thms arith_simps} @ @{thms rel_simps};
145.198 +
145.199 +(*Binary arithmetic BUT NOT ADDITION since it may collapse adjacent terms
145.200 + during re-arrangement*)
145.201 +val non_add_simps =
145.202 + subtract Thm.eq_thm [@{thm add_number_of_left}, @{thm number_of_add} RS sym] simps;
145.203 +
145.204 +(*To evaluate binary negations of coefficients*)
145.205 +val minus_simps = [@{thm numeral_m1_eq_minus_1} RS sym, @{thm number_of_minus} RS sym] @
145.206 + @{thms minus_bin_simps} @ @{thms pred_bin_simps};
145.207 +
145.208 +(*To let us treat subtraction as addition*)
145.209 +val diff_simps = [@{thm diff_minus}, @{thm minus_add_distrib}, @{thm minus_minus}];
145.210 +
145.211 +(*To let us treat division as multiplication*)
145.212 +val divide_simps = [@{thm divide_inverse}, @{thm inverse_mult_distrib}, @{thm inverse_inverse_eq}];
145.213 +
145.214 +(*push the unary minus down: - x * y = x * - y *)
145.215 +val minus_mult_eq_1_to_2 =
145.216 + [@{thm mult_minus_left}, @{thm minus_mult_right}] MRS trans |> standard;
145.217 +
145.218 +(*to extract again any uncancelled minuses*)
145.219 +val minus_from_mult_simps =
145.220 + [@{thm minus_minus}, @{thm mult_minus_left}, @{thm mult_minus_right}];
145.221 +
145.222 +(*combine unary minus with numeric literals, however nested within a product*)
145.223 +val mult_minus_simps =
145.224 + [@{thm mult_assoc}, @{thm minus_mult_left}, minus_mult_eq_1_to_2];
145.225 +
145.226 +val norm_ss1 = num_ss addsimps numeral_syms @ add_0s @ mult_1s @
145.227 + diff_simps @ minus_simps @ @{thms add_ac}
145.228 +val norm_ss2 = num_ss addsimps non_add_simps @ mult_minus_simps
145.229 +val norm_ss3 = num_ss addsimps minus_from_mult_simps @ @{thms add_ac} @ @{thms mult_ac}
145.230 +
145.231 +structure CancelNumeralsCommon =
145.232 + struct
145.233 + val mk_sum = mk_sum
145.234 + val dest_sum = dest_sum
145.235 + val mk_coeff = mk_coeff
145.236 + val dest_coeff = dest_coeff 1
145.237 + val find_first_coeff = find_first_coeff []
145.238 + val trans_tac = K Arith_Data.trans_tac
145.239 +
145.240 + fun norm_tac ss =
145.241 + ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1))
145.242 + THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2))
145.243 + THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss3))
145.244 +
145.245 + val numeral_simp_ss = HOL_ss addsimps add_0s @ simps
145.246 + fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss))
145.247 + val simplify_meta_eq = Arith_Data.simplify_meta_eq (add_0s @ mult_1s)
145.248 + end;
145.249 +
145.250 +
145.251 +structure EqCancelNumerals = CancelNumeralsFun
145.252 + (open CancelNumeralsCommon
145.253 + val prove_conv = Arith_Data.prove_conv
145.254 + val mk_bal = HOLogic.mk_eq
145.255 + val dest_bal = HOLogic.dest_bin "op =" Term.dummyT
145.256 + val bal_add1 = @{thm eq_add_iff1} RS trans
145.257 + val bal_add2 = @{thm eq_add_iff2} RS trans
145.258 +);
145.259 +
145.260 +structure LessCancelNumerals = CancelNumeralsFun
145.261 + (open CancelNumeralsCommon
145.262 + val prove_conv = Arith_Data.prove_conv
145.263 + val mk_bal = HOLogic.mk_binrel @{const_name HOL.less}
145.264 + val dest_bal = HOLogic.dest_bin @{const_name HOL.less} Term.dummyT
145.265 + val bal_add1 = @{thm less_add_iff1} RS trans
145.266 + val bal_add2 = @{thm less_add_iff2} RS trans
145.267 +);
145.268 +
145.269 +structure LeCancelNumerals = CancelNumeralsFun
145.270 + (open CancelNumeralsCommon
145.271 + val prove_conv = Arith_Data.prove_conv
145.272 + val mk_bal = HOLogic.mk_binrel @{const_name HOL.less_eq}
145.273 + val dest_bal = HOLogic.dest_bin @{const_name HOL.less_eq} Term.dummyT
145.274 + val bal_add1 = @{thm le_add_iff1} RS trans
145.275 + val bal_add2 = @{thm le_add_iff2} RS trans
145.276 +);
145.277 +
145.278 +val cancel_numerals =
145.279 + map Arith_Data.prep_simproc
145.280 + [("inteq_cancel_numerals",
145.281 + ["(l::'a::number_ring) + m = n",
145.282 + "(l::'a::number_ring) = m + n",
145.283 + "(l::'a::number_ring) - m = n",
145.284 + "(l::'a::number_ring) = m - n",
145.285 + "(l::'a::number_ring) * m = n",
145.286 + "(l::'a::number_ring) = m * n"],
145.287 + K EqCancelNumerals.proc),
145.288 + ("intless_cancel_numerals",
145.289 + ["(l::'a::{ordered_idom,number_ring}) + m < n",
145.290 + "(l::'a::{ordered_idom,number_ring}) < m + n",
145.291 + "(l::'a::{ordered_idom,number_ring}) - m < n",
145.292 + "(l::'a::{ordered_idom,number_ring}) < m - n",
145.293 + "(l::'a::{ordered_idom,number_ring}) * m < n",
145.294 + "(l::'a::{ordered_idom,number_ring}) < m * n"],
145.295 + K LessCancelNumerals.proc),
145.296 + ("intle_cancel_numerals",
145.297 + ["(l::'a::{ordered_idom,number_ring}) + m <= n",
145.298 + "(l::'a::{ordered_idom,number_ring}) <= m + n",
145.299 + "(l::'a::{ordered_idom,number_ring}) - m <= n",
145.300 + "(l::'a::{ordered_idom,number_ring}) <= m - n",
145.301 + "(l::'a::{ordered_idom,number_ring}) * m <= n",
145.302 + "(l::'a::{ordered_idom,number_ring}) <= m * n"],
145.303 + K LeCancelNumerals.proc)];
145.304 +
145.305 +structure CombineNumeralsData =
145.306 + struct
145.307 + type coeff = int
145.308 + val iszero = (fn x => x = 0)
145.309 + val add = op +
145.310 + val mk_sum = long_mk_sum (*to work for e.g. 2*x + 3*x *)
145.311 + val dest_sum = dest_sum
145.312 + val mk_coeff = mk_coeff
145.313 + val dest_coeff = dest_coeff 1
145.314 + val left_distrib = @{thm combine_common_factor} RS trans
145.315 + val prove_conv = Arith_Data.prove_conv_nohyps
145.316 + val trans_tac = K Arith_Data.trans_tac
145.317 +
145.318 + fun norm_tac ss =
145.319 + ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1))
145.320 + THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2))
145.321 + THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss3))
145.322 +
145.323 + val numeral_simp_ss = HOL_ss addsimps add_0s @ simps
145.324 + fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss))
145.325 + val simplify_meta_eq = Arith_Data.simplify_meta_eq (add_0s @ mult_1s)
145.326 + end;
145.327 +
145.328 +structure CombineNumerals = CombineNumeralsFun(CombineNumeralsData);
145.329 +
145.330 +(*Version for fields, where coefficients can be fractions*)
145.331 +structure FieldCombineNumeralsData =
145.332 + struct
145.333 + type coeff = int * int
145.334 + val iszero = (fn (p, q) => p = 0)
145.335 + val add = add_frac
145.336 + val mk_sum = long_mk_sum
145.337 + val dest_sum = dest_sum
145.338 + val mk_coeff = mk_fcoeff
145.339 + val dest_coeff = dest_fcoeff 1
145.340 + val left_distrib = @{thm combine_common_factor} RS trans
145.341 + val prove_conv = Arith_Data.prove_conv_nohyps
145.342 + val trans_tac = K Arith_Data.trans_tac
145.343 +
145.344 + val norm_ss1a = norm_ss1 addsimps inverse_1s @ divide_simps
145.345 + fun norm_tac ss =
145.346 + ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1a))
145.347 + THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2))
145.348 + THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss3))
145.349 +
145.350 + val numeral_simp_ss = HOL_ss addsimps add_0s @ simps @ [@{thm add_frac_eq}]
145.351 + fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss))
145.352 + val simplify_meta_eq = Arith_Data.simplify_meta_eq (add_0s @ mult_1s @ divide_1s)
145.353 + end;
145.354 +
145.355 +structure FieldCombineNumerals = CombineNumeralsFun(FieldCombineNumeralsData);
145.356 +
145.357 +val combine_numerals =
145.358 + Arith_Data.prep_simproc
145.359 + ("int_combine_numerals",
145.360 + ["(i::'a::number_ring) + j", "(i::'a::number_ring) - j"],
145.361 + K CombineNumerals.proc);
145.362 +
145.363 +val field_combine_numerals =
145.364 + Arith_Data.prep_simproc
145.365 + ("field_combine_numerals",
145.366 + ["(i::'a::{number_ring,field,division_by_zero}) + j",
145.367 + "(i::'a::{number_ring,field,division_by_zero}) - j"],
145.368 + K FieldCombineNumerals.proc);
145.369 +
145.370 +(** Constant folding for multiplication in semirings **)
145.371 +
145.372 +(*We do not need folding for addition: combine_numerals does the same thing*)
145.373 +
145.374 +structure Semiring_Times_Assoc_Data : ASSOC_FOLD_DATA =
145.375 +struct
145.376 + val assoc_ss = HOL_ss addsimps @{thms mult_ac}
145.377 + val eq_reflection = eq_reflection
145.378 + fun is_numeral (Const(@{const_name Int.number_of}, _) $ _) = true
145.379 + | is_numeral _ = false;
145.380 +end;
145.381 +
145.382 +structure Semiring_Times_Assoc = Assoc_Fold (Semiring_Times_Assoc_Data);
145.383 +
145.384 +val assoc_fold_simproc =
145.385 + Arith_Data.prep_simproc
145.386 + ("semiring_assoc_fold", ["(a::'a::comm_semiring_1_cancel) * b"],
145.387 + K Semiring_Times_Assoc.proc);
145.388 +
145.389 +structure CancelNumeralFactorCommon =
145.390 + struct
145.391 + val mk_coeff = mk_coeff
145.392 + val dest_coeff = dest_coeff 1
145.393 + val trans_tac = K Arith_Data.trans_tac
145.394 +
145.395 + val norm_ss1 = HOL_ss addsimps minus_from_mult_simps @ mult_1s
145.396 + val norm_ss2 = HOL_ss addsimps simps @ mult_minus_simps
145.397 + val norm_ss3 = HOL_ss addsimps @{thms mult_ac}
145.398 + fun norm_tac ss =
145.399 + ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1))
145.400 + THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2))
145.401 + THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss3))
145.402 +
145.403 + val numeral_simp_ss = HOL_ss addsimps
145.404 + [@{thm eq_number_of_eq}, @{thm less_number_of}, @{thm le_number_of}] @ simps
145.405 + fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss))
145.406 + val simplify_meta_eq = Arith_Data.simplify_meta_eq
145.407 + [@{thm add_0}, @{thm add_0_right}, @{thm mult_zero_left},
145.408 + @{thm mult_zero_right}, @{thm mult_Bit1}, @{thm mult_1_right}];
145.409 + end
145.410 +
145.411 +(*Version for semiring_div*)
145.412 +structure DivCancelNumeralFactor = CancelNumeralFactorFun
145.413 + (open CancelNumeralFactorCommon
145.414 + val prove_conv = Arith_Data.prove_conv
145.415 + val mk_bal = HOLogic.mk_binop @{const_name Divides.div}
145.416 + val dest_bal = HOLogic.dest_bin @{const_name Divides.div} Term.dummyT
145.417 + val cancel = @{thm div_mult_mult1} RS trans
145.418 + val neg_exchanges = false
145.419 +)
145.420 +
145.421 +(*Version for fields*)
145.422 +structure DivideCancelNumeralFactor = CancelNumeralFactorFun
145.423 + (open CancelNumeralFactorCommon
145.424 + val prove_conv = Arith_Data.prove_conv
145.425 + val mk_bal = HOLogic.mk_binop @{const_name HOL.divide}
145.426 + val dest_bal = HOLogic.dest_bin @{const_name HOL.divide} Term.dummyT
145.427 + val cancel = @{thm mult_divide_mult_cancel_left} RS trans
145.428 + val neg_exchanges = false
145.429 +)
145.430 +
145.431 +structure EqCancelNumeralFactor = CancelNumeralFactorFun
145.432 + (open CancelNumeralFactorCommon
145.433 + val prove_conv = Arith_Data.prove_conv
145.434 + val mk_bal = HOLogic.mk_eq
145.435 + val dest_bal = HOLogic.dest_bin "op =" Term.dummyT
145.436 + val cancel = @{thm mult_cancel_left} RS trans
145.437 + val neg_exchanges = false
145.438 +)
145.439 +
145.440 +structure LessCancelNumeralFactor = CancelNumeralFactorFun
145.441 + (open CancelNumeralFactorCommon
145.442 + val prove_conv = Arith_Data.prove_conv
145.443 + val mk_bal = HOLogic.mk_binrel @{const_name HOL.less}
145.444 + val dest_bal = HOLogic.dest_bin @{const_name HOL.less} Term.dummyT
145.445 + val cancel = @{thm mult_less_cancel_left} RS trans
145.446 + val neg_exchanges = true
145.447 +)
145.448 +
145.449 +structure LeCancelNumeralFactor = CancelNumeralFactorFun
145.450 + (open CancelNumeralFactorCommon
145.451 + val prove_conv = Arith_Data.prove_conv
145.452 + val mk_bal = HOLogic.mk_binrel @{const_name HOL.less_eq}
145.453 + val dest_bal = HOLogic.dest_bin @{const_name HOL.less_eq} Term.dummyT
145.454 + val cancel = @{thm mult_le_cancel_left} RS trans
145.455 + val neg_exchanges = true
145.456 +)
145.457 +
145.458 +val cancel_numeral_factors =
145.459 + map Arith_Data.prep_simproc
145.460 + [("ring_eq_cancel_numeral_factor",
145.461 + ["(l::'a::{idom,number_ring}) * m = n",
145.462 + "(l::'a::{idom,number_ring}) = m * n"],
145.463 + K EqCancelNumeralFactor.proc),
145.464 + ("ring_less_cancel_numeral_factor",
145.465 + ["(l::'a::{ordered_idom,number_ring}) * m < n",
145.466 + "(l::'a::{ordered_idom,number_ring}) < m * n"],
145.467 + K LessCancelNumeralFactor.proc),
145.468 + ("ring_le_cancel_numeral_factor",
145.469 + ["(l::'a::{ordered_idom,number_ring}) * m <= n",
145.470 + "(l::'a::{ordered_idom,number_ring}) <= m * n"],
145.471 + K LeCancelNumeralFactor.proc),
145.472 + ("int_div_cancel_numeral_factors",
145.473 + ["((l::'a::{semiring_div,number_ring}) * m) div n",
145.474 + "(l::'a::{semiring_div,number_ring}) div (m * n)"],
145.475 + K DivCancelNumeralFactor.proc),
145.476 + ("divide_cancel_numeral_factor",
145.477 + ["((l::'a::{division_by_zero,field,number_ring}) * m) / n",
145.478 + "(l::'a::{division_by_zero,field,number_ring}) / (m * n)",
145.479 + "((number_of v)::'a::{division_by_zero,field,number_ring}) / (number_of w)"],
145.480 + K DivideCancelNumeralFactor.proc)];
145.481 +
145.482 +val field_cancel_numeral_factors =
145.483 + map Arith_Data.prep_simproc
145.484 + [("field_eq_cancel_numeral_factor",
145.485 + ["(l::'a::{field,number_ring}) * m = n",
145.486 + "(l::'a::{field,number_ring}) = m * n"],
145.487 + K EqCancelNumeralFactor.proc),
145.488 + ("field_cancel_numeral_factor",
145.489 + ["((l::'a::{division_by_zero,field,number_ring}) * m) / n",
145.490 + "(l::'a::{division_by_zero,field,number_ring}) / (m * n)",
145.491 + "((number_of v)::'a::{division_by_zero,field,number_ring}) / (number_of w)"],
145.492 + K DivideCancelNumeralFactor.proc)]
145.493 +
145.494 +
145.495 +(** Declarations for ExtractCommonTerm **)
145.496 +
145.497 +(*Find first term that matches u*)
145.498 +fun find_first_t past u [] = raise TERM ("find_first_t", [])
145.499 + | find_first_t past u (t::terms) =
145.500 + if u aconv t then (rev past @ terms)
145.501 + else find_first_t (t::past) u terms
145.502 + handle TERM _ => find_first_t (t::past) u terms;
145.503 +
145.504 +(** Final simplification for the CancelFactor simprocs **)
145.505 +val simplify_one = Arith_Data.simplify_meta_eq
145.506 + [@{thm mult_1_left}, @{thm mult_1_right}, @{thm div_by_1}, @{thm numeral_1_eq_1}];
145.507 +
145.508 +fun cancel_simplify_meta_eq ss cancel_th th =
145.509 + simplify_one ss (([th, cancel_th]) MRS trans);
145.510 +
145.511 +local
145.512 + val Tp_Eq = Thm.reflexive (Thm.cterm_of @{theory HOL} HOLogic.Trueprop)
145.513 + fun Eq_True_elim Eq =
145.514 + Thm.equal_elim (Thm.combination Tp_Eq (Thm.symmetric Eq)) @{thm TrueI}
145.515 +in
145.516 +fun sign_conv pos_th neg_th ss t =
145.517 + let val T = fastype_of t;
145.518 + val zero = Const(@{const_name HOL.zero}, T);
145.519 + val less = Const(@{const_name HOL.less}, [T,T] ---> HOLogic.boolT);
145.520 + val pos = less $ zero $ t and neg = less $ t $ zero
145.521 + fun prove p =
145.522 + Option.map Eq_True_elim (Lin_Arith.lin_arith_simproc ss p)
145.523 + handle THM _ => NONE
145.524 + in case prove pos of
145.525 + SOME th => SOME(th RS pos_th)
145.526 + | NONE => (case prove neg of
145.527 + SOME th => SOME(th RS neg_th)
145.528 + | NONE => NONE)
145.529 + end;
145.530 +end
145.531 +
145.532 +structure CancelFactorCommon =
145.533 + struct
145.534 + val mk_sum = long_mk_prod
145.535 + val dest_sum = dest_prod
145.536 + val mk_coeff = mk_coeff
145.537 + val dest_coeff = dest_coeff
145.538 + val find_first = find_first_t []
145.539 + val trans_tac = K Arith_Data.trans_tac
145.540 + val norm_ss = HOL_ss addsimps mult_1s @ @{thms mult_ac}
145.541 + fun norm_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss))
145.542 + val simplify_meta_eq = cancel_simplify_meta_eq
145.543 + end;
145.544 +
145.545 +(*mult_cancel_left requires a ring with no zero divisors.*)
145.546 +structure EqCancelFactor = ExtractCommonTermFun
145.547 + (open CancelFactorCommon
145.548 + val prove_conv = Arith_Data.prove_conv
145.549 + val mk_bal = HOLogic.mk_eq
145.550 + val dest_bal = HOLogic.dest_bin "op =" Term.dummyT
145.551 + val simp_conv = K (K (SOME @{thm mult_cancel_left}))
145.552 +);
145.553 +
145.554 +(*for ordered rings*)
145.555 +structure LeCancelFactor = ExtractCommonTermFun
145.556 + (open CancelFactorCommon
145.557 + val prove_conv = Arith_Data.prove_conv
145.558 + val mk_bal = HOLogic.mk_binrel @{const_name HOL.less_eq}
145.559 + val dest_bal = HOLogic.dest_bin @{const_name HOL.less_eq} Term.dummyT
145.560 + val simp_conv = sign_conv
145.561 + @{thm mult_le_cancel_left_pos} @{thm mult_le_cancel_left_neg}
145.562 +);
145.563 +
145.564 +(*for ordered rings*)
145.565 +structure LessCancelFactor = ExtractCommonTermFun
145.566 + (open CancelFactorCommon
145.567 + val prove_conv = Arith_Data.prove_conv
145.568 + val mk_bal = HOLogic.mk_binrel @{const_name HOL.less}
145.569 + val dest_bal = HOLogic.dest_bin @{const_name HOL.less} Term.dummyT
145.570 + val simp_conv = sign_conv
145.571 + @{thm mult_less_cancel_left_pos} @{thm mult_less_cancel_left_neg}
145.572 +);
145.573 +
145.574 +(*for semirings with division*)
145.575 +structure DivCancelFactor = ExtractCommonTermFun
145.576 + (open CancelFactorCommon
145.577 + val prove_conv = Arith_Data.prove_conv
145.578 + val mk_bal = HOLogic.mk_binop @{const_name Divides.div}
145.579 + val dest_bal = HOLogic.dest_bin @{const_name Divides.div} Term.dummyT
145.580 + val simp_conv = K (K (SOME @{thm div_mult_mult1_if}))
145.581 +);
145.582 +
145.583 +structure ModCancelFactor = ExtractCommonTermFun
145.584 + (open CancelFactorCommon
145.585 + val prove_conv = Arith_Data.prove_conv
145.586 + val mk_bal = HOLogic.mk_binop @{const_name Divides.mod}
145.587 + val dest_bal = HOLogic.dest_bin @{const_name Divides.mod} Term.dummyT
145.588 + val simp_conv = K (K (SOME @{thm mod_mult_mult1}))
145.589 +);
145.590 +
145.591 +(*for idoms*)
145.592 +structure DvdCancelFactor = ExtractCommonTermFun
145.593 + (open CancelFactorCommon
145.594 + val prove_conv = Arith_Data.prove_conv
145.595 + val mk_bal = HOLogic.mk_binrel @{const_name Ring_and_Field.dvd}
145.596 + val dest_bal = HOLogic.dest_bin @{const_name Ring_and_Field.dvd} Term.dummyT
145.597 + val simp_conv = K (K (SOME @{thm dvd_mult_cancel_left}))
145.598 +);
145.599 +
145.600 +(*Version for all fields, including unordered ones (type complex).*)
145.601 +structure DivideCancelFactor = ExtractCommonTermFun
145.602 + (open CancelFactorCommon
145.603 + val prove_conv = Arith_Data.prove_conv
145.604 + val mk_bal = HOLogic.mk_binop @{const_name HOL.divide}
145.605 + val dest_bal = HOLogic.dest_bin @{const_name HOL.divide} Term.dummyT
145.606 + val simp_conv = K (K (SOME @{thm mult_divide_mult_cancel_left_if}))
145.607 +);
145.608 +
145.609 +val cancel_factors =
145.610 + map Arith_Data.prep_simproc
145.611 + [("ring_eq_cancel_factor",
145.612 + ["(l::'a::idom) * m = n",
145.613 + "(l::'a::idom) = m * n"],
145.614 + K EqCancelFactor.proc),
145.615 + ("ordered_ring_le_cancel_factor",
145.616 + ["(l::'a::ordered_ring) * m <= n",
145.617 + "(l::'a::ordered_ring) <= m * n"],
145.618 + K LeCancelFactor.proc),
145.619 + ("ordered_ring_less_cancel_factor",
145.620 + ["(l::'a::ordered_ring) * m < n",
145.621 + "(l::'a::ordered_ring) < m * n"],
145.622 + K LessCancelFactor.proc),
145.623 + ("int_div_cancel_factor",
145.624 + ["((l::'a::semiring_div) * m) div n", "(l::'a::semiring_div) div (m * n)"],
145.625 + K DivCancelFactor.proc),
145.626 + ("int_mod_cancel_factor",
145.627 + ["((l::'a::semiring_div) * m) mod n", "(l::'a::semiring_div) mod (m * n)"],
145.628 + K ModCancelFactor.proc),
145.629 + ("dvd_cancel_factor",
145.630 + ["((l::'a::idom) * m) dvd n", "(l::'a::idom) dvd (m * n)"],
145.631 + K DvdCancelFactor.proc),
145.632 + ("divide_cancel_factor",
145.633 + ["((l::'a::{division_by_zero,field}) * m) / n",
145.634 + "(l::'a::{division_by_zero,field}) / (m * n)"],
145.635 + K DivideCancelFactor.proc)];
145.636 +
145.637 +end;
145.638 +
145.639 +Addsimprocs Numeral_Simprocs.cancel_numerals;
145.640 +Addsimprocs [Numeral_Simprocs.combine_numerals];
145.641 +Addsimprocs [Numeral_Simprocs.field_combine_numerals];
145.642 +Addsimprocs [Numeral_Simprocs.assoc_fold_simproc];
145.643 +
145.644 +(*examples:
145.645 +print_depth 22;
145.646 +set timing;
145.647 +set trace_simp;
145.648 +fun test s = (Goal s, by (Simp_tac 1));
145.649 +
145.650 +test "l + 2 + 2 + 2 + (l + 2) + (oo + 2) = (uu::int)";
145.651 +
145.652 +test "2*u = (u::int)";
145.653 +test "(i + j + 12 + (k::int)) - 15 = y";
145.654 +test "(i + j + 12 + (k::int)) - 5 = y";
145.655 +
145.656 +test "y - b < (b::int)";
145.657 +test "y - (3*b + c) < (b::int) - 2*c";
145.658 +
145.659 +test "(2*x - (u*v) + y) - v*3*u = (w::int)";
145.660 +test "(2*x*u*v + (u*v)*4 + y) - v*u*4 = (w::int)";
145.661 +test "(2*x*u*v + (u*v)*4 + y) - v*u = (w::int)";
145.662 +test "u*v - (x*u*v + (u*v)*4 + y) = (w::int)";
145.663 +
145.664 +test "(i + j + 12 + (k::int)) = u + 15 + y";
145.665 +test "(i + j*2 + 12 + (k::int)) = j + 5 + y";
145.666 +
145.667 +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)";
145.668 +
145.669 +test "a + -(b+c) + b = (d::int)";
145.670 +test "a + -(b+c) - b = (d::int)";
145.671 +
145.672 +(*negative numerals*)
145.673 +test "(i + j + -2 + (k::int)) - (u + 5 + y) = zz";
145.674 +test "(i + j + -3 + (k::int)) < u + 5 + y";
145.675 +test "(i + j + 3 + (k::int)) < u + -6 + y";
145.676 +test "(i + j + -12 + (k::int)) - 15 = y";
145.677 +test "(i + j + 12 + (k::int)) - -15 = y";
145.678 +test "(i + j + -12 + (k::int)) - -15 = y";
145.679 +*)
145.680 +
145.681 +Addsimprocs Numeral_Simprocs.cancel_numeral_factors;
145.682 +
145.683 +(*examples:
145.684 +print_depth 22;
145.685 +set timing;
145.686 +set trace_simp;
145.687 +fun test s = (Goal s; by (Simp_tac 1));
145.688 +
145.689 +test "9*x = 12 * (y::int)";
145.690 +test "(9*x) div (12 * (y::int)) = z";
145.691 +test "9*x < 12 * (y::int)";
145.692 +test "9*x <= 12 * (y::int)";
145.693 +
145.694 +test "-99*x = 132 * (y::int)";
145.695 +test "(-99*x) div (132 * (y::int)) = z";
145.696 +test "-99*x < 132 * (y::int)";
145.697 +test "-99*x <= 132 * (y::int)";
145.698 +
145.699 +test "999*x = -396 * (y::int)";
145.700 +test "(999*x) div (-396 * (y::int)) = z";
145.701 +test "999*x < -396 * (y::int)";
145.702 +test "999*x <= -396 * (y::int)";
145.703 +
145.704 +test "-99*x = -81 * (y::int)";
145.705 +test "(-99*x) div (-81 * (y::int)) = z";
145.706 +test "-99*x <= -81 * (y::int)";
145.707 +test "-99*x < -81 * (y::int)";
145.708 +
145.709 +test "-2 * x = -1 * (y::int)";
145.710 +test "-2 * x = -(y::int)";
145.711 +test "(-2 * x) div (-1 * (y::int)) = z";
145.712 +test "-2 * x < -(y::int)";
145.713 +test "-2 * x <= -1 * (y::int)";
145.714 +test "-x < -23 * (y::int)";
145.715 +test "-x <= -23 * (y::int)";
145.716 +*)
145.717 +
145.718 +(*And the same examples for fields such as rat or real:
145.719 +test "0 <= (y::rat) * -2";
145.720 +test "9*x = 12 * (y::rat)";
145.721 +test "(9*x) / (12 * (y::rat)) = z";
145.722 +test "9*x < 12 * (y::rat)";
145.723 +test "9*x <= 12 * (y::rat)";
145.724 +
145.725 +test "-99*x = 132 * (y::rat)";
145.726 +test "(-99*x) / (132 * (y::rat)) = z";
145.727 +test "-99*x < 132 * (y::rat)";
145.728 +test "-99*x <= 132 * (y::rat)";
145.729 +
145.730 +test "999*x = -396 * (y::rat)";
145.731 +test "(999*x) / (-396 * (y::rat)) = z";
145.732 +test "999*x < -396 * (y::rat)";
145.733 +test "999*x <= -396 * (y::rat)";
145.734 +
145.735 +test "(- ((2::rat) * x) <= 2 * y)";
145.736 +test "-99*x = -81 * (y::rat)";
145.737 +test "(-99*x) / (-81 * (y::rat)) = z";
145.738 +test "-99*x <= -81 * (y::rat)";
145.739 +test "-99*x < -81 * (y::rat)";
145.740 +
145.741 +test "-2 * x = -1 * (y::rat)";
145.742 +test "-2 * x = -(y::rat)";
145.743 +test "(-2 * x) / (-1 * (y::rat)) = z";
145.744 +test "-2 * x < -(y::rat)";
145.745 +test "-2 * x <= -1 * (y::rat)";
145.746 +test "-x < -23 * (y::rat)";
145.747 +test "-x <= -23 * (y::rat)";
145.748 +*)
145.749 +
145.750 +Addsimprocs Numeral_Simprocs.cancel_factors;
145.751 +
145.752 +
145.753 +(*examples:
145.754 +print_depth 22;
145.755 +set timing;
145.756 +set trace_simp;
145.757 +fun test s = (Goal s; by (Asm_simp_tac 1));
145.758 +
145.759 +test "x*k = k*(y::int)";
145.760 +test "k = k*(y::int)";
145.761 +test "a*(b*c) = (b::int)";
145.762 +test "a*(b*c) = d*(b::int)*(x*a)";
145.763 +
145.764 +test "(x*k) div (k*(y::int)) = (uu::int)";
145.765 +test "(k) div (k*(y::int)) = (uu::int)";
145.766 +test "(a*(b*c)) div ((b::int)) = (uu::int)";
145.767 +test "(a*(b*c)) div (d*(b::int)*(x*a)) = (uu::int)";
145.768 +*)
145.769 +
145.770 +(*And the same examples for fields such as rat or real:
145.771 +print_depth 22;
145.772 +set timing;
145.773 +set trace_simp;
145.774 +fun test s = (Goal s; by (Asm_simp_tac 1));
145.775 +
145.776 +test "x*k = k*(y::rat)";
145.777 +test "k = k*(y::rat)";
145.778 +test "a*(b*c) = (b::rat)";
145.779 +test "a*(b*c) = d*(b::rat)*(x*a)";
145.780 +
145.781 +
145.782 +test "(x*k) / (k*(y::rat)) = (uu::rat)";
145.783 +test "(k) / (k*(y::rat)) = (uu::rat)";
145.784 +test "(a*(b*c)) / ((b::rat)) = (uu::rat)";
145.785 +test "(a*(b*c)) / (d*(b::rat)*(x*a)) = (uu::rat)";
145.786 +
145.787 +(*FIXME: what do we do about this?*)
145.788 +test "a*(b*c)/(y*z) = d*(b::rat)*(x*a)/z";
145.789 +*)
146.1 --- a/src/HOL/Tools/rat_arith.ML Mon May 11 09:39:53 2009 +0200
146.2 +++ b/src/HOL/Tools/rat_arith.ML Mon May 11 17:20:52 2009 +0200
146.3 @@ -1,5 +1,4 @@
146.4 (* Title: HOL/Real/rat_arith.ML
146.5 - ID: $Id$
146.6 Author: Lawrence C Paulson
146.7 Copyright 2004 University of Cambridge
146.8
146.9 @@ -10,8 +9,6 @@
146.10
146.11 local
146.12
146.13 -val simprocs = field_cancel_numeral_factors
146.14 -
146.15 val simps =
146.16 [@{thm order_less_irrefl}, @{thm neg_less_iff_less}, @{thm True_implies_equals},
146.17 read_instantiate @{context} [(("a", 0), "(number_of ?v)")] @{thm right_distrib},
146.18 @@ -42,8 +39,8 @@
146.19 lessD = lessD, (*Can't change lessD: the rats are dense!*)
146.20 neqE = neqE,
146.21 simpset = simpset addsimps simps
146.22 - addsimprocs simprocs}) #>
146.23 - arith_inj_const (@{const_name of_nat}, @{typ "nat => rat"}) #>
146.24 - arith_inj_const (@{const_name of_int}, @{typ "int => rat"})
146.25 + addsimprocs Numeral_Simprocs.field_cancel_numeral_factors}) #>
146.26 + Lin_Arith.add_inj_const (@{const_name of_nat}, @{typ "nat => rat"}) #>
146.27 + Lin_Arith.add_inj_const (@{const_name of_int}, @{typ "int => rat"})
146.28
146.29 end;
147.1 --- a/src/HOL/Tools/real_arith.ML Mon May 11 09:39:53 2009 +0200
147.2 +++ b/src/HOL/Tools/real_arith.ML Mon May 11 17:20:52 2009 +0200
147.3 @@ -36,7 +36,7 @@
147.4 lessD = lessD, (*Can't change lessD: the reals are dense!*)
147.5 neqE = neqE,
147.6 simpset = simpset addsimps simps}) #>
147.7 - arith_inj_const (@{const_name real}, HOLogic.natT --> HOLogic.realT) #>
147.8 - arith_inj_const (@{const_name real}, HOLogic.intT --> HOLogic.realT)
147.9 + Lin_Arith.add_inj_const (@{const_name real}, HOLogic.natT --> HOLogic.realT) #>
147.10 + Lin_Arith.add_inj_const (@{const_name real}, HOLogic.intT --> HOLogic.realT)
147.11
147.12 end;
148.1 --- a/src/HOL/Tools/recfun_codegen.ML Mon May 11 09:39:53 2009 +0200
148.2 +++ b/src/HOL/Tools/recfun_codegen.ML Mon May 11 17:20:52 2009 +0200
148.3 @@ -25,13 +25,13 @@
148.4
148.5 fun add_thm NONE thm thy = Code.add_eqn thm thy
148.6 | add_thm (SOME module_name) thm thy =
148.7 - case Code_Unit.warning_thm (Code_Unit.mk_eqn thy) thm
148.8 - of SOME (thm', _) => let val c = Code_Unit.const_eqn thm'
148.9 - in thy
148.10 - |> ModuleData.map (Symtab.update (c, module_name))
148.11 - |> Code.add_eqn thm'
148.12 - end
148.13 - | NONE => Code.add_eqn thm thy;
148.14 + let
148.15 + val (thm', _) = Code_Unit.mk_eqn thy (K false) (thm, true)
148.16 + in
148.17 + thy
148.18 + |> ModuleData.map (Symtab.update (Code_Unit.const_eqn thy thm', module_name))
148.19 + |> Code.add_eqn thm'
148.20 + end;
148.21
148.22 fun meta_eq_to_obj_eq thy thm =
148.23 let
148.24 @@ -57,9 +57,8 @@
148.25 val thms = Code.these_raw_eqns thy c'
148.26 |> map_filter (fn (thm, linear) => if linear then SOME thm else NONE)
148.27 |> expand_eta thy
148.28 - |> map (AxClass.overload thy)
148.29 |> map_filter (meta_eq_to_obj_eq thy)
148.30 - |> Code_Unit.norm_varnames thy Code_Name.purify_tvar Code_Name.purify_var
148.31 + |> Code_Unit.norm_varnames thy
148.32 |> map (rpair opt_name)
148.33 in if null thms then NONE else SOME thms end;
148.34
149.1 --- a/src/HOL/Tools/res_reconstruct.ML Mon May 11 09:39:53 2009 +0200
149.2 +++ b/src/HOL/Tools/res_reconstruct.ML Mon May 11 17:20:52 2009 +0200
149.3 @@ -16,10 +16,10 @@
149.4 val setup: Context.theory -> Context.theory
149.5 (* extracting lemma list*)
149.6 val find_failure: string -> string option
149.7 - val lemma_list_dfg: string * string vector * Proof.context * Thm.thm * int -> string
149.8 - val lemma_list_tstp: string * string vector * Proof.context * Thm.thm * int -> string
149.9 + val lemma_list_dfg: string -> string * string vector * Proof.context * Thm.thm * int -> string
149.10 + val lemma_list_tstp: string -> string * string vector * Proof.context * Thm.thm * int -> string
149.11 (* structured proofs *)
149.12 - val structured_proof: string * string vector * Proof.context * Thm.thm * int -> string
149.13 + val structured_proof: string -> string * string vector * Proof.context * Thm.thm * int -> string
149.14 end;
149.15
149.16 structure ResReconstruct : RES_RECONSTRUCT =
149.17 @@ -103,7 +103,7 @@
149.18
149.19 (*If string s has the prefix s1, return the result of deleting it.*)
149.20 fun strip_prefix s1 s =
149.21 - if String.isPrefix s1 s
149.22 + if String.isPrefix s1 s
149.23 then SOME (ResClause.undo_ascii_of (String.extract (s, size s1, NONE)))
149.24 else NONE;
149.25
149.26 @@ -278,10 +278,10 @@
149.27 in #1 (fold_map (decode_tstp vt0) tuples ctxt) end;
149.28
149.29 (** Finding a matching assumption. The literals may be permuted, and variable names
149.30 - may disagree. We have to try all combinations of literals (quadratic!) and
149.31 + may disagree. We have to try all combinations of literals (quadratic!) and
149.32 match up the variable names consistently. **)
149.33
149.34 -fun strip_alls_aux n (Const("all",_)$Abs(a,T,t)) =
149.35 +fun strip_alls_aux n (Const("all",_)$Abs(a,T,t)) =
149.36 strip_alls_aux (n+1) (subst_bound (Var ((a,n), T), t))
149.37 | strip_alls_aux _ t = t;
149.38
149.39 @@ -292,20 +292,20 @@
149.40 (*Ignore types: they are not to be trusted...*)
149.41 fun match_literal (t1$u1) (t2$u2) env =
149.42 match_literal t1 t2 (match_literal u1 u2 env)
149.43 - | match_literal (Abs (_,_,t1)) (Abs (_,_,t2)) env =
149.44 + | match_literal (Abs (_,_,t1)) (Abs (_,_,t2)) env =
149.45 match_literal t1 t2 env
149.46 - | match_literal (Bound i1) (Bound i2) env =
149.47 + | match_literal (Bound i1) (Bound i2) env =
149.48 if i1=i2 then env else raise MATCH_LITERAL
149.49 - | match_literal (Const(a1,_)) (Const(a2,_)) env =
149.50 + | match_literal (Const(a1,_)) (Const(a2,_)) env =
149.51 if a1=a2 then env else raise MATCH_LITERAL
149.52 - | match_literal (Free(a1,_)) (Free(a2,_)) env =
149.53 + | match_literal (Free(a1,_)) (Free(a2,_)) env =
149.54 if a1=a2 then env else raise MATCH_LITERAL
149.55 | match_literal (Var(ix1,_)) (Var(ix2,_)) env = insert (op =) (ix1,ix2) env
149.56 | match_literal _ _ env = raise MATCH_LITERAL;
149.57
149.58 (*Checking that all variable associations are unique. The list env contains no
149.59 repetitions, but does it contain say (x,y) and (y,y)? *)
149.60 -fun good env =
149.61 +fun good env =
149.62 let val (xs,ys) = ListPair.unzip env
149.63 in not (has_duplicates (op=) xs orelse has_duplicates (op=) ys) end;
149.64
149.65 @@ -316,15 +316,15 @@
149.66 let fun match1 us [] = false
149.67 | match1 us (t::ts) =
149.68 let val env' = match_literal lit t env
149.69 - in (good env' andalso matches_aux env' lits (us@ts)) orelse
149.70 - match1 (t::us) ts
149.71 + in (good env' andalso matches_aux env' lits (us@ts)) orelse
149.72 + match1 (t::us) ts
149.73 end
149.74 handle MATCH_LITERAL => match1 (t::us) ts
149.75 - in match1 [] ts end;
149.76 + in match1 [] ts end;
149.77
149.78 (*Is this length test useful?*)
149.79 -fun matches (lits1,lits2) =
149.80 - length lits1 = length lits2 andalso
149.81 +fun matches (lits1,lits2) =
149.82 + length lits1 = length lits2 andalso
149.83 matches_aux [] (map Envir.eta_contract lits1) (map Envir.eta_contract lits2);
149.84
149.85 fun permuted_clause t =
149.86 @@ -408,7 +408,7 @@
149.87 if eq_types t orelse not (null (Term.add_tvars t [])) orelse
149.88 exists_subterm bad_free t orelse
149.89 (not (null lines) andalso (*final line can't be deleted for these reasons*)
149.90 - (length deps < 2 orelse nlines mod (Config.get ctxt modulus) <> 0))
149.91 + (length deps < 2 orelse nlines mod (Config.get ctxt modulus) <> 0))
149.92 then (nlines+1, map (replace_deps (lno, deps)) lines) (*Delete line*)
149.93 else (nlines+1, (lno, t, deps) :: lines);
149.94
149.95 @@ -467,7 +467,7 @@
149.96 val failure_strings_remote = ["Remote-script could not extract proof"];
149.97 fun find_failure proof =
149.98 let val failures =
149.99 - map_filter (fn s => if String.isSubstring s proof then SOME s else NONE)
149.100 + map_filter (fn s => if String.isSubstring s proof then SOME s else NONE)
149.101 (failure_strings_E @ failure_strings_vampire @ failure_strings_SPASS @ failure_strings_remote)
149.102 in if null failures then NONE else SOME (hd failures) end;
149.103
149.104 @@ -481,7 +481,7 @@
149.105 "Formulae used in the proof"];
149.106 fun get_proof_extract proof =
149.107 let
149.108 - (*splits to_split by the first possible of a list of splitters*)
149.109 + (*splits to_split by the first possible of a list of splitters*)
149.110 fun first_field_any [] to_split = NONE
149.111 | first_field_any (splitter::splitters) to_split =
149.112 let
149.113 @@ -493,10 +493,10 @@
149.114 val (proofextract:string, c:string) = valOf (first_field_any end_proof_strings b)
149.115 in proofextract end;
149.116
149.117 - (* === EXTRACTING LEMMAS === *)
149.118 + (* === EXTRACTING LEMMAS === *)
149.119 (* lines have the form "cnf(108, axiom, ...",
149.120 the number (108) has to be extracted)*)
149.121 - fun get_step_nums_tstp proofextract =
149.122 + fun get_step_nums_tstp proofextract =
149.123 let val toks = String.tokens (not o Char.isAlphaNum)
149.124 fun inputno ("cnf"::ntok::"axiom"::_) = Int.fromString ntok
149.125 | inputno _ = NONE
149.126 @@ -513,47 +513,56 @@
149.127 val lines = split_lines proofextract
149.128 in List.mapPartial (inputno o toks) lines end
149.129
149.130 - (*extracting lemmas from tstp-output between the lines from above*)
149.131 - fun extract_lemmas get_step_nums (proof, thm_names, _, _, _) =
149.132 + (*extracting lemmas from tstp-output between the lines from above*)
149.133 + fun extract_lemmas get_step_nums (proof, thm_names, _, _, _) =
149.134 let
149.135 (* get the names of axioms from their numbers*)
149.136 fun get_axiom_names thm_names step_nums =
149.137 let
149.138 fun is_axiom n = n <= Vector.length thm_names
149.139 fun getname i = Vector.sub(thm_names, i-1)
149.140 - in
149.141 + in
149.142 sort_distinct string_ord (filter (fn x => x <> "??.unknown") (map getname (filter is_axiom step_nums)))
149.143 end
149.144 val proofextract = get_proof_extract proof
149.145 - in
149.146 + in
149.147 get_axiom_names thm_names (get_step_nums proofextract)
149.148 end;
149.149
149.150 - (* metis-command *)
149.151 - fun metis_line [] = "apply metis"
149.152 - | metis_line xs = "apply (metis " ^ space_implode " " xs ^ ")"
149.153 -
149.154 - (*Used to label theorems chained into the sledgehammer call*)
149.155 - val chained_hint = "CHAINED";
149.156 - fun sendback_metis_nochained lemmas =
149.157 - let val nochained = filter_out (fn y => y = chained_hint)
149.158 - in (Markup.markup Markup.sendback o metis_line) (nochained lemmas) end
149.159 - fun lemma_list_tstp result = sendback_metis_nochained (extract_lemmas get_step_nums_tstp result);
149.160 - fun lemma_list_dfg result = sendback_metis_nochained (extract_lemmas get_step_nums_dfg result);
149.161 -
149.162 - (* === Extracting structured Isar-proof === *)
149.163 - fun structured_proof (result as (proof, thm_names, ctxt, goal, subgoalno)) =
149.164 - let
149.165 - (*Could use split_lines, but it can return blank lines...*)
149.166 - val lines = String.tokens (equal #"\n");
149.167 - val nospaces = String.translate (fn c => if Char.isSpace c then "" else str c)
149.168 - val proofextract = get_proof_extract proof
149.169 - val cnfs = filter (String.isPrefix "cnf(") (map nospaces (lines proofextract))
149.170 - val one_line_proof = lemma_list_tstp result
149.171 - val structured = if chained_hint mem_string (String.tokens (fn c => c = #" ") one_line_proof) then ""
149.172 - else decode_tstp_file cnfs ctxt goal subgoalno thm_names
149.173 - in
149.174 - one_line_proof ^ "\n\n" ^ (Markup.markup Markup.sendback) structured
149.175 - end
149.176 + (* metis-command *)
149.177 + fun metis_line [] = "apply metis"
149.178 + | metis_line xs = "apply (metis " ^ space_implode " " xs ^ ")"
149.179
149.180 - end;
149.181 + (* atp_minimize [atp=<prover>] <lemmas> *)
149.182 + fun minimize_line _ [] = ""
149.183 + | minimize_line name lemmas = "For minimizing the number of lemmas try this command:\n" ^
149.184 + (Markup.markup Markup.sendback) ("atp_minimize [atp=" ^ name ^ "] " ^ space_implode " " lemmas)
149.185 +
149.186 + (*Used to label theorems chained into the sledgehammer call*)
149.187 + val chained_hint = "CHAINED";
149.188 + fun sendback_metis_nochained lemmas =
149.189 + let val nochained = filter_out (fn y => y = chained_hint)
149.190 + in (Markup.markup Markup.sendback o metis_line) (nochained lemmas) end
149.191 + fun lemma_list_tstp name result =
149.192 + let val lemmas = extract_lemmas get_step_nums_tstp result
149.193 + in sendback_metis_nochained lemmas ^ "\n" ^ minimize_line name lemmas end;
149.194 + fun lemma_list_dfg name result =
149.195 + let val lemmas = extract_lemmas get_step_nums_dfg result
149.196 + in sendback_metis_nochained lemmas ^ "\n" ^ minimize_line name lemmas end;
149.197 +
149.198 + (* === Extracting structured Isar-proof === *)
149.199 + fun structured_proof name (result as (proof, thm_names, ctxt, goal, subgoalno)) =
149.200 + let
149.201 + (*Could use split_lines, but it can return blank lines...*)
149.202 + val lines = String.tokens (equal #"\n");
149.203 + val nospaces = String.translate (fn c => if Char.isSpace c then "" else str c)
149.204 + val proofextract = get_proof_extract proof
149.205 + val cnfs = filter (String.isPrefix "cnf(") (map nospaces (lines proofextract))
149.206 + val one_line_proof = lemma_list_tstp name result
149.207 + val structured = if chained_hint mem_string (String.tokens (fn c => c = #" ") one_line_proof) then ""
149.208 + else decode_tstp_file cnfs ctxt goal subgoalno thm_names
149.209 + in
149.210 + one_line_proof ^ "\n\n" ^ (Markup.markup Markup.sendback) structured
149.211 + end
149.212 +
149.213 +end;
150.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
150.2 +++ b/src/HOL/Tools/string_code.ML Mon May 11 17:20:52 2009 +0200
150.3 @@ -0,0 +1,88 @@
150.4 +(* Author: Florian Haftmann, TU Muenchen
150.5 +
150.6 +Code generation for character and string literals.
150.7 +*)
150.8 +
150.9 +signature STRING_CODE =
150.10 +sig
150.11 + val add_literal_list_string: string -> theory -> theory
150.12 + val add_literal_char: string -> theory -> theory
150.13 + val add_literal_message: string -> theory -> theory
150.14 +end;
150.15 +
150.16 +structure String_Code : STRING_CODE =
150.17 +struct
150.18 +
150.19 +open Basic_Code_Thingol;
150.20 +
150.21 +fun decode_char nibbles' tt =
150.22 + let
150.23 + fun idx c = find_index (curry (op =) c) nibbles';
150.24 + fun decode ~1 _ = NONE
150.25 + | decode _ ~1 = NONE
150.26 + | decode n m = SOME (chr (n * 16 + m));
150.27 + in case tt
150.28 + of (IConst (c1, _), IConst (c2, _)) => decode (idx c1) (idx c2)
150.29 + | _ => NONE
150.30 + end;
150.31 +
150.32 +fun implode_string char' nibbles' mk_char mk_string ts =
150.33 + let
150.34 + fun implode_char (IConst (c, _) `$ t1 `$ t2) =
150.35 + if c = char' then decode_char nibbles' (t1, t2) else NONE
150.36 + | implode_char _ = NONE;
150.37 + val ts' = map_filter implode_char ts;
150.38 + in if length ts = length ts'
150.39 + then (SOME o Code_Printer.str o mk_string o implode) ts'
150.40 + else NONE
150.41 + end;
150.42 +
150.43 +val cs_nibbles = [@{const_name Nibble0}, @{const_name Nibble1},
150.44 + @{const_name Nibble2}, @{const_name Nibble3},
150.45 + @{const_name Nibble4}, @{const_name Nibble5},
150.46 + @{const_name Nibble6}, @{const_name Nibble7},
150.47 + @{const_name Nibble8}, @{const_name Nibble9},
150.48 + @{const_name NibbleA}, @{const_name NibbleB},
150.49 + @{const_name NibbleC}, @{const_name NibbleD},
150.50 + @{const_name NibbleE}, @{const_name NibbleF}];
150.51 +val cs_summa = [@{const_name Nil}, @{const_name Cons}, @{const_name Char}] @ cs_nibbles;
150.52 +
150.53 +fun add_literal_list_string target =
150.54 + let
150.55 + fun pretty literals (nil' :: cons' :: char' :: nibbles') pr thm vars fxy [(t1, _), (t2, _)] =
150.56 + case Option.map (cons t1) (List_Code.implode_list nil' cons' t2)
150.57 + of SOME ts => (case implode_string char' nibbles'
150.58 + (Code_Printer.literal_char literals) (Code_Printer.literal_string literals) ts
150.59 + of SOME p => p
150.60 + | NONE =>
150.61 + Code_Printer.literal_list literals (map (pr vars Code_Printer.NOBR) ts))
150.62 + | NONE =>
150.63 + List_Code.default_list (Code_Printer.infix_cons literals) (pr vars) fxy t1 t2;
150.64 + in Code_Target.add_syntax_const target
150.65 + @{const_name Cons} (SOME (2, (cs_summa, pretty)))
150.66 + end;
150.67 +
150.68 +fun add_literal_char target =
150.69 + let
150.70 + fun pretty literals nibbles' _ thm _ _ [(t1, _), (t2, _)] =
150.71 + case decode_char nibbles' (t1, t2)
150.72 + of SOME c => (Code_Printer.str o Code_Printer.literal_char literals) c
150.73 + | NONE => Code_Printer.nerror thm "Illegal character expression";
150.74 + in Code_Target.add_syntax_const target
150.75 + @{const_name Char} (SOME (2, (cs_nibbles, pretty)))
150.76 + end;
150.77 +
150.78 +fun add_literal_message target =
150.79 + let
150.80 + fun pretty literals (nil' :: cons' :: char' :: nibbles') _ thm _ _ [(t, _)] =
150.81 + case List_Code.implode_list nil' cons' t
150.82 + of SOME ts => (case implode_string char' nibbles'
150.83 + (Code_Printer.literal_char literals) (Code_Printer.literal_string literals) ts
150.84 + of SOME p => p
150.85 + | NONE => Code_Printer.nerror thm "Illegal message expression")
150.86 + | NONE => Code_Printer.nerror thm "Illegal message expression";
150.87 + in Code_Target.add_syntax_const target
150.88 + @{const_name STR} (SOME (1, (cs_summa, pretty)))
150.89 + end;
150.90 +
150.91 +end;
151.1 --- a/src/HOL/Tools/string_syntax.ML Mon May 11 09:39:53 2009 +0200
151.2 +++ b/src/HOL/Tools/string_syntax.ML Mon May 11 17:20:52 2009 +0200
151.3 @@ -15,12 +15,14 @@
151.4
151.5 (* nibble *)
151.6
151.7 +val nib_prefix = "String.nibble.";
151.8 +
151.9 val mk_nib =
151.10 - Syntax.Constant o unprefix "List.nibble." o
151.11 + Syntax.Constant o unprefix nib_prefix o
151.12 fst o Term.dest_Const o HOLogic.mk_nibble;
151.13
151.14 fun dest_nib (Syntax.Constant c) =
151.15 - HOLogic.dest_nibble (Const ("List.nibble." ^ c, dummyT))
151.16 + HOLogic.dest_nibble (Const (nib_prefix ^ c, dummyT))
151.17 handle TERM _ => raise Match;
151.18
151.19
152.1 --- a/src/HOL/Tools/typecopy_package.ML Mon May 11 09:39:53 2009 +0200
152.2 +++ b/src/HOL/Tools/typecopy_package.ML Mon May 11 17:20:52 2009 +0200
152.3 @@ -150,7 +150,7 @@
152.4 THEN ALLGOALS (rtac @{thm refl})) def_thm)
152.5 |-> (fn def_thm => Code.add_eqn def_thm)
152.6 |> `(fn thy => mk_eq_refl thy)
152.7 - |-> (fn refl_thm => Code.add_nonlinear_eqn refl_thm)
152.8 + |-> (fn refl_thm => Code.add_nbe_eqn refl_thm)
152.9 end;
152.10
152.11 val setup =
153.1 --- a/src/HOL/Transcendental.thy Mon May 11 09:39:53 2009 +0200
153.2 +++ b/src/HOL/Transcendental.thy Mon May 11 17:20:52 2009 +0200
153.3 @@ -14,7 +14,7 @@
153.4 subsection {* Properties of Power Series *}
153.5
153.6 lemma lemma_realpow_diff:
153.7 - fixes y :: "'a::recpower"
153.8 + fixes y :: "'a::monoid_mult"
153.9 shows "p \<le> n \<Longrightarrow> y ^ (Suc n - p) = (y ^ (n - p)) * y"
153.10 proof -
153.11 assume "p \<le> n"
153.12 @@ -23,14 +23,14 @@
153.13 qed
153.14
153.15 lemma lemma_realpow_diff_sumr:
153.16 - fixes y :: "'a::{recpower,comm_semiring_0}" shows
153.17 + fixes y :: "'a::{comm_semiring_0,monoid_mult}" shows
153.18 "(\<Sum>p=0..<Suc n. (x ^ p) * y ^ (Suc n - p)) =
153.19 y * (\<Sum>p=0..<Suc n. (x ^ p) * y ^ (n - p))"
153.20 by (simp add: setsum_right_distrib lemma_realpow_diff mult_ac
153.21 del: setsum_op_ivl_Suc cong: strong_setsum_cong)
153.22
153.23 lemma lemma_realpow_diff_sumr2:
153.24 - fixes y :: "'a::{recpower,comm_ring}" shows
153.25 + fixes y :: "'a::{comm_ring,monoid_mult}" shows
153.26 "x ^ (Suc n) - y ^ (Suc n) =
153.27 (x - y) * (\<Sum>p=0..<Suc n. (x ^ p) * y ^ (n - p))"
153.28 apply (induct n, simp)
153.29 @@ -56,7 +56,7 @@
153.30 x}, then it sums absolutely for @{term z} with @{term "\<bar>z\<bar> < \<bar>x\<bar>"}.*}
153.31
153.32 lemma powser_insidea:
153.33 - fixes x z :: "'a::{real_normed_field,banach,recpower}"
153.34 + fixes x z :: "'a::{real_normed_field,banach}"
153.35 assumes 1: "summable (\<lambda>n. f n * x ^ n)"
153.36 assumes 2: "norm z < norm x"
153.37 shows "summable (\<lambda>n. norm (f n * z ^ n))"
153.38 @@ -108,7 +108,7 @@
153.39 qed
153.40
153.41 lemma powser_inside:
153.42 - fixes f :: "nat \<Rightarrow> 'a::{real_normed_field,banach,recpower}" shows
153.43 + fixes f :: "nat \<Rightarrow> 'a::{real_normed_field,banach}" shows
153.44 "[| summable (%n. f(n) * (x ^ n)); norm z < norm x |]
153.45 ==> summable (%n. f(n) * (z ^ n))"
153.46 by (rule powser_insidea [THEN summable_norm_cancel])
153.47 @@ -347,7 +347,7 @@
153.48 done
153.49
153.50 lemma lemma_termdiff1:
153.51 - fixes z :: "'a :: {recpower,comm_ring}" shows
153.52 + fixes z :: "'a :: {monoid_mult,comm_ring}" shows
153.53 "(\<Sum>p=0..<m. (((z + h) ^ (m - p)) * (z ^ p)) - (z ^ m)) =
153.54 (\<Sum>p=0..<m. (z ^ p) * (((z + h) ^ (m - p)) - (z ^ (m - p))))"
153.55 by(auto simp add: algebra_simps power_add [symmetric] cong: strong_setsum_cong)
153.56 @@ -357,7 +357,7 @@
153.57 by (simp add: setsum_subtractf)
153.58
153.59 lemma lemma_termdiff2:
153.60 - fixes h :: "'a :: {recpower,field}"
153.61 + fixes h :: "'a :: {field}"
153.62 assumes h: "h \<noteq> 0" shows
153.63 "((z + h) ^ n - z ^ n) / h - of_nat n * z ^ (n - Suc 0) =
153.64 h * (\<Sum>p=0..< n - Suc 0. \<Sum>q=0..< n - Suc 0 - p.
153.65 @@ -393,7 +393,7 @@
153.66 done
153.67
153.68 lemma lemma_termdiff3:
153.69 - fixes h z :: "'a::{real_normed_field,recpower}"
153.70 + fixes h z :: "'a::{real_normed_field}"
153.71 assumes 1: "h \<noteq> 0"
153.72 assumes 2: "norm z \<le> K"
153.73 assumes 3: "norm (z + h) \<le> K"
153.74 @@ -433,7 +433,7 @@
153.75 qed
153.76
153.77 lemma lemma_termdiff4:
153.78 - fixes f :: "'a::{real_normed_field,recpower} \<Rightarrow>
153.79 + fixes f :: "'a::{real_normed_field} \<Rightarrow>
153.80 'b::real_normed_vector"
153.81 assumes k: "0 < (k::real)"
153.82 assumes le: "\<And>h. \<lbrakk>h \<noteq> 0; norm h < k\<rbrakk> \<Longrightarrow> norm (f h) \<le> K * norm h"
153.83 @@ -478,7 +478,7 @@
153.84 qed
153.85
153.86 lemma lemma_termdiff5:
153.87 - fixes g :: "'a::{recpower,real_normed_field} \<Rightarrow>
153.88 + fixes g :: "'a::{real_normed_field} \<Rightarrow>
153.89 nat \<Rightarrow> 'b::banach"
153.90 assumes k: "0 < (k::real)"
153.91 assumes f: "summable f"
153.92 @@ -507,7 +507,7 @@
153.93 text{* FIXME: Long proofs*}
153.94
153.95 lemma termdiffs_aux:
153.96 - fixes x :: "'a::{recpower,real_normed_field,banach}"
153.97 + fixes x :: "'a::{real_normed_field,banach}"
153.98 assumes 1: "summable (\<lambda>n. diffs (diffs c) n * K ^ n)"
153.99 assumes 2: "norm x < norm K"
153.100 shows "(\<lambda>h. \<Sum>n. c n * (((x + h) ^ n - x ^ n) / h
153.101 @@ -572,7 +572,7 @@
153.102 qed
153.103
153.104 lemma termdiffs:
153.105 - fixes K x :: "'a::{recpower,real_normed_field,banach}"
153.106 + fixes K x :: "'a::{real_normed_field,banach}"
153.107 assumes 1: "summable (\<lambda>n. c n * K ^ n)"
153.108 assumes 2: "summable (\<lambda>n. (diffs c) n * K ^ n)"
153.109 assumes 3: "summable (\<lambda>n. (diffs (diffs c)) n * K ^ n)"
153.110 @@ -822,11 +822,11 @@
153.111 subsection {* Exponential Function *}
153.112
153.113 definition
153.114 - exp :: "'a \<Rightarrow> 'a::{recpower,real_normed_field,banach}" where
153.115 + exp :: "'a \<Rightarrow> 'a::{real_normed_field,banach}" where
153.116 "exp x = (\<Sum>n. x ^ n /\<^sub>R real (fact n))"
153.117
153.118 lemma summable_exp_generic:
153.119 - fixes x :: "'a::{real_normed_algebra_1,recpower,banach}"
153.120 + fixes x :: "'a::{real_normed_algebra_1,banach}"
153.121 defines S_def: "S \<equiv> \<lambda>n. x ^ n /\<^sub>R real (fact n)"
153.122 shows "summable S"
153.123 proof -
153.124 @@ -856,7 +856,7 @@
153.125 qed
153.126
153.127 lemma summable_norm_exp:
153.128 - fixes x :: "'a::{real_normed_algebra_1,recpower,banach}"
153.129 + fixes x :: "'a::{real_normed_algebra_1,banach}"
153.130 shows "summable (\<lambda>n. norm (x ^ n /\<^sub>R real (fact n)))"
153.131 proof (rule summable_norm_comparison_test [OF exI, rule_format])
153.132 show "summable (\<lambda>n. norm x ^ n /\<^sub>R real (fact n))"
153.133 @@ -901,7 +901,7 @@
153.134 subsubsection {* Properties of the Exponential Function *}
153.135
153.136 lemma powser_zero:
153.137 - fixes f :: "nat \<Rightarrow> 'a::{real_normed_algebra_1,recpower}"
153.138 + fixes f :: "nat \<Rightarrow> 'a::{real_normed_algebra_1}"
153.139 shows "(\<Sum>n. f n * 0 ^ n) = f 0"
153.140 proof -
153.141 have "(\<Sum>n = 0..<1. f n * 0 ^ n) = (\<Sum>n. f n * 0 ^ n)"
153.142 @@ -918,7 +918,7 @@
153.143 del: setsum_cl_ivl_Suc)
153.144
153.145 lemma exp_series_add:
153.146 - fixes x y :: "'a::{real_field,recpower}"
153.147 + fixes x y :: "'a::{real_field}"
153.148 defines S_def: "S \<equiv> \<lambda>x n. x ^ n /\<^sub>R real (fact n)"
153.149 shows "S (x + y) n = (\<Sum>i=0..n. S x i * S y (n - i))"
153.150 proof (induct n)
154.1 --- a/src/HOL/Transitive_Closure.thy Mon May 11 09:39:53 2009 +0200
154.2 +++ b/src/HOL/Transitive_Closure.thy Mon May 11 17:20:52 2009 +0200
154.3 @@ -630,6 +630,140 @@
154.4
154.5 declare trancl_into_rtrancl [elim]
154.6
154.7 +subsection {* The power operation on relations *}
154.8 +
154.9 +text {* @{text "R ^^ n = R O ... O R"}, the n-fold composition of @{text R} *}
154.10 +
154.11 +overloading
154.12 + relpow == "compow :: nat \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set"
154.13 +begin
154.14 +
154.15 +primrec relpow :: "nat \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set" where
154.16 + "relpow 0 R = Id"
154.17 + | "relpow (Suc n) R = R O (R ^^ n)"
154.18 +
154.19 +end
154.20 +
154.21 +lemma rel_pow_1 [simp]:
154.22 + fixes R :: "('a \<times> 'a) set"
154.23 + shows "R ^^ 1 = R"
154.24 + by simp
154.25 +
154.26 +lemma rel_pow_0_I:
154.27 + "(x, x) \<in> R ^^ 0"
154.28 + by simp
154.29 +
154.30 +lemma rel_pow_Suc_I:
154.31 + "(x, y) \<in> R ^^ n \<Longrightarrow> (y, z) \<in> R \<Longrightarrow> (x, z) \<in> R ^^ Suc n"
154.32 + by auto
154.33 +
154.34 +lemma rel_pow_Suc_I2:
154.35 + "(x, y) \<in> R \<Longrightarrow> (y, z) \<in> R ^^ n \<Longrightarrow> (x, z) \<in> R ^^ Suc n"
154.36 + by (induct n arbitrary: z) (simp, fastsimp)
154.37 +
154.38 +lemma rel_pow_0_E:
154.39 + "(x, y) \<in> R ^^ 0 \<Longrightarrow> (x = y \<Longrightarrow> P) \<Longrightarrow> P"
154.40 + by simp
154.41 +
154.42 +lemma rel_pow_Suc_E:
154.43 + "(x, z) \<in> R ^^ Suc n \<Longrightarrow> (\<And>y. (x, y) \<in> R ^^ n \<Longrightarrow> (y, z) \<in> R \<Longrightarrow> P) \<Longrightarrow> P"
154.44 + by auto
154.45 +
154.46 +lemma rel_pow_E:
154.47 + "(x, z) \<in> R ^^ n \<Longrightarrow> (n = 0 \<Longrightarrow> x = z \<Longrightarrow> P)
154.48 + \<Longrightarrow> (\<And>y m. n = Suc m \<Longrightarrow> (x, y) \<in> R ^^ m \<Longrightarrow> (y, z) \<in> R \<Longrightarrow> P)
154.49 + \<Longrightarrow> P"
154.50 + by (cases n) auto
154.51 +
154.52 +lemma rel_pow_Suc_D2:
154.53 + "(x, z) \<in> R ^^ Suc n \<Longrightarrow> (\<exists>y. (x, y) \<in> R \<and> (y, z) \<in> R ^^ n)"
154.54 + apply (induct n arbitrary: x z)
154.55 + apply (blast intro: rel_pow_0_I elim: rel_pow_0_E rel_pow_Suc_E)
154.56 + apply (blast intro: rel_pow_Suc_I elim: rel_pow_0_E rel_pow_Suc_E)
154.57 + done
154.58 +
154.59 +lemma rel_pow_Suc_E2:
154.60 + "(x, z) \<in> R ^^ Suc n \<Longrightarrow> (\<And>y. (x, y) \<in> R \<Longrightarrow> (y, z) \<in> R ^^ n \<Longrightarrow> P) \<Longrightarrow> P"
154.61 + by (blast dest: rel_pow_Suc_D2)
154.62 +
154.63 +lemma rel_pow_Suc_D2':
154.64 + "\<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)"
154.65 + by (induct n) (simp_all, blast)
154.66 +
154.67 +lemma rel_pow_E2:
154.68 + "(x, z) \<in> R ^^ n \<Longrightarrow> (n = 0 \<Longrightarrow> x = z \<Longrightarrow> P)
154.69 + \<Longrightarrow> (\<And>y m. n = Suc m \<Longrightarrow> (x, y) \<in> R \<Longrightarrow> (y, z) \<in> R ^^ m \<Longrightarrow> P)
154.70 + \<Longrightarrow> P"
154.71 + apply (cases n, simp)
154.72 + apply (cut_tac n=nat and R=R in rel_pow_Suc_D2', simp, blast)
154.73 + done
154.74 +
154.75 +lemma rtrancl_imp_UN_rel_pow:
154.76 + assumes "p \<in> R^*"
154.77 + shows "p \<in> (\<Union>n. R ^^ n)"
154.78 +proof (cases p)
154.79 + case (Pair x y)
154.80 + with assms have "(x, y) \<in> R^*" by simp
154.81 + then have "(x, y) \<in> (\<Union>n. R ^^ n)" proof induct
154.82 + case base show ?case by (blast intro: rel_pow_0_I)
154.83 + next
154.84 + case step then show ?case by (blast intro: rel_pow_Suc_I)
154.85 + qed
154.86 + with Pair show ?thesis by simp
154.87 +qed
154.88 +
154.89 +lemma rel_pow_imp_rtrancl:
154.90 + assumes "p \<in> R ^^ n"
154.91 + shows "p \<in> R^*"
154.92 +proof (cases p)
154.93 + case (Pair x y)
154.94 + with assms have "(x, y) \<in> R ^^ n" by simp
154.95 + then have "(x, y) \<in> R^*" proof (induct n arbitrary: x y)
154.96 + case 0 then show ?case by simp
154.97 + next
154.98 + case Suc then show ?case
154.99 + by (blast elim: rel_pow_Suc_E intro: rtrancl_into_rtrancl)
154.100 + qed
154.101 + with Pair show ?thesis by simp
154.102 +qed
154.103 +
154.104 +lemma rtrancl_is_UN_rel_pow:
154.105 + "R^* = (\<Union>n. R ^^ n)"
154.106 + by (blast intro: rtrancl_imp_UN_rel_pow rel_pow_imp_rtrancl)
154.107 +
154.108 +lemma rtrancl_power:
154.109 + "p \<in> R^* \<longleftrightarrow> (\<exists>n. p \<in> R ^^ n)"
154.110 + by (simp add: rtrancl_is_UN_rel_pow)
154.111 +
154.112 +lemma trancl_power:
154.113 + "p \<in> R^+ \<longleftrightarrow> (\<exists>n > 0. p \<in> R ^^ n)"
154.114 + apply (cases p)
154.115 + apply simp
154.116 + apply (rule iffI)
154.117 + apply (drule tranclD2)
154.118 + apply (clarsimp simp: rtrancl_is_UN_rel_pow)
154.119 + apply (rule_tac x="Suc n" in exI)
154.120 + apply (clarsimp simp: rel_comp_def)
154.121 + apply fastsimp
154.122 + apply clarsimp
154.123 + apply (case_tac n, simp)
154.124 + apply clarsimp
154.125 + apply (drule rel_pow_imp_rtrancl)
154.126 + apply (drule rtrancl_into_trancl1) apply auto
154.127 + done
154.128 +
154.129 +lemma rtrancl_imp_rel_pow:
154.130 + "p \<in> R^* \<Longrightarrow> \<exists>n. p \<in> R ^^ n"
154.131 + by (auto dest: rtrancl_imp_UN_rel_pow)
154.132 +
154.133 +lemma single_valued_rel_pow:
154.134 + fixes R :: "('a * 'a) set"
154.135 + shows "single_valued R \<Longrightarrow> single_valued (R ^^ n)"
154.136 + apply (induct n arbitrary: R)
154.137 + apply simp_all
154.138 + apply (rule single_valuedI)
154.139 + apply (fast dest: single_valuedD elim: rel_pow_Suc_E)
154.140 + done
154.141
154.142 subsection {* Setup of transitivity reasoner *}
154.143
155.1 --- a/src/HOL/Typerep.thy Mon May 11 09:39:53 2009 +0200
155.2 +++ b/src/HOL/Typerep.thy Mon May 11 17:20:52 2009 +0200
155.3 @@ -1,17 +1,15 @@
155.4 -(* Title: HOL/Typerep.thy
155.5 - Author: Florian Haftmann, TU Muenchen
155.6 -*)
155.7 +(* Author: Florian Haftmann, TU Muenchen *)
155.8
155.9 header {* Reflecting Pure types into HOL *}
155.10
155.11 theory Typerep
155.12 -imports Plain List Code_Message
155.13 +imports Plain String
155.14 begin
155.15
155.16 datatype typerep = Typerep message_string "typerep list"
155.17
155.18 class typerep =
155.19 - fixes typerep :: "'a\<Colon>{} itself \<Rightarrow> typerep"
155.20 + fixes typerep :: "'a itself \<Rightarrow> typerep"
155.21 begin
155.22
155.23 definition typerep_of :: "'a \<Rightarrow> typerep" where
155.24 @@ -42,7 +40,7 @@
155.25 struct
155.26
155.27 fun mk f (Type (tyco, tys)) =
155.28 - @{term Typerep} $ Message_String.mk tyco
155.29 + @{term Typerep} $ HOLogic.mk_message_string tyco
155.30 $ HOLogic.mk_list @{typ typerep} (map (mk f) tys)
155.31 | mk f (TFree v) =
155.32 f v;
155.33 @@ -79,8 +77,7 @@
155.34 *}
155.35
155.36 setup {*
155.37 - Typerep.add_def @{type_name prop}
155.38 - #> Typerep.add_def @{type_name fun}
155.39 + Typerep.add_def @{type_name fun}
155.40 #> Typerep.add_def @{type_name itself}
155.41 #> Typerep.add_def @{type_name bool}
155.42 #> TypedefPackage.interpretation Typerep.perhaps_add_def
155.43 @@ -92,12 +89,12 @@
155.44 by (auto simp add: equals_eq [symmetric] list_all2_eq [symmetric])
155.45
155.46 code_type typerep
155.47 - (SML "Term.typ")
155.48 + (Eval "Term.typ")
155.49
155.50 code_const Typerep
155.51 - (SML "Term.Type/ (_, _)")
155.52 + (Eval "Term.Type/ (_, _)")
155.53
155.54 -code_reserved SML Term
155.55 +code_reserved Eval Term
155.56
155.57 hide (open) const typerep Typerep
155.58
156.1 --- a/src/HOL/UNITY/Comp.thy Mon May 11 09:39:53 2009 +0200
156.2 +++ b/src/HOL/UNITY/Comp.thy Mon May 11 17:20:52 2009 +0200
156.3 @@ -15,14 +15,22 @@
156.4
156.5 header{*Composition: Basic Primitives*}
156.6
156.7 -theory Comp imports Union begin
156.8 +theory Comp
156.9 +imports Union
156.10 +begin
156.11
156.12 -instance program :: (type) ord ..
156.13 +instantiation program :: (type) ord
156.14 +begin
156.15
156.16 -defs
156.17 - component_def: "F \<le> H == \<exists>G. F\<squnion>G = H"
156.18 - strict_component_def: "(F < (H::'a program)) == (F \<le> H & F \<noteq> H)"
156.19 +definition
156.20 + component_def: "F \<le> H <-> (\<exists>G. F\<squnion>G = H)"
156.21
156.22 +definition
156.23 + strict_component_def: "F < (H::'a program) <-> (F \<le> H & F \<noteq> H)"
156.24 +
156.25 +instance ..
156.26 +
156.27 +end
156.28
156.29 constdefs
156.30 component_of :: "'a program =>'a program=> bool"
156.31 @@ -114,7 +122,7 @@
156.32 by (auto simp add: stable_def component_constrains)
156.33
156.34 (*Used in Guar.thy to show that programs are partially ordered*)
156.35 -lemmas program_less_le = strict_component_def [THEN meta_eq_to_obj_eq]
156.36 +lemmas program_less_le = strict_component_def
156.37
156.38
156.39 subsection{*The preserves property*}
156.40 @@ -229,8 +237,7 @@
156.41 apply (blast intro: Join_assoc [symmetric])
156.42 done
156.43
156.44 -lemmas strict_component_of_eq =
156.45 - strict_component_of_def [THEN meta_eq_to_obj_eq, standard]
156.46 +lemmas strict_component_of_eq = strict_component_of_def
156.47
156.48 (** localize **)
156.49 lemma localize_Init_eq [simp]: "Init (localize v F) = Init F"
157.1 --- a/src/HOL/UNITY/Transformers.thy Mon May 11 09:39:53 2009 +0200
157.2 +++ b/src/HOL/UNITY/Transformers.thy Mon May 11 17:20:52 2009 +0200
157.3 @@ -338,10 +338,10 @@
157.4
157.5 constdefs
157.6 wens_single_finite :: "[('a*'a) set, 'a set, nat] => 'a set"
157.7 - "wens_single_finite act B k == \<Union>i \<in> atMost k. ((wp act)^i) B"
157.8 + "wens_single_finite act B k == \<Union>i \<in> atMost k. (wp act ^^ i) B"
157.9
157.10 wens_single :: "[('a*'a) set, 'a set] => 'a set"
157.11 - "wens_single act B == \<Union>i. ((wp act)^i) B"
157.12 + "wens_single act B == \<Union>i. (wp act ^^ i) B"
157.13
157.14 lemma wens_single_Un_eq:
157.15 "single_valued act
158.1 --- a/src/HOL/Wellfounded.thy Mon May 11 09:39:53 2009 +0200
158.2 +++ b/src/HOL/Wellfounded.thy Mon May 11 17:20:52 2009 +0200
158.3 @@ -7,7 +7,7 @@
158.4 header {*Well-founded Recursion*}
158.5
158.6 theory Wellfounded
158.7 -imports Finite_Set Transitive_Closure Nat
158.8 +imports Finite_Set Transitive_Closure
158.9 uses ("Tools/function_package/size.ML")
158.10 begin
158.11
159.1 --- a/src/HOL/Word/BinBoolList.thy Mon May 11 09:39:53 2009 +0200
159.2 +++ b/src/HOL/Word/BinBoolList.thy Mon May 11 17:20:52 2009 +0200
159.3 @@ -38,7 +38,7 @@
159.4 if y then rbl_add ws x else ws)"
159.5
159.6 lemma butlast_power:
159.7 - "(butlast ^ n) bl = take (length bl - n) bl"
159.8 + "(butlast ^^ n) bl = take (length bl - n) bl"
159.9 by (induct n) (auto simp: butlast_take)
159.10
159.11 lemma bin_to_bl_aux_Pls_minus_simp [simp]:
159.12 @@ -370,14 +370,14 @@
159.13 done
159.14
159.15 lemma nth_rest_power_bin [rule_format] :
159.16 - "ALL n. bin_nth ((bin_rest ^ k) w) n = bin_nth w (n + k)"
159.17 + "ALL n. bin_nth ((bin_rest ^^ k) w) n = bin_nth w (n + k)"
159.18 apply (induct k, clarsimp)
159.19 apply clarsimp
159.20 apply (simp only: bin_nth.Suc [symmetric] add_Suc)
159.21 done
159.22
159.23 lemma take_rest_power_bin:
159.24 - "m <= n ==> take m (bin_to_bl n w) = bin_to_bl m ((bin_rest ^ (n - m)) w)"
159.25 + "m <= n ==> take m (bin_to_bl n w) = bin_to_bl m ((bin_rest ^^ (n - m)) w)"
159.26 apply (rule nth_equalityI)
159.27 apply simp
159.28 apply (clarsimp simp add: nth_bin_to_bl nth_rest_power_bin)
160.1 --- a/src/HOL/Word/BinGeneral.thy Mon May 11 09:39:53 2009 +0200
160.2 +++ b/src/HOL/Word/BinGeneral.thy Mon May 11 17:20:52 2009 +0200
160.3 @@ -439,7 +439,7 @@
160.4 apply clarsimp
160.5 apply (simp add: bin_last_mod bin_rest_div Bit_def
160.6 cong: number_of_False_cong)
160.7 - apply (clarsimp simp: zmod_zmult_zmult1 [symmetric]
160.8 + apply (clarsimp simp: mod_mult_mult1 [symmetric]
160.9 zmod_zdiv_equality [THEN diff_eq_eq [THEN iffD2 [THEN sym]]])
160.10 apply (rule trans [symmetric, OF _ emep1])
160.11 apply auto
160.12 @@ -822,8 +822,8 @@
160.13 by (induct n) auto
160.14
160.15 lemma bin_rest_power_trunc [rule_format] :
160.16 - "(bin_rest ^ k) (bintrunc n bin) =
160.17 - bintrunc (n - k) ((bin_rest ^ k) bin)"
160.18 + "(bin_rest ^^ k) (bintrunc n bin) =
160.19 + bintrunc (n - k) ((bin_rest ^^ k) bin)"
160.20 by (induct k) (auto simp: bin_rest_trunc)
160.21
160.22 lemma bin_rest_trunc_i:
160.23 @@ -857,7 +857,7 @@
160.24 by (rule ext) auto
160.25
160.26 lemma rco_lem:
160.27 - "f o g o f = g o f ==> f o (g o f) ^ n = g ^ n o f"
160.28 + "f o g o f = g o f ==> f o (g o f) ^^ n = g ^^ n o f"
160.29 apply (rule ext)
160.30 apply (induct_tac n)
160.31 apply (simp_all (no_asm))
160.32 @@ -867,7 +867,7 @@
160.33 apply simp
160.34 done
160.35
160.36 -lemma rco_alt: "(f o g) ^ n o f = f o (g o f) ^ n"
160.37 +lemma rco_alt: "(f o g) ^^ n o f = f o (g o f) ^^ n"
160.38 apply (rule ext)
160.39 apply (induct n)
160.40 apply (simp_all add: o_def)
160.41 @@ -891,8 +891,9 @@
160.42
160.43 subsection {* Miscellaneous lemmas *}
160.44
160.45 -lemmas funpow_minus_simp =
160.46 - trans [OF gen_minus [where f = "power f"] funpow_Suc, standard]
160.47 +lemma funpow_minus_simp:
160.48 + "0 < n \<Longrightarrow> f ^^ n = f \<circ> f ^^ (n - 1)"
160.49 + by (cases n) simp_all
160.50
160.51 lemmas funpow_pred_simp [simp] =
160.52 funpow_minus_simp [of "number_of bin", simplified nobm1, standard]
161.1 --- a/src/HOL/Word/BinOperations.thy Mon May 11 09:39:53 2009 +0200
161.2 +++ b/src/HOL/Word/BinOperations.thy Mon May 11 17:20:52 2009 +0200
161.3 @@ -641,7 +641,7 @@
161.4 apply (simp add: bin_rest_div zdiv_zmult2_eq)
161.5 apply (case_tac b rule: bin_exhaust)
161.6 apply simp
161.7 - apply (simp add: Bit_def zmod_zmult_zmult1 p1mod22k
161.8 + apply (simp add: Bit_def mod_mult_mult1 p1mod22k
161.9 split: bit.split
161.10 cong: number_of_False_cong)
161.11 done
162.1 --- a/src/HOL/Word/Num_Lemmas.thy Mon May 11 09:39:53 2009 +0200
162.2 +++ b/src/HOL/Word/Num_Lemmas.thy Mon May 11 17:20:52 2009 +0200
162.3 @@ -45,10 +45,6 @@
162.4 apply (simp add: number_of_eq nat_diff_distrib [symmetric])
162.5 done
162.6
162.7 -lemma of_int_power:
162.8 - "of_int (a ^ n) = (of_int a ^ n :: 'a :: {recpower, comm_ring_1})"
162.9 - by (induct n) (auto simp add: power_Suc)
162.10 -
162.11 lemma zless2: "0 < (2 :: int)" by arith
162.12
162.13 lemmas zless2p [simp] = zless2 [THEN zero_less_power]
162.14 @@ -66,7 +62,7 @@
162.15 apply (safe dest!: even_equiv_def [THEN iffD1])
162.16 apply (subst pos_zmod_mult_2)
162.17 apply arith
162.18 - apply (simp add: zmod_zmult_zmult1)
162.19 + apply (simp add: mod_mult_mult1)
162.20 done
162.21
162.22 lemmas eme1p = emep1 [simplified add_commute]
163.1 --- a/src/HOL/Word/TdThs.thy Mon May 11 09:39:53 2009 +0200
163.2 +++ b/src/HOL/Word/TdThs.thy Mon May 11 17:20:52 2009 +0200
163.3 @@ -110,7 +110,7 @@
163.4 done
163.5
163.6 lemma fn_comm_power:
163.7 - "fa o tr = tr o fr ==> fa ^ n o tr = tr o fr ^ n"
163.8 + "fa o tr = tr o fr ==> fa ^^ n o tr = tr o fr ^^ n"
163.9 apply (rule ext)
163.10 apply (induct n)
163.11 apply (auto dest: fun_cong)
164.1 --- a/src/HOL/Word/WordArith.thy Mon May 11 09:39:53 2009 +0200
164.2 +++ b/src/HOL/Word/WordArith.thy Mon May 11 17:20:52 2009 +0200
164.3 @@ -701,7 +701,8 @@
164.4 apply (erule (2) udvd_decr0)
164.5 done
164.6
164.7 -ML{*Delsimprocs cancel_factors*}
164.8 +ML {* Delsimprocs Numeral_Simprocs.cancel_factors *}
164.9 +
164.10 lemma udvd_incr2_K:
164.11 "p < a + s ==> a <= a + s ==> K udvd s ==> K udvd p - a ==> a <= p ==>
164.12 0 < K ==> p <= p + K & p + K <= a + s"
164.13 @@ -717,7 +718,8 @@
164.14 apply arith
164.15 apply simp
164.16 done
164.17 -ML{*Delsimprocs cancel_factors*}
164.18 +
164.19 +ML {* Addsimprocs Numeral_Simprocs.cancel_factors *}
164.20
164.21 (* links with rbl operations *)
164.22 lemma word_succ_rbl:
164.23 @@ -794,9 +796,6 @@
164.24
164.25 instance word :: (len0) order ..
164.26
164.27 -instance word :: (len) recpower
164.28 - by (intro_classes) simp_all
164.29 -
164.30 (* note that iszero_def is only for class comm_semiring_1_cancel,
164.31 which requires word length >= 1, ie 'a :: len word *)
164.32 lemma zero_bintrunc:
165.1 --- a/src/HOL/Word/WordBitwise.thy Mon May 11 09:39:53 2009 +0200
165.2 +++ b/src/HOL/Word/WordBitwise.thy Mon May 11 17:20:52 2009 +0200
165.3 @@ -443,8 +443,10 @@
165.4
165.5 lemmas test_bit_2p = refl [THEN test_bit_2p', unfolded word_size]
165.6
165.7 -lemmas nth_w2p = test_bit_2p [unfolded of_int_number_of_eq
165.8 - word_of_int [symmetric] Int.of_int_power]
165.9 +lemma nth_w2p:
165.10 + "((2\<Colon>'a\<Colon>len word) ^ n) !! m \<longleftrightarrow> m = n \<and> m < len_of TYPE('a\<Colon>len)"
165.11 + unfolding test_bit_2p [symmetric] word_of_int [symmetric]
165.12 + by (simp add: of_int_power)
165.13
165.14 lemma uint_2p:
165.15 "(0::'a::len word) < 2 ^ n ==> uint (2 ^ n::'a::len word) = 2 ^ n"
166.1 --- a/src/HOL/Word/WordDefinition.thy Mon May 11 09:39:53 2009 +0200
166.2 +++ b/src/HOL/Word/WordDefinition.thy Mon May 11 17:20:52 2009 +0200
166.3 @@ -99,7 +99,7 @@
166.4
166.5 subsection "Arithmetic operations"
166.6
166.7 -instantiation word :: (len0) "{number, uminus, minus, plus, one, zero, times, Divides.div, power, ord, bit}"
166.8 +instantiation word :: (len0) "{number, uminus, minus, plus, one, zero, times, Divides.div, ord, bit}"
166.9 begin
166.10
166.11 definition
166.12 @@ -126,10 +126,6 @@
166.13 definition
166.14 word_mod_def: "a mod b = word_of_int (uint a mod uint b)"
166.15
166.16 -primrec power_word where
166.17 - "(a\<Colon>'a word) ^ 0 = 1"
166.18 - | "(a\<Colon>'a word) ^ Suc n = a * a ^ n"
166.19 -
166.20 definition
166.21 word_number_of_def: "number_of w = word_of_int w"
166.22
166.23 @@ -157,7 +153,7 @@
166.24
166.25 instance ..
166.26
166.27 -end
166.28 +end
166.29
166.30 definition
166.31 word_succ :: "'a :: len0 word => 'a word"
166.32 @@ -207,10 +203,10 @@
166.33 "shiftr1 w = word_of_int (bin_rest (uint w))"
166.34
166.35 definition
166.36 - shiftl_def: "w << n = (shiftl1 ^ n) w"
166.37 + shiftl_def: "w << n = (shiftl1 ^^ n) w"
166.38
166.39 definition
166.40 - shiftr_def: "w >> n = (shiftr1 ^ n) w"
166.41 + shiftr_def: "w >> n = (shiftr1 ^^ n) w"
166.42
166.43 instance ..
166.44
166.45 @@ -245,7 +241,7 @@
166.46 "bshiftr1 b w == of_bl (b # butlast (to_bl w))"
166.47
166.48 sshiftr :: "'a :: len word => nat => 'a word" (infixl ">>>" 55)
166.49 - "w >>> n == (sshiftr1 ^ n) w"
166.50 + "w >>> n == (sshiftr1 ^^ n) w"
166.51
166.52 mask :: "nat => 'a::len word"
166.53 "mask n == (1 << n) - 1"
166.54 @@ -268,7 +264,7 @@
166.55 case ys of [] => [] | x # xs => last ys # butlast ys"
166.56
166.57 rotater :: "nat => 'a list => 'a list"
166.58 - "rotater n == rotater1 ^ n"
166.59 + "rotater n == rotater1 ^^ n"
166.60
166.61 word_rotr :: "nat => 'a :: len0 word => 'a :: len0 word"
166.62 "word_rotr n w == of_bl (rotater n (to_bl w))"
166.63 @@ -303,7 +299,7 @@
166.64 constdefs
166.65 -- "Largest representable machine integer."
166.66 max_word :: "'a::len word"
166.67 - "max_word \<equiv> word_of_int (2^len_of TYPE('a) - 1)"
166.68 + "max_word \<equiv> word_of_int (2 ^ len_of TYPE('a) - 1)"
166.69
166.70 consts
166.71 of_bool :: "bool \<Rightarrow> 'a::len word"
167.1 --- a/src/HOL/Word/WordShift.thy Mon May 11 09:39:53 2009 +0200
167.2 +++ b/src/HOL/Word/WordShift.thy Mon May 11 17:20:52 2009 +0200
167.3 @@ -361,14 +361,14 @@
167.4
167.5 lemma shiftr_no':
167.6 "w = number_of bin ==>
167.7 - (w::'a::len0 word) >> n = number_of ((bin_rest ^ n) (bintrunc (size w) bin))"
167.8 + (w::'a::len0 word) >> n = number_of ((bin_rest ^^ n) (bintrunc (size w) bin))"
167.9 apply clarsimp
167.10 apply (rule word_eqI)
167.11 apply (auto simp: nth_shiftr nth_rest_power_bin nth_bintr word_size)
167.12 done
167.13
167.14 lemma sshiftr_no':
167.15 - "w = number_of bin ==> w >>> n = number_of ((bin_rest ^ n)
167.16 + "w = number_of bin ==> w >>> n = number_of ((bin_rest ^^ n)
167.17 (sbintrunc (size w - 1) bin))"
167.18 apply clarsimp
167.19 apply (rule word_eqI)
168.1 --- a/src/HOL/base.ML Mon May 11 09:39:53 2009 +0200
168.2 +++ b/src/HOL/base.ML Mon May 11 17:20:52 2009 +0200
168.3 @@ -1,2 +1,2 @@
168.4 (*side-entry for HOL-Base*)
168.5 -use_thy "Code_Setup";
168.6 +use_thy "HOL";
169.1 --- a/src/HOL/ex/Arith_Examples.thy Mon May 11 09:39:53 2009 +0200
169.2 +++ b/src/HOL/ex/Arith_Examples.thy Mon May 11 17:20:52 2009 +0200
169.3 @@ -4,7 +4,9 @@
169.4
169.5 header {* Arithmetic *}
169.6
169.7 -theory Arith_Examples imports Main begin
169.8 +theory Arith_Examples
169.9 +imports Main
169.10 +begin
169.11
169.12 text {*
169.13 The @{text arith} method is used frequently throughout the Isabelle
169.14 @@ -27,7 +29,7 @@
169.15 *}
169.16
169.17 (*
169.18 -ML {* set trace_arith; *}
169.19 +ML {* set Lin_Arith.trace; *}
169.20 *)
169.21
169.22 subsection {* Splitting of Operators: @{term max}, @{term min}, @{term abs},
169.23 @@ -35,87 +37,87 @@
169.24 @{term Divides.div} *}
169.25
169.26 lemma "(i::nat) <= max i j"
169.27 - by (tactic {* fast_arith_tac @{context} 1 *})
169.28 + by linarith
169.29
169.30 lemma "(i::int) <= max i j"
169.31 - by (tactic {* fast_arith_tac @{context} 1 *})
169.32 + by linarith
169.33
169.34 lemma "min i j <= (i::nat)"
169.35 - by (tactic {* fast_arith_tac @{context} 1 *})
169.36 + by linarith
169.37
169.38 lemma "min i j <= (i::int)"
169.39 - by (tactic {* fast_arith_tac @{context} 1 *})
169.40 + by linarith
169.41
169.42 lemma "min (i::nat) j <= max i j"
169.43 - by (tactic {* fast_arith_tac @{context} 1 *})
169.44 + by linarith
169.45
169.46 lemma "min (i::int) j <= max i j"
169.47 - by (tactic {* fast_arith_tac @{context} 1 *})
169.48 + by linarith
169.49
169.50 lemma "min (i::nat) j + max i j = i + j"
169.51 - by (tactic {* fast_arith_tac @{context} 1 *})
169.52 + by linarith
169.53
169.54 lemma "min (i::int) j + max i j = i + j"
169.55 - by (tactic {* fast_arith_tac @{context} 1 *})
169.56 + by linarith
169.57
169.58 lemma "(i::nat) < j ==> min i j < max i j"
169.59 - by (tactic {* fast_arith_tac @{context} 1 *})
169.60 + by linarith
169.61
169.62 lemma "(i::int) < j ==> min i j < max i j"
169.63 - by (tactic {* fast_arith_tac @{context} 1 *})
169.64 + by linarith
169.65
169.66 lemma "(0::int) <= abs i"
169.67 - by (tactic {* fast_arith_tac @{context} 1 *})
169.68 + by linarith
169.69
169.70 lemma "(i::int) <= abs i"
169.71 - by (tactic {* fast_arith_tac @{context} 1 *})
169.72 + by linarith
169.73
169.74 lemma "abs (abs (i::int)) = abs i"
169.75 - by (tactic {* fast_arith_tac @{context} 1 *})
169.76 + by linarith
169.77
169.78 text {* Also testing subgoals with bound variables. *}
169.79
169.80 lemma "!!x. (x::nat) <= y ==> x - y = 0"
169.81 - by (tactic {* fast_arith_tac @{context} 1 *})
169.82 + by linarith
169.83
169.84 lemma "!!x. (x::nat) - y = 0 ==> x <= y"
169.85 - by (tactic {* fast_arith_tac @{context} 1 *})
169.86 + by linarith
169.87
169.88 lemma "!!x. ((x::nat) <= y) = (x - y = 0)"
169.89 - by (tactic {* linear_arith_tac @{context} 1 *})
169.90 + by linarith
169.91
169.92 lemma "[| (x::nat) < y; d < 1 |] ==> x - y = d"
169.93 - by (tactic {* fast_arith_tac @{context} 1 *})
169.94 + by linarith
169.95
169.96 lemma "[| (x::nat) < y; d < 1 |] ==> x - y - x = d - x"
169.97 - by (tactic {* fast_arith_tac @{context} 1 *})
169.98 + by linarith
169.99
169.100 lemma "(x::int) < y ==> x - y < 0"
169.101 - by (tactic {* fast_arith_tac @{context} 1 *})
169.102 + by linarith
169.103
169.104 lemma "nat (i + j) <= nat i + nat j"
169.105 - by (tactic {* fast_arith_tac @{context} 1 *})
169.106 + by linarith
169.107
169.108 lemma "i < j ==> nat (i - j) = 0"
169.109 - by (tactic {* fast_arith_tac @{context} 1 *})
169.110 + by linarith
169.111
169.112 lemma "(i::nat) mod 0 = i"
169.113 (* FIXME: need to replace 0 by its numeral representation *)
169.114 apply (subst nat_numeral_0_eq_0 [symmetric])
169.115 - by (tactic {* fast_arith_tac @{context} 1 *})
169.116 + by linarith
169.117
169.118 lemma "(i::nat) mod 1 = 0"
169.119 (* FIXME: need to replace 1 by its numeral representation *)
169.120 apply (subst nat_numeral_1_eq_1 [symmetric])
169.121 - by (tactic {* fast_arith_tac @{context} 1 *})
169.122 + by linarith
169.123
169.124 lemma "(i::nat) mod 42 <= 41"
169.125 - by (tactic {* fast_arith_tac @{context} 1 *})
169.126 + by linarith
169.127
169.128 lemma "(i::int) mod 0 = i"
169.129 (* FIXME: need to replace 0 by its numeral representation *)
169.130 apply (subst numeral_0_eq_0 [symmetric])
169.131 - by (tactic {* fast_arith_tac @{context} 1 *})
169.132 + by linarith
169.133
169.134 lemma "(i::int) mod 1 = 0"
169.135 (* FIXME: need to replace 1 by its numeral representation *)
169.136 @@ -130,70 +132,70 @@
169.137 oops
169.138
169.139 lemma "-(i::int) * 1 = 0 ==> i = 0"
169.140 - by (tactic {* fast_arith_tac @{context} 1 *})
169.141 + by linarith
169.142
169.143 lemma "[| (0::int) < abs i; abs i * 1 < abs i * j |] ==> 1 < abs i * j"
169.144 - by (tactic {* fast_arith_tac @{context} 1 *})
169.145 + by linarith
169.146
169.147
169.148 subsection {* Meta-Logic *}
169.149
169.150 lemma "x < Suc y == x <= y"
169.151 - by (tactic {* linear_arith_tac @{context} 1 *})
169.152 + by linarith
169.153
169.154 lemma "((x::nat) == z ==> x ~= y) ==> x ~= y | z ~= y"
169.155 - by (tactic {* linear_arith_tac @{context} 1 *})
169.156 + by linarith
169.157
169.158
169.159 subsection {* Various Other Examples *}
169.160
169.161 lemma "(x < Suc y) = (x <= y)"
169.162 - by (tactic {* linear_arith_tac @{context} 1 *})
169.163 + by linarith
169.164
169.165 lemma "[| (x::nat) < y; y < z |] ==> x < z"
169.166 - by (tactic {* fast_arith_tac @{context} 1 *})
169.167 + by linarith
169.168
169.169 lemma "(x::nat) < y & y < z ==> x < z"
169.170 - by (tactic {* linear_arith_tac @{context} 1 *})
169.171 + by linarith
169.172
169.173 text {* This example involves no arithmetic at all, but is solved by
169.174 preprocessing (i.e. NNF normalization) alone. *}
169.175
169.176 lemma "(P::bool) = Q ==> Q = P"
169.177 - by (tactic {* linear_arith_tac @{context} 1 *})
169.178 + by linarith
169.179
169.180 lemma "[| P = (x = 0); (~P) = (y = 0) |] ==> min (x::nat) y = 0"
169.181 - by (tactic {* linear_arith_tac @{context} 1 *})
169.182 + by linarith
169.183
169.184 lemma "[| P = (x = 0); (~P) = (y = 0) |] ==> max (x::nat) y = x + y"
169.185 - by (tactic {* linear_arith_tac @{context} 1 *})
169.186 + by linarith
169.187
169.188 lemma "[| (x::nat) ~= y; a + 2 = b; a < y; y < b; a < x; x < b |] ==> False"
169.189 - by (tactic {* fast_arith_tac @{context} 1 *})
169.190 + by linarith
169.191
169.192 lemma "[| (x::nat) > y; y > z; z > x |] ==> False"
169.193 - by (tactic {* fast_arith_tac @{context} 1 *})
169.194 + by linarith
169.195
169.196 lemma "(x::nat) - 5 > y ==> y < x"
169.197 - by (tactic {* fast_arith_tac @{context} 1 *})
169.198 + by linarith
169.199
169.200 lemma "(x::nat) ~= 0 ==> 0 < x"
169.201 - by (tactic {* fast_arith_tac @{context} 1 *})
169.202 + by linarith
169.203
169.204 lemma "[| (x::nat) ~= y; x <= y |] ==> x < y"
169.205 - by (tactic {* fast_arith_tac @{context} 1 *})
169.206 + by linarith
169.207
169.208 lemma "[| (x::nat) < y; P (x - y) |] ==> P 0"
169.209 - by (tactic {* linear_arith_tac @{context} 1 *})
169.210 + by linarith
169.211
169.212 lemma "(x - y) - (x::nat) = (x - x) - y"
169.213 - by (tactic {* fast_arith_tac @{context} 1 *})
169.214 + by linarith
169.215
169.216 lemma "[| (a::nat) < b; c < d |] ==> (a - b) = (c - d)"
169.217 - by (tactic {* fast_arith_tac @{context} 1 *})
169.218 + by linarith
169.219
169.220 lemma "((a::nat) - (b - (c - (d - e)))) = (a - (b - (c - (d - e))))"
169.221 - by (tactic {* fast_arith_tac @{context} 1 *})
169.222 + by linarith
169.223
169.224 lemma "(n < m & m < n') | (n < m & m = n') | (n < n' & n' < m) |
169.225 (n = n' & n' < m) | (n = m & m < n') |
169.226 @@ -218,31 +220,31 @@
169.227 text {* Constants. *}
169.228
169.229 lemma "(0::nat) < 1"
169.230 - by (tactic {* fast_arith_tac @{context} 1 *})
169.231 + by linarith
169.232
169.233 lemma "(0::int) < 1"
169.234 - by (tactic {* fast_arith_tac @{context} 1 *})
169.235 + by linarith
169.236
169.237 lemma "(47::nat) + 11 < 08 * 15"
169.238 - by (tactic {* fast_arith_tac @{context} 1 *})
169.239 + by linarith
169.240
169.241 lemma "(47::int) + 11 < 08 * 15"
169.242 - by (tactic {* fast_arith_tac @{context} 1 *})
169.243 + by linarith
169.244
169.245 text {* Splitting of inequalities of different type. *}
169.246
169.247 lemma "[| (a::nat) ~= b; (i::int) ~= j; a < 2; b < 2 |] ==>
169.248 a + b <= nat (max (abs i) (abs j))"
169.249 - by (tactic {* fast_arith_tac @{context} 1 *})
169.250 + by linarith
169.251
169.252 text {* Again, but different order. *}
169.253
169.254 lemma "[| (i::int) ~= j; (a::nat) ~= b; a < 2; b < 2 |] ==>
169.255 a + b <= nat (max (abs i) (abs j))"
169.256 - by (tactic {* fast_arith_tac @{context} 1 *})
169.257 + by linarith
169.258
169.259 (*
169.260 -ML {* reset trace_arith; *}
169.261 +ML {* reset Lin_Arith.trace; *}
169.262 *)
169.263
169.264 end
170.1 --- a/src/HOL/ex/BinEx.thy Mon May 11 09:39:53 2009 +0200
170.2 +++ b/src/HOL/ex/BinEx.thy Mon May 11 17:20:52 2009 +0200
170.3 @@ -712,38 +712,38 @@
170.4 by arith
170.5
170.6 lemma "!!a::real. a \<le> b ==> c \<le> d ==> x + y < z ==> a + c \<le> b + d"
170.7 -by (tactic "fast_arith_tac @{context} 1")
170.8 +by linarith
170.9
170.10 lemma "!!a::real. a < b ==> c < d ==> a - d \<le> b + (-c)"
170.11 -by (tactic "fast_arith_tac @{context} 1")
170.12 +by linarith
170.13
170.14 lemma "!!a::real. a \<le> b ==> b + b \<le> c ==> a + a \<le> c"
170.15 -by (tactic "fast_arith_tac @{context} 1")
170.16 +by linarith
170.17
170.18 lemma "!!a::real. a + b \<le> i + j ==> a \<le> b ==> i \<le> j ==> a + a \<le> j + j"
170.19 -by (tactic "fast_arith_tac @{context} 1")
170.20 +by linarith
170.21
170.22 lemma "!!a::real. a + b < i + j ==> a < b ==> i < j ==> a + a < j + j"
170.23 -by (tactic "fast_arith_tac @{context} 1")
170.24 +by linarith
170.25
170.26 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"
170.27 by arith
170.28
170.29 lemma "!!a::real. a + b + c + d \<le> i + j + k + l ==> a \<le> b ==> b \<le> c
170.30 ==> c \<le> d ==> i \<le> j ==> j \<le> k ==> k \<le> l ==> a \<le> l"
170.31 -by (tactic "fast_arith_tac @{context} 1")
170.32 +by linarith
170.33
170.34 lemma "!!a::real. a + b + c + d \<le> i + j + k + l ==> a \<le> b ==> b \<le> c
170.35 ==> c \<le> d ==> i \<le> j ==> j \<le> k ==> k \<le> l ==> a + a + a + a \<le> l + l + l + l"
170.36 -by (tactic "fast_arith_tac @{context} 1")
170.37 +by linarith
170.38
170.39 lemma "!!a::real. a + b + c + d \<le> i + j + k + l ==> a \<le> b ==> b \<le> c
170.40 ==> c \<le> d ==> i \<le> j ==> j \<le> k ==> k \<le> l ==> a + a + a + a + a \<le> l + l + l + l + i"
170.41 -by (tactic "fast_arith_tac @{context} 1")
170.42 +by linarith
170.43
170.44 lemma "!!a::real. a + b + c + d \<le> i + j + k + l ==> a \<le> b ==> b \<le> c
170.45 ==> 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"
170.46 -by (tactic "fast_arith_tac @{context} 1")
170.47 +by linarith
170.48
170.49
170.50 subsection{*Complex Arithmetic*}
171.1 --- a/src/HOL/ex/Commutative_Ring_Complete.thy Mon May 11 09:39:53 2009 +0200
171.2 +++ b/src/HOL/ex/Commutative_Ring_Complete.thy Mon May 11 17:20:52 2009 +0200
171.3 @@ -1,5 +1,4 @@
171.4 -(* ID: $Id$
171.5 - Author: Bernhard Haeupler
171.6 +(* Author: Bernhard Haeupler
171.7
171.8 This theory is about of the relative completeness of method comm-ring
171.9 method. As long as the reified atomic polynomials of type 'a pol are
171.10 @@ -14,7 +13,7 @@
171.11
171.12 text {* Formalization of normal form *}
171.13 fun
171.14 - isnorm :: "('a::{comm_ring,recpower}) pol \<Rightarrow> bool"
171.15 + isnorm :: "('a::{comm_ring}) pol \<Rightarrow> bool"
171.16 where
171.17 "isnorm (Pc c) \<longleftrightarrow> True"
171.18 | "isnorm (Pinj i (Pc c)) \<longleftrightarrow> False"
172.1 --- a/src/HOL/ex/Formal_Power_Series_Examples.thy Mon May 11 09:39:53 2009 +0200
172.2 +++ b/src/HOL/ex/Formal_Power_Series_Examples.thy Mon May 11 17:20:52 2009 +0200
172.3 @@ -11,7 +11,7 @@
172.4
172.5 section{* The generalized binomial theorem *}
172.6 lemma gbinomial_theorem:
172.7 - "((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))"
172.8 + "((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))"
172.9 proof-
172.10 from E_add_mult[of a b]
172.11 have "(E (a + b)) $ n = (E a * E b)$n" by simp
172.12 @@ -38,7 +38,7 @@
172.13 by (simp add: fps_binomial_def)
172.14
172.15 lemma fps_binomial_ODE_unique:
172.16 - fixes c :: "'a::{field, recpower,ring_char_0}"
172.17 + fixes c :: "'a::{field, ring_char_0}"
172.18 shows "fps_deriv a = (fps_const c * a) / (1 + X) \<longleftrightarrow> a = fps_const (a$0) * fps_binomial c"
172.19 (is "?lhs \<longleftrightarrow> ?rhs")
172.20 proof-
173.1 --- a/src/HOL/ex/Groebner_Examples.thy Mon May 11 09:39:53 2009 +0200
173.2 +++ b/src/HOL/ex/Groebner_Examples.thy Mon May 11 17:20:52 2009 +0200
173.3 @@ -1,5 +1,4 @@
173.4 (* Title: HOL/ex/Groebner_Examples.thy
173.5 - ID: $Id$
173.6 Author: Amine Chaieb, TU Muenchen
173.7 *)
173.8
173.9 @@ -11,7 +10,7 @@
173.10
173.11 subsection {* Basic examples *}
173.12
173.13 -lemma "3 ^ 3 == (?X::'a::{number_ring,recpower})"
173.14 +lemma "3 ^ 3 == (?X::'a::{number_ring})"
173.15 by sring_norm
173.16
173.17 lemma "(x - (-2))^5 == ?X::int"
173.18 @@ -20,7 +19,7 @@
173.19 lemma "(x - (-2))^5 * (y - 78) ^ 8 == ?X::int"
173.20 by sring_norm
173.21
173.22 -lemma "((-3) ^ (Suc (Suc (Suc 0)))) == (X::'a::{number_ring,recpower})"
173.23 +lemma "((-3) ^ (Suc (Suc (Suc 0)))) == (X::'a::{number_ring})"
173.24 apply (simp only: power_Suc power_0)
173.25 apply (simp only: comp_arith)
173.26 oops
173.27 @@ -47,7 +46,7 @@
173.28 by algebra
173.29
173.30 lemma
173.31 - fixes x::"'a::{idom,recpower,number_ring}"
173.32 + fixes x::"'a::{idom,number_ring}"
173.33 shows "x^2*y = x^2 & x*y^2 = y^2 \<longleftrightarrow> x=1 & y=1 | x=0 & y=0"
173.34 by algebra
173.35
173.36 @@ -58,7 +57,7 @@
173.37 "sq x == x*x"
173.38
173.39 lemma
173.40 - fixes x1 :: "'a::{idom,recpower,number_ring}"
173.41 + fixes x1 :: "'a::{idom,number_ring}"
173.42 shows
173.43 "(sq x1 + sq x2 + sq x3 + sq x4) * (sq y1 + sq y2 + sq y3 + sq y4) =
173.44 sq (x1*y1 - x2*y2 - x3*y3 - x4*y4) +
173.45 @@ -68,7 +67,7 @@
173.46 by (algebra add: sq_def)
173.47
173.48 lemma
173.49 - fixes p1 :: "'a::{idom,recpower,number_ring}"
173.50 + fixes p1 :: "'a::{idom,number_ring}"
173.51 shows
173.52 "(sq p1 + sq q1 + sq r1 + sq s1 + sq t1 + sq u1 + sq v1 + sq w1) *
173.53 (sq p2 + sq q2 + sq r2 + sq s2 + sq t2 + sq u2 + sq v2 + sq w2)
174.1 --- a/src/HOL/ex/NormalForm.thy Mon May 11 09:39:53 2009 +0200
174.2 +++ b/src/HOL/ex/NormalForm.thy Mon May 11 17:20:52 2009 +0200
174.3 @@ -1,7 +1,6 @@
174.4 -(* Authors: Klaus Aehlig, Tobias Nipkow
174.5 -*)
174.6 +(* Authors: Klaus Aehlig, Tobias Nipkow *)
174.7
174.8 -header {* Test of normalization function *}
174.9 +header {* Testing implementation of normalization by evaluation *}
174.10
174.11 theory NormalForm
174.12 imports Main Rational
174.13 @@ -11,7 +10,6 @@
174.14 lemma "p \<longrightarrow> True" by normalization
174.15 declare disj_assoc [code nbe]
174.16 lemma "((P | Q) | R) = (P | (Q | R))" by normalization
174.17 -declare disj_assoc [code del]
174.18 lemma "0 + (n::nat) = n" by normalization
174.19 lemma "0 + Suc n = Suc n" by normalization
174.20 lemma "Suc n + Suc m = n + Suc (Suc m)" by normalization
174.21 @@ -19,18 +17,13 @@
174.22
174.23 datatype n = Z | S n
174.24
174.25 -consts
174.26 - add :: "n \<Rightarrow> n \<Rightarrow> n"
174.27 - add2 :: "n \<Rightarrow> n \<Rightarrow> n"
174.28 - mul :: "n \<Rightarrow> n \<Rightarrow> n"
174.29 - mul2 :: "n \<Rightarrow> n \<Rightarrow> n"
174.30 - exp :: "n \<Rightarrow> n \<Rightarrow> n"
174.31 -primrec
174.32 - "add Z = id"
174.33 - "add (S m) = S o add m"
174.34 -primrec
174.35 - "add2 Z n = n"
174.36 - "add2 (S m) n = S(add2 m n)"
174.37 +primrec add :: "n \<Rightarrow> n \<Rightarrow> n" where
174.38 + "add Z = id"
174.39 + | "add (S m) = S o add m"
174.40 +
174.41 +primrec add2 :: "n \<Rightarrow> n \<Rightarrow> n" where
174.42 + "add2 Z n = n"
174.43 + | "add2 (S m) n = S(add2 m n)"
174.44
174.45 declare add2.simps [code]
174.46 lemma [code nbe]: "add2 (add2 n m) k = add2 n (add2 m k)"
174.47 @@ -44,15 +37,17 @@
174.48 lemma "add2 (add2 (S n) (S m)) (S k) = S(S(S(add2 n (add2 m k))))" by normalization
174.49 lemma "add2 (add2 (S n) (add2 (S m) Z)) (S k) = S(S(S(add2 n (add2 m k))))" by normalization
174.50
174.51 -primrec
174.52 - "mul Z = (%n. Z)"
174.53 - "mul (S m) = (%n. add (mul m n) n)"
174.54 -primrec
174.55 - "mul2 Z n = Z"
174.56 - "mul2 (S m) n = add2 n (mul2 m n)"
174.57 -primrec
174.58 - "exp m Z = S Z"
174.59 - "exp m (S n) = mul (exp m n) m"
174.60 +primrec mul :: "n \<Rightarrow> n \<Rightarrow> n" where
174.61 + "mul Z = (%n. Z)"
174.62 + | "mul (S m) = (%n. add (mul m n) n)"
174.63 +
174.64 +primrec mul2 :: "n \<Rightarrow> n \<Rightarrow> n" where
174.65 + "mul2 Z n = Z"
174.66 + | "mul2 (S m) n = add2 n (mul2 m n)"
174.67 +
174.68 +primrec exp :: "n \<Rightarrow> n \<Rightarrow> n" where
174.69 + "exp m Z = S Z"
174.70 + | "exp m (S n) = mul (exp m n) m"
174.71
174.72 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
174.73 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
175.1 --- a/src/HOL/ex/Numeral.thy Mon May 11 09:39:53 2009 +0200
175.2 +++ b/src/HOL/ex/Numeral.thy Mon May 11 17:20:52 2009 +0200
175.3 @@ -14,32 +14,26 @@
175.4
175.5 text {* Increment function for type @{typ num} *}
175.6
175.7 -primrec
175.8 - inc :: "num \<Rightarrow> num"
175.9 -where
175.10 +primrec inc :: "num \<Rightarrow> num" where
175.11 "inc One = Dig0 One"
175.12 | "inc (Dig0 x) = Dig1 x"
175.13 | "inc (Dig1 x) = Dig0 (inc x)"
175.14
175.15 text {* Converting between type @{typ num} and type @{typ nat} *}
175.16
175.17 -primrec
175.18 - nat_of_num :: "num \<Rightarrow> nat"
175.19 -where
175.20 +primrec nat_of_num :: "num \<Rightarrow> nat" where
175.21 "nat_of_num One = Suc 0"
175.22 | "nat_of_num (Dig0 x) = nat_of_num x + nat_of_num x"
175.23 | "nat_of_num (Dig1 x) = Suc (nat_of_num x + nat_of_num x)"
175.24
175.25 -primrec
175.26 - num_of_nat :: "nat \<Rightarrow> num"
175.27 -where
175.28 +primrec num_of_nat :: "nat \<Rightarrow> num" where
175.29 "num_of_nat 0 = One"
175.30 | "num_of_nat (Suc n) = (if 0 < n then inc (num_of_nat n) else One)"
175.31
175.32 lemma nat_of_num_pos: "0 < nat_of_num x"
175.33 by (induct x) simp_all
175.34
175.35 -lemma nat_of_num_neq_0: " nat_of_num x \<noteq> 0"
175.36 +lemma nat_of_num_neq_0: "nat_of_num x \<noteq> 0"
175.37 by (induct x) simp_all
175.38
175.39 lemma nat_of_num_inc: "nat_of_num (inc x) = Suc (nat_of_num x)"
175.40 @@ -247,13 +241,24 @@
175.41 begin
175.42
175.43 primrec of_num :: "num \<Rightarrow> 'a" where
175.44 - of_num_one [numeral]: "of_num One = 1"
175.45 + of_num_One [numeral]: "of_num One = 1"
175.46 | "of_num (Dig0 n) = of_num n + of_num n"
175.47 | "of_num (Dig1 n) = of_num n + of_num n + 1"
175.48
175.49 lemma of_num_inc: "of_num (inc x) = of_num x + 1"
175.50 by (induct x) (simp_all add: add_ac)
175.51
175.52 +lemma of_num_add: "of_num (m + n) = of_num m + of_num n"
175.53 + apply (induct n rule: num_induct)
175.54 + apply (simp_all add: add_One add_inc of_num_inc add_ac)
175.55 + done
175.56 +
175.57 +lemma of_num_mult: "of_num (m * n) = of_num m * of_num n"
175.58 + apply (induct n rule: num_induct)
175.59 + apply (simp add: mult_One)
175.60 + apply (simp add: mult_inc of_num_add of_num_inc right_distrib)
175.61 + done
175.62 +
175.63 declare of_num.simps [simp del]
175.64
175.65 end
175.66 @@ -263,16 +268,19 @@
175.67 *}
175.68
175.69 ML {*
175.70 -fun mk_num 1 = @{term One}
175.71 - | mk_num k =
175.72 - let
175.73 - val (l, b) = Integer.div_mod k 2;
175.74 - val bit = (if b = 0 then @{term Dig0} else @{term Dig1});
175.75 - in bit $ (mk_num l) end;
175.76 +fun mk_num k =
175.77 + if k > 1 then
175.78 + let
175.79 + val (l, b) = Integer.div_mod k 2;
175.80 + val bit = (if b = 0 then @{term Dig0} else @{term Dig1});
175.81 + in bit $ (mk_num l) end
175.82 + else if k = 1 then @{term One}
175.83 + else error ("mk_num " ^ string_of_int k);
175.84
175.85 fun dest_num @{term One} = 1
175.86 | dest_num (@{term Dig0} $ n) = 2 * dest_num n
175.87 - | dest_num (@{term Dig1} $ n) = 2 * dest_num n + 1;
175.88 + | dest_num (@{term Dig1} $ n) = 2 * dest_num n + 1
175.89 + | dest_num t = raise TERM ("dest_num", [t]);
175.90
175.91 (*FIXME these have to gain proper context via morphisms phi*)
175.92
175.93 @@ -348,16 +356,15 @@
175.94
175.95 lemma of_num_plus_one [numeral]:
175.96 "of_num n + 1 = of_num (n + One)"
175.97 - by (rule sym, induct n) (simp_all add: of_num.simps add_ac)
175.98 + by (simp only: of_num_add of_num_One)
175.99
175.100 lemma of_num_one_plus [numeral]:
175.101 - "1 + of_num n = of_num (n + One)"
175.102 - unfolding of_num_plus_one [symmetric] add_commute ..
175.103 + "1 + of_num n = of_num (One + n)"
175.104 + by (simp only: of_num_add of_num_One)
175.105
175.106 lemma of_num_plus [numeral]:
175.107 "of_num m + of_num n = of_num (m + n)"
175.108 - by (induct n rule: num_induct)
175.109 - (simp_all add: add_One add_inc of_num_one of_num_inc add_ac)
175.110 + unfolding of_num_add ..
175.111
175.112 lemma of_num_times_one [numeral]:
175.113 "of_num n * 1 = of_num n"
175.114 @@ -369,9 +376,7 @@
175.115
175.116 lemma of_num_times [numeral]:
175.117 "of_num m * of_num n = of_num (m * n)"
175.118 - by (induct n rule: num_induct)
175.119 - (simp_all add: of_num_plus [symmetric] mult_One mult_inc
175.120 - semiring_class.right_distrib right_distrib of_num_one of_num_inc)
175.121 + unfolding of_num_mult ..
175.122
175.123 end
175.124
175.125 @@ -421,21 +426,15 @@
175.126 context semiring_char_0
175.127 begin
175.128
175.129 -lemma of_num_eq_iff [numeral]:
175.130 - "of_num m = of_num n \<longleftrightarrow> m = n"
175.131 +lemma of_num_eq_iff [numeral]: "of_num m = of_num n \<longleftrightarrow> m = n"
175.132 unfolding of_nat_of_num [symmetric] nat_of_num_of_num [symmetric]
175.133 of_nat_eq_iff num_eq_iff ..
175.134
175.135 -lemma of_num_eq_one_iff [numeral]:
175.136 - "of_num n = 1 \<longleftrightarrow> n = One"
175.137 -proof -
175.138 - have "of_num n = of_num One \<longleftrightarrow> n = One" unfolding of_num_eq_iff ..
175.139 - then show ?thesis by (simp add: of_num_one)
175.140 -qed
175.141 +lemma of_num_eq_one_iff [numeral]: "of_num n = 1 \<longleftrightarrow> n = One"
175.142 + using of_num_eq_iff [of n One] by (simp add: of_num_One)
175.143
175.144 -lemma one_eq_of_num_iff [numeral]:
175.145 - "1 = of_num n \<longleftrightarrow> n = One"
175.146 - unfolding of_num_eq_one_iff [symmetric] by auto
175.147 +lemma one_eq_of_num_iff [numeral]: "1 = of_num n \<longleftrightarrow> One = n"
175.148 + using of_num_eq_iff [of One n] by (simp add: of_num_One)
175.149
175.150 end
175.151
175.152 @@ -458,19 +457,11 @@
175.153 then show ?thesis by (simp add: of_nat_of_num)
175.154 qed
175.155
175.156 -lemma of_num_less_eq_one_iff [numeral]: "of_num n \<le> 1 \<longleftrightarrow> n = One"
175.157 -proof -
175.158 - have "of_num n \<le> of_num One \<longleftrightarrow> n = One"
175.159 - by (cases n) (simp_all add: of_num_less_eq_iff)
175.160 - then show ?thesis by (simp add: of_num_one)
175.161 -qed
175.162 +lemma of_num_less_eq_one_iff [numeral]: "of_num n \<le> 1 \<longleftrightarrow> n \<le> One"
175.163 + using of_num_less_eq_iff [of n One] by (simp add: of_num_One)
175.164
175.165 lemma one_less_eq_of_num_iff [numeral]: "1 \<le> of_num n"
175.166 -proof -
175.167 - have "of_num One \<le> of_num n"
175.168 - by (cases n) (simp_all add: of_num_less_eq_iff)
175.169 - then show ?thesis by (simp add: of_num_one)
175.170 -qed
175.171 + using of_num_less_eq_iff [of One n] by (simp add: of_num_One)
175.172
175.173 lemma of_num_less_iff [numeral]: "of_num m < of_num n \<longleftrightarrow> m < n"
175.174 proof -
175.175 @@ -480,18 +471,10 @@
175.176 qed
175.177
175.178 lemma of_num_less_one_iff [numeral]: "\<not> of_num n < 1"
175.179 -proof -
175.180 - have "\<not> of_num n < of_num One"
175.181 - by (cases n) (simp_all add: of_num_less_iff)
175.182 - then show ?thesis by (simp add: of_num_one)
175.183 -qed
175.184 + using of_num_less_iff [of n One] by (simp add: of_num_One)
175.185
175.186 -lemma one_less_of_num_iff [numeral]: "1 < of_num n \<longleftrightarrow> n \<noteq> One"
175.187 -proof -
175.188 - have "of_num One < of_num n \<longleftrightarrow> n \<noteq> One"
175.189 - by (cases n) (simp_all add: of_num_less_iff)
175.190 - then show ?thesis by (simp add: of_num_one)
175.191 -qed
175.192 +lemma one_less_of_num_iff [numeral]: "1 < of_num n \<longleftrightarrow> One < n"
175.193 + using of_num_less_iff [of One n] by (simp add: of_num_One)
175.194
175.195 lemma of_num_nonneg [numeral]: "0 \<le> of_num n"
175.196 by (induct n) (simp_all add: of_num.simps add_nonneg_nonneg)
175.197 @@ -515,13 +498,13 @@
175.198 qed
175.199
175.200 lemma minus_of_num_less_one_iff: "- of_num n < 1"
175.201 -using minus_of_num_less_of_num_iff [of n One] by (simp add: of_num_one)
175.202 + using minus_of_num_less_of_num_iff [of n One] by (simp add: of_num_One)
175.203
175.204 lemma minus_one_less_of_num_iff: "- 1 < of_num n"
175.205 -using minus_of_num_less_of_num_iff [of One n] by (simp add: of_num_one)
175.206 + using minus_of_num_less_of_num_iff [of One n] by (simp add: of_num_One)
175.207
175.208 lemma minus_one_less_one_iff: "- 1 < 1"
175.209 -using minus_of_num_less_of_num_iff [of One One] by (simp add: of_num_one)
175.210 + using minus_of_num_less_of_num_iff [of One One] by (simp add: of_num_One)
175.211
175.212 lemma minus_of_num_le_of_num_iff: "- of_num m \<le> of_num n"
175.213 by (simp add: less_imp_le minus_of_num_less_of_num_iff)
175.214 @@ -700,7 +683,7 @@
175.215 "- of_num n * of_num m = - (of_num n * of_num m)"
175.216 "of_num n * - of_num m = - (of_num n * of_num m)"
175.217 "- of_num n * - of_num m = of_num n * of_num m"
175.218 - by (simp_all add: minus_mult_left [symmetric] minus_mult_right [symmetric])
175.219 + by simp_all
175.220
175.221 lemma of_int_of_num [numeral]: "of_int (of_num n) = of_num n"
175.222 by (induct n)
175.223 @@ -716,38 +699,29 @@
175.224
175.225 lemma of_num_square: "of_num (square x) = of_num x * of_num x"
175.226 by (induct x)
175.227 - (simp_all add: of_num.simps of_num_plus [symmetric] algebra_simps)
175.228 + (simp_all add: of_num.simps of_num_add algebra_simps)
175.229
175.230 -lemma of_num_pow:
175.231 - "(of_num (pow x y)::'a::{semiring_numeral,recpower}) = of_num x ^ of_num y"
175.232 +lemma of_num_pow: "of_num (pow x y) = of_num x ^ of_num y"
175.233 by (induct y)
175.234 - (simp_all add: of_num.simps of_num_square of_num_times [symmetric]
175.235 - power_Suc power_add)
175.236 + (simp_all add: of_num.simps of_num_square of_num_mult power_add)
175.237
175.238 -lemma power_of_num [numeral]:
175.239 - "of_num x ^ of_num y = (of_num (pow x y)::'a::{semiring_numeral,recpower})"
175.240 - by (rule of_num_pow [symmetric])
175.241 +lemma power_of_num [numeral]: "of_num x ^ of_num y = of_num (pow x y)"
175.242 + unfolding of_num_pow ..
175.243
175.244 lemma power_zero_of_num [numeral]:
175.245 - "0 ^ of_num n = (0::'a::{semiring_0,recpower})"
175.246 + "0 ^ of_num n = (0::'a::semiring_1)"
175.247 using of_num_pos [where n=n and ?'a=nat]
175.248 by (simp add: power_0_left)
175.249
175.250 -lemma power_minus_one_double:
175.251 - "(- 1) ^ (n + n) = (1::'a::{ring_1,recpower})"
175.252 - by (induct n) (simp_all add: power_Suc)
175.253 -
175.254 lemma power_minus_Dig0 [numeral]:
175.255 - fixes x :: "'a::{ring_1,recpower}"
175.256 + fixes x :: "'a::ring_1"
175.257 shows "(- x) ^ of_num (Dig0 n) = x ^ of_num (Dig0 n)"
175.258 - by (subst power_minus)
175.259 - (simp add: of_num.simps power_minus_one_double)
175.260 + by (induct n rule: num_induct) (simp_all add: of_num.simps of_num_inc)
175.261
175.262 lemma power_minus_Dig1 [numeral]:
175.263 - fixes x :: "'a::{ring_1,recpower}"
175.264 + fixes x :: "'a::ring_1"
175.265 shows "(- x) ^ of_num (Dig1 n) = - (x ^ of_num (Dig1 n))"
175.266 - by (subst power_minus)
175.267 - (simp add: of_num.simps power_Suc power_minus_one_double)
175.268 + by (induct n rule: num_induct) (simp_all add: of_num.simps of_num_inc)
175.269
175.270 declare power_one [numeral]
175.271
175.272 @@ -823,7 +797,7 @@
175.273
175.274 lemma one_int_code [code]:
175.275 "1 = Pls One"
175.276 - by (simp add: of_num_one)
175.277 + by (simp add: of_num_One)
175.278
175.279 lemma plus_int_code [code]:
175.280 "k + 0 = (k::int)"
175.281 @@ -832,7 +806,7 @@
175.282 "Pls m - Pls n = sub m n"
175.283 "Mns m + Mns n = Mns (m + n)"
175.284 "Mns m - Mns n = sub n m"
175.285 - by (simp_all add: of_num_plus [symmetric])
175.286 + by (simp_all add: of_num_add)
175.287
175.288 lemma uminus_int_code [code]:
175.289 "uminus 0 = (0::int)"
175.290 @@ -847,7 +821,7 @@
175.291 "Pls m - Mns n = Pls (m + n)"
175.292 "Mns m - Pls n = Mns (m + n)"
175.293 "Mns m - Mns n = sub n m"
175.294 - by (simp_all add: of_num_plus [symmetric])
175.295 + by (simp_all add: of_num_add)
175.296
175.297 lemma times_int_code [code]:
175.298 "k * 0 = (0::int)"
175.299 @@ -856,7 +830,7 @@
175.300 "Pls m * Mns n = Mns (m * n)"
175.301 "Mns m * Pls n = Mns (m * n)"
175.302 "Mns m * Mns n = Pls (m * n)"
175.303 - by (simp_all add: of_num_times [symmetric])
175.304 + by (simp_all add: of_num_mult)
175.305
175.306 lemma eq_int_code [code]:
175.307 "eq_class.eq 0 (0::int) \<longleftrightarrow> True"
175.308 @@ -907,15 +881,109 @@
175.309
175.310 subsection {* Numeral equations as default simplification rules *}
175.311
175.312 -text {* TODO. Be more precise here with respect to subsumed facts. Or use named theorems anyway. *}
175.313 -declare (in semiring_numeral) numeral [simp]
175.314 -declare (in semiring_1) numeral [simp]
175.315 -declare (in semiring_char_0) numeral [simp]
175.316 -declare (in ring_1) numeral [simp]
175.317 +declare (in semiring_numeral) of_num_One [simp]
175.318 +declare (in semiring_numeral) of_num_plus_one [simp]
175.319 +declare (in semiring_numeral) of_num_one_plus [simp]
175.320 +declare (in semiring_numeral) of_num_plus [simp]
175.321 +declare (in semiring_numeral) of_num_times [simp]
175.322 +
175.323 +declare (in semiring_1) of_nat_of_num [simp]
175.324 +
175.325 +declare (in semiring_char_0) of_num_eq_iff [simp]
175.326 +declare (in semiring_char_0) of_num_eq_one_iff [simp]
175.327 +declare (in semiring_char_0) one_eq_of_num_iff [simp]
175.328 +
175.329 +declare (in ordered_semidom) of_num_pos [simp]
175.330 +declare (in ordered_semidom) of_num_less_eq_iff [simp]
175.331 +declare (in ordered_semidom) of_num_less_eq_one_iff [simp]
175.332 +declare (in ordered_semidom) one_less_eq_of_num_iff [simp]
175.333 +declare (in ordered_semidom) of_num_less_iff [simp]
175.334 +declare (in ordered_semidom) of_num_less_one_iff [simp]
175.335 +declare (in ordered_semidom) one_less_of_num_iff [simp]
175.336 +declare (in ordered_semidom) of_num_nonneg [simp]
175.337 +declare (in ordered_semidom) of_num_less_zero_iff [simp]
175.338 +declare (in ordered_semidom) of_num_le_zero_iff [simp]
175.339 +
175.340 +declare (in ordered_idom) le_signed_numeral_special [simp]
175.341 +declare (in ordered_idom) less_signed_numeral_special [simp]
175.342 +
175.343 +declare (in semiring_1_minus) Dig_of_num_minus_one [simp]
175.344 +declare (in semiring_1_minus) Dig_one_minus_of_num [simp]
175.345 +
175.346 +declare (in ring_1) Dig_plus_uminus [simp]
175.347 +declare (in ring_1) of_int_of_num [simp]
175.348 +
175.349 +declare power_of_num [simp]
175.350 +declare power_zero_of_num [simp]
175.351 +declare power_minus_Dig0 [simp]
175.352 +declare power_minus_Dig1 [simp]
175.353 +
175.354 +declare Suc_of_num [simp]
175.355 +
175.356 thm numeral
175.357
175.358
175.359 -text {* Toy examples *}
175.360 +subsection {* Simplification Procedures *}
175.361 +
175.362 +subsubsection {* Reorientation of equalities *}
175.363 +
175.364 +setup {*
175.365 + ReorientProc.add
175.366 + (fn Const(@{const_name of_num}, _) $ _ => true
175.367 + | Const(@{const_name uminus}, _) $
175.368 + (Const(@{const_name of_num}, _) $ _) => true
175.369 + | _ => false)
175.370 +*}
175.371 +
175.372 +simproc_setup reorient_num ("of_num n = x" | "- of_num m = y") = ReorientProc.proc
175.373 +
175.374 +subsubsection {* Constant folding for multiplication in semirings *}
175.375 +
175.376 +context semiring_numeral
175.377 +begin
175.378 +
175.379 +lemma mult_of_num_commute: "x * of_num n = of_num n * x"
175.380 +by (induct n)
175.381 + (simp_all only: of_num.simps left_distrib right_distrib mult_1_left mult_1_right)
175.382 +
175.383 +definition
175.384 + "commutes_with a b \<longleftrightarrow> a * b = b * a"
175.385 +
175.386 +lemma commutes_with_commute: "commutes_with a b \<Longrightarrow> a * b = b * a"
175.387 +unfolding commutes_with_def .
175.388 +
175.389 +lemma commutes_with_left_commute: "commutes_with a b \<Longrightarrow> a * (b * c) = b * (a * c)"
175.390 +unfolding commutes_with_def by (simp only: mult_assoc [symmetric])
175.391 +
175.392 +lemma commutes_with_numeral: "commutes_with x (of_num n)" "commutes_with (of_num n) x"
175.393 +unfolding commutes_with_def by (simp_all add: mult_of_num_commute)
175.394 +
175.395 +lemmas mult_ac_numeral =
175.396 + mult_assoc
175.397 + commutes_with_commute
175.398 + commutes_with_left_commute
175.399 + commutes_with_numeral
175.400 +
175.401 +end
175.402 +
175.403 +ML {*
175.404 +structure Semiring_Times_Assoc_Data : ASSOC_FOLD_DATA =
175.405 +struct
175.406 + val assoc_ss = HOL_ss addsimps @{thms mult_ac_numeral}
175.407 + val eq_reflection = eq_reflection
175.408 + fun is_numeral (Const(@{const_name of_num}, _) $ _) = true
175.409 + | is_numeral _ = false;
175.410 +end;
175.411 +
175.412 +structure Semiring_Times_Assoc = Assoc_Fold (Semiring_Times_Assoc_Data);
175.413 +*}
175.414 +
175.415 +simproc_setup semiring_assoc_fold' ("(a::'a::semiring_numeral) * b") =
175.416 + {* fn phi => fn ss => fn ct =>
175.417 + Semiring_Times_Assoc.proc ss (Thm.term_of ct) *}
175.418 +
175.419 +
175.420 +subsection {* Toy examples *}
175.421
175.422 definition "bar \<longleftrightarrow> #4 * #2 + #7 = (#8 :: nat) \<and> #4 * #2 + #7 \<ge> (#8 :: int) - #3"
175.423 code_thms bar
176.1 --- a/src/HOL/ex/Predicate_Compile.thy Mon May 11 09:39:53 2009 +0200
176.2 +++ b/src/HOL/ex/Predicate_Compile.thy Mon May 11 17:20:52 2009 +0200
176.3 @@ -1,8 +1,10 @@
176.4 theory Predicate_Compile
176.5 -imports Complex_Main Code_Index Lattice_Syntax
176.6 +imports Complex_Main Lattice_Syntax Code_Eval
176.7 uses "predicate_compile.ML"
176.8 begin
176.9
176.10 +text {* Package setup *}
176.11 +
176.12 setup {* Predicate_Compile.setup *}
176.13
176.14 ML {*
176.15 @@ -10,34 +12,81 @@
176.16 OuterKeyword.thy_goal (OuterParse.term_group >> Predicate_Compile.code_pred_cmd)
176.17 *}
176.18
176.19 -primrec "next" :: "('a Predicate.pred \<Rightarrow> ('a \<times> 'a Predicate.pred) option)
176.20 - \<Rightarrow> 'a Predicate.seq \<Rightarrow> ('a \<times> 'a Predicate.pred) option" where
176.21 - "next yield Predicate.Empty = None"
176.22 - | "next yield (Predicate.Insert x P) = Some (x, P)"
176.23 - | "next yield (Predicate.Join P xq) = (case yield P
176.24 - of None \<Rightarrow> next yield xq | Some (x, Q) \<Rightarrow> Some (x, Predicate.Seq (\<lambda>_. Predicate.Join Q xq)))"
176.25 +
176.26 +text {* Experimental code *}
176.27 +
176.28 +definition pred_map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a Predicate.pred \<Rightarrow> 'b Predicate.pred" where
176.29 + "pred_map f P = Predicate.bind P (Predicate.single o f)"
176.30
176.31 ML {*
176.32 -let
176.33 - fun yield (@{code Predicate.Seq} f) = @{code next} yield (f ())
176.34 -in
176.35 - yield @{code "\<bottom> :: 'a Predicate.pred"} (*replace bottom with sequence to evaluate*)
176.36 -end
176.37 +structure Predicate =
176.38 +struct
176.39 +
176.40 +open Predicate;
176.41 +
176.42 +val pred_ref = ref (NONE : (unit -> term Predicate.pred) option);
176.43 +
176.44 +fun eval_pred thy t =
176.45 + t
176.46 + |> Eval.mk_term_of (fastype_of t)
176.47 + |> (fn t => Code_ML.eval NONE ("Predicate.pred_ref", pred_ref) @{code pred_map} thy t []);
176.48 +
176.49 +fun eval_pred_elems thy t T length =
176.50 + t |> eval_pred thy |> yieldn length |> fst |> HOLogic.mk_list T;
176.51 +
176.52 +fun analyze_compr thy t =
176.53 + let
176.54 + val split = case t of (Const (@{const_name Collect}, _) $ t') => t'
176.55 + | _ => error ("Not a set comprehension: " ^ Syntax.string_of_term_global thy t);
176.56 + val (body, Ts, fp) = HOLogic.strip_split split;
176.57 + val (t_pred, args) = strip_comb body;
176.58 + val pred = case t_pred of Const (pred, _) => pred
176.59 + | _ => error ("Not a constant: " ^ Syntax.string_of_term_global thy t_pred);
176.60 + val mode = map is_Bound args; (*FIXME what about higher-order modes?*)
176.61 + val args' = filter_out is_Bound args;
176.62 + val T = HOLogic.mk_tupleT fp Ts;
176.63 + val mk = HOLogic.mk_tuple' fp T;
176.64 + in (((pred, mode), args), (mk, T)) end;
176.65 +
176.66 +end;
176.67 *}
176.68
176.69 -fun anamorph :: "('b \<Rightarrow> ('a \<times> 'b) option) \<Rightarrow> index \<Rightarrow> 'b \<Rightarrow> 'a list \<times> 'b" where
176.70 - "anamorph f k x = (if k = 0 then ([], x)
176.71 - else case f x of None \<Rightarrow> ([], x) | Some (v, y) \<Rightarrow> let (vs, z) = anamorph f (k - 1) y in (v # vs, z))"
176.72
176.73 -ML {*
176.74 -let
176.75 - fun yield (@{code Predicate.Seq} f) = @{code next} yield (f ())
176.76 - fun yieldn k = @{code anamorph} yield k
176.77 -in
176.78 - yieldn 0 (*replace with number of elements to retrieve*)
176.79 - @{code "\<bottom> :: 'a Predicate.pred"} (*replace bottom with sequence to evaluate*)
176.80 -end
176.81 -*}
176.82 +text {* Example(s) *}
176.83 +
176.84 +inductive even :: "nat \<Rightarrow> bool" and odd :: "nat \<Rightarrow> bool" where
176.85 + "even 0"
176.86 + | "even n \<Longrightarrow> odd (Suc n)"
176.87 + | "odd n \<Longrightarrow> even (Suc n)"
176.88 +
176.89 +setup {* pred_compile "even" *}
176.90 +thm even_codegen
176.91 +
176.92 +
176.93 +inductive append :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
176.94 + append_Nil: "append [] xs xs"
176.95 + | append_Cons: "append xs ys zs \<Longrightarrow> append (x # xs) ys (x # zs)"
176.96 +
176.97 +setup {* pred_compile "append" *}
176.98 +thm append_codegen
176.99 +
176.100 +
176.101 +inductive partition :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
176.102 + for f where
176.103 + "partition f [] [] []"
176.104 + | "f x \<Longrightarrow> partition f xs ys zs \<Longrightarrow> partition f (x # xs) (x # ys) zs"
176.105 + | "\<not> f x \<Longrightarrow> partition f xs ys zs \<Longrightarrow> partition f (x # xs) ys (x # zs)"
176.106 +
176.107 +setup {* pred_compile "partition" *}
176.108 +thm partition_codegen
176.109 +
176.110 +setup {* pred_compile "tranclp" *}
176.111 +thm tranclp_codegen
176.112 +
176.113 +ML_val {* Predicate_Compile.modes_of @{theory} @{const_name partition} *}
176.114 +ML_val {* Predicate_Compile.modes_of @{theory} @{const_name tranclp} *}
176.115 +
176.116 +ML_val {* Predicate.analyze_compr @{theory} @{term "{n. odd n}"} *}
176.117
176.118 section {* Example for user interface *}
176.119
177.1 --- a/src/HOL/ex/Quickcheck_Generators.thy Mon May 11 09:39:53 2009 +0200
177.2 +++ b/src/HOL/ex/Quickcheck_Generators.thy Mon May 11 17:20:52 2009 +0200
177.3 @@ -6,62 +6,6 @@
177.4 imports Quickcheck State_Monad
177.5 begin
177.6
177.7 -subsection {* Type @{typ "'a \<Rightarrow> 'b"} *}
177.8 -
177.9 -ML {*
177.10 -structure Random_Engine =
177.11 -struct
177.12 -
177.13 -open Random_Engine;
177.14 -
177.15 -fun random_fun (T1 : typ) (T2 : typ) (eq : 'a -> 'a -> bool) (term_of : 'a -> term)
177.16 - (random : Random_Engine.seed -> ('b * (unit -> term)) * Random_Engine.seed)
177.17 - (random_split : Random_Engine.seed -> Random_Engine.seed * Random_Engine.seed)
177.18 - (seed : Random_Engine.seed) =
177.19 - let
177.20 - val (seed', seed'') = random_split seed;
177.21 - val state = ref (seed', [], Const (@{const_name undefined}, T1 --> T2));
177.22 - val fun_upd = Const (@{const_name fun_upd},
177.23 - (T1 --> T2) --> T1 --> T2 --> T1 --> T2);
177.24 - fun random_fun' x =
177.25 - let
177.26 - val (seed, fun_map, f_t) = ! state;
177.27 - in case AList.lookup (uncurry eq) fun_map x
177.28 - of SOME y => y
177.29 - | NONE => let
177.30 - val t1 = term_of x;
177.31 - val ((y, t2), seed') = random seed;
177.32 - val fun_map' = (x, y) :: fun_map;
177.33 - val f_t' = fun_upd $ f_t $ t1 $ t2 ();
177.34 - val _ = state := (seed', fun_map', f_t');
177.35 - in y end
177.36 - end;
177.37 - fun term_fun' () = #3 (! state);
177.38 - in ((random_fun', term_fun'), seed'') end;
177.39 -
177.40 -end
177.41 -*}
177.42 -
177.43 -axiomatization
177.44 - random_fun_aux :: "typerep \<Rightarrow> typerep \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> term)
177.45 - \<Rightarrow> (seed \<Rightarrow> ('b \<times> (unit \<Rightarrow> term)) \<times> seed) \<Rightarrow> (seed \<Rightarrow> seed \<times> seed)
177.46 - \<Rightarrow> seed \<Rightarrow> (('a \<Rightarrow> 'b) \<times> (unit \<Rightarrow> term)) \<times> seed"
177.47 -
177.48 -code_const random_fun_aux (SML "Random'_Engine.random'_fun")
177.49 -
177.50 -instantiation "fun" :: ("{eq, term_of}", "{type, random}") random
177.51 -begin
177.52 -
177.53 -definition random_fun :: "index \<Rightarrow> seed \<Rightarrow> (('a \<Rightarrow> 'b) \<times> (unit \<Rightarrow> term)) \<times> seed" where
177.54 - "random n = random_fun_aux TYPEREP('a) TYPEREP('b) (op =) Code_Eval.term_of (random n) split_seed"
177.55 -
177.56 -instance ..
177.57 -
177.58 -end
177.59 -
177.60 -code_reserved SML Random_Engine
177.61 -
177.62 -
177.63 subsection {* Datatypes *}
177.64
177.65 definition
178.1 --- a/src/HOL/ex/ReflectionEx.thy Mon May 11 09:39:53 2009 +0200
178.2 +++ b/src/HOL/ex/ReflectionEx.thy Mon May 11 17:20:52 2009 +0200
178.3 @@ -385,7 +385,7 @@
178.4 (* An example for equations containing type variables *)
178.5 datatype prod = Zero | One | Var nat | Mul prod prod
178.6 | Pw prod nat | PNM nat nat prod
178.7 -consts Iprod :: " prod \<Rightarrow> ('a::{ordered_idom,recpower}) list \<Rightarrow>'a"
178.8 +consts Iprod :: " prod \<Rightarrow> ('a::{ordered_idom}) list \<Rightarrow>'a"
178.9 primrec
178.10 "Iprod Zero vs = 0"
178.11 "Iprod One vs = 1"
178.12 @@ -397,7 +397,7 @@
178.13 datatype sgn = Pos prod | Neg prod | ZeroEq prod | NZeroEq prod | Tr | F
178.14 | Or sgn sgn | And sgn sgn
178.15
178.16 -consts Isgn :: " sgn \<Rightarrow> ('a::{ordered_idom, recpower}) list \<Rightarrow>bool"
178.17 +consts Isgn :: " sgn \<Rightarrow> ('a::{ordered_idom}) list \<Rightarrow>bool"
178.18 primrec
178.19 "Isgn Tr vs = True"
178.20 "Isgn F vs = False"
178.21 @@ -410,7 +410,7 @@
178.22
178.23 lemmas eqs = Isgn.simps Iprod.simps
178.24
178.25 -lemma "(x::'a::{ordered_idom, recpower})^4 * y * z * y^2 * z^23 > 0"
178.26 +lemma "(x::'a::{ordered_idom})^4 * y * z * y^2 * z^23 > 0"
178.27 apply (reify eqs)
178.28 oops
178.29
179.1 --- a/src/HOL/ex/predicate_compile.ML Mon May 11 09:39:53 2009 +0200
179.2 +++ b/src/HOL/ex/predicate_compile.ML Mon May 11 17:20:52 2009 +0200
179.3 @@ -6,13 +6,17 @@
179.4
179.5 signature PREDICATE_COMPILE =
179.6 sig
179.7 - val create_def_equation': string -> (int list option list * int list) option -> theory -> theory
179.8 + type mode = int list option list * int list
179.9 + val create_def_equation': string -> mode option -> theory -> theory
179.10 val create_def_equation: string -> theory -> theory
179.11 - val intro_rule: theory -> string -> (int list option list * int list) -> thm
179.12 - val elim_rule: theory -> string -> (int list option list * int list) -> thm
179.13 + val intro_rule: theory -> string -> mode -> thm
179.14 + val elim_rule: theory -> string -> mode -> thm
179.15 val strip_intro_concl : term -> int -> (term * (term list * term list))
179.16 val code_ind_intros_attrib : attribute
179.17 val code_ind_cases_attrib : attribute
179.18 + val print_alternative_rules : theory -> theory
179.19 + val modename_of: theory -> string -> mode -> string
179.20 + val modes_of: theory -> string -> mode list
179.21 val setup : theory -> theory
179.22 val code_pred : string -> Proof.context -> Proof.state
179.23 val code_pred_cmd : string -> Proof.context -> Proof.state
179.24 @@ -25,23 +29,101 @@
179.25 structure Predicate_Compile: PREDICATE_COMPILE =
179.26 struct
179.27
179.28 +(** auxiliary **)
179.29 +
179.30 +(* debug stuff *)
179.31 +
179.32 +fun tracing s = (if ! Toplevel.debug then Output.tracing s else ());
179.33 +
179.34 +fun print_tac s = (if ! Toplevel.debug then Tactical.print_tac s else Seq.single);
179.35 +fun debug_tac msg = (fn st => (tracing msg; Seq.single st));
179.36 +
179.37 +val do_proofs = ref true;
179.38 +
179.39 +
179.40 +(** fundamentals **)
179.41 +
179.42 +(* syntactic operations *)
179.43 +
179.44 +fun mk_eq (x, xs) =
179.45 + let fun mk_eqs _ [] = []
179.46 + | mk_eqs a (b::cs) =
179.47 + HOLogic.mk_eq (Free (a, fastype_of b), b) :: mk_eqs a cs
179.48 + in mk_eqs x xs end;
179.49 +
179.50 +fun mk_tupleT [] = HOLogic.unitT
179.51 + | mk_tupleT Ts = foldr1 HOLogic.mk_prodT Ts;
179.52 +
179.53 +fun mk_tuple [] = HOLogic.unit
179.54 + | mk_tuple ts = foldr1 HOLogic.mk_prod ts;
179.55 +
179.56 +fun dest_tuple (Const (@{const_name Product_Type.Unity}, _)) = []
179.57 + | dest_tuple (Const (@{const_name Pair}, _) $ t1 $ t2) = t1 :: (dest_tuple t2)
179.58 + | dest_tuple t = [t]
179.59 +
179.60 +fun mk_pred_enumT T = Type ("Predicate.pred", [T])
179.61 +
179.62 +fun dest_pred_enumT (Type ("Predicate.pred", [T])) = T
179.63 + | dest_pred_enumT T = raise TYPE ("dest_pred_enumT", [T], []);
179.64 +
179.65 +fun mk_Enum f =
179.66 + let val T as Type ("fun", [T', _]) = fastype_of f
179.67 + in
179.68 + Const (@{const_name Predicate.Pred}, T --> mk_pred_enumT T') $ f
179.69 + end;
179.70 +
179.71 +fun mk_Eval (f, x) =
179.72 + let val T = fastype_of x
179.73 + in
179.74 + Const (@{const_name Predicate.eval}, mk_pred_enumT T --> T --> HOLogic.boolT) $ f $ x
179.75 + end;
179.76 +
179.77 +fun mk_empty T = Const (@{const_name Orderings.bot}, mk_pred_enumT T);
179.78 +
179.79 +fun mk_single t =
179.80 + let val T = fastype_of t
179.81 + in Const(@{const_name Predicate.single}, T --> mk_pred_enumT T) $ t end;
179.82 +
179.83 +fun mk_bind (x, f) =
179.84 + let val T as Type ("fun", [_, U]) = fastype_of f
179.85 + in
179.86 + Const (@{const_name Predicate.bind}, fastype_of x --> T --> U) $ x $ f
179.87 + end;
179.88 +
179.89 +val mk_sup = HOLogic.mk_binop @{const_name sup};
179.90 +
179.91 +fun mk_if_predenum cond = Const (@{const_name Predicate.if_pred},
179.92 + HOLogic.boolT --> mk_pred_enumT HOLogic.unitT) $ cond;
179.93 +
179.94 +fun mk_not_pred t = let val T = mk_pred_enumT HOLogic.unitT
179.95 + in Const (@{const_name Predicate.not_pred}, T --> T) $ t end
179.96 +
179.97 +
179.98 +(* data structures *)
179.99 +
179.100 +type mode = int list option list * int list;
179.101 +
179.102 +val mode_ord = prod_ord (list_ord (option_ord (list_ord int_ord))) (list_ord int_ord);
179.103 +
179.104 structure PredModetab = TableFun(
179.105 - type key = (string * (int list option list * int list))
179.106 - val ord = prod_ord fast_string_ord (prod_ord
179.107 - (list_ord (option_ord (list_ord int_ord))) (list_ord int_ord)))
179.108 + type key = string * mode
179.109 + val ord = prod_ord fast_string_ord mode_ord
179.110 +);
179.111
179.112
179.113 +(*FIXME scrap boilerplate*)
179.114 +
179.115 structure IndCodegenData = TheoryDataFun
179.116 (
179.117 type T = {names : string PredModetab.table,
179.118 - modes : ((int list option list * int list) list) Symtab.table,
179.119 + modes : mode list Symtab.table,
179.120 function_defs : Thm.thm Symtab.table,
179.121 function_intros : Thm.thm Symtab.table,
179.122 function_elims : Thm.thm Symtab.table,
179.123 - intro_rules : (Thm.thm list) Symtab.table,
179.124 + intro_rules : Thm.thm list Symtab.table,
179.125 elim_rules : Thm.thm Symtab.table,
179.126 nparams : int Symtab.table
179.127 - };
179.128 + }; (*FIXME: better group tables according to key*)
179.129 (* names: map from inductive predicate and mode to function name (string).
179.130 modes: map from inductive predicates to modes
179.131 function_defs: map from function name to definition
179.132 @@ -119,26 +201,12 @@
179.133 intro_rules = #intro_rules x, elim_rules = #elim_rules x,
179.134 nparams = f (#nparams x)}) thy
179.135
179.136 -(* Debug stuff and tactics ***********************************************************)
179.137 -
179.138 -fun tracing s = (if ! Toplevel.debug then Output.tracing s else ());
179.139 -fun print_tac s = (if ! Toplevel.debug then Tactical.print_tac s else Seq.single);
179.140 -
179.141 -fun debug_tac msg = (fn st =>
179.142 - (tracing msg; Seq.single st));
179.143 -
179.144 (* removes first subgoal *)
179.145 fun mycheat_tac thy i st =
179.146 (Tactic.rtac (SkipProof.make_thm thy (Var (("A", 0), propT))) i) st
179.147
179.148 -val (do_proofs : bool ref) = ref true;
179.149 -
179.150 (* Lightweight mode analysis **********************************************)
179.151
179.152 -(* Hack for message from old code generator *)
179.153 -val message = tracing;
179.154 -
179.155 -
179.156 (**************************************************************************)
179.157 (* source code from old code generator ************************************)
179.158
179.159 @@ -157,7 +225,8 @@
179.160 | _ => false)
179.161 in check end;
179.162
179.163 -(**** check if a type is an equality type (i.e. doesn't contain fun) ****)
179.164 +(**** check if a type is an equality type (i.e. doesn't contain fun)
179.165 + FIXME this is only an approximation ****)
179.166
179.167 fun is_eqT (Type (s, Ts)) = s <> "fun" andalso forall is_eqT Ts
179.168 | is_eqT _ = true;
179.169 @@ -169,7 +238,7 @@
179.170 | SOME js => enclose "[" "]" (commas (map string_of_int js)))
179.171 (iss @ [SOME is]));
179.172
179.173 -fun print_modes modes = message ("Inferred modes:\n" ^
179.174 +fun print_modes modes = tracing ("Inferred modes:\n" ^
179.175 cat_lines (map (fn (s, ms) => s ^ ": " ^ commas (map
179.176 string_of_mode ms)) modes));
179.177
179.178 @@ -186,6 +255,7 @@
179.179 (get_args' is (i+1) ts)
179.180 in get_args' is 1 ts end
179.181
179.182 +(*FIXME this function should not be named merge... make it local instead*)
179.183 fun merge xs [] = xs
179.184 | merge [] ys = ys
179.185 | merge (x::xs) (y::ys) = if length x >= length y then x::merge xs (y::ys)
179.186 @@ -201,7 +271,8 @@
179.187
179.188 fun cprods xss = foldr (map op :: o cprod) [[]] xss;
179.189
179.190 -datatype mode = Mode of (int list option list * int list) * int list * mode option list;
179.191 +datatype hmode = Mode of mode * int list * hmode option list; (*FIXME don't understand
179.192 + why there is another mode type!?*)
179.193
179.194 fun modes_of modes t =
179.195 let
179.196 @@ -289,11 +360,11 @@
179.197 in (p, List.filter (fn m => case find_index
179.198 (not o check_mode_clause thy param_vs modes m) rs of
179.199 ~1 => true
179.200 - | i => (message ("Clause " ^ string_of_int (i+1) ^ " of " ^
179.201 + | i => (tracing ("Clause " ^ string_of_int (i+1) ^ " of " ^
179.202 p ^ " violates mode " ^ string_of_mode m); false)) ms)
179.203 end;
179.204
179.205 -fun fixp f (x : (string * (int list option list * int list) list) list) =
179.206 +fun fixp f (x : (string * mode list) list) =
179.207 let val y = f x
179.208 in if x = y then x else fixp f y end;
179.209
179.210 @@ -310,66 +381,6 @@
179.211 (*****************************************************************************************)
179.212 (**** term construction ****)
179.213
179.214 -fun mk_eq (x, xs) =
179.215 - let fun mk_eqs _ [] = []
179.216 - | mk_eqs a (b::cs) =
179.217 - HOLogic.mk_eq (Free (a, fastype_of b), b) :: mk_eqs a cs
179.218 - in mk_eqs x xs end;
179.219 -
179.220 -fun mk_tuple [] = HOLogic.unit
179.221 - | mk_tuple ts = foldr1 HOLogic.mk_prod ts;
179.222 -
179.223 -fun dest_tuple (Const (@{const_name Product_Type.Unity}, _)) = []
179.224 - | dest_tuple (Const (@{const_name Pair}, _) $ t1 $ t2) = t1 :: (dest_tuple t2)
179.225 - | dest_tuple t = [t]
179.226 -
179.227 -fun mk_tupleT [] = HOLogic.unitT
179.228 - | mk_tupleT Ts = foldr1 HOLogic.mk_prodT Ts;
179.229 -
179.230 -fun mk_pred_enumT T = Type ("Predicate.pred", [T])
179.231 -
179.232 -fun dest_pred_enumT (Type ("Predicate.pred", [T])) = T
179.233 - | dest_pred_enumT T = raise TYPE ("dest_pred_enumT", [T], []);
179.234 -
179.235 -fun mk_single t =
179.236 - let val T = fastype_of t
179.237 - in Const(@{const_name Predicate.single}, T --> mk_pred_enumT T) $ t end;
179.238 -
179.239 -fun mk_empty T = Const (@{const_name Orderings.bot}, mk_pred_enumT T);
179.240 -
179.241 -fun mk_if_predenum cond = Const (@{const_name Predicate.if_pred},
179.242 - HOLogic.boolT --> mk_pred_enumT HOLogic.unitT)
179.243 - $ cond
179.244 -
179.245 -fun mk_not_pred t = let val T = mk_pred_enumT HOLogic.unitT
179.246 - in Const (@{const_name Predicate.not_pred}, T --> T) $ t end
179.247 -
179.248 -fun mk_bind (x, f) =
179.249 - let val T as Type ("fun", [_, U]) = fastype_of f
179.250 - in
179.251 - Const (@{const_name Predicate.bind}, fastype_of x --> T --> U) $ x $ f
179.252 - end;
179.253 -
179.254 -fun mk_Enum f =
179.255 - let val T as Type ("fun", [T', _]) = fastype_of f
179.256 - in
179.257 - Const (@{const_name Predicate.Pred}, T --> mk_pred_enumT T') $ f
179.258 - end;
179.259 -
179.260 -fun mk_Eval (f, x) =
179.261 - let val T = fastype_of x
179.262 - in
179.263 - Const (@{const_name Predicate.eval}, mk_pred_enumT T --> T --> HOLogic.boolT) $ f $ x
179.264 - end;
179.265 -
179.266 -fun mk_Eval' f =
179.267 - let val T = fastype_of f
179.268 - in
179.269 - Const (@{const_name Predicate.eval}, T --> dest_pred_enumT T --> HOLogic.boolT) $ f
179.270 - end;
179.271 -
179.272 -val mk_sup = HOLogic.mk_binop @{const_name sup};
179.273 -
179.274 (* for simple modes (e.g. parameters) only: better call it param_funT *)
179.275 (* or even better: remove it and only use funT'_of - some modifications to funT'_of necessary *)
179.276 fun funT_of T NONE = T
179.277 @@ -428,13 +439,16 @@
179.278 (v', mk_empty U')]))
179.279 end;
179.280
179.281 -fun modename thy name mode = let
179.282 +fun modename_of thy name mode = let
179.283 val v = (PredModetab.lookup (#names (IndCodegenData.get thy)) (name, mode))
179.284 - in if (is_some v) then the v
179.285 - else error ("fun modename - definition not found: name: " ^ name ^ " mode: " ^ (makestring mode))
179.286 + in if (is_some v) then the v (*FIXME use case here*)
179.287 + else error ("fun modename_of - definition not found: name: " ^ name ^ " mode: " ^ (makestring mode))
179.288 end
179.289
179.290 -(* function can be removed *)
179.291 +fun modes_of thy =
179.292 + these o Symtab.lookup ((#modes o IndCodegenData.get) thy);
179.293 +
179.294 +(*FIXME function can be removed*)
179.295 fun mk_funcomp f t =
179.296 let
179.297 val names = Term.add_free_names t [];
179.298 @@ -453,7 +467,7 @@
179.299 val f' = case f of
179.300 Const (name, T) =>
179.301 if AList.defined op = modes name then
179.302 - Const (modename thy name (iss, is'), funT'_of (iss, is') T)
179.303 + Const (modename_of thy name (iss, is'), funT'_of (iss, is') T)
179.304 else error "compile param: Not an inductive predicate with correct mode"
179.305 | Free (name, T) => Free (name, funT_of T (SOME is'))
179.306 in list_comb (f', params' @ args') end
179.307 @@ -467,7 +481,7 @@
179.308 val (Ts, Us) = get_args is
179.309 (curry Library.drop (length ms) (fst (strip_type T)))
179.310 val params' = map (compile_param thy modes) (ms ~~ params)
179.311 - val mode_id = modename thy name mode
179.312 + val mode_id = modename_of thy name mode
179.313 in list_comb (Const (mode_id, ((map fastype_of params') @ Ts) --->
179.314 mk_pred_enumT (mk_tupleT Us)), params')
179.315 end
179.316 @@ -560,7 +574,7 @@
179.317 val cl_ts =
179.318 map (fn cl => compile_clause thy
179.319 all_vs param_vs modes mode cl (mk_tuple xs)) cls;
179.320 - val mode_id = modename thy s mode
179.321 + val mode_id = modename_of thy s mode
179.322 in
179.323 HOLogic.mk_Trueprop (HOLogic.mk_eq
179.324 (list_comb (Const (mode_id, (Ts1' @ Us1) --->
179.325 @@ -595,7 +609,7 @@
179.326 fold Term.add_consts intrs [] |> map fst
179.327 |> filter_out (member (op =) preds) |> filter (is_ind_pred thy)
179.328
179.329 -fun print_arities arities = message ("Arities:\n" ^
179.330 +fun print_arities arities = tracing ("Arities:\n" ^
179.331 cat_lines (map (fn (s, (ks, k)) => s ^ ": " ^
179.332 space_implode " -> " (map
179.333 (fn NONE => "X" | SOME k' => string_of_int k')
179.334 @@ -695,10 +709,10 @@
179.335 (* Proving equivalence of term *)
179.336
179.337
179.338 -fun intro_rule thy pred mode = modename thy pred mode
179.339 +fun intro_rule thy pred mode = modename_of thy pred mode
179.340 |> Symtab.lookup (#function_intros (IndCodegenData.get thy)) |> the
179.341
179.342 -fun elim_rule thy pred mode = modename thy pred mode
179.343 +fun elim_rule thy pred mode = modename_of thy pred mode
179.344 |> Symtab.lookup (#function_elims (IndCodegenData.get thy)) |> the
179.345
179.346 fun pred_intros thy predname = let
179.347 @@ -715,7 +729,7 @@
179.348 end
179.349
179.350 fun function_definition thy pred mode =
179.351 - modename thy pred mode |> Symtab.lookup (#function_defs (IndCodegenData.get thy)) |> the
179.352 + modename_of thy pred mode |> Symtab.lookup (#function_defs (IndCodegenData.get thy)) |> the
179.353
179.354 fun is_Type (Type _) = true
179.355 | is_Type _ = false
179.356 @@ -977,7 +991,7 @@
179.357 in nth (#elims (snd ind_result)) index end)
179.358
179.359 fun prove_one_direction thy all_vs param_vs modes clauses ((pred, T), mode) = let
179.360 - val elim_rule = the (Symtab.lookup (#function_elims (IndCodegenData.get thy)) (modename thy pred mode))
179.361 + val elim_rule = the (Symtab.lookup (#function_elims (IndCodegenData.get thy)) (modename_of thy pred mode))
179.362 (* val ind_result = InductivePackage.the_inductive (ProofContext.init thy) pred
179.363 val index = find_index (fn s => s = pred) (#names (fst ind_result))
179.364 val (_, T) = dest_Const (nth (#preds (snd ind_result)) index) *)
179.365 @@ -1229,7 +1243,7 @@
179.366 (* main function *********************************************************************)
179.367 (*************************************************************************************)
179.368
179.369 -fun create_def_equation' ind_name (mode : (int list option list * int list) option) thy =
179.370 +fun create_def_equation' ind_name (mode : mode option) thy =
179.371 let
179.372 val _ = tracing ("starting create_def_equation' with " ^ ind_name)
179.373 val (prednames, preds) =
179.374 @@ -1253,6 +1267,7 @@
179.375 val _ = tracing ("calling preds: " ^ makestring name_of_calls)
179.376 val _ = tracing "starting recursive compilations"
179.377 fun rec_call name thy =
179.378 + (*FIXME use member instead of infix mem*)
179.379 if not (name mem (Symtab.keys (#modes (IndCodegenData.get thy)))) then
179.380 create_def_equation name thy else thy
179.381 val thy'' = fold rec_call name_of_calls thy'
180.1 --- a/src/HOLCF/Adm.thy Mon May 11 09:39:53 2009 +0200
180.2 +++ b/src/HOLCF/Adm.thy Mon May 11 17:20:52 2009 +0200
180.3 @@ -78,7 +78,7 @@
180.4 "\<lbrakk>chain (Y::nat \<Rightarrow> 'a::cpo); \<forall>i. \<exists>j\<ge>i. P (Y j)\<rbrakk> \<Longrightarrow>
180.5 (\<Squnion>i. Y i) = (\<Squnion>i. Y (LEAST j. i \<le> j \<and> P (Y j)))"
180.6 apply (frule (1) adm_disj_lemma1)
180.7 - apply (rule antisym_less)
180.8 + apply (rule below_antisym)
180.9 apply (rule lub_mono, assumption+)
180.10 apply (erule chain_mono)
180.11 apply (simp add: adm_disj_lemma2)
180.12 @@ -122,7 +122,7 @@
180.13
180.14 text {* admissibility and continuity *}
180.15
180.16 -lemma adm_less: "\<lbrakk>cont u; cont v\<rbrakk> \<Longrightarrow> adm (\<lambda>x. u x \<sqsubseteq> v x)"
180.17 +lemma adm_below: "\<lbrakk>cont u; cont v\<rbrakk> \<Longrightarrow> adm (\<lambda>x. u x \<sqsubseteq> v x)"
180.18 apply (rule admI)
180.19 apply (simp add: cont2contlubE)
180.20 apply (rule lub_mono)
180.21 @@ -132,7 +132,7 @@
180.22 done
180.23
180.24 lemma adm_eq: "\<lbrakk>cont u; cont v\<rbrakk> \<Longrightarrow> adm (\<lambda>x. u x = v x)"
180.25 -by (simp add: po_eq_conv adm_conj adm_less)
180.26 +by (simp add: po_eq_conv adm_conj adm_below)
180.27
180.28 lemma adm_subst: "\<lbrakk>cont t; adm P\<rbrakk> \<Longrightarrow> adm (\<lambda>x. P (t x))"
180.29 apply (rule admI)
180.30 @@ -142,11 +142,11 @@
180.31 apply (erule spec)
180.32 done
180.33
180.34 -lemma adm_not_less: "cont t \<Longrightarrow> adm (\<lambda>x. \<not> t x \<sqsubseteq> u)"
180.35 +lemma adm_not_below: "cont t \<Longrightarrow> adm (\<lambda>x. \<not> t x \<sqsubseteq> u)"
180.36 apply (rule admI)
180.37 apply (drule_tac x=0 in spec)
180.38 apply (erule contrapos_nn)
180.39 -apply (erule rev_trans_less)
180.40 +apply (erule rev_below_trans)
180.41 apply (erule cont2mono [THEN monofunE])
180.42 apply (erule is_ub_thelub)
180.43 done
180.44 @@ -179,21 +179,21 @@
180.45 apply (drule (1) compactD2, simp)
180.46 apply (erule exE, rule_tac x=i in exI)
180.47 apply (rule max_in_chainI)
180.48 -apply (rule antisym_less)
180.49 +apply (rule below_antisym)
180.50 apply (erule (1) chain_mono)
180.51 -apply (erule (1) trans_less [OF is_ub_thelub])
180.52 +apply (erule (1) below_trans [OF is_ub_thelub])
180.53 done
180.54
180.55 text {* admissibility and compactness *}
180.56
180.57 -lemma adm_compact_not_less: "\<lbrakk>compact k; cont t\<rbrakk> \<Longrightarrow> adm (\<lambda>x. \<not> k \<sqsubseteq> t x)"
180.58 +lemma adm_compact_not_below: "\<lbrakk>compact k; cont t\<rbrakk> \<Longrightarrow> adm (\<lambda>x. \<not> k \<sqsubseteq> t x)"
180.59 unfolding compact_def by (rule adm_subst)
180.60
180.61 lemma adm_neq_compact: "\<lbrakk>compact k; cont t\<rbrakk> \<Longrightarrow> adm (\<lambda>x. t x \<noteq> k)"
180.62 -by (simp add: po_eq_conv adm_imp adm_not_less adm_compact_not_less)
180.63 +by (simp add: po_eq_conv adm_imp adm_not_below adm_compact_not_below)
180.64
180.65 lemma adm_compact_neq: "\<lbrakk>compact k; cont t\<rbrakk> \<Longrightarrow> adm (\<lambda>x. k \<noteq> t x)"
180.66 -by (simp add: po_eq_conv adm_imp adm_not_less adm_compact_not_less)
180.67 +by (simp add: po_eq_conv adm_imp adm_not_below adm_compact_not_below)
180.68
180.69 lemma compact_UU [simp, intro]: "compact \<bottom>"
180.70 by (rule compactI, simp add: adm_not_free)
180.71 @@ -210,7 +210,7 @@
180.72
180.73 lemmas adm_lemmas [simp] =
180.74 adm_not_free adm_conj adm_all adm_ball adm_disj adm_imp adm_iff
180.75 - adm_less adm_eq adm_not_less
180.76 - adm_compact_not_less adm_compact_neq adm_neq_compact adm_not_UU
180.77 + adm_below adm_eq adm_not_below
180.78 + adm_compact_not_below adm_compact_neq adm_neq_compact adm_not_UU
180.79
180.80 end
181.1 --- a/src/HOLCF/Algebraic.thy Mon May 11 09:39:53 2009 +0200
181.2 +++ b/src/HOLCF/Algebraic.thy Mon May 11 17:20:52 2009 +0200
181.3 @@ -33,21 +33,21 @@
181.4
181.5 locale pre_deflation =
181.6 fixes f :: "'a \<rightarrow> 'a::cpo"
181.7 - assumes less: "\<And>x. f\<cdot>x \<sqsubseteq> x"
181.8 + assumes below: "\<And>x. f\<cdot>x \<sqsubseteq> x"
181.9 assumes finite_range: "finite (range (\<lambda>x. f\<cdot>x))"
181.10 begin
181.11
181.12 -lemma iterate_less: "iterate i\<cdot>f\<cdot>x \<sqsubseteq> x"
181.13 -by (induct i, simp_all add: trans_less [OF less])
181.14 +lemma iterate_below: "iterate i\<cdot>f\<cdot>x \<sqsubseteq> x"
181.15 +by (induct i, simp_all add: below_trans [OF below])
181.16
181.17 lemma iterate_fixed: "f\<cdot>x = x \<Longrightarrow> iterate i\<cdot>f\<cdot>x = x"
181.18 by (induct i, simp_all)
181.19
181.20 lemma antichain_iterate_app: "i \<le> j \<Longrightarrow> iterate j\<cdot>f\<cdot>x \<sqsubseteq> iterate i\<cdot>f\<cdot>x"
181.21 apply (erule le_Suc_induct)
181.22 -apply (simp add: less)
181.23 -apply (rule refl_less)
181.24 -apply (erule (1) trans_less)
181.25 +apply (simp add: below)
181.26 +apply (rule below_refl)
181.27 +apply (erule (1) below_trans)
181.28 done
181.29
181.30 lemma finite_range_iterate_app: "finite (range (\<lambda>i. iterate i\<cdot>f\<cdot>x))"
181.31 @@ -144,7 +144,7 @@
181.32 next
181.33 fix x :: 'a
181.34 show "d\<cdot>x \<sqsubseteq> x"
181.35 - by (rule MOST_d, simp add: iterate_less)
181.36 + by (rule MOST_d, simp add: iterate_below)
181.37 next
181.38 from finite_range
181.39 have "finite {x. f\<cdot>x = x}"
181.40 @@ -163,7 +163,7 @@
181.41 interpret d: finite_deflation d by fact
181.42 fix x
181.43 show "\<And>x. (d oo f)\<cdot>x \<sqsubseteq> x"
181.44 - by (simp, rule trans_less [OF d.less f])
181.45 + by (simp, rule below_trans [OF d.below f])
181.46 show "finite (range (\<lambda>x. (d oo f)\<cdot>x))"
181.47 by (rule finite_subset [OF _ d.finite_range], auto)
181.48 qed
181.49 @@ -185,9 +185,9 @@
181.50 apply safe
181.51 apply (erule subst)
181.52 apply (rule d.idem)
181.53 - apply (rule antisym_less)
181.54 + apply (rule below_antisym)
181.55 apply (rule f)
181.56 - apply (erule subst, rule d.less)
181.57 + apply (erule subst, rule d.below)
181.58 apply simp
181.59 done
181.60 qed
181.61 @@ -199,18 +199,17 @@
181.62 typedef (open) 'a fin_defl = "{d::'a \<rightarrow> 'a. finite_deflation d}"
181.63 by (fast intro: finite_deflation_approx)
181.64
181.65 -instantiation fin_defl :: (profinite) sq_ord
181.66 +instantiation fin_defl :: (profinite) below
181.67 begin
181.68
181.69 -definition
181.70 - sq_le_fin_defl_def:
181.71 +definition below_fin_defl_def:
181.72 "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep_fin_defl x \<sqsubseteq> Rep_fin_defl y"
181.73
181.74 instance ..
181.75 end
181.76
181.77 instance fin_defl :: (profinite) po
181.78 -by (rule typedef_po [OF type_definition_fin_defl sq_le_fin_defl_def])
181.79 +by (rule typedef_po [OF type_definition_fin_defl below_fin_defl_def])
181.80
181.81 lemma finite_deflation_Rep_fin_defl: "finite_deflation (Rep_fin_defl d)"
181.82 using Rep_fin_defl by simp
181.83 @@ -218,27 +217,27 @@
181.84 interpretation Rep_fin_defl: finite_deflation "Rep_fin_defl d"
181.85 by (rule finite_deflation_Rep_fin_defl)
181.86
181.87 -lemma fin_defl_lessI:
181.88 +lemma fin_defl_belowI:
181.89 "(\<And>x. Rep_fin_defl a\<cdot>x = x \<Longrightarrow> Rep_fin_defl b\<cdot>x = x) \<Longrightarrow> a \<sqsubseteq> b"
181.90 -unfolding sq_le_fin_defl_def
181.91 -by (rule Rep_fin_defl.lessI)
181.92 +unfolding below_fin_defl_def
181.93 +by (rule Rep_fin_defl.belowI)
181.94
181.95 -lemma fin_defl_lessD:
181.96 +lemma fin_defl_belowD:
181.97 "\<lbrakk>a \<sqsubseteq> b; Rep_fin_defl a\<cdot>x = x\<rbrakk> \<Longrightarrow> Rep_fin_defl b\<cdot>x = x"
181.98 -unfolding sq_le_fin_defl_def
181.99 -by (rule Rep_fin_defl.lessD)
181.100 +unfolding below_fin_defl_def
181.101 +by (rule Rep_fin_defl.belowD)
181.102
181.103 lemma fin_defl_eqI:
181.104 "(\<And>x. Rep_fin_defl a\<cdot>x = x \<longleftrightarrow> Rep_fin_defl b\<cdot>x = x) \<Longrightarrow> a = b"
181.105 -apply (rule antisym_less)
181.106 -apply (rule fin_defl_lessI, simp)
181.107 -apply (rule fin_defl_lessI, simp)
181.108 +apply (rule below_antisym)
181.109 +apply (rule fin_defl_belowI, simp)
181.110 +apply (rule fin_defl_belowI, simp)
181.111 done
181.112
181.113 lemma Abs_fin_defl_mono:
181.114 "\<lbrakk>finite_deflation a; finite_deflation b; a \<sqsubseteq> b\<rbrakk>
181.115 \<Longrightarrow> Abs_fin_defl a \<sqsubseteq> Abs_fin_defl b"
181.116 -unfolding sq_le_fin_defl_def
181.117 +unfolding below_fin_defl_def
181.118 by (simp add: Abs_fin_defl_inverse)
181.119
181.120
181.121 @@ -257,7 +256,7 @@
181.122 apply (rule pre_deflation.finite_deflation_d)
181.123 apply (rule pre_deflation_d_f)
181.124 apply (rule finite_deflation_approx)
181.125 -apply (rule Rep_fin_defl.less)
181.126 +apply (rule Rep_fin_defl.below)
181.127 done
181.128
181.129 lemma fd_take_fixed_iff:
181.130 @@ -265,10 +264,10 @@
181.131 approx i\<cdot>x = x \<and> Rep_fin_defl d\<cdot>x = x"
181.132 unfolding Rep_fin_defl_fd_take
181.133 by (rule eventual_iterate_oo_fixed_iff
181.134 - [OF finite_deflation_approx Rep_fin_defl.less])
181.135 + [OF finite_deflation_approx Rep_fin_defl.below])
181.136
181.137 -lemma fd_take_less: "fd_take n d \<sqsubseteq> d"
181.138 -apply (rule fin_defl_lessI)
181.139 +lemma fd_take_below: "fd_take n d \<sqsubseteq> d"
181.140 +apply (rule fin_defl_belowI)
181.141 apply (simp add: fd_take_fixed_iff)
181.142 done
181.143
181.144 @@ -278,16 +277,16 @@
181.145 done
181.146
181.147 lemma fd_take_mono: "a \<sqsubseteq> b \<Longrightarrow> fd_take n a \<sqsubseteq> fd_take n b"
181.148 -apply (rule fin_defl_lessI)
181.149 +apply (rule fin_defl_belowI)
181.150 apply (simp add: fd_take_fixed_iff)
181.151 -apply (simp add: fin_defl_lessD)
181.152 +apply (simp add: fin_defl_belowD)
181.153 done
181.154
181.155 lemma approx_fixed_le_lemma: "\<lbrakk>i \<le> j; approx i\<cdot>x = x\<rbrakk> \<Longrightarrow> approx j\<cdot>x = x"
181.156 by (erule subst, simp add: min_def)
181.157
181.158 lemma fd_take_chain: "m \<le> n \<Longrightarrow> fd_take m a \<sqsubseteq> fd_take n a"
181.159 -apply (rule fin_defl_lessI)
181.160 +apply (rule fin_defl_belowI)
181.161 apply (simp add: fd_take_fixed_iff)
181.162 apply (simp add: approx_fixed_le_lemma)
181.163 done
181.164 @@ -304,9 +303,9 @@
181.165 lemma fd_take_covers: "\<exists>n. fd_take n a = a"
181.166 apply (rule_tac x=
181.167 "Max ((\<lambda>x. LEAST n. approx n\<cdot>x = x) ` {x. Rep_fin_defl a\<cdot>x = x})" in exI)
181.168 -apply (rule antisym_less)
181.169 -apply (rule fd_take_less)
181.170 -apply (rule fin_defl_lessI)
181.171 +apply (rule below_antisym)
181.172 +apply (rule fd_take_below)
181.173 +apply (rule fin_defl_belowI)
181.174 apply (simp add: fd_take_fixed_iff)
181.175 apply (rule approx_fixed_le_lemma)
181.176 apply (rule Max_ge)
181.177 @@ -320,9 +319,9 @@
181.178 apply (rule Rep_fin_defl.compact)
181.179 done
181.180
181.181 -interpretation fin_defl: basis_take sq_le fd_take
181.182 +interpretation fin_defl: basis_take below fd_take
181.183 apply default
181.184 -apply (rule fd_take_less)
181.185 +apply (rule fd_take_below)
181.186 apply (rule fd_take_idem)
181.187 apply (erule fd_take_mono)
181.188 apply (rule fd_take_chain, simp)
181.189 @@ -333,10 +332,10 @@
181.190 subsection {* Defining algebraic deflations by ideal completion *}
181.191
181.192 typedef (open) 'a alg_defl =
181.193 - "{S::'a fin_defl set. sq_le.ideal S}"
181.194 -by (fast intro: sq_le.ideal_principal)
181.195 + "{S::'a fin_defl set. below.ideal S}"
181.196 +by (fast intro: below.ideal_principal)
181.197
181.198 -instantiation alg_defl :: (profinite) sq_ord
181.199 +instantiation alg_defl :: (profinite) below
181.200 begin
181.201
181.202 definition
181.203 @@ -346,19 +345,19 @@
181.204 end
181.205
181.206 instance alg_defl :: (profinite) po
181.207 -by (rule sq_le.typedef_ideal_po
181.208 - [OF type_definition_alg_defl sq_le_alg_defl_def])
181.209 +by (rule below.typedef_ideal_po
181.210 + [OF type_definition_alg_defl below_alg_defl_def])
181.211
181.212 instance alg_defl :: (profinite) cpo
181.213 -by (rule sq_le.typedef_ideal_cpo
181.214 - [OF type_definition_alg_defl sq_le_alg_defl_def])
181.215 +by (rule below.typedef_ideal_cpo
181.216 + [OF type_definition_alg_defl below_alg_defl_def])
181.217
181.218 lemma Rep_alg_defl_lub:
181.219 "chain Y \<Longrightarrow> Rep_alg_defl (\<Squnion>i. Y i) = (\<Union>i. Rep_alg_defl (Y i))"
181.220 -by (rule sq_le.typedef_ideal_rep_contlub
181.221 - [OF type_definition_alg_defl sq_le_alg_defl_def])
181.222 +by (rule below.typedef_ideal_rep_contlub
181.223 + [OF type_definition_alg_defl below_alg_defl_def])
181.224
181.225 -lemma ideal_Rep_alg_defl: "sq_le.ideal (Rep_alg_defl xs)"
181.226 +lemma ideal_Rep_alg_defl: "below.ideal (Rep_alg_defl xs)"
181.227 by (rule Rep_alg_defl [unfolded mem_Collect_eq])
181.228
181.229 definition
181.230 @@ -368,15 +367,15 @@
181.231 lemma Rep_alg_defl_principal:
181.232 "Rep_alg_defl (alg_defl_principal t) = {u. u \<sqsubseteq> t}"
181.233 unfolding alg_defl_principal_def
181.234 -by (simp add: Abs_alg_defl_inverse sq_le.ideal_principal)
181.235 +by (simp add: Abs_alg_defl_inverse below.ideal_principal)
181.236
181.237 interpretation alg_defl:
181.238 - ideal_completion sq_le fd_take alg_defl_principal Rep_alg_defl
181.239 + ideal_completion below fd_take alg_defl_principal Rep_alg_defl
181.240 apply default
181.241 apply (rule ideal_Rep_alg_defl)
181.242 apply (erule Rep_alg_defl_lub)
181.243 apply (rule Rep_alg_defl_principal)
181.244 -apply (simp only: sq_le_alg_defl_def)
181.245 +apply (simp only: below_alg_defl_def)
181.246 done
181.247
181.248 text {* Algebraic deflations are pointed *}
181.249 @@ -443,7 +442,7 @@
181.250 "cast\<cdot>(alg_defl_principal a) = Rep_fin_defl a"
181.251 unfolding cast_def
181.252 apply (rule alg_defl.basis_fun_principal)
181.253 -apply (simp only: sq_le_fin_defl_def)
181.254 +apply (simp only: below_fin_defl_def)
181.255 done
181.256
181.257 lemma deflation_cast: "deflation (cast\<cdot>d)"
181.258 @@ -522,10 +521,10 @@
181.259 apply (rule finite_deflation_p_d_e)
181.260 apply (rule finite_deflation_cast)
181.261 apply (rule compact_approx)
181.262 - apply (rule sq_ord_less_eq_trans [OF _ d])
181.263 + apply (rule below_eq_trans [OF _ d])
181.264 apply (rule monofun_cfun_fun)
181.265 apply (rule monofun_cfun_arg)
181.266 - apply (rule approx_less)
181.267 + apply (rule approx_below)
181.268 done
181.269 show "(\<Squnion>i. ?a i) = ID"
181.270 apply (rule ext_cfun, simp)
182.1 --- a/src/HOLCF/Bifinite.thy Mon May 11 09:39:53 2009 +0200
182.2 +++ b/src/HOLCF/Bifinite.thy Mon May 11 17:20:52 2009 +0200
182.3 @@ -19,7 +19,7 @@
182.4
182.5 class bifinite = profinite + pcpo
182.6
182.7 -lemma approx_less: "approx i\<cdot>x \<sqsubseteq> x"
182.8 +lemma approx_below: "approx i\<cdot>x \<sqsubseteq> x"
182.9 proof -
182.10 have "chain (\<lambda>i. approx i\<cdot>x)" by simp
182.11 hence "approx i\<cdot>x \<sqsubseteq> (\<Squnion>i. approx i\<cdot>x)" by (rule is_ub_thelub)
182.12 @@ -32,7 +32,7 @@
182.13 show "approx i\<cdot>(approx i\<cdot>x) = approx i\<cdot>x"
182.14 by (rule approx_idem)
182.15 show "approx i\<cdot>x \<sqsubseteq> x"
182.16 - by (rule approx_less)
182.17 + by (rule approx_below)
182.18 show "finite {x. approx i\<cdot>x = x}"
182.19 by (rule finite_fixes_approx)
182.20 qed
182.21 @@ -49,17 +49,17 @@
182.22 by (rule ext_cfun, simp add: contlub_cfun_fun)
182.23
182.24 lemma approx_strict [simp]: "approx i\<cdot>\<bottom> = \<bottom>"
182.25 -by (rule UU_I, rule approx_less)
182.26 +by (rule UU_I, rule approx_below)
182.27
182.28 lemma approx_approx1:
182.29 "i \<le> j \<Longrightarrow> approx i\<cdot>(approx j\<cdot>x) = approx i\<cdot>x"
182.30 -apply (rule deflation_less_comp1 [OF deflation_approx deflation_approx])
182.31 +apply (rule deflation_below_comp1 [OF deflation_approx deflation_approx])
182.32 apply (erule chain_mono [OF chain_approx])
182.33 done
182.34
182.35 lemma approx_approx2:
182.36 "j \<le> i \<Longrightarrow> approx i\<cdot>(approx j\<cdot>x) = approx j\<cdot>x"
182.37 -apply (rule deflation_less_comp2 [OF deflation_approx deflation_approx])
182.38 +apply (rule deflation_below_comp2 [OF deflation_approx deflation_approx])
182.39 apply (erule chain_mono [OF chain_approx])
182.40 done
182.41
182.42 @@ -99,7 +99,7 @@
182.43 thus "P x" by simp
182.44 qed
182.45
182.46 -lemma profinite_less_ext: "(\<And>i. approx i\<cdot>x \<sqsubseteq> approx i\<cdot>y) \<Longrightarrow> x \<sqsubseteq> y"
182.47 +lemma profinite_below_ext: "(\<And>i. approx i\<cdot>x \<sqsubseteq> approx i\<cdot>y) \<Longrightarrow> x \<sqsubseteq> y"
182.48 apply (subgoal_tac "(\<Squnion>i. approx i\<cdot>x) \<sqsubseteq> (\<Squnion>i. approx i\<cdot>y)", simp)
182.49 apply (rule lub_mono, simp, simp, simp)
182.50 done
183.1 --- a/src/HOLCF/Cfun.thy Mon May 11 09:39:53 2009 +0200
183.2 +++ b/src/HOLCF/Cfun.thy Mon May 11 17:20:52 2009 +0200
183.3 @@ -105,19 +105,19 @@
183.4 by (rule typedef_finite_po [OF type_definition_CFun])
183.5
183.6 instance "->" :: (finite_po, chfin) chfin
183.7 -by (rule typedef_chfin [OF type_definition_CFun less_CFun_def])
183.8 +by (rule typedef_chfin [OF type_definition_CFun below_CFun_def])
183.9
183.10 instance "->" :: (cpo, discrete_cpo) discrete_cpo
183.11 -by intro_classes (simp add: less_CFun_def Rep_CFun_inject)
183.12 +by intro_classes (simp add: below_CFun_def Rep_CFun_inject)
183.13
183.14 instance "->" :: (cpo, pcpo) pcpo
183.15 -by (rule typedef_pcpo [OF type_definition_CFun less_CFun_def UU_CFun])
183.16 +by (rule typedef_pcpo [OF type_definition_CFun below_CFun_def UU_CFun])
183.17
183.18 lemmas Rep_CFun_strict =
183.19 - typedef_Rep_strict [OF type_definition_CFun less_CFun_def UU_CFun]
183.20 + typedef_Rep_strict [OF type_definition_CFun below_CFun_def UU_CFun]
183.21
183.22 lemmas Abs_CFun_strict =
183.23 - typedef_Abs_strict [OF type_definition_CFun less_CFun_def UU_CFun]
183.24 + typedef_Abs_strict [OF type_definition_CFun below_CFun_def UU_CFun]
183.25
183.26 text {* function application is strict in its first argument *}
183.27
183.28 @@ -153,11 +153,11 @@
183.29
183.30 text {* Extensionality wrt. ordering for continuous functions *}
183.31
183.32 -lemma expand_cfun_less: "f \<sqsubseteq> g = (\<forall>x. f\<cdot>x \<sqsubseteq> g\<cdot>x)"
183.33 -by (simp add: less_CFun_def expand_fun_less)
183.34 +lemma expand_cfun_below: "f \<sqsubseteq> g = (\<forall>x. f\<cdot>x \<sqsubseteq> g\<cdot>x)"
183.35 +by (simp add: below_CFun_def expand_fun_below)
183.36
183.37 -lemma less_cfun_ext: "(\<And>x. f\<cdot>x \<sqsubseteq> g\<cdot>x) \<Longrightarrow> f \<sqsubseteq> g"
183.38 -by (simp add: expand_cfun_less)
183.39 +lemma below_cfun_ext: "(\<And>x. f\<cdot>x \<sqsubseteq> g\<cdot>x) \<Longrightarrow> f \<sqsubseteq> g"
183.40 +by (simp add: expand_cfun_below)
183.41
183.42 text {* Congruence for continuous function application *}
183.43
183.44 @@ -205,13 +205,13 @@
183.45 text {* monotonicity of application *}
183.46
183.47 lemma monofun_cfun_fun: "f \<sqsubseteq> g \<Longrightarrow> f\<cdot>x \<sqsubseteq> g\<cdot>x"
183.48 -by (simp add: expand_cfun_less)
183.49 +by (simp add: expand_cfun_below)
183.50
183.51 lemma monofun_cfun_arg: "x \<sqsubseteq> y \<Longrightarrow> f\<cdot>x \<sqsubseteq> f\<cdot>y"
183.52 by (rule monofun_Rep_CFun2 [THEN monofunE])
183.53
183.54 lemma monofun_cfun: "\<lbrakk>f \<sqsubseteq> g; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> f\<cdot>x \<sqsubseteq> g\<cdot>y"
183.55 -by (rule trans_less [OF monofun_cfun_fun monofun_cfun_arg])
183.56 +by (rule below_trans [OF monofun_cfun_fun monofun_cfun_arg])
183.57
183.58 text {* ch2ch - rules for the type @{typ "'a -> 'b"} *}
183.59
183.60 @@ -230,7 +230,7 @@
183.61
183.62 lemma ch2ch_LAM [simp]:
183.63 "\<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)"
183.64 -by (simp add: chain_def expand_cfun_less)
183.65 +by (simp add: chain_def expand_cfun_below)
183.66
183.67 text {* contlub, cont properties of @{term Rep_CFun} in both arguments *}
183.68
183.69 @@ -316,7 +316,7 @@
183.70 lemma cont2mono_LAM:
183.71 "\<lbrakk>\<And>x. cont (\<lambda>y. f x y); \<And>y. monofun (\<lambda>x. f x y)\<rbrakk>
183.72 \<Longrightarrow> monofun (\<lambda>x. \<Lambda> y. f x y)"
183.73 - unfolding monofun_def expand_cfun_less by simp
183.74 + unfolding monofun_def expand_cfun_below by simp
183.75
183.76 text {* cont2cont Lemma for @{term "%x. LAM y. f x y"} *}
183.77
183.78 @@ -345,21 +345,11 @@
183.79 assumes f: "cont (\<lambda>p. f (fst p) (snd p))"
183.80 shows "cont (\<lambda>x. \<Lambda> y. f x y)"
183.81 proof (rule cont2cont_LAM)
183.82 - fix x :: 'a
183.83 - have "cont (\<lambda>y. (x, y))"
183.84 - by (rule cont_pair2)
183.85 - with f have "cont (\<lambda>y. f (fst (x, y)) (snd (x, y)))"
183.86 - by (rule cont2cont_app3)
183.87 - thus "cont (\<lambda>y. f x y)"
183.88 - by (simp only: fst_conv snd_conv)
183.89 + fix x :: 'a show "cont (\<lambda>y. f x y)"
183.90 + using f by (rule cont_fst_snd_D2)
183.91 next
183.92 - fix y :: 'b
183.93 - have "cont (\<lambda>x. (x, y))"
183.94 - by (rule cont_pair1)
183.95 - with f have "cont (\<lambda>x. f (fst (x, y)) (snd (x, y)))"
183.96 - by (rule cont2cont_app3)
183.97 - thus "cont (\<lambda>x. f x y)"
183.98 - by (simp only: fst_conv snd_conv)
183.99 + fix y :: 'b show "cont (\<lambda>x. f x y)"
183.100 + using f by (rule cont_fst_snd_D1)
183.101 qed
183.102
183.103 lemma cont2cont_LAM_discrete [cont2cont]:
183.104 @@ -375,7 +365,7 @@
183.105
183.106 lemma semi_monofun_Abs_CFun:
183.107 "\<lbrakk>cont f; cont g; f \<sqsubseteq> g\<rbrakk> \<Longrightarrow> Abs_CFun f \<sqsubseteq> Abs_CFun g"
183.108 -by (simp add: less_CFun_def Abs_CFun_inverse2)
183.109 +by (simp add: below_CFun_def Abs_CFun_inverse2)
183.110
183.111 text {* some lemmata for functions with flat/chfin domain/range types *}
183.112
183.113 @@ -411,7 +401,7 @@
183.114 apply simp
183.115 done
183.116
183.117 -lemma injection_less:
183.118 +lemma injection_below:
183.119 "\<forall>x. f\<cdot>(g\<cdot>x) = x \<Longrightarrow> (g\<cdot>x \<sqsubseteq> g\<cdot>y) = (x \<sqsubseteq> y)"
183.120 apply (rule iffI)
183.121 apply (drule_tac f=f in monofun_cfun_arg)
184.1 --- a/src/HOLCF/CompactBasis.thy Mon May 11 09:39:53 2009 +0200
184.2 +++ b/src/HOLCF/CompactBasis.thy Mon May 11 17:20:52 2009 +0200
184.3 @@ -18,7 +18,7 @@
184.4 lemma compact_Rep_compact_basis: "compact (Rep_compact_basis a)"
184.5 by (rule Rep_compact_basis [unfolded mem_Collect_eq])
184.6
184.7 -instantiation compact_basis :: (profinite) sq_ord
184.8 +instantiation compact_basis :: (profinite) below
184.9 begin
184.10
184.11 definition
184.12 @@ -47,12 +47,12 @@
184.13 lemmas approx_Rep_compact_basis = Rep_compact_take [symmetric]
184.14
184.15 interpretation compact_basis:
184.16 - basis_take sq_le compact_take
184.17 + basis_take below compact_take
184.18 proof
184.19 fix n :: nat and a :: "'a compact_basis"
184.20 show "compact_take n a \<sqsubseteq> a"
184.21 unfolding compact_le_def
184.22 - by (simp add: Rep_compact_take approx_less)
184.23 + by (simp add: Rep_compact_take approx_below)
184.24 next
184.25 fix n :: nat and a :: "'a compact_basis"
184.26 show "compact_take n (compact_take n a) = compact_take n a"
184.27 @@ -93,15 +93,15 @@
184.28 "approximants = (\<lambda>x. {a. Rep_compact_basis a \<sqsubseteq> x})"
184.29
184.30 interpretation compact_basis:
184.31 - ideal_completion sq_le compact_take Rep_compact_basis approximants
184.32 + ideal_completion below compact_take Rep_compact_basis approximants
184.33 proof
184.34 fix w :: 'a
184.35 - show "preorder.ideal sq_le (approximants w)"
184.36 - proof (rule sq_le.idealI)
184.37 + show "preorder.ideal below (approximants w)"
184.38 + proof (rule below.idealI)
184.39 show "\<exists>x. x \<in> approximants w"
184.40 unfolding approximants_def
184.41 apply (rule_tac x="Abs_compact_basis (approx 0\<cdot>w)" in exI)
184.42 - apply (simp add: Abs_compact_basis_inverse approx_less)
184.43 + apply (simp add: Abs_compact_basis_inverse approx_below)
184.44 done
184.45 next
184.46 fix x y :: "'a compact_basis"
184.47 @@ -116,7 +116,7 @@
184.48 apply (clarify, rename_tac i j)
184.49 apply (rule_tac x="Abs_compact_basis (approx (max i j)\<cdot>w)" in exI)
184.50 apply (simp add: compact_le_def)
184.51 - apply (simp add: Abs_compact_basis_inverse approx_less)
184.52 + apply (simp add: Abs_compact_basis_inverse approx_below)
184.53 apply (erule subst, erule subst)
184.54 apply (simp add: monofun_cfun chain_mono [OF chain_approx])
184.55 done
184.56 @@ -126,7 +126,7 @@
184.57 unfolding approximants_def
184.58 apply simp
184.59 apply (simp add: compact_le_def)
184.60 - apply (erule (1) trans_less)
184.61 + apply (erule (1) below_trans)
184.62 done
184.63 qed
184.64 next
184.65 @@ -136,7 +136,7 @@
184.66 unfolding approximants_def
184.67 apply safe
184.68 apply (simp add: compactD2 [OF compact_Rep_compact_basis Y])
184.69 - apply (erule trans_less, rule is_ub_thelub [OF Y])
184.70 + apply (erule below_trans, rule is_ub_thelub [OF Y])
184.71 done
184.72 next
184.73 fix a :: "'a compact_basis"
184.74 @@ -148,7 +148,7 @@
184.75 apply (subgoal_tac "(\<Squnion>i. approx i\<cdot>x) \<sqsubseteq> y", simp)
184.76 apply (rule admD, simp, simp)
184.77 apply (drule_tac c="Abs_compact_basis (approx i\<cdot>x)" in subsetD)
184.78 - apply (simp add: approximants_def Abs_compact_basis_inverse approx_less)
184.79 + apply (simp add: approximants_def Abs_compact_basis_inverse approx_below)
184.80 apply (simp add: approximants_def Abs_compact_basis_inverse)
184.81 done
184.82 qed
184.83 @@ -288,7 +288,7 @@
184.84 apply (cut_tac a=a in compact_basis.take_covers)
184.85 apply (clarify, rule_tac x=n in exI)
184.86 apply (clarify, simp)
184.87 -apply (rule antisym_less)
184.88 +apply (rule below_antisym)
184.89 apply (rule compact_basis.take_less)
184.90 apply (drule_tac a=a in compact_basis.take_chain_le)
184.91 apply simp
185.1 --- a/src/HOLCF/Completion.thy Mon May 11 09:39:53 2009 +0200
185.2 +++ b/src/HOLCF/Completion.thy Mon May 11 17:20:52 2009 +0200
185.3 @@ -108,11 +108,11 @@
185.4 done
185.5
185.6 lemma typedef_ideal_po:
185.7 - fixes Abs :: "'a set \<Rightarrow> 'b::sq_ord"
185.8 + fixes Abs :: "'a set \<Rightarrow> 'b::below"
185.9 assumes type: "type_definition Rep Abs {S. ideal S}"
185.10 - assumes less: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
185.11 + assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
185.12 shows "OFCLASS('b, po_class)"
185.13 - apply (intro_classes, unfold less)
185.14 + apply (intro_classes, unfold below)
185.15 apply (rule subset_refl)
185.16 apply (erule (1) subset_trans)
185.17 apply (rule type_definition.Rep_inject [OF type, THEN iffD1])
185.18 @@ -122,7 +122,7 @@
185.19 lemma
185.20 fixes Abs :: "'a set \<Rightarrow> 'b::po"
185.21 assumes type: "type_definition Rep Abs {S. ideal S}"
185.22 - assumes less: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
185.23 + assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
185.24 assumes S: "chain S"
185.25 shows typedef_ideal_lub: "range S <<| Abs (\<Union>i. Rep (S i))"
185.26 and typedef_ideal_rep_contlub: "Rep (\<Squnion>i. S i) = (\<Union>i. Rep (S i))"
185.27 @@ -130,7 +130,7 @@
185.28 have 1: "ideal (\<Union>i. Rep (S i))"
185.29 apply (rule ideal_UN)
185.30 apply (rule type_definition.Rep [OF type, unfolded mem_Collect_eq])
185.31 - apply (subst less [symmetric])
185.32 + apply (subst below [symmetric])
185.33 apply (erule chain_mono [OF S])
185.34 done
185.35 hence 2: "Rep (Abs (\<Union>i. Rep (S i))) = (\<Union>i. Rep (S i))"
185.36 @@ -138,8 +138,8 @@
185.37 show 3: "range S <<| Abs (\<Union>i. Rep (S i))"
185.38 apply (rule is_lubI)
185.39 apply (rule is_ubI)
185.40 - apply (simp add: less 2, fast)
185.41 - apply (simp add: less 2 is_ub_def, fast)
185.42 + apply (simp add: below 2, fast)
185.43 + apply (simp add: below 2 is_ub_def, fast)
185.44 done
185.45 hence 4: "(\<Squnion>i. S i) = Abs (\<Union>i. Rep (S i))"
185.46 by (rule thelubI)
185.47 @@ -150,16 +150,16 @@
185.48 lemma typedef_ideal_cpo:
185.49 fixes Abs :: "'a set \<Rightarrow> 'b::po"
185.50 assumes type: "type_definition Rep Abs {S. ideal S}"
185.51 - assumes less: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
185.52 + assumes below: "\<And>x y. x \<sqsubseteq> y \<longleftrightarrow> Rep x \<subseteq> Rep y"
185.53 shows "OFCLASS('b, cpo_class)"
185.54 -by (default, rule exI, erule typedef_ideal_lub [OF type less])
185.55 +by (default, rule exI, erule typedef_ideal_lub [OF type below])
185.56
185.57 end
185.58
185.59 -interpretation sq_le: preorder "sq_le :: 'a::po \<Rightarrow> 'a \<Rightarrow> bool"
185.60 +interpretation below: preorder "below :: 'a::po \<Rightarrow> 'a \<Rightarrow> bool"
185.61 apply unfold_locales
185.62 -apply (rule refl_less)
185.63 -apply (erule (1) trans_less)
185.64 +apply (rule below_refl)
185.65 +apply (erule (1) below_trans)
185.66 done
185.67
185.68 subsection {* Lemmas about least upper bounds *}
185.69 @@ -229,43 +229,43 @@
185.70 apply (rule subsetI, rule UN_I [where a=0], simp_all)
185.71 done
185.72
185.73 -lemma less_def: "x \<sqsubseteq> y \<longleftrightarrow> rep x \<subseteq> rep y"
185.74 +lemma below_def: "x \<sqsubseteq> y \<longleftrightarrow> rep x \<subseteq> rep y"
185.75 by (rule iffI [OF rep_mono subset_repD])
185.76
185.77 lemma rep_eq: "rep x = {a. principal a \<sqsubseteq> x}"
185.78 -unfolding less_def rep_principal
185.79 +unfolding below_def rep_principal
185.80 apply safe
185.81 apply (erule (1) idealD3 [OF ideal_rep])
185.82 apply (erule subsetD, simp add: r_refl)
185.83 done
185.84
185.85 -lemma mem_rep_iff_principal_less: "a \<in> rep x \<longleftrightarrow> principal a \<sqsubseteq> x"
185.86 +lemma mem_rep_iff_principal_below: "a \<in> rep x \<longleftrightarrow> principal a \<sqsubseteq> x"
185.87 by (simp add: rep_eq)
185.88
185.89 -lemma principal_less_iff_mem_rep: "principal a \<sqsubseteq> x \<longleftrightarrow> a \<in> rep x"
185.90 +lemma principal_below_iff_mem_rep: "principal a \<sqsubseteq> x \<longleftrightarrow> a \<in> rep x"
185.91 by (simp add: rep_eq)
185.92
185.93 -lemma principal_less_iff [simp]: "principal a \<sqsubseteq> principal b \<longleftrightarrow> a \<preceq> b"
185.94 -by (simp add: principal_less_iff_mem_rep rep_principal)
185.95 +lemma principal_below_iff [simp]: "principal a \<sqsubseteq> principal b \<longleftrightarrow> a \<preceq> b"
185.96 +by (simp add: principal_below_iff_mem_rep rep_principal)
185.97
185.98 lemma principal_eq_iff: "principal a = principal b \<longleftrightarrow> a \<preceq> b \<and> b \<preceq> a"
185.99 -unfolding po_eq_conv [where 'a='b] principal_less_iff ..
185.100 +unfolding po_eq_conv [where 'a='b] principal_below_iff ..
185.101
185.102 lemma repD: "a \<in> rep x \<Longrightarrow> principal a \<sqsubseteq> x"
185.103 by (simp add: rep_eq)
185.104
185.105 lemma principal_mono: "a \<preceq> b \<Longrightarrow> principal a \<sqsubseteq> principal b"
185.106 -by (simp only: principal_less_iff)
185.107 +by (simp only: principal_below_iff)
185.108
185.109 -lemma lessI: "(\<And>a. principal a \<sqsubseteq> x \<Longrightarrow> principal a \<sqsubseteq> u) \<Longrightarrow> x \<sqsubseteq> u"
185.110 -unfolding principal_less_iff_mem_rep
185.111 -by (simp add: less_def subset_eq)
185.112 +lemma belowI: "(\<And>a. principal a \<sqsubseteq> x \<Longrightarrow> principal a \<sqsubseteq> u) \<Longrightarrow> x \<sqsubseteq> u"
185.113 +unfolding principal_below_iff_mem_rep
185.114 +by (simp add: below_def subset_eq)
185.115
185.116 lemma lub_principal_rep: "principal ` rep x <<| x"
185.117 apply (rule is_lubI)
185.118 apply (rule ub_imageI)
185.119 apply (erule repD)
185.120 -apply (subst less_def)
185.121 +apply (subst below_def)
185.122 apply (rule subsetI)
185.123 apply (drule (1) ub_imageD)
185.124 apply (simp add: rep_eq)
185.125 @@ -299,7 +299,7 @@
185.126 apply (rule is_lub_thelub0)
185.127 apply (rule basis_fun_lemma0, erule f_mono)
185.128 apply (rule is_ubI, clarsimp, rename_tac a)
185.129 - apply (rule trans_less [OF f_mono [OF take_chain]])
185.130 + apply (rule below_trans [OF f_mono [OF take_chain]])
185.131 apply (rule is_ub_thelub0)
185.132 apply (rule basis_fun_lemma0, erule f_mono)
185.133 apply simp
185.134 @@ -313,7 +313,7 @@
185.135 apply (rule ub_imageI, rename_tac a)
185.136 apply (cut_tac a=a in take_covers, erule exE, rename_tac i)
185.137 apply (erule subst)
185.138 - apply (rule rev_trans_less)
185.139 + apply (rule rev_below_trans)
185.140 apply (rule_tac x=i in is_ub_thelub)
185.141 apply (rule basis_fun_lemma1, erule f_mono)
185.142 apply (rule is_ub_thelub0)
185.143 @@ -324,7 +324,7 @@
185.144 apply (rule is_lub_thelub0)
185.145 apply (rule basis_fun_lemma0, erule f_mono)
185.146 apply (rule is_ubI, clarsimp, rename_tac a)
185.147 - apply (rule trans_less [OF f_mono [OF take_less]])
185.148 + apply (rule below_trans [OF f_mono [OF take_less]])
185.149 apply (erule (1) ub_imageD)
185.150 done
185.151
185.152 @@ -350,7 +350,7 @@
185.153 apply (erule (1) subsetD [OF rep_mono])
185.154 apply (rule is_lub_thelub0 [OF lub ub_imageI])
185.155 apply (simp add: rep_contlub, clarify)
185.156 - apply (erule rev_trans_less [OF is_ub_thelub])
185.157 + apply (erule rev_below_trans [OF is_ub_thelub])
185.158 apply (erule is_ub_thelub0 [OF lub imageI])
185.159 done
185.160 qed
185.161 @@ -367,21 +367,21 @@
185.162 lemma basis_fun_mono:
185.163 assumes f_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> f a \<sqsubseteq> f b"
185.164 assumes g_mono: "\<And>a b. a \<preceq> b \<Longrightarrow> g a \<sqsubseteq> g b"
185.165 - assumes less: "\<And>a. f a \<sqsubseteq> g a"
185.166 + assumes below: "\<And>a. f a \<sqsubseteq> g a"
185.167 shows "basis_fun f \<sqsubseteq> basis_fun g"
185.168 - apply (rule less_cfun_ext)
185.169 + apply (rule below_cfun_ext)
185.170 apply (simp only: basis_fun_beta f_mono g_mono)
185.171 apply (rule is_lub_thelub0)
185.172 apply (rule basis_fun_lemma, erule f_mono)
185.173 apply (rule ub_imageI, rename_tac a)
185.174 - apply (rule trans_less [OF less])
185.175 + apply (rule below_trans [OF below])
185.176 apply (rule is_ub_thelub0)
185.177 apply (rule basis_fun_lemma, erule g_mono)
185.178 apply (erule imageI)
185.179 done
185.180
185.181 lemma compact_principal [simp]: "compact (principal a)"
185.182 -by (rule compactI2, simp add: principal_less_iff_mem_rep rep_contlub)
185.183 +by (rule compactI2, simp add: principal_below_iff_mem_rep rep_contlub)
185.184
185.185 subsection {* Bifiniteness of ideal completions *}
185.186
186.1 --- a/src/HOLCF/Cont.thy Mon May 11 09:39:53 2009 +0200
186.2 +++ b/src/HOLCF/Cont.thy Mon May 11 17:20:52 2009 +0200
186.3 @@ -121,14 +121,14 @@
186.4
186.5 lemma contI2:
186.6 assumes mono: "monofun f"
186.7 - assumes less: "\<And>Y. \<lbrakk>chain Y; chain (\<lambda>i. f (Y i))\<rbrakk>
186.8 + assumes below: "\<And>Y. \<lbrakk>chain Y; chain (\<lambda>i. f (Y i))\<rbrakk>
186.9 \<Longrightarrow> f (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. f (Y i))"
186.10 shows "cont f"
186.11 apply (rule monocontlub2cont)
186.12 apply (rule mono)
186.13 apply (rule contlubI)
186.14 -apply (rule antisym_less)
186.15 -apply (rule less, assumption)
186.16 +apply (rule below_antisym)
186.17 +apply (rule below, assumption)
186.18 apply (erule ch2ch_monofun [OF mono])
186.19 apply (rule is_lub_thelub)
186.20 apply (erule ch2ch_monofun [OF mono])
186.21 @@ -144,7 +144,7 @@
186.22 ( val name = "cont2cont" val description = "continuity intro rule" )
186.23 *}
186.24
186.25 -setup {* Cont2ContData.setup *}
186.26 +setup Cont2ContData.setup
186.27
186.28 text {*
186.29 Given the term @{term "cont f"}, the procedure tries to construct the
186.30 @@ -153,20 +153,13 @@
186.31 conditional rewrite rule with the unsolved subgoals as premises.
186.32 *}
186.33
186.34 -setup {*
186.35 -let
186.36 - fun solve_cont thy ss t =
186.37 +simproc_setup cont_proc ("cont f") = {*
186.38 + fn phi => fn ss => fn ct =>
186.39 let
186.40 - val tr = instantiate' [] [SOME (cterm_of thy t)] Eq_TrueI;
186.41 + val tr = instantiate' [] [SOME ct] @{thm Eq_TrueI};
186.42 val rules = Cont2ContData.get (Simplifier.the_context ss);
186.43 val tac = REPEAT_ALL_NEW (match_tac rules);
186.44 - in Option.map fst (Seq.pull (tac 1 tr)) end
186.45 -
186.46 - val proc =
186.47 - Simplifier.simproc @{theory} "cont_proc" ["cont f"] solve_cont;
186.48 -in
186.49 - Simplifier.map_simpset (fn ss => ss addsimprocs [proc])
186.50 -end
186.51 + in SINGLE (tac 1) tr end
186.52 *}
186.53
186.54 subsection {* Continuity of basic functions *}
186.55 @@ -187,31 +180,31 @@
186.56
186.57 text {* application of functions is continuous *}
186.58
186.59 -lemma cont2cont_apply:
186.60 +lemma cont_apply:
186.61 fixes f :: "'a::cpo \<Rightarrow> 'b::cpo \<Rightarrow> 'c::cpo" and t :: "'a \<Rightarrow> 'b"
186.62 - assumes f1: "\<And>y. cont (\<lambda>x. f x y)"
186.63 - assumes f2: "\<And>x. cont (\<lambda>y. f x y)"
186.64 - assumes t: "cont (\<lambda>x. t x)"
186.65 + assumes 1: "cont (\<lambda>x. t x)"
186.66 + assumes 2: "\<And>x. cont (\<lambda>y. f x y)"
186.67 + assumes 3: "\<And>y. cont (\<lambda>x. f x y)"
186.68 shows "cont (\<lambda>x. (f x) (t x))"
186.69 proof (rule monocontlub2cont [OF monofunI contlubI])
186.70 fix x y :: "'a" assume "x \<sqsubseteq> y"
186.71 then show "f x (t x) \<sqsubseteq> f y (t y)"
186.72 - by (auto intro: cont2monofunE [OF f1]
186.73 - cont2monofunE [OF f2]
186.74 - cont2monofunE [OF t]
186.75 - trans_less)
186.76 + by (auto intro: cont2monofunE [OF 1]
186.77 + cont2monofunE [OF 2]
186.78 + cont2monofunE [OF 3]
186.79 + below_trans)
186.80 next
186.81 fix Y :: "nat \<Rightarrow> 'a" assume "chain Y"
186.82 then show "f (\<Squnion>i. Y i) (t (\<Squnion>i. Y i)) = (\<Squnion>i. f (Y i) (t (Y i)))"
186.83 - by (simp only: cont2contlubE [OF t] ch2ch_cont [OF t]
186.84 - cont2contlubE [OF f1] ch2ch_cont [OF f1]
186.85 - cont2contlubE [OF f2] ch2ch_cont [OF f2]
186.86 + by (simp only: cont2contlubE [OF 1] ch2ch_cont [OF 1]
186.87 + cont2contlubE [OF 2] ch2ch_cont [OF 2]
186.88 + cont2contlubE [OF 3] ch2ch_cont [OF 3]
186.89 diag_lub)
186.90 qed
186.91
186.92 -lemma cont2cont_compose:
186.93 +lemma cont_compose:
186.94 "\<lbrakk>cont c; cont (\<lambda>x. f x)\<rbrakk> \<Longrightarrow> cont (\<lambda>x. c (f x))"
186.95 -by (rule cont2cont_apply [OF cont_const])
186.96 +by (rule cont_apply [OF _ _ cont_const])
186.97
186.98 text {* if-then-else is continuous *}
186.99
187.1 --- a/src/HOLCF/ConvexPD.thy Mon May 11 09:39:53 2009 +0200
187.2 +++ b/src/HOLCF/ConvexPD.thy Mon May 11 17:20:52 2009 +0200
187.3 @@ -144,7 +144,7 @@
187.4 "{S::'a pd_basis set. convex_le.ideal S}"
187.5 by (fast intro: convex_le.ideal_principal)
187.6
187.7 -instantiation convex_pd :: (profinite) sq_ord
187.8 +instantiation convex_pd :: (profinite) below
187.9 begin
187.10
187.11 definition
187.12 @@ -155,16 +155,16 @@
187.13
187.14 instance convex_pd :: (profinite) po
187.15 by (rule convex_le.typedef_ideal_po
187.16 - [OF type_definition_convex_pd sq_le_convex_pd_def])
187.17 + [OF type_definition_convex_pd below_convex_pd_def])
187.18
187.19 instance convex_pd :: (profinite) cpo
187.20 by (rule convex_le.typedef_ideal_cpo
187.21 - [OF type_definition_convex_pd sq_le_convex_pd_def])
187.22 + [OF type_definition_convex_pd below_convex_pd_def])
187.23
187.24 lemma Rep_convex_pd_lub:
187.25 "chain Y \<Longrightarrow> Rep_convex_pd (\<Squnion>i. Y i) = (\<Union>i. Rep_convex_pd (Y i))"
187.26 by (rule convex_le.typedef_ideal_rep_contlub
187.27 - [OF type_definition_convex_pd sq_le_convex_pd_def])
187.28 + [OF type_definition_convex_pd below_convex_pd_def])
187.29
187.30 lemma ideal_Rep_convex_pd: "convex_le.ideal (Rep_convex_pd xs)"
187.31 by (rule Rep_convex_pd [unfolded mem_Collect_eq])
187.32 @@ -190,7 +190,7 @@
187.33 apply (rule ideal_Rep_convex_pd)
187.34 apply (erule Rep_convex_pd_lub)
187.35 apply (rule Rep_convex_principal)
187.36 -apply (simp only: sq_le_convex_pd_def)
187.37 +apply (simp only: below_convex_pd_def)
187.38 done
187.39
187.40 text {* Convex powerdomain is pointed *}
187.41 @@ -311,7 +311,7 @@
187.42 lemmas convex_plus_aci =
187.43 convex_plus_ac convex_plus_absorb convex_plus_left_absorb
187.44
187.45 -lemma convex_unit_less_plus_iff [simp]:
187.46 +lemma convex_unit_below_plus_iff [simp]:
187.47 "{x}\<natural> \<sqsubseteq> ys +\<natural> zs \<longleftrightarrow> {x}\<natural> \<sqsubseteq> ys \<and> {x}\<natural> \<sqsubseteq> zs"
187.48 apply (rule iffI)
187.49 apply (subgoal_tac
187.50 @@ -329,7 +329,7 @@
187.51 apply (erule (1) monofun_cfun [OF monofun_cfun_arg])
187.52 done
187.53
187.54 -lemma convex_plus_less_unit_iff [simp]:
187.55 +lemma convex_plus_below_unit_iff [simp]:
187.56 "xs +\<natural> ys \<sqsubseteq> {z}\<natural> \<longleftrightarrow> xs \<sqsubseteq> {z}\<natural> \<and> ys \<sqsubseteq> {z}\<natural>"
187.57 apply (rule iffI)
187.58 apply (subgoal_tac
187.59 @@ -347,9 +347,9 @@
187.60 apply (erule (1) monofun_cfun [OF monofun_cfun_arg])
187.61 done
187.62
187.63 -lemma convex_unit_less_iff [simp]: "{x}\<natural> \<sqsubseteq> {y}\<natural> \<longleftrightarrow> x \<sqsubseteq> y"
187.64 +lemma convex_unit_below_iff [simp]: "{x}\<natural> \<sqsubseteq> {y}\<natural> \<longleftrightarrow> x \<sqsubseteq> y"
187.65 apply (rule iffI)
187.66 - apply (rule profinite_less_ext)
187.67 + apply (rule profinite_below_ext)
187.68 apply (drule_tac f="approx i" in monofun_cfun_arg, simp)
187.69 apply (cut_tac x="approx i\<cdot>x" in compact_basis.compact_imp_principal, simp)
187.70 apply (cut_tac x="approx i\<cdot>y" in compact_basis.compact_imp_principal, simp)
187.71 @@ -433,12 +433,12 @@
187.72
187.73 lemma monofun_LAM:
187.74 "\<lbrakk>cont f; cont g; \<And>x. f x \<sqsubseteq> g x\<rbrakk> \<Longrightarrow> (\<Lambda> x. f x) \<sqsubseteq> (\<Lambda> x. g x)"
187.75 -by (simp add: expand_cfun_less)
187.76 +by (simp add: expand_cfun_below)
187.77
187.78 lemma convex_bind_basis_mono:
187.79 "t \<le>\<natural> u \<Longrightarrow> convex_bind_basis t \<sqsubseteq> convex_bind_basis u"
187.80 apply (erule convex_le_induct)
187.81 -apply (erule (1) trans_less)
187.82 +apply (erule (1) below_trans)
187.83 apply (simp add: monofun_LAM monofun_cfun)
187.84 apply (simp add: monofun_LAM monofun_cfun)
187.85 done
187.86 @@ -606,12 +606,12 @@
187.87
187.88 text {* Ordering property *}
187.89
187.90 -lemma convex_pd_less_iff:
187.91 +lemma convex_pd_below_iff:
187.92 "(xs \<sqsubseteq> ys) =
187.93 (convex_to_upper\<cdot>xs \<sqsubseteq> convex_to_upper\<cdot>ys \<and>
187.94 convex_to_lower\<cdot>xs \<sqsubseteq> convex_to_lower\<cdot>ys)"
187.95 apply (safe elim!: monofun_cfun_arg)
187.96 - apply (rule profinite_less_ext)
187.97 + apply (rule profinite_below_ext)
187.98 apply (drule_tac f="approx i" in monofun_cfun_arg)
187.99 apply (drule_tac f="approx i" in monofun_cfun_arg)
187.100 apply (cut_tac x="approx i\<cdot>xs" in convex_pd.compact_imp_principal, simp)
187.101 @@ -620,19 +620,19 @@
187.102 apply (simp add: approx_convex_to_upper approx_convex_to_lower convex_le_def)
187.103 done
187.104
187.105 -lemmas convex_plus_less_plus_iff =
187.106 - convex_pd_less_iff [where xs="xs +\<natural> ys" and ys="zs +\<natural> ws", standard]
187.107 +lemmas convex_plus_below_plus_iff =
187.108 + convex_pd_below_iff [where xs="xs +\<natural> ys" and ys="zs +\<natural> ws", standard]
187.109
187.110 -lemmas convex_pd_less_simps =
187.111 - convex_unit_less_plus_iff
187.112 - convex_plus_less_unit_iff
187.113 - convex_plus_less_plus_iff
187.114 - convex_unit_less_iff
187.115 +lemmas convex_pd_below_simps =
187.116 + convex_unit_below_plus_iff
187.117 + convex_plus_below_unit_iff
187.118 + convex_plus_below_plus_iff
187.119 + convex_unit_below_iff
187.120 convex_to_upper_unit
187.121 convex_to_upper_plus
187.122 convex_to_lower_unit
187.123 convex_to_lower_plus
187.124 - upper_pd_less_simps
187.125 - lower_pd_less_simps
187.126 + upper_pd_below_simps
187.127 + lower_pd_below_simps
187.128
187.129 end
188.1 --- a/src/HOLCF/Cprod.thy Mon May 11 09:39:53 2009 +0200
188.2 +++ b/src/HOLCF/Cprod.thy Mon May 11 17:20:52 2009 +0200
188.3 @@ -68,7 +68,7 @@
188.4 lemma cpair_eq [iff]: "(<a, b> = <a', b'>) = (a = a' \<and> b = b')"
188.5 by (simp add: cpair_eq_pair)
188.6
188.7 -lemma cpair_less [iff]: "(<a, b> \<sqsubseteq> <a', b'>) = (a \<sqsubseteq> a' \<and> b \<sqsubseteq> b')"
188.8 +lemma cpair_below [iff]: "(<a, b> \<sqsubseteq> <a', b'>) = (a \<sqsubseteq> a' \<and> b \<sqsubseteq> b')"
188.9 by (simp add: cpair_eq_pair)
188.10
188.11 lemma cpair_defined_iff [iff]: "(<x, y> = \<bottom>) = (x = \<bottom> \<and> y = \<bottom>)"
188.12 @@ -107,23 +107,23 @@
188.13
188.14 lemmas surjective_pairing_Cprod2 = cpair_cfst_csnd
188.15
188.16 -lemma less_cprod: "x \<sqsubseteq> y = (cfst\<cdot>x \<sqsubseteq> cfst\<cdot>y \<and> csnd\<cdot>x \<sqsubseteq> csnd\<cdot>y)"
188.17 -by (simp add: less_cprod_def cfst_def csnd_def cont_fst cont_snd)
188.18 +lemma below_cprod: "x \<sqsubseteq> y = (cfst\<cdot>x \<sqsubseteq> cfst\<cdot>y \<and> csnd\<cdot>x \<sqsubseteq> csnd\<cdot>y)"
188.19 +by (simp add: below_prod_def cfst_def csnd_def cont_fst cont_snd)
188.20
188.21 lemma eq_cprod: "(x = y) = (cfst\<cdot>x = cfst\<cdot>y \<and> csnd\<cdot>x = csnd\<cdot>y)"
188.22 -by (auto simp add: po_eq_conv less_cprod)
188.23 +by (auto simp add: po_eq_conv below_cprod)
188.24
188.25 -lemma cfst_less_iff: "cfst\<cdot>x \<sqsubseteq> y = x \<sqsubseteq> <y, csnd\<cdot>x>"
188.26 -by (simp add: less_cprod)
188.27 +lemma cfst_below_iff: "cfst\<cdot>x \<sqsubseteq> y = x \<sqsubseteq> <y, csnd\<cdot>x>"
188.28 +by (simp add: below_cprod)
188.29
188.30 -lemma csnd_less_iff: "csnd\<cdot>x \<sqsubseteq> y = x \<sqsubseteq> <cfst\<cdot>x, y>"
188.31 -by (simp add: less_cprod)
188.32 +lemma csnd_below_iff: "csnd\<cdot>x \<sqsubseteq> y = x \<sqsubseteq> <cfst\<cdot>x, y>"
188.33 +by (simp add: below_cprod)
188.34
188.35 lemma compact_cfst: "compact x \<Longrightarrow> compact (cfst\<cdot>x)"
188.36 -by (rule compactI, simp add: cfst_less_iff)
188.37 +by (rule compactI, simp add: cfst_below_iff)
188.38
188.39 lemma compact_csnd: "compact x \<Longrightarrow> compact (csnd\<cdot>x)"
188.40 -by (rule compactI, simp add: csnd_less_iff)
188.41 +by (rule compactI, simp add: csnd_below_iff)
188.42
188.43 lemma compact_cpair: "\<lbrakk>compact x; compact y\<rbrakk> \<Longrightarrow> compact <x, y>"
188.44 by (simp add: cpair_eq_pair)
189.1 --- a/src/HOLCF/Deflation.thy Mon May 11 09:39:53 2009 +0200
189.2 +++ b/src/HOLCF/Deflation.thy Mon May 11 17:20:52 2009 +0200
189.3 @@ -15,11 +15,11 @@
189.4 locale deflation =
189.5 fixes d :: "'a \<rightarrow> 'a"
189.6 assumes idem: "\<And>x. d\<cdot>(d\<cdot>x) = d\<cdot>x"
189.7 - assumes less: "\<And>x. d\<cdot>x \<sqsubseteq> x"
189.8 + assumes below: "\<And>x. d\<cdot>x \<sqsubseteq> x"
189.9 begin
189.10
189.11 -lemma less_ID: "d \<sqsubseteq> ID"
189.12 -by (rule less_cfun_ext, simp add: less)
189.13 +lemma below_ID: "d \<sqsubseteq> ID"
189.14 +by (rule below_cfun_ext, simp add: below)
189.15
189.16 text {* The set of fixed points is the same as the range. *}
189.17
189.18 @@ -34,18 +34,18 @@
189.19 the subset ordering of their sets of fixed-points.
189.20 *}
189.21
189.22 -lemma lessI:
189.23 +lemma belowI:
189.24 assumes f: "\<And>x. d\<cdot>x = x \<Longrightarrow> f\<cdot>x = x" shows "d \<sqsubseteq> f"
189.25 -proof (rule less_cfun_ext)
189.26 +proof (rule below_cfun_ext)
189.27 fix x
189.28 - from less have "f\<cdot>(d\<cdot>x) \<sqsubseteq> f\<cdot>x" by (rule monofun_cfun_arg)
189.29 + from below have "f\<cdot>(d\<cdot>x) \<sqsubseteq> f\<cdot>x" by (rule monofun_cfun_arg)
189.30 also from idem have "f\<cdot>(d\<cdot>x) = d\<cdot>x" by (rule f)
189.31 finally show "d\<cdot>x \<sqsubseteq> f\<cdot>x" .
189.32 qed
189.33
189.34 -lemma lessD: "\<lbrakk>f \<sqsubseteq> d; f\<cdot>x = x\<rbrakk> \<Longrightarrow> d\<cdot>x = x"
189.35 -proof (rule antisym_less)
189.36 - from less show "d\<cdot>x \<sqsubseteq> x" .
189.37 +lemma belowD: "\<lbrakk>f \<sqsubseteq> d; f\<cdot>x = x\<rbrakk> \<Longrightarrow> d\<cdot>x = x"
189.38 +proof (rule below_antisym)
189.39 + from below show "d\<cdot>x \<sqsubseteq> x" .
189.40 next
189.41 assume "f \<sqsubseteq> d"
189.42 hence "f\<cdot>x \<sqsubseteq> d\<cdot>x" by (rule monofun_cfun_fun)
189.43 @@ -64,11 +64,11 @@
189.44 lemma deflation_UU: "deflation \<bottom>"
189.45 by (simp add: deflation.intro)
189.46
189.47 -lemma deflation_less_iff:
189.48 +lemma deflation_below_iff:
189.49 "\<lbrakk>deflation p; deflation q\<rbrakk> \<Longrightarrow> p \<sqsubseteq> q \<longleftrightarrow> (\<forall>x. p\<cdot>x = x \<longrightarrow> q\<cdot>x = x)"
189.50 apply safe
189.51 - apply (simp add: deflation.lessD)
189.52 - apply (simp add: deflation.lessI)
189.53 + apply (simp add: deflation.belowD)
189.54 + apply (simp add: deflation.belowI)
189.55 done
189.56
189.57 text {*
189.58 @@ -76,13 +76,13 @@
189.59 the lesser of the two (if they are comparable).
189.60 *}
189.61
189.62 -lemma deflation_less_comp1:
189.63 +lemma deflation_below_comp1:
189.64 assumes "deflation f"
189.65 assumes "deflation g"
189.66 shows "f \<sqsubseteq> g \<Longrightarrow> f\<cdot>(g\<cdot>x) = f\<cdot>x"
189.67 -proof (rule antisym_less)
189.68 +proof (rule below_antisym)
189.69 interpret g: deflation g by fact
189.70 - from g.less show "f\<cdot>(g\<cdot>x) \<sqsubseteq> f\<cdot>x" by (rule monofun_cfun_arg)
189.71 + from g.below show "f\<cdot>(g\<cdot>x) \<sqsubseteq> f\<cdot>x" by (rule monofun_cfun_arg)
189.72 next
189.73 interpret f: deflation f by fact
189.74 assume "f \<sqsubseteq> g" hence "f\<cdot>x \<sqsubseteq> g\<cdot>x" by (rule monofun_cfun_fun)
189.75 @@ -91,9 +91,9 @@
189.76 finally show "f\<cdot>x \<sqsubseteq> f\<cdot>(g\<cdot>x)" .
189.77 qed
189.78
189.79 -lemma deflation_less_comp2:
189.80 +lemma deflation_below_comp2:
189.81 "\<lbrakk>deflation f; deflation g; f \<sqsubseteq> g\<rbrakk> \<Longrightarrow> g\<cdot>(f\<cdot>x) = f\<cdot>x"
189.82 -by (simp only: deflation.lessD deflation.idem)
189.83 +by (simp only: deflation.belowD deflation.idem)
189.84
189.85
189.86 subsection {* Deflations with finite range *}
189.87 @@ -143,7 +143,7 @@
189.88 hence "d\<cdot>x \<sqsubseteq> d\<cdot>(Y j)"
189.89 using j by simp
189.90 hence "d\<cdot>x \<sqsubseteq> Y j"
189.91 - using less by (rule trans_less)
189.92 + using below by (rule below_trans)
189.93 thus "\<exists>j. d\<cdot>x \<sqsubseteq> Y j" ..
189.94 qed
189.95
189.96 @@ -155,10 +155,10 @@
189.97 locale ep_pair =
189.98 fixes e :: "'a \<rightarrow> 'b" and p :: "'b \<rightarrow> 'a"
189.99 assumes e_inverse [simp]: "\<And>x. p\<cdot>(e\<cdot>x) = x"
189.100 - and e_p_less: "\<And>y. e\<cdot>(p\<cdot>y) \<sqsubseteq> y"
189.101 + and e_p_below: "\<And>y. e\<cdot>(p\<cdot>y) \<sqsubseteq> y"
189.102 begin
189.103
189.104 -lemma e_less_iff [simp]: "e\<cdot>x \<sqsubseteq> e\<cdot>y \<longleftrightarrow> x \<sqsubseteq> y"
189.105 +lemma e_below_iff [simp]: "e\<cdot>x \<sqsubseteq> e\<cdot>y \<longleftrightarrow> x \<sqsubseteq> y"
189.106 proof
189.107 assume "e\<cdot>x \<sqsubseteq> e\<cdot>y"
189.108 hence "p\<cdot>(e\<cdot>x) \<sqsubseteq> p\<cdot>(e\<cdot>y)" by (rule monofun_cfun_arg)
189.109 @@ -169,7 +169,7 @@
189.110 qed
189.111
189.112 lemma e_eq_iff [simp]: "e\<cdot>x = e\<cdot>y \<longleftrightarrow> x = y"
189.113 -unfolding po_eq_conv e_less_iff ..
189.114 +unfolding po_eq_conv e_below_iff ..
189.115
189.116 lemma p_eq_iff:
189.117 "\<lbrakk>e\<cdot>(p\<cdot>x) = x; e\<cdot>(p\<cdot>y) = y\<rbrakk> \<Longrightarrow> p\<cdot>x = p\<cdot>y \<longleftrightarrow> x = y"
189.118 @@ -178,7 +178,7 @@
189.119 lemma p_inverse: "(\<exists>x. y = e\<cdot>x) = (e\<cdot>(p\<cdot>y) = y)"
189.120 by (auto, rule exI, erule sym)
189.121
189.122 -lemma e_less_iff_less_p: "e\<cdot>x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> p\<cdot>y"
189.123 +lemma e_below_iff_below_p: "e\<cdot>x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> p\<cdot>y"
189.124 proof
189.125 assume "e\<cdot>x \<sqsubseteq> y"
189.126 then have "p\<cdot>(e\<cdot>x) \<sqsubseteq> p\<cdot>y" by (rule monofun_cfun_arg)
189.127 @@ -186,7 +186,7 @@
189.128 next
189.129 assume "x \<sqsubseteq> p\<cdot>y"
189.130 then have "e\<cdot>x \<sqsubseteq> e\<cdot>(p\<cdot>y)" by (rule monofun_cfun_arg)
189.131 - then show "e\<cdot>x \<sqsubseteq> y" using e_p_less by (rule trans_less)
189.132 + then show "e\<cdot>x \<sqsubseteq> y" using e_p_below by (rule below_trans)
189.133 qed
189.134
189.135 lemma compact_e_rev: "compact (e\<cdot>x) \<Longrightarrow> compact x"
189.136 @@ -203,7 +203,7 @@
189.137 assume "compact x"
189.138 hence "adm (\<lambda>y. \<not> x \<sqsubseteq> y)" by (rule compactD)
189.139 hence "adm (\<lambda>y. \<not> x \<sqsubseteq> p\<cdot>y)" by (rule adm_subst [OF cont_Rep_CFun2])
189.140 - hence "adm (\<lambda>y. \<not> e\<cdot>x \<sqsubseteq> y)" by (simp add: e_less_iff_less_p)
189.141 + hence "adm (\<lambda>y. \<not> e\<cdot>x \<sqsubseteq> y)" by (simp add: e_below_iff_below_p)
189.142 thus "compact (e\<cdot>x)" by (rule compactI)
189.143 qed
189.144
189.145 @@ -213,7 +213,7 @@
189.146 text {* Deflations from ep-pairs *}
189.147
189.148 lemma deflation_e_p: "deflation (e oo p)"
189.149 -by (simp add: deflation.intro e_p_less)
189.150 +by (simp add: deflation.intro e_p_below)
189.151
189.152 lemma deflation_e_d_p:
189.153 assumes "deflation d"
189.154 @@ -224,7 +224,7 @@
189.155 show "(e oo d oo p)\<cdot>((e oo d oo p)\<cdot>x) = (e oo d oo p)\<cdot>x"
189.156 by (simp add: idem)
189.157 show "(e oo d oo p)\<cdot>x \<sqsubseteq> x"
189.158 - by (simp add: e_less_iff_less_p less)
189.159 + by (simp add: e_below_iff_below_p below)
189.160 qed
189.161
189.162 lemma finite_deflation_e_d_p:
189.163 @@ -236,7 +236,7 @@
189.164 show "(e oo d oo p)\<cdot>((e oo d oo p)\<cdot>x) = (e oo d oo p)\<cdot>x"
189.165 by (simp add: idem)
189.166 show "(e oo d oo p)\<cdot>x \<sqsubseteq> x"
189.167 - by (simp add: e_less_iff_less_p less)
189.168 + by (simp add: e_below_iff_below_p below)
189.169 have "finite ((\<lambda>x. e\<cdot>x) ` (\<lambda>x. d\<cdot>x) ` range (\<lambda>x. p\<cdot>x))"
189.170 by (simp add: finite_image)
189.171 hence "finite (range (\<lambda>x. (e oo d oo p)\<cdot>x))"
189.172 @@ -254,24 +254,24 @@
189.173 {
189.174 fix x
189.175 have "d\<cdot>(e\<cdot>x) \<sqsubseteq> e\<cdot>x"
189.176 - by (rule d.less)
189.177 + by (rule d.below)
189.178 hence "p\<cdot>(d\<cdot>(e\<cdot>x)) \<sqsubseteq> p\<cdot>(e\<cdot>x)"
189.179 by (rule monofun_cfun_arg)
189.180 hence "(p oo d oo e)\<cdot>x \<sqsubseteq> x"
189.181 by simp
189.182 }
189.183 - note p_d_e_less = this
189.184 + note p_d_e_below = this
189.185 show ?thesis
189.186 proof
189.187 fix x
189.188 show "(p oo d oo e)\<cdot>x \<sqsubseteq> x"
189.189 - by (rule p_d_e_less)
189.190 + by (rule p_d_e_below)
189.191 next
189.192 fix x
189.193 show "(p oo d oo e)\<cdot>((p oo d oo e)\<cdot>x) = (p oo d oo e)\<cdot>x"
189.194 - proof (rule antisym_less)
189.195 + proof (rule below_antisym)
189.196 show "(p oo d oo e)\<cdot>((p oo d oo e)\<cdot>x) \<sqsubseteq> (p oo d oo e)\<cdot>x"
189.197 - by (rule p_d_e_less)
189.198 + by (rule p_d_e_below)
189.199 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)))))"
189.200 by (intro monofun_cfun_arg d)
189.201 hence "p\<cdot>(d\<cdot>(e\<cdot>x)) \<sqsubseteq> p\<cdot>(d\<cdot>(e\<cdot>(p\<cdot>(d\<cdot>(e\<cdot>x)))))"
189.202 @@ -315,29 +315,29 @@
189.203 lemma ep_pair_unique_e_lemma:
189.204 assumes "ep_pair e1 p" and "ep_pair e2 p"
189.205 shows "e1 \<sqsubseteq> e2"
189.206 -proof (rule less_cfun_ext)
189.207 +proof (rule below_cfun_ext)
189.208 interpret e1: ep_pair e1 p by fact
189.209 interpret e2: ep_pair e2 p by fact
189.210 fix x
189.211 have "e1\<cdot>(p\<cdot>(e2\<cdot>x)) \<sqsubseteq> e2\<cdot>x"
189.212 - by (rule e1.e_p_less)
189.213 + by (rule e1.e_p_below)
189.214 thus "e1\<cdot>x \<sqsubseteq> e2\<cdot>x"
189.215 by (simp only: e2.e_inverse)
189.216 qed
189.217
189.218 lemma ep_pair_unique_e:
189.219 "\<lbrakk>ep_pair e1 p; ep_pair e2 p\<rbrakk> \<Longrightarrow> e1 = e2"
189.220 -by (fast intro: antisym_less elim: ep_pair_unique_e_lemma)
189.221 +by (fast intro: below_antisym elim: ep_pair_unique_e_lemma)
189.222
189.223 lemma ep_pair_unique_p_lemma:
189.224 assumes "ep_pair e p1" and "ep_pair e p2"
189.225 shows "p1 \<sqsubseteq> p2"
189.226 -proof (rule less_cfun_ext)
189.227 +proof (rule below_cfun_ext)
189.228 interpret p1: ep_pair e p1 by fact
189.229 interpret p2: ep_pair e p2 by fact
189.230 fix x
189.231 have "e\<cdot>(p1\<cdot>x) \<sqsubseteq> x"
189.232 - by (rule p1.e_p_less)
189.233 + by (rule p1.e_p_below)
189.234 hence "p2\<cdot>(e\<cdot>(p1\<cdot>x)) \<sqsubseteq> p2\<cdot>x"
189.235 by (rule monofun_cfun_arg)
189.236 thus "p1\<cdot>x \<sqsubseteq> p2\<cdot>x"
189.237 @@ -346,7 +346,7 @@
189.238
189.239 lemma ep_pair_unique_p:
189.240 "\<lbrakk>ep_pair e p1; ep_pair e p2\<rbrakk> \<Longrightarrow> p1 = p2"
189.241 -by (fast intro: antisym_less elim: ep_pair_unique_p_lemma)
189.242 +by (fast intro: below_antisym elim: ep_pair_unique_p_lemma)
189.243
189.244 subsection {* Composing ep-pairs *}
189.245
189.246 @@ -363,11 +363,11 @@
189.247 show "(p1 oo p2)\<cdot>((e2 oo e1)\<cdot>x) = x"
189.248 by simp
189.249 have "e1\<cdot>(p1\<cdot>(p2\<cdot>y)) \<sqsubseteq> p2\<cdot>y"
189.250 - by (rule ep1.e_p_less)
189.251 + by (rule ep1.e_p_below)
189.252 hence "e2\<cdot>(e1\<cdot>(p1\<cdot>(p2\<cdot>y))) \<sqsubseteq> e2\<cdot>(p2\<cdot>y)"
189.253 by (rule monofun_cfun_arg)
189.254 also have "e2\<cdot>(p2\<cdot>y) \<sqsubseteq> y"
189.255 - by (rule ep2.e_p_less)
189.256 + by (rule ep2.e_p_below)
189.257 finally show "(e2 oo e1)\<cdot>((p1 oo p2)\<cdot>y) \<sqsubseteq> y"
189.258 by simp
189.259 qed
189.260 @@ -381,7 +381,7 @@
189.261 proof -
189.262 have "\<bottom> \<sqsubseteq> p\<cdot>\<bottom>" by (rule minimal)
189.263 hence "e\<cdot>\<bottom> \<sqsubseteq> e\<cdot>(p\<cdot>\<bottom>)" by (rule monofun_cfun_arg)
189.264 - also have "e\<cdot>(p\<cdot>\<bottom>) \<sqsubseteq> \<bottom>" by (rule e_p_less)
189.265 + also have "e\<cdot>(p\<cdot>\<bottom>) \<sqsubseteq> \<bottom>" by (rule e_p_below)
189.266 finally show "e\<cdot>\<bottom> = \<bottom>" by simp
189.267 qed
189.268
190.1 --- a/src/HOLCF/Discrete.thy Mon May 11 09:39:53 2009 +0200
190.2 +++ b/src/HOLCF/Discrete.thy Mon May 11 17:20:52 2009 +0200
190.3 @@ -12,21 +12,21 @@
190.4
190.5 subsection {* Type @{typ "'a discr"} is a discrete cpo *}
190.6
190.7 -instantiation discr :: (type) sq_ord
190.8 +instantiation discr :: (type) below
190.9 begin
190.10
190.11 definition
190.12 - less_discr_def:
190.13 + below_discr_def:
190.14 "(op \<sqsubseteq> :: 'a discr \<Rightarrow> 'a discr \<Rightarrow> bool) = (op =)"
190.15
190.16 instance ..
190.17 end
190.18
190.19 instance discr :: (type) discrete_cpo
190.20 -by intro_classes (simp add: less_discr_def)
190.21 +by intro_classes (simp add: below_discr_def)
190.22
190.23 -lemma discr_less_eq [iff]: "((x::('a::type)discr) << y) = (x = y)"
190.24 -by simp
190.25 +lemma discr_below_eq [iff]: "((x::('a::type)discr) << y) = (x = y)"
190.26 +by simp (* FIXME: same discrete_cpo - remove? is [iff] important? *)
190.27
190.28 subsection {* Type @{typ "'a discr"} is a cpo *}
190.29
191.1 --- a/src/HOLCF/Domain.thy Mon May 11 09:39:53 2009 +0200
191.2 +++ b/src/HOLCF/Domain.thy Mon May 11 17:20:52 2009 +0200
191.3 @@ -6,6 +6,14 @@
191.4
191.5 theory Domain
191.6 imports Ssum Sprod Up One Tr Fixrec
191.7 +uses
191.8 + ("Tools/cont_consts.ML")
191.9 + ("Tools/cont_proc.ML")
191.10 + ("Tools/domain/domain_library.ML")
191.11 + ("Tools/domain/domain_syntax.ML")
191.12 + ("Tools/domain/domain_axioms.ML")
191.13 + ("Tools/domain/domain_theorems.ML")
191.14 + ("Tools/domain/domain_extender.ML")
191.15 begin
191.16
191.17 defaultsort pcpo
191.18 @@ -25,7 +33,7 @@
191.19 lemma swap: "iso rep abs"
191.20 by (rule iso.intro [OF rep_iso abs_iso])
191.21
191.22 -lemma abs_less: "(abs\<cdot>x \<sqsubseteq> abs\<cdot>y) = (x \<sqsubseteq> y)"
191.23 +lemma abs_below: "(abs\<cdot>x \<sqsubseteq> abs\<cdot>y) = (x \<sqsubseteq> y)"
191.24 proof
191.25 assume "abs\<cdot>x \<sqsubseteq> abs\<cdot>y"
191.26 then have "rep\<cdot>(abs\<cdot>x) \<sqsubseteq> rep\<cdot>(abs\<cdot>y)" by (rule monofun_cfun_arg)
191.27 @@ -35,11 +43,11 @@
191.28 then show "abs\<cdot>x \<sqsubseteq> abs\<cdot>y" by (rule monofun_cfun_arg)
191.29 qed
191.30
191.31 -lemma rep_less: "(rep\<cdot>x \<sqsubseteq> rep\<cdot>y) = (x \<sqsubseteq> y)"
191.32 - by (rule iso.abs_less [OF swap])
191.33 +lemma rep_below: "(rep\<cdot>x \<sqsubseteq> rep\<cdot>y) = (x \<sqsubseteq> y)"
191.34 + by (rule iso.abs_below [OF swap])
191.35
191.36 lemma abs_eq: "(abs\<cdot>x = abs\<cdot>y) = (x = y)"
191.37 - by (simp add: po_eq_conv abs_less)
191.38 + by (simp add: po_eq_conv abs_below)
191.39
191.40 lemma rep_eq: "(rep\<cdot>x = rep\<cdot>y) = (x = y)"
191.41 by (rule iso.abs_eq [OF swap])
191.42 @@ -83,7 +91,7 @@
191.43 assume "adm (\<lambda>y. \<not> abs\<cdot>x \<sqsubseteq> y)"
191.44 with cont_Rep_CFun2
191.45 have "adm (\<lambda>y. \<not> abs\<cdot>x \<sqsubseteq> abs\<cdot>y)" by (rule adm_subst)
191.46 - then show "adm (\<lambda>y. \<not> x \<sqsubseteq> y)" using abs_less by simp
191.47 + then show "adm (\<lambda>y. \<not> x \<sqsubseteq> y)" using abs_below by simp
191.48 qed
191.49
191.50 lemma compact_rep_rev: "compact (rep\<cdot>x) \<Longrightarrow> compact x"
191.51 @@ -193,4 +201,24 @@
191.52
191.53 lemmas exh_casedists = exh_casedist1 exh_casedist2 exh_casedist3
191.54
191.55 +
191.56 +subsection {* Installing the domain package *}
191.57 +
191.58 +lemmas con_strict_rules =
191.59 + sinl_strict sinr_strict spair_strict1 spair_strict2
191.60 +
191.61 +lemmas con_defin_rules =
191.62 + sinl_defined sinr_defined spair_defined up_defined ONE_defined
191.63 +
191.64 +lemmas con_defined_iff_rules =
191.65 + sinl_defined_iff sinr_defined_iff spair_strict_iff up_defined ONE_defined
191.66 +
191.67 +use "Tools/cont_consts.ML"
191.68 +use "Tools/cont_proc.ML"
191.69 +use "Tools/domain/domain_library.ML"
191.70 +use "Tools/domain/domain_syntax.ML"
191.71 +use "Tools/domain/domain_axioms.ML"
191.72 +use "Tools/domain/domain_theorems.ML"
191.73 +use "Tools/domain/domain_extender.ML"
191.74 +
191.75 end
192.1 --- a/src/HOLCF/FOCUS/Stream_adm.thy Mon May 11 09:39:53 2009 +0200
192.2 +++ b/src/HOLCF/FOCUS/Stream_adm.thy Mon May 11 17:20:52 2009 +0200
192.3 @@ -50,11 +50,7 @@
192.4 apply ( erule spec)
192.5 apply ( assumption)
192.6 apply ( assumption)
192.7 -apply (drule not_ex [THEN iffD1])
192.8 -apply (subst slen_infinite)
192.9 -apply (erule thin_rl)
192.10 -apply (erule_tac x = j in allE)
192.11 -apply auto
192.12 +apply (metis inat_ord_code(4) slen_infinite)
192.13 done
192.14
192.15 (* should be without reference to stream length? *)
193.1 --- a/src/HOLCF/Ffun.thy Mon May 11 09:39:53 2009 +0200
193.2 +++ b/src/HOLCF/Ffun.thy Mon May 11 17:20:52 2009 +0200
193.3 @@ -10,11 +10,11 @@
193.4
193.5 subsection {* Full function space is a partial order *}
193.6
193.7 -instantiation "fun" :: (type, sq_ord) sq_ord
193.8 +instantiation "fun" :: (type, below) below
193.9 begin
193.10
193.11 definition
193.12 - less_fun_def: "(op \<sqsubseteq>) \<equiv> (\<lambda>f g. \<forall>x. f x \<sqsubseteq> g x)"
193.13 + below_fun_def: "(op \<sqsubseteq>) \<equiv> (\<lambda>f g. \<forall>x. f x \<sqsubseteq> g x)"
193.14
193.15 instance ..
193.16 end
193.17 @@ -23,45 +23,45 @@
193.18 proof
193.19 fix f :: "'a \<Rightarrow> 'b"
193.20 show "f \<sqsubseteq> f"
193.21 - by (simp add: less_fun_def)
193.22 + by (simp add: below_fun_def)
193.23 next
193.24 fix f g :: "'a \<Rightarrow> 'b"
193.25 assume "f \<sqsubseteq> g" and "g \<sqsubseteq> f" thus "f = g"
193.26 - by (simp add: less_fun_def expand_fun_eq antisym_less)
193.27 + by (simp add: below_fun_def expand_fun_eq below_antisym)
193.28 next
193.29 fix f g h :: "'a \<Rightarrow> 'b"
193.30 assume "f \<sqsubseteq> g" and "g \<sqsubseteq> h" thus "f \<sqsubseteq> h"
193.31 - unfolding less_fun_def by (fast elim: trans_less)
193.32 + unfolding below_fun_def by (fast elim: below_trans)
193.33 qed
193.34
193.35 text {* make the symbol @{text "<<"} accessible for type fun *}
193.36
193.37 -lemma expand_fun_less: "(f \<sqsubseteq> g) = (\<forall>x. f x \<sqsubseteq> g x)"
193.38 -by (simp add: less_fun_def)
193.39 +lemma expand_fun_below: "(f \<sqsubseteq> g) = (\<forall>x. f x \<sqsubseteq> g x)"
193.40 +by (simp add: below_fun_def)
193.41
193.42 -lemma less_fun_ext: "(\<And>x. f x \<sqsubseteq> g x) \<Longrightarrow> f \<sqsubseteq> g"
193.43 -by (simp add: less_fun_def)
193.44 +lemma below_fun_ext: "(\<And>x. f x \<sqsubseteq> g x) \<Longrightarrow> f \<sqsubseteq> g"
193.45 +by (simp add: below_fun_def)
193.46
193.47 subsection {* Full function space is chain complete *}
193.48
193.49 text {* function application is monotone *}
193.50
193.51 lemma monofun_app: "monofun (\<lambda>f. f x)"
193.52 -by (rule monofunI, simp add: less_fun_def)
193.53 +by (rule monofunI, simp add: below_fun_def)
193.54
193.55 text {* chains of functions yield chains in the po range *}
193.56
193.57 lemma ch2ch_fun: "chain S \<Longrightarrow> chain (\<lambda>i. S i x)"
193.58 -by (simp add: chain_def less_fun_def)
193.59 +by (simp add: chain_def below_fun_def)
193.60
193.61 lemma ch2ch_lambda: "(\<And>x. chain (\<lambda>i. S i x)) \<Longrightarrow> chain S"
193.62 -by (simp add: chain_def less_fun_def)
193.63 +by (simp add: chain_def below_fun_def)
193.64
193.65 text {* upper bounds of function chains yield upper bound in the po range *}
193.66
193.67 lemma ub2ub_fun:
193.68 "range S <| u \<Longrightarrow> range (\<lambda>i. S i x) <| u x"
193.69 -by (auto simp add: is_ub_def less_fun_def)
193.70 +by (auto simp add: is_ub_def below_fun_def)
193.71
193.72 text {* Type @{typ "'a::type => 'b::cpo"} is chain complete *}
193.73
193.74 @@ -70,9 +70,9 @@
193.75 shows "range Y <<| f"
193.76 apply (rule is_lubI)
193.77 apply (rule ub_rangeI)
193.78 -apply (rule less_fun_ext)
193.79 +apply (rule below_fun_ext)
193.80 apply (rule is_ub_lub [OF f])
193.81 -apply (rule less_fun_ext)
193.82 +apply (rule below_fun_ext)
193.83 apply (rule is_lub_lub [OF f])
193.84 apply (erule ub2ub_fun)
193.85 done
193.86 @@ -103,7 +103,7 @@
193.87 proof
193.88 fix f g :: "'a \<Rightarrow> 'b"
193.89 show "f \<sqsubseteq> g \<longleftrightarrow> f = g"
193.90 - unfolding expand_fun_less expand_fun_eq
193.91 + unfolding expand_fun_below expand_fun_eq
193.92 by simp
193.93 qed
193.94
193.95 @@ -148,7 +148,7 @@
193.96 subsection {* Full function space is pointed *}
193.97
193.98 lemma minimal_fun: "(\<lambda>x. \<bottom>) \<sqsubseteq> f"
193.99 -by (simp add: less_fun_def)
193.100 +by (simp add: below_fun_def)
193.101
193.102 lemma least_fun: "\<exists>x::'a::type \<Rightarrow> 'b::pcpo. \<forall>y. x \<sqsubseteq> y"
193.103 apply (rule_tac x = "\<lambda>x. \<bottom>" in exI)
193.104 @@ -171,13 +171,13 @@
193.105 *}
193.106
193.107 lemma monofun_fun_fun: "f \<sqsubseteq> g \<Longrightarrow> f x \<sqsubseteq> g x"
193.108 -by (simp add: less_fun_def)
193.109 +by (simp add: below_fun_def)
193.110
193.111 lemma monofun_fun_arg: "\<lbrakk>monofun f; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> f x \<sqsubseteq> f y"
193.112 by (rule monofunE)
193.113
193.114 lemma monofun_fun: "\<lbrakk>monofun f; monofun g; f \<sqsubseteq> g; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> f x \<sqsubseteq> g y"
193.115 -by (rule trans_less [OF monofun_fun_arg monofun_fun_fun])
193.116 +by (rule below_trans [OF monofun_fun_arg monofun_fun_fun])
193.117
193.118 subsection {* Propagation of monotonicity and continuity *}
193.119
193.120 @@ -236,7 +236,7 @@
193.121 lemma mono2mono_lambda:
193.122 assumes f: "\<And>y. monofun (\<lambda>x. f x y)" shows "monofun f"
193.123 apply (rule monofunI)
193.124 -apply (rule less_fun_ext)
193.125 +apply (rule below_fun_ext)
193.126 apply (erule monofunE [OF f])
193.127 done
193.128
193.129 @@ -296,4 +296,3 @@
193.130 by (rule cont2cont_app2 [OF cont_const])
193.131
193.132 end
193.133 -
194.1 --- a/src/HOLCF/Fix.thy Mon May 11 09:39:53 2009 +0200
194.2 +++ b/src/HOLCF/Fix.thy Mon May 11 17:20:52 2009 +0200
194.3 @@ -90,7 +90,7 @@
194.4 apply simp
194.5 done
194.6
194.7 -lemma fix_least_less: "F\<cdot>x \<sqsubseteq> x \<Longrightarrow> fix\<cdot>F \<sqsubseteq> x"
194.8 +lemma fix_least_below: "F\<cdot>x \<sqsubseteq> x \<Longrightarrow> fix\<cdot>F \<sqsubseteq> x"
194.9 apply (simp add: fix_def2)
194.10 apply (rule is_lub_thelub)
194.11 apply (rule chain_iterate)
194.12 @@ -98,17 +98,17 @@
194.13 apply (induct_tac i)
194.14 apply simp
194.15 apply simp
194.16 -apply (erule rev_trans_less)
194.17 +apply (erule rev_below_trans)
194.18 apply (erule monofun_cfun_arg)
194.19 done
194.20
194.21 lemma fix_least: "F\<cdot>x = x \<Longrightarrow> fix\<cdot>F \<sqsubseteq> x"
194.22 -by (rule fix_least_less, simp)
194.23 +by (rule fix_least_below, simp)
194.24
194.25 lemma fix_eqI:
194.26 assumes fixed: "F\<cdot>x = x" and least: "\<And>z. F\<cdot>z = z \<Longrightarrow> x \<sqsubseteq> z"
194.27 shows "fix\<cdot>F = x"
194.28 -apply (rule antisym_less)
194.29 +apply (rule below_antisym)
194.30 apply (rule fix_least [OF fixed])
194.31 apply (rule least [OF fix_eq [symmetric]])
194.32 done
194.33 @@ -230,10 +230,10 @@
194.34 have "?y1 \<sqsubseteq> y" by (rule fix_least, simp add: F_y)
194.35 hence "cfst\<cdot>(F\<cdot>\<langle>x, ?y1\<rangle>) \<sqsubseteq> cfst\<cdot>(F\<cdot>\<langle>x, y\<rangle>)" by (simp add: monofun_cfun)
194.36 hence "cfst\<cdot>(F\<cdot>\<langle>x, ?y1\<rangle>) \<sqsubseteq> x" using F_x by simp
194.37 - hence 1: "?x \<sqsubseteq> x" by (simp add: fix_least_less)
194.38 + hence 1: "?x \<sqsubseteq> x" by (simp add: fix_least_below)
194.39 hence "csnd\<cdot>(F\<cdot>\<langle>?x, y\<rangle>) \<sqsubseteq> csnd\<cdot>(F\<cdot>\<langle>x, y\<rangle>)" by (simp add: monofun_cfun)
194.40 hence "csnd\<cdot>(F\<cdot>\<langle>?x, y\<rangle>) \<sqsubseteq> y" using F_y by simp
194.41 - hence 2: "?y \<sqsubseteq> y" by (simp add: fix_least_less)
194.42 + hence 2: "?y \<sqsubseteq> y" by (simp add: fix_least_below)
194.43 show "\<langle>?x, ?y\<rangle> \<sqsubseteq> z" using z 1 2 by simp
194.44 qed
194.45
195.1 --- a/src/HOLCF/Fixrec.thy Mon May 11 09:39:53 2009 +0200
195.2 +++ b/src/HOLCF/Fixrec.thy Mon May 11 17:20:52 2009 +0200
195.3 @@ -475,86 +475,96 @@
195.4 defaultsort pcpo
195.5
195.6 definition
195.7 - match_UU :: "'a \<rightarrow> unit maybe" where
195.8 - "match_UU = (\<Lambda> x. fail)"
195.9 + match_UU :: "'a \<rightarrow> 'c maybe \<rightarrow> 'c maybe"
195.10 +where
195.11 + "match_UU = strictify\<cdot>(\<Lambda> x k. fail)"
195.12
195.13 definition
195.14 - match_cpair :: "'a::cpo \<times> 'b::cpo \<rightarrow> ('a \<times> 'b) maybe" where
195.15 - "match_cpair = csplit\<cdot>(\<Lambda> x y. return\<cdot><x,y>)"
195.16 + match_cpair :: "'a::cpo \<times> 'b::cpo \<rightarrow> ('a \<rightarrow> 'b \<rightarrow> 'c maybe) \<rightarrow> 'c maybe"
195.17 +where
195.18 + "match_cpair = (\<Lambda> x k. csplit\<cdot>k\<cdot>x)"
195.19
195.20 definition
195.21 - match_spair :: "'a \<otimes> 'b \<rightarrow> ('a \<times> 'b) maybe" where
195.22 - "match_spair = ssplit\<cdot>(\<Lambda> x y. return\<cdot><x,y>)"
195.23 + match_spair :: "'a \<otimes> 'b \<rightarrow> ('a \<rightarrow> 'b \<rightarrow> 'c maybe) \<rightarrow> 'c maybe"
195.24 +where
195.25 + "match_spair = (\<Lambda> x k. ssplit\<cdot>k\<cdot>x)"
195.26
195.27 definition
195.28 - match_sinl :: "'a \<oplus> 'b \<rightarrow> 'a maybe" where
195.29 - "match_sinl = sscase\<cdot>return\<cdot>(\<Lambda> y. fail)"
195.30 + match_sinl :: "'a \<oplus> 'b \<rightarrow> ('a \<rightarrow> 'c maybe) \<rightarrow> 'c maybe"
195.31 +where
195.32 + "match_sinl = (\<Lambda> x k. sscase\<cdot>k\<cdot>(\<Lambda> b. fail)\<cdot>x)"
195.33
195.34 definition
195.35 - match_sinr :: "'a \<oplus> 'b \<rightarrow> 'b maybe" where
195.36 - "match_sinr = sscase\<cdot>(\<Lambda> x. fail)\<cdot>return"
195.37 + match_sinr :: "'a \<oplus> 'b \<rightarrow> ('b \<rightarrow> 'c maybe) \<rightarrow> 'c maybe"
195.38 +where
195.39 + "match_sinr = (\<Lambda> x k. sscase\<cdot>(\<Lambda> a. fail)\<cdot>k\<cdot>x)"
195.40
195.41 definition
195.42 - match_up :: "'a::cpo u \<rightarrow> 'a maybe" where
195.43 - "match_up = fup\<cdot>return"
195.44 + match_up :: "'a::cpo u \<rightarrow> ('a \<rightarrow> 'c maybe) \<rightarrow> 'c maybe"
195.45 +where
195.46 + "match_up = (\<Lambda> x k. fup\<cdot>k\<cdot>x)"
195.47
195.48 definition
195.49 - match_ONE :: "one \<rightarrow> unit maybe" where
195.50 - "match_ONE = (\<Lambda> ONE. return\<cdot>())"
195.51 + match_ONE :: "one \<rightarrow> 'c maybe \<rightarrow> 'c maybe"
195.52 +where
195.53 + "match_ONE = (\<Lambda> ONE k. k)"
195.54 +
195.55 +definition
195.56 + match_TT :: "tr \<rightarrow> 'c maybe \<rightarrow> 'c maybe"
195.57 +where
195.58 + "match_TT = (\<Lambda> x k. If x then k else fail fi)"
195.59
195.60 definition
195.61 - match_TT :: "tr \<rightarrow> unit maybe" where
195.62 - "match_TT = (\<Lambda> b. If b then return\<cdot>() else fail fi)"
195.63 -
195.64 -definition
195.65 - match_FF :: "tr \<rightarrow> unit maybe" where
195.66 - "match_FF = (\<Lambda> b. If b then fail else return\<cdot>() fi)"
195.67 + match_FF :: "tr \<rightarrow> 'c maybe \<rightarrow> 'c maybe"
195.68 +where
195.69 + "match_FF = (\<Lambda> x k. If x then fail else k fi)"
195.70
195.71 lemma match_UU_simps [simp]:
195.72 - "match_UU\<cdot>x = fail"
195.73 -by (simp add: match_UU_def)
195.74 + "match_UU\<cdot>\<bottom>\<cdot>k = \<bottom>"
195.75 + "x \<noteq> \<bottom> \<Longrightarrow> match_UU\<cdot>x\<cdot>k = fail"
195.76 +by (simp_all add: match_UU_def)
195.77
195.78 lemma match_cpair_simps [simp]:
195.79 - "match_cpair\<cdot><x,y> = return\<cdot><x,y>"
195.80 + "match_cpair\<cdot>\<langle>x, y\<rangle>\<cdot>k = k\<cdot>x\<cdot>y"
195.81 by (simp add: match_cpair_def)
195.82
195.83 lemma match_spair_simps [simp]:
195.84 - "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> match_spair\<cdot>(:x,y:) = return\<cdot><x,y>"
195.85 - "match_spair\<cdot>\<bottom> = \<bottom>"
195.86 + "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> match_spair\<cdot>(:x, y:)\<cdot>k = k\<cdot>x\<cdot>y"
195.87 + "match_spair\<cdot>\<bottom>\<cdot>k = \<bottom>"
195.88 by (simp_all add: match_spair_def)
195.89
195.90 lemma match_sinl_simps [simp]:
195.91 - "x \<noteq> \<bottom> \<Longrightarrow> match_sinl\<cdot>(sinl\<cdot>x) = return\<cdot>x"
195.92 - "x \<noteq> \<bottom> \<Longrightarrow> match_sinl\<cdot>(sinr\<cdot>x) = fail"
195.93 - "match_sinl\<cdot>\<bottom> = \<bottom>"
195.94 + "x \<noteq> \<bottom> \<Longrightarrow> match_sinl\<cdot>(sinl\<cdot>x)\<cdot>k = k\<cdot>x"
195.95 + "y \<noteq> \<bottom> \<Longrightarrow> match_sinl\<cdot>(sinr\<cdot>y)\<cdot>k = fail"
195.96 + "match_sinl\<cdot>\<bottom>\<cdot>k = \<bottom>"
195.97 by (simp_all add: match_sinl_def)
195.98
195.99 lemma match_sinr_simps [simp]:
195.100 - "x \<noteq> \<bottom> \<Longrightarrow> match_sinr\<cdot>(sinr\<cdot>x) = return\<cdot>x"
195.101 - "x \<noteq> \<bottom> \<Longrightarrow> match_sinr\<cdot>(sinl\<cdot>x) = fail"
195.102 - "match_sinr\<cdot>\<bottom> = \<bottom>"
195.103 + "x \<noteq> \<bottom> \<Longrightarrow> match_sinr\<cdot>(sinl\<cdot>x)\<cdot>k = fail"
195.104 + "y \<noteq> \<bottom> \<Longrightarrow> match_sinr\<cdot>(sinr\<cdot>y)\<cdot>k = k\<cdot>y"
195.105 + "match_sinr\<cdot>\<bottom>\<cdot>k = \<bottom>"
195.106 by (simp_all add: match_sinr_def)
195.107
195.108 lemma match_up_simps [simp]:
195.109 - "match_up\<cdot>(up\<cdot>x) = return\<cdot>x"
195.110 - "match_up\<cdot>\<bottom> = \<bottom>"
195.111 + "match_up\<cdot>(up\<cdot>x)\<cdot>k = k\<cdot>x"
195.112 + "match_up\<cdot>\<bottom>\<cdot>k = \<bottom>"
195.113 by (simp_all add: match_up_def)
195.114
195.115 lemma match_ONE_simps [simp]:
195.116 - "match_ONE\<cdot>ONE = return\<cdot>()"
195.117 - "match_ONE\<cdot>\<bottom> = \<bottom>"
195.118 + "match_ONE\<cdot>ONE\<cdot>k = k"
195.119 + "match_ONE\<cdot>\<bottom>\<cdot>k = \<bottom>"
195.120 by (simp_all add: match_ONE_def)
195.121
195.122 lemma match_TT_simps [simp]:
195.123 - "match_TT\<cdot>TT = return\<cdot>()"
195.124 - "match_TT\<cdot>FF = fail"
195.125 - "match_TT\<cdot>\<bottom> = \<bottom>"
195.126 + "match_TT\<cdot>TT\<cdot>k = k"
195.127 + "match_TT\<cdot>FF\<cdot>k = fail"
195.128 + "match_TT\<cdot>\<bottom>\<cdot>k = \<bottom>"
195.129 by (simp_all add: match_TT_def)
195.130
195.131 lemma match_FF_simps [simp]:
195.132 - "match_FF\<cdot>FF = return\<cdot>()"
195.133 - "match_FF\<cdot>TT = fail"
195.134 - "match_FF\<cdot>\<bottom> = \<bottom>"
195.135 + "match_FF\<cdot>FF\<cdot>k = k"
195.136 + "match_FF\<cdot>TT\<cdot>k = fail"
195.137 + "match_FF\<cdot>\<bottom>\<cdot>k = \<bottom>"
195.138 by (simp_all add: match_FF_def)
195.139
195.140 subsection {* Mutual recursion *}
195.141 @@ -594,7 +604,8 @@
195.142 (@{const_name cpair}, @{const_name match_cpair}),
195.143 (@{const_name ONE}, @{const_name match_ONE}),
195.144 (@{const_name TT}, @{const_name match_TT}),
195.145 - (@{const_name FF}, @{const_name match_FF}) ]
195.146 + (@{const_name FF}, @{const_name match_FF}),
195.147 + (@{const_name UU}, @{const_name match_UU}) ]
195.148 *}
195.149
195.150 hide (open) const return bind fail run cases
196.1 --- a/src/HOLCF/HOLCF.thy Mon May 11 09:39:53 2009 +0200
196.2 +++ b/src/HOLCF/HOLCF.thy Mon May 11 17:20:52 2009 +0200
196.3 @@ -9,13 +9,6 @@
196.4 Domain ConvexPD Algebraic Universal Sum_Cpo Main
196.5 uses
196.6 "holcf_logic.ML"
196.7 - "Tools/cont_consts.ML"
196.8 - "Tools/cont_proc.ML"
196.9 - "Tools/domain/domain_library.ML"
196.10 - "Tools/domain/domain_syntax.ML"
196.11 - "Tools/domain/domain_axioms.ML"
196.12 - "Tools/domain/domain_theorems.ML"
196.13 - "Tools/domain/domain_extender.ML"
196.14 "Tools/adm_tac.ML"
196.15 begin
196.16
196.17 @@ -28,4 +21,58 @@
196.18 (cut_facts_tac (Simplifier.prems_of_ss ss) THEN' cont_tacRs ss))));
196.19 *}
196.20
196.21 +text {* Legacy theorem names *}
196.22 +
196.23 +lemmas sq_ord_less_eq_trans = below_eq_trans
196.24 +lemmas sq_ord_eq_less_trans = eq_below_trans
196.25 +lemmas refl_less = below_refl
196.26 +lemmas trans_less = below_trans
196.27 +lemmas antisym_less = below_antisym
196.28 +lemmas antisym_less_inverse = below_antisym_inverse
196.29 +lemmas box_less = box_below
196.30 +lemmas rev_trans_less = rev_below_trans
196.31 +lemmas not_less2not_eq = not_below2not_eq
196.32 +lemmas less_UU_iff = below_UU_iff
196.33 +lemmas flat_less_iff = flat_below_iff
196.34 +lemmas adm_less = adm_below
196.35 +lemmas adm_not_less = adm_not_below
196.36 +lemmas adm_compact_not_less = adm_compact_not_below
196.37 +lemmas less_fun_def = below_fun_def
196.38 +lemmas expand_fun_less = expand_fun_below
196.39 +lemmas less_fun_ext = below_fun_ext
196.40 +lemmas less_discr_def = below_discr_def
196.41 +lemmas discr_less_eq = discr_below_eq
196.42 +lemmas less_unit_def = below_unit_def
196.43 +lemmas less_cprod_def = below_prod_def
196.44 +lemmas prod_lessI = prod_belowI
196.45 +lemmas Pair_less_iff = Pair_below_iff
196.46 +lemmas fst_less_iff = fst_below_iff
196.47 +lemmas snd_less_iff = snd_below_iff
196.48 +lemmas expand_cfun_less = expand_cfun_below
196.49 +lemmas less_cfun_ext = below_cfun_ext
196.50 +lemmas injection_less = injection_below
196.51 +lemmas approx_less = approx_below
196.52 +lemmas profinite_less_ext = profinite_below_ext
196.53 +lemmas less_up_def = below_up_def
196.54 +lemmas not_Iup_less = not_Iup_below
196.55 +lemmas Iup_less = Iup_below
196.56 +lemmas up_less = up_below
196.57 +lemmas cpair_less = cpair_below
196.58 +lemmas less_cprod = below_cprod
196.59 +lemmas cfst_less_iff = cfst_below_iff
196.60 +lemmas csnd_less_iff = csnd_below_iff
196.61 +lemmas Def_inject_less_eq = Def_below_Def
196.62 +lemmas Def_less_is_eq = Def_below_iff
196.63 +lemmas spair_less_iff = spair_below_iff
196.64 +lemmas less_sprod = below_sprod
196.65 +lemmas spair_less = spair_below
196.66 +lemmas sfst_less_iff = sfst_below_iff
196.67 +lemmas ssnd_less_iff = ssnd_below_iff
196.68 +lemmas fix_least_less = fix_least_below
196.69 +lemmas dist_less_one = dist_below_one
196.70 +lemmas less_ONE = below_ONE
196.71 +lemmas ONE_less_iff = ONE_below_iff
196.72 +lemmas less_sinlD = below_sinlD
196.73 +lemmas less_sinrD = below_sinrD
196.74 +
196.75 end
197.1 --- a/src/HOLCF/IOA/meta_theory/Sequence.thy Mon May 11 09:39:53 2009 +0200
197.2 +++ b/src/HOLCF/IOA/meta_theory/Sequence.thy Mon May 11 17:20:52 2009 +0200
197.3 @@ -288,8 +288,7 @@
197.4
197.5 lemma Cons_not_UU: "a>>s ~= UU"
197.6 apply (subst Consq_def2)
197.7 -apply (rule seq.con_rews)
197.8 -apply (rule Def_not_UU)
197.9 +apply simp
197.10 done
197.11
197.12
198.1 --- a/src/HOLCF/IOA/meta_theory/ioa_package.ML Mon May 11 09:39:53 2009 +0200
198.2 +++ b/src/HOLCF/IOA/meta_theory/ioa_package.ML Mon May 11 17:20:52 2009 +0200
198.3 @@ -347,12 +347,12 @@
198.4 val alt_string = make_alt_string thy inp_head_list out_head_list int_head_list
198.5 atyp statetupel trans;
198.6 val thy2 = (thy
198.7 -|> ContConsts.add_consts
198.8 -[(automaton_name ^ "_initial", "(" ^ state_type_string ^ ")set" ,NoSyn),
198.9 -(automaton_name ^ "_asig", "(" ^ action_type ^ ")signature" ,NoSyn),
198.10 -(automaton_name ^ "_trans",
198.11 +|> Sign.add_consts
198.12 +[(Binding.name (automaton_name ^ "_initial"), "(" ^ state_type_string ^ ")set" ,NoSyn),
198.13 +(Binding.name (automaton_name ^ "_asig"), "(" ^ action_type ^ ")signature" ,NoSyn),
198.14 +(Binding.name (automaton_name ^ "_trans"),
198.15 "(" ^ action_type ^ "," ^ state_type_string ^ ")transition set" ,NoSyn),
198.16 -(automaton_name, "(" ^ action_type ^ "," ^ state_type_string ^ ")ioa" ,NoSyn)]
198.17 +(Binding.name automaton_name, "(" ^ action_type ^ "," ^ state_type_string ^ ")ioa" ,NoSyn)]
198.18 |> add_defs
198.19 [(automaton_name ^ "_initial_def",
198.20 automaton_name ^ "_initial == {" ^ state_vars_tupel ^ "." ^ ini ^ "}"),
198.21 @@ -386,8 +386,8 @@
198.22 val comp_list = clist aut_list;
198.23 in
198.24 thy
198.25 -|> ContConsts.add_consts_i
198.26 -[(automaton_name,
198.27 +|> Sign.add_consts_i
198.28 +[(Binding.name automaton_name,
198.29 Type("*",
198.30 [Type("*",[Type("set",[acttyp]),Type("*",[Type("set",[acttyp]),Type("set",[acttyp])])]),
198.31 Type("*",[Type("set",[st_typ]),
198.32 @@ -407,8 +407,8 @@
198.33 val rest_set = action_set_string thy acttyp actlist
198.34 in
198.35 thy
198.36 -|> ContConsts.add_consts_i
198.37 -[(automaton_name, auttyp,NoSyn)]
198.38 +|> Sign.add_consts_i
198.39 +[(Binding.name automaton_name, auttyp,NoSyn)]
198.40 |> add_defs
198.41 [(automaton_name ^ "_def",
198.42 automaton_name ^ " == restrict " ^ aut_source ^ " " ^ rest_set)]
198.43 @@ -421,8 +421,8 @@
198.44 val hid_set = action_set_string thy acttyp actlist
198.45 in
198.46 thy
198.47 -|> ContConsts.add_consts_i
198.48 -[(automaton_name, auttyp,NoSyn)]
198.49 +|> Sign.add_consts_i
198.50 +[(Binding.name automaton_name, auttyp,NoSyn)]
198.51 |> add_defs
198.52 [(automaton_name ^ "_def",
198.53 automaton_name ^ " == hide " ^ aut_source ^ " " ^ hid_set)]
198.54 @@ -441,8 +441,8 @@
198.55 val acttyp = ren_act_type_of thy fun_name
198.56 in
198.57 thy
198.58 -|> ContConsts.add_consts_i
198.59 -[(automaton_name,
198.60 +|> Sign.add_consts_i
198.61 +[(Binding.name automaton_name,
198.62 Type("*",
198.63 [Type("*",[Type("set",[acttyp]),Type("*",[Type("set",[acttyp]),Type("set",[acttyp])])]),
198.64 Type("*",[Type("set",[st_typ]),
199.1 --- a/src/HOLCF/IsaMakefile Mon May 11 09:39:53 2009 +0200
199.2 +++ b/src/HOLCF/IsaMakefile Mon May 11 17:20:52 2009 +0200
199.3 @@ -87,10 +87,19 @@
199.4
199.5 HOLCF-ex: HOLCF $(LOG)/HOLCF-ex.gz
199.6
199.7 -$(LOG)/HOLCF-ex.gz: $(OUT)/HOLCF ex/Stream.thy ex/Dagstuhl.thy \
199.8 - ex/Dnat.thy ex/Fix2.thy ex/Focus_ex.thy ex/Hoare.thy ex/Loop.thy \
199.9 +$(LOG)/HOLCF-ex.gz: $(OUT)/HOLCF \
199.10 + ../HOL/Library/Nat_Infinity.thy \
199.11 + ex/Dagstuhl.thy \
199.12 + ex/Dnat.thy \
199.13 + ex/Domain_ex.thy \
199.14 + ex/Fix2.thy \
199.15 + ex/Fixrec_ex.thy \
199.16 + ex/Focus_ex.thy \
199.17 + ex/Hoare.thy \
199.18 + ex/Loop.thy \
199.19 ex/Powerdomain_ex.thy \
199.20 - ex/ROOT.ML ex/Fixrec_ex.thy ../HOL/Library/Nat_Infinity.thy
199.21 + ex/Stream.thy \
199.22 + ex/ROOT.ML
199.23 @$(ISABELLE_TOOL) usedir $(OUT)/HOLCF ex
199.24
199.25
200.1 --- a/src/HOLCF/Lift.thy Mon May 11 09:39:53 2009 +0200
200.2 +++ b/src/HOLCF/Lift.thy Mon May 11 17:20:52 2009 +0200
200.3 @@ -70,11 +70,11 @@
200.4 lemma DefE2: "\<lbrakk>x = Def s; x = \<bottom>\<rbrakk> \<Longrightarrow> R"
200.5 by simp
200.6
200.7 -lemma Def_inject_less_eq: "Def x \<sqsubseteq> Def y \<longleftrightarrow> x = y"
200.8 -by (simp add: less_lift_def Def_def Abs_lift_inverse lift_def)
200.9 +lemma Def_below_Def: "Def x \<sqsubseteq> Def y \<longleftrightarrow> x = y"
200.10 +by (simp add: below_lift_def Def_def Abs_lift_inverse lift_def)
200.11
200.12 -lemma Def_less_is_eq [simp]: "Def x \<sqsubseteq> y \<longleftrightarrow> Def x = y"
200.13 -by (induct y, simp, simp add: Def_inject_less_eq)
200.14 +lemma Def_below_iff [simp]: "Def x \<sqsubseteq> y \<longleftrightarrow> Def x = y"
200.15 +by (induct y, simp, simp add: Def_below_Def)
200.16
200.17
200.18 subsection {* Lift is flat *}
200.19 @@ -134,7 +134,7 @@
200.20 "(\<And>x. f x \<sqsubseteq> g x) \<Longrightarrow> (FLIFT x. f x) \<sqsubseteq> (FLIFT x. g x)"
200.21 apply (rule monofunE [where f=flift1])
200.22 apply (rule cont2mono [OF cont_flift1])
200.23 -apply (simp add: less_fun_ext)
200.24 +apply (simp add: below_fun_ext)
200.25 done
200.26
200.27 lemma cont2cont_flift1 [simp]:
200.28 @@ -216,7 +216,7 @@
200.29 apply (rule is_lubI)
200.30 apply (rule ub_rangeI, simp)
200.31 apply (drule ub_rangeD)
200.32 - apply (erule rev_trans_less)
200.33 + apply (erule rev_below_trans)
200.34 apply simp
200.35 apply (rule lessI)
200.36 done
201.1 --- a/src/HOLCF/LowerPD.thy Mon May 11 09:39:53 2009 +0200
201.2 +++ b/src/HOLCF/LowerPD.thy Mon May 11 17:20:52 2009 +0200
201.3 @@ -23,7 +23,7 @@
201.4 apply (drule (1) bspec, erule bexE)
201.5 apply (drule (1) bspec, erule bexE)
201.6 apply (erule rev_bexI)
201.7 -apply (erule (1) trans_less)
201.8 +apply (erule (1) below_trans)
201.9 done
201.10
201.11 interpretation lower_le: preorder lower_le
201.12 @@ -39,7 +39,7 @@
201.13 lemma PDPlus_lower_mono: "\<lbrakk>s \<le>\<flat> t; u \<le>\<flat> v\<rbrakk> \<Longrightarrow> PDPlus s u \<le>\<flat> PDPlus t v"
201.14 unfolding lower_le_def Rep_PDPlus by fast
201.15
201.16 -lemma PDPlus_lower_less: "t \<le>\<flat> PDPlus t u"
201.17 +lemma PDPlus_lower_le: "t \<le>\<flat> PDPlus t u"
201.18 unfolding lower_le_def Rep_PDPlus by fast
201.19
201.20 lemma lower_le_PDUnit_PDUnit_iff [simp]:
201.21 @@ -99,7 +99,7 @@
201.22 "{S::'a pd_basis set. lower_le.ideal S}"
201.23 by (fast intro: lower_le.ideal_principal)
201.24
201.25 -instantiation lower_pd :: (profinite) sq_ord
201.26 +instantiation lower_pd :: (profinite) below
201.27 begin
201.28
201.29 definition
201.30 @@ -110,16 +110,16 @@
201.31
201.32 instance lower_pd :: (profinite) po
201.33 by (rule lower_le.typedef_ideal_po
201.34 - [OF type_definition_lower_pd sq_le_lower_pd_def])
201.35 + [OF type_definition_lower_pd below_lower_pd_def])
201.36
201.37 instance lower_pd :: (profinite) cpo
201.38 by (rule lower_le.typedef_ideal_cpo
201.39 - [OF type_definition_lower_pd sq_le_lower_pd_def])
201.40 + [OF type_definition_lower_pd below_lower_pd_def])
201.41
201.42 lemma Rep_lower_pd_lub:
201.43 "chain Y \<Longrightarrow> Rep_lower_pd (\<Squnion>i. Y i) = (\<Union>i. Rep_lower_pd (Y i))"
201.44 by (rule lower_le.typedef_ideal_rep_contlub
201.45 - [OF type_definition_lower_pd sq_le_lower_pd_def])
201.46 + [OF type_definition_lower_pd below_lower_pd_def])
201.47
201.48 lemma ideal_Rep_lower_pd: "lower_le.ideal (Rep_lower_pd xs)"
201.49 by (rule Rep_lower_pd [unfolded mem_Collect_eq])
201.50 @@ -145,7 +145,7 @@
201.51 apply (rule ideal_Rep_lower_pd)
201.52 apply (erule Rep_lower_pd_lub)
201.53 apply (rule Rep_lower_principal)
201.54 -apply (simp only: sq_le_lower_pd_def)
201.55 +apply (simp only: below_lower_pd_def)
201.56 done
201.57
201.58 text {* Lower powerdomain is pointed *}
201.59 @@ -264,28 +264,28 @@
201.60 lemmas lower_plus_aci =
201.61 lower_plus_ac lower_plus_absorb lower_plus_left_absorb
201.62
201.63 -lemma lower_plus_less1: "xs \<sqsubseteq> xs +\<flat> ys"
201.64 +lemma lower_plus_below1: "xs \<sqsubseteq> xs +\<flat> ys"
201.65 apply (induct xs ys rule: lower_pd.principal_induct2, simp, simp)
201.66 -apply (simp add: PDPlus_lower_less)
201.67 +apply (simp add: PDPlus_lower_le)
201.68 done
201.69
201.70 -lemma lower_plus_less2: "ys \<sqsubseteq> xs +\<flat> ys"
201.71 -by (subst lower_plus_commute, rule lower_plus_less1)
201.72 +lemma lower_plus_below2: "ys \<sqsubseteq> xs +\<flat> ys"
201.73 +by (subst lower_plus_commute, rule lower_plus_below1)
201.74
201.75 lemma lower_plus_least: "\<lbrakk>xs \<sqsubseteq> zs; ys \<sqsubseteq> zs\<rbrakk> \<Longrightarrow> xs +\<flat> ys \<sqsubseteq> zs"
201.76 apply (subst lower_plus_absorb [of zs, symmetric])
201.77 apply (erule (1) monofun_cfun [OF monofun_cfun_arg])
201.78 done
201.79
201.80 -lemma lower_plus_less_iff:
201.81 +lemma lower_plus_below_iff:
201.82 "xs +\<flat> ys \<sqsubseteq> zs \<longleftrightarrow> xs \<sqsubseteq> zs \<and> ys \<sqsubseteq> zs"
201.83 apply safe
201.84 -apply (erule trans_less [OF lower_plus_less1])
201.85 -apply (erule trans_less [OF lower_plus_less2])
201.86 +apply (erule below_trans [OF lower_plus_below1])
201.87 +apply (erule below_trans [OF lower_plus_below2])
201.88 apply (erule (1) lower_plus_least)
201.89 done
201.90
201.91 -lemma lower_unit_less_plus_iff:
201.92 +lemma lower_unit_below_plus_iff:
201.93 "{x}\<flat> \<sqsubseteq> ys +\<flat> zs \<longleftrightarrow> {x}\<flat> \<sqsubseteq> ys \<or> {x}\<flat> \<sqsubseteq> zs"
201.94 apply (rule iffI)
201.95 apply (subgoal_tac
201.96 @@ -299,13 +299,13 @@
201.97 apply simp
201.98 apply simp
201.99 apply (erule disjE)
201.100 - apply (erule trans_less [OF _ lower_plus_less1])
201.101 - apply (erule trans_less [OF _ lower_plus_less2])
201.102 + apply (erule below_trans [OF _ lower_plus_below1])
201.103 + apply (erule below_trans [OF _ lower_plus_below2])
201.104 done
201.105
201.106 -lemma lower_unit_less_iff [simp]: "{x}\<flat> \<sqsubseteq> {y}\<flat> \<longleftrightarrow> x \<sqsubseteq> y"
201.107 +lemma lower_unit_below_iff [simp]: "{x}\<flat> \<sqsubseteq> {y}\<flat> \<longleftrightarrow> x \<sqsubseteq> y"
201.108 apply (rule iffI)
201.109 - apply (rule profinite_less_ext)
201.110 + apply (rule profinite_below_ext)
201.111 apply (drule_tac f="approx i" in monofun_cfun_arg, simp)
201.112 apply (cut_tac x="approx i\<cdot>x" in compact_basis.compact_imp_principal, simp)
201.113 apply (cut_tac x="approx i\<cdot>y" in compact_basis.compact_imp_principal, simp)
201.114 @@ -313,10 +313,10 @@
201.115 apply (erule monofun_cfun_arg)
201.116 done
201.117
201.118 -lemmas lower_pd_less_simps =
201.119 - lower_unit_less_iff
201.120 - lower_plus_less_iff
201.121 - lower_unit_less_plus_iff
201.122 +lemmas lower_pd_below_simps =
201.123 + lower_unit_below_iff
201.124 + lower_plus_below_iff
201.125 + lower_unit_below_plus_iff
201.126
201.127 lemma lower_unit_eq_iff [simp]: "{x}\<flat> = {y}\<flat> \<longleftrightarrow> x = y"
201.128 by (simp add: po_eq_conv)
201.129 @@ -330,18 +330,18 @@
201.130 lemma lower_plus_strict_iff [simp]:
201.131 "xs +\<flat> ys = \<bottom> \<longleftrightarrow> xs = \<bottom> \<and> ys = \<bottom>"
201.132 apply safe
201.133 -apply (rule UU_I, erule subst, rule lower_plus_less1)
201.134 -apply (rule UU_I, erule subst, rule lower_plus_less2)
201.135 +apply (rule UU_I, erule subst, rule lower_plus_below1)
201.136 +apply (rule UU_I, erule subst, rule lower_plus_below2)
201.137 apply (rule lower_plus_absorb)
201.138 done
201.139
201.140 lemma lower_plus_strict1 [simp]: "\<bottom> +\<flat> ys = ys"
201.141 -apply (rule antisym_less [OF _ lower_plus_less2])
201.142 +apply (rule below_antisym [OF _ lower_plus_below2])
201.143 apply (simp add: lower_plus_least)
201.144 done
201.145
201.146 lemma lower_plus_strict2 [simp]: "xs +\<flat> \<bottom> = xs"
201.147 -apply (rule antisym_less [OF _ lower_plus_less1])
201.148 +apply (rule below_antisym [OF _ lower_plus_below1])
201.149 apply (simp add: lower_plus_least)
201.150 done
201.151
201.152 @@ -412,11 +412,11 @@
201.153
201.154 lemma lower_bind_basis_mono:
201.155 "t \<le>\<flat> u \<Longrightarrow> lower_bind_basis t \<sqsubseteq> lower_bind_basis u"
201.156 -unfolding expand_cfun_less
201.157 +unfolding expand_cfun_below
201.158 apply (erule lower_le_induct, safe)
201.159 apply (simp add: monofun_cfun)
201.160 -apply (simp add: rev_trans_less [OF lower_plus_less1])
201.161 -apply (simp add: lower_plus_less_iff)
201.162 +apply (simp add: rev_below_trans [OF lower_plus_below1])
201.163 +apply (simp add: lower_plus_below_iff)
201.164 done
201.165
201.166 definition
202.1 --- a/src/HOLCF/One.thy Mon May 11 09:39:53 2009 +0200
202.2 +++ b/src/HOLCF/One.thy Mon May 11 17:20:52 2009 +0200
202.3 @@ -28,17 +28,17 @@
202.4 lemma one_induct: "\<lbrakk>P \<bottom>; P ONE\<rbrakk> \<Longrightarrow> P x"
202.5 by (cases x rule: oneE) simp_all
202.6
202.7 -lemma dist_less_one [simp]: "\<not> ONE \<sqsubseteq> \<bottom>"
202.8 +lemma dist_below_one [simp]: "\<not> ONE \<sqsubseteq> \<bottom>"
202.9 unfolding ONE_def by simp
202.10
202.11 -lemma less_ONE [simp]: "x \<sqsubseteq> ONE"
202.12 +lemma below_ONE [simp]: "x \<sqsubseteq> ONE"
202.13 by (induct x rule: one_induct) simp_all
202.14
202.15 -lemma ONE_less_iff [simp]: "ONE \<sqsubseteq> x \<longleftrightarrow> x = ONE"
202.16 +lemma ONE_below_iff [simp]: "ONE \<sqsubseteq> x \<longleftrightarrow> x = ONE"
202.17 by (induct x rule: one_induct) simp_all
202.18
202.19 -lemma dist_eq_one [simp]: "ONE \<noteq> \<bottom>" "\<bottom> \<noteq> ONE"
202.20 -unfolding ONE_def by simp_all
202.21 +lemma ONE_defined [simp]: "ONE \<noteq> \<bottom>"
202.22 +unfolding ONE_def by simp
202.23
202.24 lemma one_neq_iffs [simp]:
202.25 "x \<noteq> ONE \<longleftrightarrow> x = \<bottom>"
203.1 --- a/src/HOLCF/Pcpo.thy Mon May 11 09:39:53 2009 +0200
203.2 +++ b/src/HOLCF/Pcpo.thy Mon May 11 17:20:52 2009 +0200
203.3 @@ -13,28 +13,28 @@
203.4 text {* The class cpo of chain complete partial orders *}
203.5
203.6 class cpo = po +
203.7 - -- {* class axiom: *}
203.8 - assumes cpo: "chain S \<Longrightarrow> \<exists>x :: 'a::po. range S <<| x"
203.9 + assumes cpo: "chain S \<Longrightarrow> \<exists>x. range S <<| x"
203.10 +begin
203.11
203.12 text {* in cpo's everthing equal to THE lub has lub properties for every chain *}
203.13
203.14 -lemma cpo_lubI: "chain (S::nat \<Rightarrow> 'a::cpo) \<Longrightarrow> range S <<| (\<Squnion>i. S i)"
203.15 -by (fast dest: cpo elim: lubI)
203.16 +lemma cpo_lubI: "chain S \<Longrightarrow> range S <<| (\<Squnion>i. S i)"
203.17 + by (fast dest: cpo elim: lubI)
203.18
203.19 -lemma thelubE: "\<lbrakk>chain S; (\<Squnion>i. S i) = (l::'a::cpo)\<rbrakk> \<Longrightarrow> range S <<| l"
203.20 -by (blast dest: cpo intro: lubI)
203.21 +lemma thelubE: "\<lbrakk>chain S; (\<Squnion>i. S i) = l\<rbrakk> \<Longrightarrow> range S <<| l"
203.22 + by (blast dest: cpo intro: lubI)
203.23
203.24 text {* Properties of the lub *}
203.25
203.26 -lemma is_ub_thelub: "chain (S::nat \<Rightarrow> 'a::cpo) \<Longrightarrow> S x \<sqsubseteq> (\<Squnion>i. S i)"
203.27 -by (blast dest: cpo intro: lubI [THEN is_ub_lub])
203.28 +lemma is_ub_thelub: "chain S \<Longrightarrow> S x \<sqsubseteq> (\<Squnion>i. S i)"
203.29 + by (blast dest: cpo intro: lubI [THEN is_ub_lub])
203.30
203.31 lemma is_lub_thelub:
203.32 - "\<lbrakk>chain (S::nat \<Rightarrow> 'a::cpo); range S <| x\<rbrakk> \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x"
203.33 -by (blast dest: cpo intro: lubI [THEN is_lub_lub])
203.34 + "\<lbrakk>chain S; range S <| x\<rbrakk> \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x"
203.35 + by (blast dest: cpo intro: lubI [THEN is_lub_lub])
203.36
203.37 lemma lub_range_mono:
203.38 - "\<lbrakk>range X \<subseteq> range Y; chain Y; chain (X::nat \<Rightarrow> 'a::cpo)\<rbrakk>
203.39 + "\<lbrakk>range X \<subseteq> range Y; chain Y; chain X\<rbrakk>
203.40 \<Longrightarrow> (\<Squnion>i. X i) \<sqsubseteq> (\<Squnion>i. Y i)"
203.41 apply (erule is_lub_thelub)
203.42 apply (rule ub_rangeI)
203.43 @@ -45,8 +45,8 @@
203.44 done
203.45
203.46 lemma lub_range_shift:
203.47 - "chain (Y::nat \<Rightarrow> 'a::cpo) \<Longrightarrow> (\<Squnion>i. Y (i + j)) = (\<Squnion>i. Y i)"
203.48 -apply (rule antisym_less)
203.49 + "chain Y \<Longrightarrow> (\<Squnion>i. Y (i + j)) = (\<Squnion>i. Y i)"
203.50 +apply (rule below_antisym)
203.51 apply (rule lub_range_mono)
203.52 apply fast
203.53 apply assumption
203.54 @@ -54,7 +54,7 @@
203.55 apply (rule is_lub_thelub)
203.56 apply assumption
203.57 apply (rule ub_rangeI)
203.58 -apply (rule_tac y="Y (i + j)" in trans_less)
203.59 +apply (rule_tac y="Y (i + j)" in below_trans)
203.60 apply (erule chain_mono)
203.61 apply (rule le_add1)
203.62 apply (rule is_ub_thelub)
203.63 @@ -62,11 +62,11 @@
203.64 done
203.65
203.66 lemma maxinch_is_thelub:
203.67 - "chain Y \<Longrightarrow> max_in_chain i Y = ((\<Squnion>i. Y i) = ((Y i)::'a::cpo))"
203.68 + "chain Y \<Longrightarrow> max_in_chain i Y = ((\<Squnion>i. Y i) = Y i)"
203.69 apply (rule iffI)
203.70 apply (fast intro!: thelubI lub_finch1)
203.71 apply (unfold max_in_chain_def)
203.72 -apply (safe intro!: antisym_less)
203.73 +apply (safe intro!: below_antisym)
203.74 apply (fast elim!: chain_mono)
203.75 apply (drule sym)
203.76 apply (force elim!: is_ub_thelub)
203.77 @@ -75,11 +75,11 @@
203.78 text {* the @{text "\<sqsubseteq>"} relation between two chains is preserved by their lubs *}
203.79
203.80 lemma lub_mono:
203.81 - "\<lbrakk>chain (X::nat \<Rightarrow> 'a::cpo); chain Y; \<And>i. X i \<sqsubseteq> Y i\<rbrakk>
203.82 + "\<lbrakk>chain X; chain Y; \<And>i. X i \<sqsubseteq> Y i\<rbrakk>
203.83 \<Longrightarrow> (\<Squnion>i. X i) \<sqsubseteq> (\<Squnion>i. Y i)"
203.84 apply (erule is_lub_thelub)
203.85 apply (rule ub_rangeI)
203.86 -apply (rule trans_less)
203.87 +apply (rule below_trans)
203.88 apply (erule meta_spec)
203.89 apply (erule is_ub_thelub)
203.90 done
203.91 @@ -87,14 +87,14 @@
203.92 text {* the = relation between two chains is preserved by their lubs *}
203.93
203.94 lemma lub_equal:
203.95 - "\<lbrakk>chain (X::nat \<Rightarrow> 'a::cpo); chain Y; \<forall>k. X k = Y k\<rbrakk>
203.96 + "\<lbrakk>chain X; chain Y; \<forall>k. X k = Y k\<rbrakk>
203.97 \<Longrightarrow> (\<Squnion>i. X i) = (\<Squnion>i. Y i)"
203.98 -by (simp only: expand_fun_eq [symmetric])
203.99 + by (simp only: expand_fun_eq [symmetric])
203.100
203.101 text {* more results about mono and = of lubs of chains *}
203.102
203.103 lemma lub_mono2:
203.104 - "\<lbrakk>\<exists>j. \<forall>i>j. X i = Y i; chain (X::nat \<Rightarrow> 'a::cpo); chain Y\<rbrakk>
203.105 + "\<lbrakk>\<exists>j. \<forall>i>j. X i = Y i; chain X; chain Y\<rbrakk>
203.106 \<Longrightarrow> (\<Squnion>i. X i) \<sqsubseteq> (\<Squnion>i. Y i)"
203.107 apply (erule exE)
203.108 apply (subgoal_tac "(\<Squnion>i. X (i + Suc j)) \<sqsubseteq> (\<Squnion>i. Y (i + Suc j))")
203.109 @@ -104,23 +104,22 @@
203.110 done
203.111
203.112 lemma lub_equal2:
203.113 - "\<lbrakk>\<exists>j. \<forall>i>j. X i = Y i; chain (X::nat \<Rightarrow> 'a::cpo); chain Y\<rbrakk>
203.114 + "\<lbrakk>\<exists>j. \<forall>i>j. X i = Y i; chain X; chain Y\<rbrakk>
203.115 \<Longrightarrow> (\<Squnion>i. X i) = (\<Squnion>i. Y i)"
203.116 -by (blast intro: antisym_less lub_mono2 sym)
203.117 + by (blast intro: below_antisym lub_mono2 sym)
203.118
203.119 lemma lub_mono3:
203.120 - "\<lbrakk>chain (Y::nat \<Rightarrow> 'a::cpo); chain X; \<forall>i. \<exists>j. Y i \<sqsubseteq> X j\<rbrakk>
203.121 + "\<lbrakk>chain Y; chain X; \<forall>i. \<exists>j. Y i \<sqsubseteq> X j\<rbrakk>
203.122 \<Longrightarrow> (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. X i)"
203.123 apply (erule is_lub_thelub)
203.124 apply (rule ub_rangeI)
203.125 apply (erule allE)
203.126 apply (erule exE)
203.127 -apply (erule trans_less)
203.128 +apply (erule below_trans)
203.129 apply (erule is_ub_thelub)
203.130 done
203.131
203.132 lemma ch2ch_lub:
203.133 - fixes Y :: "nat \<Rightarrow> nat \<Rightarrow> 'a::cpo"
203.134 assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
203.135 assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
203.136 shows "chain (\<lambda>i. \<Squnion>j. Y i j)"
203.137 @@ -130,14 +129,13 @@
203.138 done
203.139
203.140 lemma diag_lub:
203.141 - fixes Y :: "nat \<Rightarrow> nat \<Rightarrow> 'a::cpo"
203.142 assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
203.143 assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
203.144 shows "(\<Squnion>i. \<Squnion>j. Y i j) = (\<Squnion>i. Y i i)"
203.145 -proof (rule antisym_less)
203.146 +proof (rule below_antisym)
203.147 have 3: "chain (\<lambda>i. Y i i)"
203.148 apply (rule chainI)
203.149 - apply (rule trans_less)
203.150 + apply (rule below_trans)
203.151 apply (rule chainE [OF 1])
203.152 apply (rule chainE [OF 2])
203.153 done
203.154 @@ -148,7 +146,7 @@
203.155 apply (rule ub_rangeI)
203.156 apply (rule lub_mono3 [rule_format, OF 2 3])
203.157 apply (rule exI)
203.158 - apply (rule trans_less)
203.159 + apply (rule below_trans)
203.160 apply (rule chain_mono [OF 1 le_maxI1])
203.161 apply (rule chain_mono [OF 2 le_maxI2])
203.162 done
203.163 @@ -159,12 +157,12 @@
203.164 qed
203.165
203.166 lemma ex_lub:
203.167 - fixes Y :: "nat \<Rightarrow> nat \<Rightarrow> 'a::cpo"
203.168 assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
203.169 assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
203.170 shows "(\<Squnion>i. \<Squnion>j. Y i j) = (\<Squnion>j. \<Squnion>i. Y i j)"
203.171 -by (simp add: diag_lub 1 2)
203.172 + by (simp add: diag_lub 1 2)
203.173
203.174 +end
203.175
203.176 subsection {* Pointed cpos *}
203.177
203.178 @@ -172,9 +170,9 @@
203.179
203.180 class pcpo = cpo +
203.181 assumes least: "\<exists>x. \<forall>y. x \<sqsubseteq> y"
203.182 +begin
203.183
203.184 -definition
203.185 - UU :: "'a::pcpo" where
203.186 +definition UU :: 'a where
203.187 "UU = (THE x. \<forall>y. x \<sqsubseteq> y)"
203.188
203.189 notation (xsymbols)
203.190 @@ -187,36 +185,29 @@
203.191 apply (rule theI')
203.192 apply (rule ex_ex1I)
203.193 apply (rule least)
203.194 -apply (blast intro: antisym_less)
203.195 +apply (blast intro: below_antisym)
203.196 done
203.197
203.198 lemma minimal [iff]: "\<bottom> \<sqsubseteq> x"
203.199 by (rule UU_least [THEN spec])
203.200
203.201 -lemma UU_reorient: "(\<bottom> = x) = (x = \<bottom>)"
203.202 -by auto
203.203 +end
203.204
203.205 -ML {*
203.206 -local
203.207 - val meta_UU_reorient = thm "UU_reorient" RS eq_reflection;
203.208 - fun reorient_proc sg _ (_ $ t $ u) =
203.209 - case u of
203.210 - Const("Pcpo.UU",_) => NONE
203.211 - | Const("HOL.zero", _) => NONE
203.212 - | Const("HOL.one", _) => NONE
203.213 - | Const("Numeral.number_of", _) $ _ => NONE
203.214 - | _ => SOME meta_UU_reorient;
203.215 -in
203.216 - val UU_reorient_simproc =
203.217 - Simplifier.simproc (the_context ()) "UU_reorient_simproc" ["UU=x"] reorient_proc
203.218 -end;
203.219 +text {* Simproc to rewrite @{term "\<bottom> = x"} to @{term "x = \<bottom>"}. *}
203.220
203.221 -Addsimprocs [UU_reorient_simproc];
203.222 +setup {*
203.223 + ReorientProc.add
203.224 + (fn Const(@{const_name UU}, _) => true | _ => false)
203.225 *}
203.226
203.227 +simproc_setup reorient_bottom ("\<bottom> = x") = ReorientProc.proc
203.228 +
203.229 +context pcpo
203.230 +begin
203.231 +
203.232 text {* useful lemmas about @{term \<bottom>} *}
203.233
203.234 -lemma less_UU_iff [simp]: "(x \<sqsubseteq> \<bottom>) = (x = \<bottom>)"
203.235 +lemma below_UU_iff [simp]: "(x \<sqsubseteq> \<bottom>) = (x = \<bottom>)"
203.236 by (simp add: po_eq_conv)
203.237
203.238 lemma eq_UU_iff: "(x = \<bottom>) = (x \<sqsubseteq> \<bottom>)"
203.239 @@ -225,9 +216,6 @@
203.240 lemma UU_I: "x \<sqsubseteq> \<bottom> \<Longrightarrow> x = \<bottom>"
203.241 by (subst eq_UU_iff)
203.242
203.243 -lemma not_less2not_eq: "\<not> (x::'a::po) \<sqsubseteq> y \<Longrightarrow> x \<noteq> y"
203.244 -by auto
203.245 -
203.246 lemma chain_UU_I: "\<lbrakk>chain Y; (\<Squnion>i. Y i) = \<bottom>\<rbrakk> \<Longrightarrow> \<forall>i. Y i = \<bottom>"
203.247 apply (rule allI)
203.248 apply (rule UU_I)
203.249 @@ -242,49 +230,53 @@
203.250 done
203.251
203.252 lemma chain_UU_I_inverse2: "(\<Squnion>i. Y i) \<noteq> \<bottom> \<Longrightarrow> \<exists>i::nat. Y i \<noteq> \<bottom>"
203.253 -by (blast intro: chain_UU_I_inverse)
203.254 + by (blast intro: chain_UU_I_inverse)
203.255
203.256 lemma notUU_I: "\<lbrakk>x \<sqsubseteq> y; x \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> y \<noteq> \<bottom>"
203.257 -by (blast intro: UU_I)
203.258 + by (blast intro: UU_I)
203.259
203.260 lemma chain_mono2: "\<lbrakk>\<exists>j. Y j \<noteq> \<bottom>; chain Y\<rbrakk> \<Longrightarrow> \<exists>j. \<forall>i>j. Y i \<noteq> \<bottom>"
203.261 -by (blast dest: notUU_I chain_mono_less)
203.262 + by (blast dest: notUU_I chain_mono_less)
203.263 +
203.264 +end
203.265
203.266 subsection {* Chain-finite and flat cpos *}
203.267
203.268 text {* further useful classes for HOLCF domains *}
203.269
203.270 +class chfin = po +
203.271 + assumes chfin: "chain Y \<Longrightarrow> \<exists>n. max_in_chain n Y"
203.272 +begin
203.273 +
203.274 +subclass cpo
203.275 +apply default
203.276 +apply (frule chfin)
203.277 +apply (blast intro: lub_finch1)
203.278 +done
203.279 +
203.280 +lemma chfin2finch: "chain Y \<Longrightarrow> finite_chain Y"
203.281 + by (simp add: chfin finite_chain_def)
203.282 +
203.283 +end
203.284 +
203.285 class finite_po = finite + po
203.286 +begin
203.287
203.288 -class chfin = po +
203.289 - assumes chfin: "chain Y \<Longrightarrow> \<exists>n. max_in_chain n (Y :: nat => 'a::po)"
203.290 -
203.291 -class flat = pcpo +
203.292 - assumes ax_flat: "(x :: 'a::pcpo) \<sqsubseteq> y \<Longrightarrow> x = \<bottom> \<or> x = y"
203.293 -
203.294 -text {* finite partial orders are chain-finite *}
203.295 -
203.296 -instance finite_po < chfin
203.297 -apply intro_classes
203.298 +subclass chfin
203.299 +apply default
203.300 apply (drule finite_range_imp_finch)
203.301 apply (rule finite)
203.302 apply (simp add: finite_chain_def)
203.303 done
203.304
203.305 -text {* some properties for chfin and flat *}
203.306 +end
203.307
203.308 -text {* chfin types are cpo *}
203.309 +class flat = pcpo +
203.310 + assumes ax_flat: "x \<sqsubseteq> y \<Longrightarrow> x = \<bottom> \<or> x = y"
203.311 +begin
203.312
203.313 -instance chfin < cpo
203.314 -apply intro_classes
203.315 -apply (frule chfin)
203.316 -apply (blast intro: lub_finch1)
203.317 -done
203.318 -
203.319 -text {* flat types are chfin *}
203.320 -
203.321 -instance flat < chfin
203.322 -apply intro_classes
203.323 +subclass chfin
203.324 +apply default
203.325 apply (unfold max_in_chain_def)
203.326 apply (case_tac "\<forall>i. Y i = \<bottom>")
203.327 apply simp
203.328 @@ -295,31 +287,28 @@
203.329 apply (blast dest: chain_mono ax_flat)
203.330 done
203.331
203.332 -text {* flat subclass of chfin; @{text adm_flat} not needed *}
203.333 +lemma flat_below_iff:
203.334 + shows "(x \<sqsubseteq> y) = (x = \<bottom> \<or> x = y)"
203.335 + by (safe dest!: ax_flat)
203.336
203.337 -lemma flat_less_iff:
203.338 - fixes x y :: "'a::flat"
203.339 - shows "(x \<sqsubseteq> y) = (x = \<bottom> \<or> x = y)"
203.340 -by (safe dest!: ax_flat)
203.341 +lemma flat_eq: "a \<noteq> \<bottom> \<Longrightarrow> a \<sqsubseteq> b = (a = b)"
203.342 + by (safe dest!: ax_flat)
203.343
203.344 -lemma flat_eq: "(a::'a::flat) \<noteq> \<bottom> \<Longrightarrow> a \<sqsubseteq> b = (a = b)"
203.345 -by (safe dest!: ax_flat)
203.346 -
203.347 -lemma chfin2finch: "chain (Y::nat \<Rightarrow> 'a::chfin) \<Longrightarrow> finite_chain Y"
203.348 -by (simp add: chfin finite_chain_def)
203.349 +end
203.350
203.351 text {* Discrete cpos *}
203.352
203.353 -class discrete_cpo = sq_ord +
203.354 +class discrete_cpo = below +
203.355 assumes discrete_cpo [simp]: "x \<sqsubseteq> y \<longleftrightarrow> x = y"
203.356 +begin
203.357
203.358 -subclass (in discrete_cpo) po
203.359 +subclass po
203.360 proof qed simp_all
203.361
203.362 text {* In a discrete cpo, every chain is constant *}
203.363
203.364 lemma discrete_chain_const:
203.365 - assumes S: "chain (S::nat \<Rightarrow> 'a::discrete_cpo)"
203.366 + assumes S: "chain S"
203.367 shows "\<exists>x. S = (\<lambda>i. x)"
203.368 proof (intro exI ext)
203.369 fix i :: nat
203.370 @@ -328,7 +317,7 @@
203.371 thus "S i = S 0" by (rule sym)
203.372 qed
203.373
203.374 -instance discrete_cpo < cpo
203.375 +subclass cpo
203.376 proof
203.377 fix S :: "nat \<Rightarrow> 'a"
203.378 assume S: "chain S"
203.379 @@ -338,31 +327,6 @@
203.380 by (fast intro: lub_const)
203.381 qed
203.382
203.383 -text {* lemmata for improved admissibility introdution rule *}
203.384 -
203.385 -lemma infinite_chain_adm_lemma:
203.386 - "\<lbrakk>chain Y; \<forall>i. P (Y i);
203.387 - \<And>Y. \<lbrakk>chain Y; \<forall>i. P (Y i); \<not> finite_chain Y\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)\<rbrakk>
203.388 - \<Longrightarrow> P (\<Squnion>i. Y i)"
203.389 -apply (case_tac "finite_chain Y")
203.390 -prefer 2 apply fast
203.391 -apply (unfold finite_chain_def)
203.392 -apply safe
203.393 -apply (erule lub_finch1 [THEN thelubI, THEN ssubst])
203.394 -apply assumption
203.395 -apply (erule spec)
203.396 -done
203.397 -
203.398 -lemma increasing_chain_adm_lemma:
203.399 - "\<lbrakk>chain Y; \<forall>i. P (Y i); \<And>Y. \<lbrakk>chain Y; \<forall>i. P (Y i);
203.400 - \<forall>i. \<exists>j>i. Y i \<noteq> Y j \<and> Y i \<sqsubseteq> Y j\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)\<rbrakk>
203.401 - \<Longrightarrow> P (\<Squnion>i. Y i)"
203.402 -apply (erule infinite_chain_adm_lemma)
203.403 -apply assumption
203.404 -apply (erule thin_rl)
203.405 -apply (unfold finite_chain_def)
203.406 -apply (unfold max_in_chain_def)
203.407 -apply (fast dest: le_imp_less_or_eq elim: chain_mono_less)
203.408 -done
203.409 +end
203.410
203.411 end
204.1 --- a/src/HOLCF/Pcpodef.thy Mon May 11 09:39:53 2009 +0200
204.2 +++ b/src/HOLCF/Pcpodef.thy Mon May 11 17:20:52 2009 +0200
204.3 @@ -16,22 +16,22 @@
204.4 if the ordering is defined in the standard way.
204.5 *}
204.6
204.7 -setup {* Sign.add_const_constraint (@{const_name Porder.sq_le}, NONE) *}
204.8 +setup {* Sign.add_const_constraint (@{const_name Porder.below}, NONE) *}
204.9
204.10 theorem typedef_po:
204.11 fixes Abs :: "'a::po \<Rightarrow> 'b::type"
204.12 assumes type: "type_definition Rep Abs A"
204.13 - and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.14 + and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.15 shows "OFCLASS('b, po_class)"
204.16 - apply (intro_classes, unfold less)
204.17 - apply (rule refl_less)
204.18 - apply (erule (1) trans_less)
204.19 + apply (intro_classes, unfold below)
204.20 + apply (rule below_refl)
204.21 + apply (erule (1) below_trans)
204.22 apply (rule type_definition.Rep_inject [OF type, THEN iffD1])
204.23 - apply (erule (1) antisym_less)
204.24 + apply (erule (1) below_antisym)
204.25 done
204.26
204.27 -setup {* Sign.add_const_constraint (@{const_name Porder.sq_le},
204.28 - SOME @{typ "'a::sq_ord \<Rightarrow> 'a::sq_ord \<Rightarrow> bool"}) *}
204.29 +setup {* Sign.add_const_constraint (@{const_name Porder.below},
204.30 + SOME @{typ "'a::below \<Rightarrow> 'a::below \<Rightarrow> bool"}) *}
204.31
204.32 subsection {* Proving a subtype is finite *}
204.33
204.34 @@ -58,9 +58,9 @@
204.35 subsection {* Proving a subtype is chain-finite *}
204.36
204.37 lemma monofun_Rep:
204.38 - assumes less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.39 + assumes below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.40 shows "monofun Rep"
204.41 -by (rule monofunI, unfold less)
204.42 +by (rule monofunI, unfold below)
204.43
204.44 lemmas ch2ch_Rep = ch2ch_monofun [OF monofun_Rep]
204.45 lemmas ub2ub_Rep = ub2ub_monofun [OF monofun_Rep]
204.46 @@ -68,10 +68,10 @@
204.47 theorem typedef_chfin:
204.48 fixes Abs :: "'a::chfin \<Rightarrow> 'b::po"
204.49 assumes type: "type_definition Rep Abs A"
204.50 - and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.51 + and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.52 shows "OFCLASS('b, chfin_class)"
204.53 apply intro_classes
204.54 - apply (drule ch2ch_Rep [OF less])
204.55 + apply (drule ch2ch_Rep [OF below])
204.56 apply (drule chfin)
204.57 apply (unfold max_in_chain_def)
204.58 apply (simp add: type_definition.Rep_inject [OF type])
204.59 @@ -90,28 +90,28 @@
204.60 lemma Abs_inverse_lub_Rep:
204.61 fixes Abs :: "'a::cpo \<Rightarrow> 'b::po"
204.62 assumes type: "type_definition Rep Abs A"
204.63 - and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.64 + and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.65 and adm: "adm (\<lambda>x. x \<in> A)"
204.66 shows "chain S \<Longrightarrow> Rep (Abs (\<Squnion>i. Rep (S i))) = (\<Squnion>i. Rep (S i))"
204.67 apply (rule type_definition.Abs_inverse [OF type])
204.68 - apply (erule admD [OF adm ch2ch_Rep [OF less]])
204.69 + apply (erule admD [OF adm ch2ch_Rep [OF below]])
204.70 apply (rule type_definition.Rep [OF type])
204.71 done
204.72
204.73 theorem typedef_lub:
204.74 fixes Abs :: "'a::cpo \<Rightarrow> 'b::po"
204.75 assumes type: "type_definition Rep Abs A"
204.76 - and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.77 + and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.78 and adm: "adm (\<lambda>x. x \<in> A)"
204.79 shows "chain S \<Longrightarrow> range S <<| Abs (\<Squnion>i. Rep (S i))"
204.80 - apply (frule ch2ch_Rep [OF less])
204.81 + apply (frule ch2ch_Rep [OF below])
204.82 apply (rule is_lubI)
204.83 apply (rule ub_rangeI)
204.84 - apply (simp only: less Abs_inverse_lub_Rep [OF type less adm])
204.85 + apply (simp only: below Abs_inverse_lub_Rep [OF type below adm])
204.86 apply (erule is_ub_thelub)
204.87 - apply (simp only: less Abs_inverse_lub_Rep [OF type less adm])
204.88 + apply (simp only: below Abs_inverse_lub_Rep [OF type below adm])
204.89 apply (erule is_lub_thelub)
204.90 - apply (erule ub2ub_Rep [OF less])
204.91 + apply (erule ub2ub_Rep [OF below])
204.92 done
204.93
204.94 lemmas typedef_thelub = typedef_lub [THEN thelubI, standard]
204.95 @@ -119,13 +119,13 @@
204.96 theorem typedef_cpo:
204.97 fixes Abs :: "'a::cpo \<Rightarrow> 'b::po"
204.98 assumes type: "type_definition Rep Abs A"
204.99 - and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.100 + and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.101 and adm: "adm (\<lambda>x. x \<in> A)"
204.102 shows "OFCLASS('b, cpo_class)"
204.103 proof
204.104 fix S::"nat \<Rightarrow> 'b" assume "chain S"
204.105 hence "range S <<| Abs (\<Squnion>i. Rep (S i))"
204.106 - by (rule typedef_lub [OF type less adm])
204.107 + by (rule typedef_lub [OF type below adm])
204.108 thus "\<exists>x. range S <<| x" ..
204.109 qed
204.110
204.111 @@ -136,14 +136,14 @@
204.112 theorem typedef_cont_Rep:
204.113 fixes Abs :: "'a::cpo \<Rightarrow> 'b::cpo"
204.114 assumes type: "type_definition Rep Abs A"
204.115 - and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.116 + and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.117 and adm: "adm (\<lambda>x. x \<in> A)"
204.118 shows "cont Rep"
204.119 apply (rule contI)
204.120 - apply (simp only: typedef_thelub [OF type less adm])
204.121 - apply (simp only: Abs_inverse_lub_Rep [OF type less adm])
204.122 + apply (simp only: typedef_thelub [OF type below adm])
204.123 + apply (simp only: Abs_inverse_lub_Rep [OF type below adm])
204.124 apply (rule cpo_lubI)
204.125 - apply (erule ch2ch_Rep [OF less])
204.126 + apply (erule ch2ch_Rep [OF below])
204.127 done
204.128
204.129 text {*
204.130 @@ -153,28 +153,28 @@
204.131 *}
204.132
204.133 theorem typedef_is_lubI:
204.134 - assumes less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.135 + assumes below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.136 shows "range (\<lambda>i. Rep (S i)) <<| Rep x \<Longrightarrow> range S <<| x"
204.137 apply (rule is_lubI)
204.138 apply (rule ub_rangeI)
204.139 - apply (subst less)
204.140 + apply (subst below)
204.141 apply (erule is_ub_lub)
204.142 - apply (subst less)
204.143 + apply (subst below)
204.144 apply (erule is_lub_lub)
204.145 - apply (erule ub2ub_Rep [OF less])
204.146 + apply (erule ub2ub_Rep [OF below])
204.147 done
204.148
204.149 theorem typedef_cont_Abs:
204.150 fixes Abs :: "'a::cpo \<Rightarrow> 'b::cpo"
204.151 fixes f :: "'c::cpo \<Rightarrow> 'a::cpo"
204.152 assumes type: "type_definition Rep Abs A"
204.153 - and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.154 + and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.155 and adm: "adm (\<lambda>x. x \<in> A)" (* not used *)
204.156 and f_in_A: "\<And>x. f x \<in> A"
204.157 and cont_f: "cont f"
204.158 shows "cont (\<lambda>x. Abs (f x))"
204.159 apply (rule contI)
204.160 - apply (rule typedef_is_lubI [OF less])
204.161 + apply (rule typedef_is_lubI [OF below])
204.162 apply (simp only: type_definition.Abs_inverse [OF type f_in_A])
204.163 apply (erule cont_f [THEN contE])
204.164 done
204.165 @@ -184,15 +184,15 @@
204.166 theorem typedef_compact:
204.167 fixes Abs :: "'a::cpo \<Rightarrow> 'b::cpo"
204.168 assumes type: "type_definition Rep Abs A"
204.169 - and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.170 + and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.171 and adm: "adm (\<lambda>x. x \<in> A)"
204.172 shows "compact (Rep k) \<Longrightarrow> compact k"
204.173 proof (unfold compact_def)
204.174 have cont_Rep: "cont Rep"
204.175 - by (rule typedef_cont_Rep [OF type less adm])
204.176 + by (rule typedef_cont_Rep [OF type below adm])
204.177 assume "adm (\<lambda>x. \<not> Rep k \<sqsubseteq> x)"
204.178 with cont_Rep have "adm (\<lambda>x. \<not> Rep k \<sqsubseteq> Rep x)" by (rule adm_subst)
204.179 - thus "adm (\<lambda>x. \<not> k \<sqsubseteq> x)" by (unfold less)
204.180 + thus "adm (\<lambda>x. \<not> k \<sqsubseteq> x)" by (unfold below)
204.181 qed
204.182
204.183 subsection {* Proving a subtype is pointed *}
204.184 @@ -205,13 +205,13 @@
204.185 theorem typedef_pcpo_generic:
204.186 fixes Abs :: "'a::cpo \<Rightarrow> 'b::cpo"
204.187 assumes type: "type_definition Rep Abs A"
204.188 - and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.189 + and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.190 and z_in_A: "z \<in> A"
204.191 and z_least: "\<And>x. x \<in> A \<Longrightarrow> z \<sqsubseteq> x"
204.192 shows "OFCLASS('b, pcpo_class)"
204.193 apply (intro_classes)
204.194 apply (rule_tac x="Abs z" in exI, rule allI)
204.195 - apply (unfold less)
204.196 + apply (unfold below)
204.197 apply (subst type_definition.Abs_inverse [OF type z_in_A])
204.198 apply (rule z_least [OF type_definition.Rep [OF type]])
204.199 done
204.200 @@ -224,10 +224,10 @@
204.201 theorem typedef_pcpo:
204.202 fixes Abs :: "'a::pcpo \<Rightarrow> 'b::cpo"
204.203 assumes type: "type_definition Rep Abs A"
204.204 - and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.205 + and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.206 and UU_in_A: "\<bottom> \<in> A"
204.207 shows "OFCLASS('b, pcpo_class)"
204.208 -by (rule typedef_pcpo_generic [OF type less UU_in_A], rule minimal)
204.209 +by (rule typedef_pcpo_generic [OF type below UU_in_A], rule minimal)
204.210
204.211 subsubsection {* Strictness of @{term Rep} and @{term Abs} *}
204.212
204.213 @@ -238,66 +238,66 @@
204.214
204.215 theorem typedef_Abs_strict:
204.216 assumes type: "type_definition Rep Abs A"
204.217 - and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.218 + and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.219 and UU_in_A: "\<bottom> \<in> A"
204.220 shows "Abs \<bottom> = \<bottom>"
204.221 - apply (rule UU_I, unfold less)
204.222 + apply (rule UU_I, unfold below)
204.223 apply (simp add: type_definition.Abs_inverse [OF type UU_in_A])
204.224 done
204.225
204.226 theorem typedef_Rep_strict:
204.227 assumes type: "type_definition Rep Abs A"
204.228 - and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.229 + and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.230 and UU_in_A: "\<bottom> \<in> A"
204.231 shows "Rep \<bottom> = \<bottom>"
204.232 - apply (rule typedef_Abs_strict [OF type less UU_in_A, THEN subst])
204.233 + apply (rule typedef_Abs_strict [OF type below UU_in_A, THEN subst])
204.234 apply (rule type_definition.Abs_inverse [OF type UU_in_A])
204.235 done
204.236
204.237 theorem typedef_Abs_strict_iff:
204.238 assumes type: "type_definition Rep Abs A"
204.239 - and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.240 + and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.241 and UU_in_A: "\<bottom> \<in> A"
204.242 shows "x \<in> A \<Longrightarrow> (Abs x = \<bottom>) = (x = \<bottom>)"
204.243 - apply (rule typedef_Abs_strict [OF type less UU_in_A, THEN subst])
204.244 + apply (rule typedef_Abs_strict [OF type below UU_in_A, THEN subst])
204.245 apply (simp add: type_definition.Abs_inject [OF type] UU_in_A)
204.246 done
204.247
204.248 theorem typedef_Rep_strict_iff:
204.249 assumes type: "type_definition Rep Abs A"
204.250 - and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.251 + and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.252 and UU_in_A: "\<bottom> \<in> A"
204.253 shows "(Rep x = \<bottom>) = (x = \<bottom>)"
204.254 - apply (rule typedef_Rep_strict [OF type less UU_in_A, THEN subst])
204.255 + apply (rule typedef_Rep_strict [OF type below UU_in_A, THEN subst])
204.256 apply (simp add: type_definition.Rep_inject [OF type])
204.257 done
204.258
204.259 theorem typedef_Abs_defined:
204.260 assumes type: "type_definition Rep Abs A"
204.261 - and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.262 + and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.263 and UU_in_A: "\<bottom> \<in> A"
204.264 shows "\<lbrakk>x \<noteq> \<bottom>; x \<in> A\<rbrakk> \<Longrightarrow> Abs x \<noteq> \<bottom>"
204.265 -by (simp add: typedef_Abs_strict_iff [OF type less UU_in_A])
204.266 +by (simp add: typedef_Abs_strict_iff [OF type below UU_in_A])
204.267
204.268 theorem typedef_Rep_defined:
204.269 assumes type: "type_definition Rep Abs A"
204.270 - and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.271 + and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.272 and UU_in_A: "\<bottom> \<in> A"
204.273 shows "x \<noteq> \<bottom> \<Longrightarrow> Rep x \<noteq> \<bottom>"
204.274 -by (simp add: typedef_Rep_strict_iff [OF type less UU_in_A])
204.275 +by (simp add: typedef_Rep_strict_iff [OF type below UU_in_A])
204.276
204.277 subsection {* Proving a subtype is flat *}
204.278
204.279 theorem typedef_flat:
204.280 fixes Abs :: "'a::flat \<Rightarrow> 'b::pcpo"
204.281 assumes type: "type_definition Rep Abs A"
204.282 - and less: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.283 + and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
204.284 and UU_in_A: "\<bottom> \<in> A"
204.285 shows "OFCLASS('b, flat_class)"
204.286 apply (intro_classes)
204.287 - apply (unfold less)
204.288 + apply (unfold below)
204.289 apply (simp add: type_definition.Rep_inject [OF type, symmetric])
204.290 - apply (simp add: typedef_Rep_strict [OF type less UU_in_A])
204.291 + apply (simp add: typedef_Rep_strict [OF type below UU_in_A])
204.292 apply (simp add: ax_flat)
204.293 done
204.294
205.1 --- a/src/HOLCF/Porder.thy Mon May 11 09:39:53 2009 +0200
205.2 +++ b/src/HOLCF/Porder.thy Mon May 11 17:20:52 2009 +0200
205.3 @@ -10,94 +10,105 @@
205.4
205.5 subsection {* Type class for partial orders *}
205.6
205.7 -class sq_ord =
205.8 - fixes sq_le :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
205.9 +class below =
205.10 + fixes below :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
205.11 +begin
205.12
205.13 notation
205.14 - sq_le (infixl "<<" 55)
205.15 + below (infixl "<<" 55)
205.16
205.17 notation (xsymbols)
205.18 - sq_le (infixl "\<sqsubseteq>" 55)
205.19 + below (infixl "\<sqsubseteq>" 55)
205.20
205.21 -class po = sq_ord +
205.22 - assumes refl_less [iff]: "x \<sqsubseteq> x"
205.23 - assumes trans_less: "\<lbrakk>x \<sqsubseteq> y; y \<sqsubseteq> z\<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"
205.24 - assumes antisym_less: "\<lbrakk>x \<sqsubseteq> y; y \<sqsubseteq> x\<rbrakk> \<Longrightarrow> x = y"
205.25 +lemma below_eq_trans: "\<lbrakk>a \<sqsubseteq> b; b = c\<rbrakk> \<Longrightarrow> a \<sqsubseteq> c"
205.26 + by (rule subst)
205.27 +
205.28 +lemma eq_below_trans: "\<lbrakk>a = b; b \<sqsubseteq> c\<rbrakk> \<Longrightarrow> a \<sqsubseteq> c"
205.29 + by (rule ssubst)
205.30 +
205.31 +end
205.32 +
205.33 +class po = below +
205.34 + assumes below_refl [iff]: "x \<sqsubseteq> x"
205.35 + assumes below_trans: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> z"
205.36 + assumes below_antisym: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> x \<Longrightarrow> x = y"
205.37 +begin
205.38
205.39 text {* minimal fixes least element *}
205.40
205.41 -lemma minimal2UU[OF allI] : "\<forall>x::'a::po. uu \<sqsubseteq> x \<Longrightarrow> uu = (THE u. \<forall>y. u \<sqsubseteq> y)"
205.42 -by (blast intro: theI2 antisym_less)
205.43 +lemma minimal2UU[OF allI] : "\<forall>x. uu \<sqsubseteq> x \<Longrightarrow> uu = (THE u. \<forall>y. u \<sqsubseteq> y)"
205.44 + by (blast intro: theI2 below_antisym)
205.45
205.46 text {* the reverse law of anti-symmetry of @{term "op <<"} *}
205.47 +(* Is this rule ever useful? *)
205.48 +lemma below_antisym_inverse: "x = y \<Longrightarrow> x \<sqsubseteq> y \<and> y \<sqsubseteq> x"
205.49 + by simp
205.50
205.51 -lemma antisym_less_inverse: "(x::'a::po) = y \<Longrightarrow> x \<sqsubseteq> y \<and> y \<sqsubseteq> x"
205.52 -by simp
205.53 +lemma box_below: "a \<sqsubseteq> b \<Longrightarrow> c \<sqsubseteq> a \<Longrightarrow> b \<sqsubseteq> d \<Longrightarrow> c \<sqsubseteq> d"
205.54 + by (rule below_trans [OF below_trans])
205.55
205.56 -lemma box_less: "\<lbrakk>(a::'a::po) \<sqsubseteq> b; c \<sqsubseteq> a; b \<sqsubseteq> d\<rbrakk> \<Longrightarrow> c \<sqsubseteq> d"
205.57 -by (rule trans_less [OF trans_less])
205.58 +lemma po_eq_conv: "x = y \<longleftrightarrow> x \<sqsubseteq> y \<and> y \<sqsubseteq> x"
205.59 + by (fast intro!: below_antisym)
205.60
205.61 -lemma po_eq_conv: "((x::'a::po) = y) = (x \<sqsubseteq> y \<and> y \<sqsubseteq> x)"
205.62 -by (fast elim!: antisym_less_inverse intro!: antisym_less)
205.63 +lemma rev_below_trans: "y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> x \<sqsubseteq> z"
205.64 + by (rule below_trans)
205.65
205.66 -lemma rev_trans_less: "\<lbrakk>(y::'a::po) \<sqsubseteq> z; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"
205.67 -by (rule trans_less)
205.68 +lemma not_below2not_eq: "\<not> x \<sqsubseteq> y \<Longrightarrow> x \<noteq> y"
205.69 + by auto
205.70
205.71 -lemma sq_ord_less_eq_trans: "\<lbrakk>a \<sqsubseteq> b; b = c\<rbrakk> \<Longrightarrow> a \<sqsubseteq> c"
205.72 -by (rule subst)
205.73 -
205.74 -lemma sq_ord_eq_less_trans: "\<lbrakk>a = b; b \<sqsubseteq> c\<rbrakk> \<Longrightarrow> a \<sqsubseteq> c"
205.75 -by (rule ssubst)
205.76 +end
205.77
205.78 lemmas HOLCF_trans_rules [trans] =
205.79 - trans_less
205.80 - antisym_less
205.81 - sq_ord_less_eq_trans
205.82 - sq_ord_eq_less_trans
205.83 + below_trans
205.84 + below_antisym
205.85 + below_eq_trans
205.86 + eq_below_trans
205.87 +
205.88 +context po
205.89 +begin
205.90
205.91 subsection {* Upper bounds *}
205.92
205.93 -definition
205.94 - is_ub :: "['a set, 'a::po] \<Rightarrow> bool" (infixl "<|" 55) where
205.95 - "(S <| x) = (\<forall>y. y \<in> S \<longrightarrow> y \<sqsubseteq> x)"
205.96 +definition is_ub :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infixl "<|" 55) where
205.97 + "S <| x \<longleftrightarrow> (\<forall>y. y \<in> S \<longrightarrow> y \<sqsubseteq> x)"
205.98
205.99 lemma is_ubI: "(\<And>x. x \<in> S \<Longrightarrow> x \<sqsubseteq> u) \<Longrightarrow> S <| u"
205.100 -by (simp add: is_ub_def)
205.101 + by (simp add: is_ub_def)
205.102
205.103 lemma is_ubD: "\<lbrakk>S <| u; x \<in> S\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
205.104 -by (simp add: is_ub_def)
205.105 + by (simp add: is_ub_def)
205.106
205.107 lemma ub_imageI: "(\<And>x. x \<in> S \<Longrightarrow> f x \<sqsubseteq> u) \<Longrightarrow> (\<lambda>x. f x) ` S <| u"
205.108 -unfolding is_ub_def by fast
205.109 + unfolding is_ub_def by fast
205.110
205.111 lemma ub_imageD: "\<lbrakk>f ` S <| u; x \<in> S\<rbrakk> \<Longrightarrow> f x \<sqsubseteq> u"
205.112 -unfolding is_ub_def by fast
205.113 + unfolding is_ub_def by fast
205.114
205.115 lemma ub_rangeI: "(\<And>i. S i \<sqsubseteq> x) \<Longrightarrow> range S <| x"
205.116 -unfolding is_ub_def by fast
205.117 + unfolding is_ub_def by fast
205.118
205.119 lemma ub_rangeD: "range S <| x \<Longrightarrow> S i \<sqsubseteq> x"
205.120 -unfolding is_ub_def by fast
205.121 + unfolding is_ub_def by fast
205.122
205.123 lemma is_ub_empty [simp]: "{} <| u"
205.124 -unfolding is_ub_def by fast
205.125 + unfolding is_ub_def by fast
205.126
205.127 lemma is_ub_insert [simp]: "(insert x A) <| y = (x \<sqsubseteq> y \<and> A <| y)"
205.128 -unfolding is_ub_def by fast
205.129 + unfolding is_ub_def by fast
205.130
205.131 lemma is_ub_upward: "\<lbrakk>S <| x; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> S <| y"
205.132 -unfolding is_ub_def by (fast intro: trans_less)
205.133 + unfolding is_ub_def by (fast intro: below_trans)
205.134
205.135 subsection {* Least upper bounds *}
205.136
205.137 -definition
205.138 - is_lub :: "['a set, 'a::po] \<Rightarrow> bool" (infixl "<<|" 55) where
205.139 - "(S <<| x) = (S <| x \<and> (\<forall>u. S <| u \<longrightarrow> x \<sqsubseteq> u))"
205.140 +definition is_lub :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infixl "<<|" 55) where
205.141 + "S <<| x \<longleftrightarrow> S <| x \<and> (\<forall>u. S <| u \<longrightarrow> x \<sqsubseteq> u)"
205.142
205.143 -definition
205.144 - lub :: "'a set \<Rightarrow> 'a::po" where
205.145 +definition lub :: "'a set \<Rightarrow> 'a" where
205.146 "lub S = (THE x. S <<| x)"
205.147
205.148 +end
205.149 +
205.150 syntax
205.151 "_BLub" :: "[pttrn, 'a set, 'b] \<Rightarrow> 'b" ("(3LUB _:_./ _)" [0,0, 10] 10)
205.152
205.153 @@ -107,6 +118,9 @@
205.154 translations
205.155 "LUB x:A. t" == "CONST lub ((%x. t) ` A)"
205.156
205.157 +context po
205.158 +begin
205.159 +
205.160 abbreviation
205.161 Lub (binder "LUB " 10) where
205.162 "LUB n. t n == lub (range t)"
205.163 @@ -117,19 +131,19 @@
205.164 text {* access to some definition as inference rule *}
205.165
205.166 lemma is_lubD1: "S <<| x \<Longrightarrow> S <| x"
205.167 -unfolding is_lub_def by fast
205.168 + unfolding is_lub_def by fast
205.169
205.170 lemma is_lub_lub: "\<lbrakk>S <<| x; S <| u\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
205.171 -unfolding is_lub_def by fast
205.172 + unfolding is_lub_def by fast
205.173
205.174 lemma is_lubI: "\<lbrakk>S <| x; \<And>u. S <| u \<Longrightarrow> x \<sqsubseteq> u\<rbrakk> \<Longrightarrow> S <<| x"
205.175 -unfolding is_lub_def by fast
205.176 + unfolding is_lub_def by fast
205.177
205.178 text {* lubs are unique *}
205.179
205.180 lemma unique_lub: "\<lbrakk>S <<| x; S <<| y\<rbrakk> \<Longrightarrow> x = y"
205.181 apply (unfold is_lub_def is_ub_def)
205.182 -apply (blast intro: antisym_less)
205.183 +apply (blast intro: below_antisym)
205.184 done
205.185
205.186 text {* technical lemmas about @{term lub} and @{term is_lub} *}
205.187 @@ -142,60 +156,59 @@
205.188 done
205.189
205.190 lemma thelubI: "M <<| l \<Longrightarrow> lub M = l"
205.191 -by (rule unique_lub [OF lubI])
205.192 + by (rule unique_lub [OF lubI])
205.193
205.194 lemma is_lub_singleton: "{x} <<| x"
205.195 -by (simp add: is_lub_def)
205.196 + by (simp add: is_lub_def)
205.197
205.198 lemma lub_singleton [simp]: "lub {x} = x"
205.199 -by (rule thelubI [OF is_lub_singleton])
205.200 + by (rule thelubI [OF is_lub_singleton])
205.201
205.202 lemma is_lub_bin: "x \<sqsubseteq> y \<Longrightarrow> {x, y} <<| y"
205.203 -by (simp add: is_lub_def)
205.204 + by (simp add: is_lub_def)
205.205
205.206 lemma lub_bin: "x \<sqsubseteq> y \<Longrightarrow> lub {x, y} = y"
205.207 -by (rule is_lub_bin [THEN thelubI])
205.208 + by (rule is_lub_bin [THEN thelubI])
205.209
205.210 lemma is_lub_maximal: "\<lbrakk>S <| x; x \<in> S\<rbrakk> \<Longrightarrow> S <<| x"
205.211 -by (erule is_lubI, erule (1) is_ubD)
205.212 + by (erule is_lubI, erule (1) is_ubD)
205.213
205.214 lemma lub_maximal: "\<lbrakk>S <| x; x \<in> S\<rbrakk> \<Longrightarrow> lub S = x"
205.215 -by (rule is_lub_maximal [THEN thelubI])
205.216 + by (rule is_lub_maximal [THEN thelubI])
205.217
205.218 subsection {* Countable chains *}
205.219
205.220 -definition
205.221 +definition chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool" where
205.222 -- {* Here we use countable chains and I prefer to code them as functions! *}
205.223 - chain :: "(nat \<Rightarrow> 'a::po) \<Rightarrow> bool" where
205.224 "chain Y = (\<forall>i. Y i \<sqsubseteq> Y (Suc i))"
205.225
205.226 lemma chainI: "(\<And>i. Y i \<sqsubseteq> Y (Suc i)) \<Longrightarrow> chain Y"
205.227 -unfolding chain_def by fast
205.228 + unfolding chain_def by fast
205.229
205.230 lemma chainE: "chain Y \<Longrightarrow> Y i \<sqsubseteq> Y (Suc i)"
205.231 -unfolding chain_def by fast
205.232 + unfolding chain_def by fast
205.233
205.234 text {* chains are monotone functions *}
205.235
205.236 lemma chain_mono_less: "\<lbrakk>chain Y; i < j\<rbrakk> \<Longrightarrow> Y i \<sqsubseteq> Y j"
205.237 -by (erule less_Suc_induct, erule chainE, erule trans_less)
205.238 + by (erule less_Suc_induct, erule chainE, erule below_trans)
205.239
205.240 lemma chain_mono: "\<lbrakk>chain Y; i \<le> j\<rbrakk> \<Longrightarrow> Y i \<sqsubseteq> Y j"
205.241 -by (cases "i = j", simp, simp add: chain_mono_less)
205.242 + by (cases "i = j", simp, simp add: chain_mono_less)
205.243
205.244 lemma chain_shift: "chain Y \<Longrightarrow> chain (\<lambda>i. Y (i + j))"
205.245 -by (rule chainI, simp, erule chainE)
205.246 + by (rule chainI, simp, erule chainE)
205.247
205.248 text {* technical lemmas about (least) upper bounds of chains *}
205.249
205.250 lemma is_ub_lub: "range S <<| x \<Longrightarrow> S i \<sqsubseteq> x"
205.251 -by (rule is_lubD1 [THEN ub_rangeD])
205.252 + by (rule is_lubD1 [THEN ub_rangeD])
205.253
205.254 lemma is_ub_range_shift:
205.255 "chain S \<Longrightarrow> range (\<lambda>i. S (i + j)) <| x = range S <| x"
205.256 apply (rule iffI)
205.257 apply (rule ub_rangeI)
205.258 -apply (rule_tac y="S (i + j)" in trans_less)
205.259 +apply (rule_tac y="S (i + j)" in below_trans)
205.260 apply (erule chain_mono)
205.261 apply (rule le_add1)
205.262 apply (erule ub_rangeD)
205.263 @@ -205,45 +218,43 @@
205.264
205.265 lemma is_lub_range_shift:
205.266 "chain S \<Longrightarrow> range (\<lambda>i. S (i + j)) <<| x = range S <<| x"
205.267 -by (simp add: is_lub_def is_ub_range_shift)
205.268 + by (simp add: is_lub_def is_ub_range_shift)
205.269
205.270 text {* the lub of a constant chain is the constant *}
205.271
205.272 lemma chain_const [simp]: "chain (\<lambda>i. c)"
205.273 -by (simp add: chainI)
205.274 + by (simp add: chainI)
205.275
205.276 lemma lub_const: "range (\<lambda>x. c) <<| c"
205.277 by (blast dest: ub_rangeD intro: is_lubI ub_rangeI)
205.278
205.279 lemma thelub_const [simp]: "(\<Squnion>i. c) = c"
205.280 -by (rule lub_const [THEN thelubI])
205.281 + by (rule lub_const [THEN thelubI])
205.282
205.283 subsection {* Finite chains *}
205.284
205.285 -definition
205.286 +definition max_in_chain :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool" where
205.287 -- {* finite chains, needed for monotony of continuous functions *}
205.288 - max_in_chain :: "[nat, nat \<Rightarrow> 'a::po] \<Rightarrow> bool" where
205.289 - "max_in_chain i C = (\<forall>j. i \<le> j \<longrightarrow> C i = C j)"
205.290 + "max_in_chain i C \<longleftrightarrow> (\<forall>j. i \<le> j \<longrightarrow> C i = C j)"
205.291
205.292 -definition
205.293 - finite_chain :: "(nat \<Rightarrow> 'a::po) \<Rightarrow> bool" where
205.294 +definition finite_chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool" where
205.295 "finite_chain C = (chain C \<and> (\<exists>i. max_in_chain i C))"
205.296
205.297 text {* results about finite chains *}
205.298
205.299 lemma max_in_chainI: "(\<And>j. i \<le> j \<Longrightarrow> Y i = Y j) \<Longrightarrow> max_in_chain i Y"
205.300 -unfolding max_in_chain_def by fast
205.301 + unfolding max_in_chain_def by fast
205.302
205.303 lemma max_in_chainD: "\<lbrakk>max_in_chain i Y; i \<le> j\<rbrakk> \<Longrightarrow> Y i = Y j"
205.304 -unfolding max_in_chain_def by fast
205.305 + unfolding max_in_chain_def by fast
205.306
205.307 lemma finite_chainI:
205.308 "\<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> finite_chain C"
205.309 -unfolding finite_chain_def by fast
205.310 + unfolding finite_chain_def by fast
205.311
205.312 lemma finite_chainE:
205.313 "\<lbrakk>finite_chain C; \<And>i. \<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
205.314 -unfolding finite_chain_def by fast
205.315 + unfolding finite_chain_def by fast
205.316
205.317 lemma lub_finch1: "\<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> range C <<| C i"
205.318 apply (rule is_lubI)
205.319 @@ -302,7 +313,7 @@
205.320 apply (erule exE)
205.321 apply (rule finite_chainI, assumption)
205.322 apply (rule max_in_chainI)
205.323 - apply (rule antisym_less)
205.324 + apply (rule below_antisym)
205.325 apply (erule (1) chain_mono)
205.326 apply (erule spec)
205.327 apply (rule finite_range_has_max)
205.328 @@ -311,11 +322,11 @@
205.329 done
205.330
205.331 lemma bin_chain: "x \<sqsubseteq> y \<Longrightarrow> chain (\<lambda>i. if i=0 then x else y)"
205.332 -by (rule chainI, simp)
205.333 + by (rule chainI, simp)
205.334
205.335 lemma bin_chainmax:
205.336 "x \<sqsubseteq> y \<Longrightarrow> max_in_chain (Suc 0) (\<lambda>i. if i=0 then x else y)"
205.337 -unfolding max_in_chain_def by simp
205.338 + unfolding max_in_chain_def by simp
205.339
205.340 lemma lub_bin_chain:
205.341 "x \<sqsubseteq> y \<Longrightarrow> range (\<lambda>i::nat. if i=0 then x else y) <<| y"
205.342 @@ -328,36 +339,35 @@
205.343 text {* the maximal element in a chain is its lub *}
205.344
205.345 lemma lub_chain_maxelem: "\<lbrakk>Y i = c; \<forall>i. Y i \<sqsubseteq> c\<rbrakk> \<Longrightarrow> lub (range Y) = c"
205.346 -by (blast dest: ub_rangeD intro: thelubI is_lubI ub_rangeI)
205.347 + by (blast dest: ub_rangeD intro: thelubI is_lubI ub_rangeI)
205.348
205.349 subsection {* Directed sets *}
205.350
205.351 -definition
205.352 - directed :: "'a::po set \<Rightarrow> bool" where
205.353 - "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))"
205.354 +definition directed :: "'a set \<Rightarrow> bool" where
205.355 + "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)"
205.356
205.357 lemma directedI:
205.358 assumes 1: "\<exists>z. z \<in> S"
205.359 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"
205.360 shows "directed S"
205.361 -unfolding directed_def using prems by fast
205.362 + unfolding directed_def using prems by fast
205.363
205.364 lemma directedD1: "directed S \<Longrightarrow> \<exists>z. z \<in> S"
205.365 -unfolding directed_def by fast
205.366 + unfolding directed_def by fast
205.367
205.368 lemma directedD2: "\<lbrakk>directed S; x \<in> S; y \<in> S\<rbrakk> \<Longrightarrow> \<exists>z\<in>S. x \<sqsubseteq> z \<and> y \<sqsubseteq> z"
205.369 -unfolding directed_def by fast
205.370 + unfolding directed_def by fast
205.371
205.372 lemma directedE1:
205.373 assumes S: "directed S"
205.374 obtains z where "z \<in> S"
205.375 -by (insert directedD1 [OF S], fast)
205.376 + by (insert directedD1 [OF S], fast)
205.377
205.378 lemma directedE2:
205.379 assumes S: "directed S"
205.380 assumes x: "x \<in> S" and y: "y \<in> S"
205.381 obtains z where "z \<in> S" "x \<sqsubseteq> z" "y \<sqsubseteq> z"
205.382 -by (insert directedD2 [OF S x y], fast)
205.383 + by (insert directedD2 [OF S x y], fast)
205.384
205.385 lemma directed_finiteI:
205.386 assumes U: "\<And>U. \<lbrakk>finite U; U \<subseteq> S\<rbrakk> \<Longrightarrow> \<exists>z\<in>S. U <| z"
205.387 @@ -395,13 +405,13 @@
205.388 qed
205.389
205.390 lemma not_directed_empty [simp]: "\<not> directed {}"
205.391 -by (rule notI, drule directedD1, simp)
205.392 + by (rule notI, drule directedD1, simp)
205.393
205.394 lemma directed_singleton: "directed {x}"
205.395 -by (rule directedI, auto)
205.396 + by (rule directedI, auto)
205.397
205.398 lemma directed_bin: "x \<sqsubseteq> y \<Longrightarrow> directed {x, y}"
205.399 -by (rule directedI, auto)
205.400 + by (rule directedI, auto)
205.401
205.402 lemma directed_chain: "chain S \<Longrightarrow> directed (range S)"
205.403 apply (rule directedI)
205.404 @@ -412,4 +422,33 @@
205.405 apply simp
205.406 done
205.407
205.408 +text {* lemmata for improved admissibility introdution rule *}
205.409 +
205.410 +lemma infinite_chain_adm_lemma:
205.411 + "\<lbrakk>chain Y; \<forall>i. P (Y i);
205.412 + \<And>Y. \<lbrakk>chain Y; \<forall>i. P (Y i); \<not> finite_chain Y\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)\<rbrakk>
205.413 + \<Longrightarrow> P (\<Squnion>i. Y i)"
205.414 +apply (case_tac "finite_chain Y")
205.415 +prefer 2 apply fast
205.416 +apply (unfold finite_chain_def)
205.417 +apply safe
205.418 +apply (erule lub_finch1 [THEN thelubI, THEN ssubst])
205.419 +apply assumption
205.420 +apply (erule spec)
205.421 +done
205.422 +
205.423 +lemma increasing_chain_adm_lemma:
205.424 + "\<lbrakk>chain Y; \<forall>i. P (Y i); \<And>Y. \<lbrakk>chain Y; \<forall>i. P (Y i);
205.425 + \<forall>i. \<exists>j>i. Y i \<noteq> Y j \<and> Y i \<sqsubseteq> Y j\<rbrakk> \<Longrightarrow> P (\<Squnion>i. Y i)\<rbrakk>
205.426 + \<Longrightarrow> P (\<Squnion>i. Y i)"
205.427 +apply (erule infinite_chain_adm_lemma)
205.428 +apply assumption
205.429 +apply (erule thin_rl)
205.430 +apply (unfold finite_chain_def)
205.431 +apply (unfold max_in_chain_def)
205.432 +apply (fast dest: le_imp_less_or_eq elim: chain_mono_less)
205.433 +done
205.434 +
205.435 end
205.436 +
205.437 +end
206.1 --- a/src/HOLCF/Product_Cpo.thy Mon May 11 09:39:53 2009 +0200
206.2 +++ b/src/HOLCF/Product_Cpo.thy Mon May 11 17:20:52 2009 +0200
206.3 @@ -12,11 +12,11 @@
206.4
206.5 subsection {* Type @{typ unit} is a pcpo *}
206.6
206.7 -instantiation unit :: sq_ord
206.8 +instantiation unit :: below
206.9 begin
206.10
206.11 definition
206.12 - less_unit_def [simp]: "x \<sqsubseteq> (y::unit) \<equiv> True"
206.13 + below_unit_def [simp]: "x \<sqsubseteq> (y::unit) \<longleftrightarrow> True"
206.14
206.15 instance ..
206.16 end
206.17 @@ -32,11 +32,11 @@
206.18
206.19 subsection {* Product type is a partial order *}
206.20
206.21 -instantiation "*" :: (sq_ord, sq_ord) sq_ord
206.22 +instantiation "*" :: (below, below) below
206.23 begin
206.24
206.25 definition
206.26 - less_cprod_def: "(op \<sqsubseteq>) \<equiv> \<lambda>p1 p2. (fst p1 \<sqsubseteq> fst p2 \<and> snd p1 \<sqsubseteq> snd p2)"
206.27 + below_prod_def: "(op \<sqsubseteq>) \<equiv> \<lambda>p1 p2. (fst p1 \<sqsubseteq> fst p2 \<and> snd p1 \<sqsubseteq> snd p2)"
206.28
206.29 instance ..
206.30 end
206.31 @@ -45,26 +45,26 @@
206.32 proof
206.33 fix x :: "'a \<times> 'b"
206.34 show "x \<sqsubseteq> x"
206.35 - unfolding less_cprod_def by simp
206.36 + unfolding below_prod_def by simp
206.37 next
206.38 fix x y :: "'a \<times> 'b"
206.39 assume "x \<sqsubseteq> y" "y \<sqsubseteq> x" thus "x = y"
206.40 - unfolding less_cprod_def Pair_fst_snd_eq
206.41 - by (fast intro: antisym_less)
206.42 + unfolding below_prod_def Pair_fst_snd_eq
206.43 + by (fast intro: below_antisym)
206.44 next
206.45 fix x y z :: "'a \<times> 'b"
206.46 assume "x \<sqsubseteq> y" "y \<sqsubseteq> z" thus "x \<sqsubseteq> z"
206.47 - unfolding less_cprod_def
206.48 - by (fast intro: trans_less)
206.49 + unfolding below_prod_def
206.50 + by (fast intro: below_trans)
206.51 qed
206.52
206.53 subsection {* Monotonicity of @{text "(_,_)"}, @{term fst}, @{term snd} *}
206.54
206.55 -lemma prod_lessI: "\<lbrakk>fst p \<sqsubseteq> fst q; snd p \<sqsubseteq> snd q\<rbrakk> \<Longrightarrow> p \<sqsubseteq> q"
206.56 -unfolding less_cprod_def by simp
206.57 +lemma prod_belowI: "\<lbrakk>fst p \<sqsubseteq> fst q; snd p \<sqsubseteq> snd q\<rbrakk> \<Longrightarrow> p \<sqsubseteq> q"
206.58 +unfolding below_prod_def by simp
206.59
206.60 -lemma Pair_less_iff [simp]: "(a, b) \<sqsubseteq> (c, d) \<longleftrightarrow> a \<sqsubseteq> c \<and> b \<sqsubseteq> d"
206.61 -unfolding less_cprod_def by simp
206.62 +lemma Pair_below_iff [simp]: "(a, b) \<sqsubseteq> (c, d) \<longleftrightarrow> a \<sqsubseteq> c \<and> b \<sqsubseteq> d"
206.63 +unfolding below_prod_def by simp
206.64
206.65 text {* Pair @{text "(_,_)"} is monotone in both arguments *}
206.66
206.67 @@ -81,20 +81,20 @@
206.68 text {* @{term fst} and @{term snd} are monotone *}
206.69
206.70 lemma monofun_fst: "monofun fst"
206.71 -by (simp add: monofun_def less_cprod_def)
206.72 +by (simp add: monofun_def below_prod_def)
206.73
206.74 lemma monofun_snd: "monofun snd"
206.75 -by (simp add: monofun_def less_cprod_def)
206.76 +by (simp add: monofun_def below_prod_def)
206.77
206.78 subsection {* Product type is a cpo *}
206.79
206.80 lemma is_lub_Pair:
206.81 "\<lbrakk>range X <<| x; range Y <<| y\<rbrakk> \<Longrightarrow> range (\<lambda>i. (X i, Y i)) <<| (x, y)"
206.82 apply (rule is_lubI [OF ub_rangeI])
206.83 -apply (simp add: less_cprod_def is_ub_lub)
206.84 +apply (simp add: below_prod_def is_ub_lub)
206.85 apply (frule ub2ub_monofun [OF monofun_fst])
206.86 apply (drule ub2ub_monofun [OF monofun_snd])
206.87 -apply (simp add: less_cprod_def is_lub_lub)
206.88 +apply (simp add: below_prod_def is_lub_lub)
206.89 done
206.90
206.91 lemma lub_cprod:
206.92 @@ -134,14 +134,14 @@
206.93 proof
206.94 fix x y :: "'a \<times> 'b"
206.95 show "x \<sqsubseteq> y \<longleftrightarrow> x = y"
206.96 - unfolding less_cprod_def Pair_fst_snd_eq
206.97 + unfolding below_prod_def Pair_fst_snd_eq
206.98 by simp
206.99 qed
206.100
206.101 subsection {* Product type is pointed *}
206.102
206.103 lemma minimal_cprod: "(\<bottom>, \<bottom>) \<sqsubseteq> p"
206.104 -by (simp add: less_cprod_def)
206.105 +by (simp add: below_prod_def)
206.106
206.107 instance "*" :: (pcpo, pcpo) pcpo
206.108 by intro_classes (fast intro: minimal_cprod)
206.109 @@ -206,31 +206,71 @@
206.110 assumes f: "cont (\<lambda>x. f x)"
206.111 assumes g: "cont (\<lambda>x. g x)"
206.112 shows "cont (\<lambda>x. (f x, g x))"
206.113 -apply (rule cont2cont_apply [OF _ cont_pair1 f])
206.114 -apply (rule cont2cont_apply [OF _ cont_pair2 g])
206.115 +apply (rule cont_apply [OF f cont_pair1])
206.116 +apply (rule cont_apply [OF g cont_pair2])
206.117 apply (rule cont_const)
206.118 done
206.119
206.120 -lemmas cont2cont_fst [cont2cont] = cont2cont_compose [OF cont_fst]
206.121 +lemmas cont2cont_fst [cont2cont] = cont_compose [OF cont_fst]
206.122
206.123 -lemmas cont2cont_snd [cont2cont] = cont2cont_compose [OF cont_snd]
206.124 +lemmas cont2cont_snd [cont2cont] = cont_compose [OF cont_snd]
206.125 +
206.126 +lemma cont2cont_split:
206.127 + assumes f1: "\<And>a b. cont (\<lambda>x. f x a b)"
206.128 + assumes f2: "\<And>x b. cont (\<lambda>a. f x a b)"
206.129 + assumes f3: "\<And>x a. cont (\<lambda>b. f x a b)"
206.130 + assumes g: "cont (\<lambda>x. g x)"
206.131 + shows "cont (\<lambda>x. split (\<lambda>a b. f x a b) (g x))"
206.132 +unfolding split_def
206.133 +apply (rule cont_apply [OF g])
206.134 +apply (rule cont_apply [OF cont_fst f2])
206.135 +apply (rule cont_apply [OF cont_snd f3])
206.136 +apply (rule cont_const)
206.137 +apply (rule f1)
206.138 +done
206.139 +
206.140 +lemma cont_fst_snd_D1:
206.141 + "cont (\<lambda>p. f (fst p) (snd p)) \<Longrightarrow> cont (\<lambda>x. f x y)"
206.142 +by (drule cont_compose [OF _ cont_pair1], simp)
206.143 +
206.144 +lemma cont_fst_snd_D2:
206.145 + "cont (\<lambda>p. f (fst p) (snd p)) \<Longrightarrow> cont (\<lambda>y. f x y)"
206.146 +by (drule cont_compose [OF _ cont_pair2], simp)
206.147 +
206.148 +lemma cont2cont_split' [cont2cont]:
206.149 + assumes f: "cont (\<lambda>p. f (fst p) (fst (snd p)) (snd (snd p)))"
206.150 + assumes g: "cont (\<lambda>x. g x)"
206.151 + shows "cont (\<lambda>x. split (f x) (g x))"
206.152 +proof -
206.153 + note f1 = f [THEN cont_fst_snd_D1]
206.154 + note f2 = f [THEN cont_fst_snd_D2, THEN cont_fst_snd_D1]
206.155 + note f3 = f [THEN cont_fst_snd_D2, THEN cont_fst_snd_D2]
206.156 + show ?thesis
206.157 + unfolding split_def
206.158 + apply (rule cont_apply [OF g])
206.159 + apply (rule cont_apply [OF cont_fst f2])
206.160 + apply (rule cont_apply [OF cont_snd f3])
206.161 + apply (rule cont_const)
206.162 + apply (rule f1)
206.163 + done
206.164 +qed
206.165
206.166 subsection {* Compactness and chain-finiteness *}
206.167
206.168 -lemma fst_less_iff: "fst (x::'a \<times> 'b) \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (y, snd x)"
206.169 -unfolding less_cprod_def by simp
206.170 +lemma fst_below_iff: "fst (x::'a \<times> 'b) \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (y, snd x)"
206.171 +unfolding below_prod_def by simp
206.172
206.173 -lemma snd_less_iff: "snd (x::'a \<times> 'b) \<sqsubseteq> y = x \<sqsubseteq> (fst x, y)"
206.174 -unfolding less_cprod_def by simp
206.175 +lemma snd_below_iff: "snd (x::'a \<times> 'b) \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (fst x, y)"
206.176 +unfolding below_prod_def by simp
206.177
206.178 lemma compact_fst: "compact x \<Longrightarrow> compact (fst x)"
206.179 -by (rule compactI, simp add: fst_less_iff)
206.180 +by (rule compactI, simp add: fst_below_iff)
206.181
206.182 lemma compact_snd: "compact x \<Longrightarrow> compact (snd x)"
206.183 -by (rule compactI, simp add: snd_less_iff)
206.184 +by (rule compactI, simp add: snd_below_iff)
206.185
206.186 lemma compact_Pair: "\<lbrakk>compact x; compact y\<rbrakk> \<Longrightarrow> compact (x, y)"
206.187 -by (rule compactI, simp add: less_cprod_def)
206.188 +by (rule compactI, simp add: below_prod_def)
206.189
206.190 lemma compact_Pair_iff [simp]: "compact (x, y) \<longleftrightarrow> compact x \<and> compact y"
206.191 apply (safe intro!: compact_Pair)
207.1 --- a/src/HOLCF/Sprod.thy Mon May 11 09:39:53 2009 +0200
207.2 +++ b/src/HOLCF/Sprod.thy Mon May 11 17:20:52 2009 +0200
207.3 @@ -20,7 +20,7 @@
207.4 by (rule typedef_finite_po [OF type_definition_Sprod])
207.5
207.6 instance "**" :: ("{chfin,pcpo}", "{chfin,pcpo}") chfin
207.7 -by (rule typedef_chfin [OF type_definition_Sprod less_Sprod_def])
207.8 +by (rule typedef_chfin [OF type_definition_Sprod below_Sprod_def])
207.9
207.10 syntax (xsymbols)
207.11 "**" :: "[type, type] => type" ("(_ \<otimes>/ _)" [21,20] 20)
207.12 @@ -67,7 +67,7 @@
207.13 by (simp add: cont_Abs_Sprod Abs_Sprod_inverse spair_lemma)
207.14
207.15 lemmas Rep_Sprod_simps =
207.16 - Rep_Sprod_inject [symmetric] less_Sprod_def
207.17 + Rep_Sprod_inject [symmetric] below_Sprod_def
207.18 Rep_Sprod_strict Rep_Sprod_spair
207.19
207.20 lemma Exh_Sprod:
207.21 @@ -99,7 +99,7 @@
207.22 lemma spair_strict_iff [simp]: "((:x, y:) = \<bottom>) = (x = \<bottom> \<or> y = \<bottom>)"
207.23 by (simp add: Rep_Sprod_simps strictify_conv_if)
207.24
207.25 -lemma spair_less_iff:
207.26 +lemma spair_below_iff:
207.27 "((:a, b:) \<sqsubseteq> (:c, d:)) = (a = \<bottom> \<or> b = \<bottom> \<or> (a \<sqsubseteq> c \<and> b \<sqsubseteq> d))"
207.28 by (simp add: Rep_Sprod_simps strictify_conv_if)
207.29
207.30 @@ -160,38 +160,38 @@
207.31 lemma surjective_pairing_Sprod2: "(:sfst\<cdot>p, ssnd\<cdot>p:) = p"
207.32 by (cases p, simp_all)
207.33
207.34 -lemma less_sprod: "x \<sqsubseteq> y = (sfst\<cdot>x \<sqsubseteq> sfst\<cdot>y \<and> ssnd\<cdot>x \<sqsubseteq> ssnd\<cdot>y)"
207.35 -apply (simp add: less_Sprod_def sfst_def ssnd_def cont_Rep_Sprod)
207.36 -apply (rule less_cprod)
207.37 +lemma below_sprod: "x \<sqsubseteq> y = (sfst\<cdot>x \<sqsubseteq> sfst\<cdot>y \<and> ssnd\<cdot>x \<sqsubseteq> ssnd\<cdot>y)"
207.38 +apply (simp add: below_Sprod_def sfst_def ssnd_def cont_Rep_Sprod)
207.39 +apply (rule below_cprod)
207.40 done
207.41
207.42 lemma eq_sprod: "(x = y) = (sfst\<cdot>x = sfst\<cdot>y \<and> ssnd\<cdot>x = ssnd\<cdot>y)"
207.43 -by (auto simp add: po_eq_conv less_sprod)
207.44 +by (auto simp add: po_eq_conv below_sprod)
207.45
207.46 -lemma spair_less:
207.47 +lemma spair_below:
207.48 "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> (:x, y:) \<sqsubseteq> (:a, b:) = (x \<sqsubseteq> a \<and> y \<sqsubseteq> b)"
207.49 apply (cases "a = \<bottom>", simp)
207.50 apply (cases "b = \<bottom>", simp)
207.51 -apply (simp add: less_sprod)
207.52 +apply (simp add: below_sprod)
207.53 done
207.54
207.55 -lemma sfst_less_iff: "sfst\<cdot>x \<sqsubseteq> y = x \<sqsubseteq> (:y, ssnd\<cdot>x:)"
207.56 +lemma sfst_below_iff: "sfst\<cdot>x \<sqsubseteq> y = x \<sqsubseteq> (:y, ssnd\<cdot>x:)"
207.57 apply (cases "x = \<bottom>", simp, cases "y = \<bottom>", simp)
207.58 -apply (simp add: less_sprod)
207.59 +apply (simp add: below_sprod)
207.60 done
207.61
207.62 -lemma ssnd_less_iff: "ssnd\<cdot>x \<sqsubseteq> y = x \<sqsubseteq> (:sfst\<cdot>x, y:)"
207.63 +lemma ssnd_below_iff: "ssnd\<cdot>x \<sqsubseteq> y = x \<sqsubseteq> (:sfst\<cdot>x, y:)"
207.64 apply (cases "x = \<bottom>", simp, cases "y = \<bottom>", simp)
207.65 -apply (simp add: less_sprod)
207.66 +apply (simp add: below_sprod)
207.67 done
207.68
207.69 subsection {* Compactness *}
207.70
207.71 lemma compact_sfst: "compact x \<Longrightarrow> compact (sfst\<cdot>x)"
207.72 -by (rule compactI, simp add: sfst_less_iff)
207.73 +by (rule compactI, simp add: sfst_below_iff)
207.74
207.75 lemma compact_ssnd: "compact x \<Longrightarrow> compact (ssnd\<cdot>x)"
207.76 -by (rule compactI, simp add: ssnd_less_iff)
207.77 +by (rule compactI, simp add: ssnd_below_iff)
207.78
207.79 lemma compact_spair: "\<lbrakk>compact x; compact y\<rbrakk> \<Longrightarrow> compact (:x, y:)"
207.80 by (rule compact_Sprod, simp add: Rep_Sprod_spair strictify_conv_if)
207.81 @@ -224,7 +224,7 @@
207.82 assume "x \<sqsubseteq> y" thus "x = \<bottom> \<or> x = y"
207.83 apply (induct x, simp)
207.84 apply (induct y, simp)
207.85 - apply (simp add: spair_less_iff flat_less_iff)
207.86 + apply (simp add: spair_below_iff flat_below_iff)
207.87 done
207.88 qed
207.89
208.1 --- a/src/HOLCF/Ssum.thy Mon May 11 09:39:53 2009 +0200
208.2 +++ b/src/HOLCF/Ssum.thy Mon May 11 17:20:52 2009 +0200
208.3 @@ -22,7 +22,7 @@
208.4 by (rule typedef_finite_po [OF type_definition_Ssum])
208.5
208.6 instance "++" :: ("{chfin,pcpo}", "{chfin,pcpo}") chfin
208.7 -by (rule typedef_chfin [OF type_definition_Ssum less_Ssum_def])
208.8 +by (rule typedef_chfin [OF type_definition_Ssum below_Ssum_def])
208.9
208.10 syntax (xsymbols)
208.11 "++" :: "[type, type] => type" ("(_ \<oplus>/ _)" [21, 20] 20)
208.12 @@ -61,17 +61,17 @@
208.13
208.14 text {* Ordering *}
208.15
208.16 -lemma sinl_less [simp]: "(sinl\<cdot>x \<sqsubseteq> sinl\<cdot>y) = (x \<sqsubseteq> y)"
208.17 -by (simp add: less_Ssum_def Rep_Ssum_sinl strictify_conv_if)
208.18 +lemma sinl_below [simp]: "(sinl\<cdot>x \<sqsubseteq> sinl\<cdot>y) = (x \<sqsubseteq> y)"
208.19 +by (simp add: below_Ssum_def Rep_Ssum_sinl strictify_conv_if)
208.20
208.21 -lemma sinr_less [simp]: "(sinr\<cdot>x \<sqsubseteq> sinr\<cdot>y) = (x \<sqsubseteq> y)"
208.22 -by (simp add: less_Ssum_def Rep_Ssum_sinr strictify_conv_if)
208.23 +lemma sinr_below [simp]: "(sinr\<cdot>x \<sqsubseteq> sinr\<cdot>y) = (x \<sqsubseteq> y)"
208.24 +by (simp add: below_Ssum_def Rep_Ssum_sinr strictify_conv_if)
208.25
208.26 -lemma sinl_less_sinr [simp]: "(sinl\<cdot>x \<sqsubseteq> sinr\<cdot>y) = (x = \<bottom>)"
208.27 -by (simp add: less_Ssum_def Rep_Ssum_sinl Rep_Ssum_sinr strictify_conv_if)
208.28 +lemma sinl_below_sinr [simp]: "(sinl\<cdot>x \<sqsubseteq> sinr\<cdot>y) = (x = \<bottom>)"
208.29 +by (simp add: below_Ssum_def Rep_Ssum_sinl Rep_Ssum_sinr strictify_conv_if)
208.30
208.31 -lemma sinr_less_sinl [simp]: "(sinr\<cdot>x \<sqsubseteq> sinl\<cdot>y) = (x = \<bottom>)"
208.32 -by (simp add: less_Ssum_def Rep_Ssum_sinl Rep_Ssum_sinr strictify_conv_if)
208.33 +lemma sinr_below_sinl [simp]: "(sinr\<cdot>x \<sqsubseteq> sinl\<cdot>y) = (x = \<bottom>)"
208.34 +by (simp add: below_Ssum_def Rep_Ssum_sinl Rep_Ssum_sinr strictify_conv_if)
208.35
208.36 text {* Equality *}
208.37
208.38 @@ -167,10 +167,10 @@
208.39 "\<lbrakk>\<And>x. p = sinl\<cdot>x \<Longrightarrow> Q; \<And>y. p = sinr\<cdot>y \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
208.40 by (cases p, simp only: sinl_strict [symmetric], simp, simp)
208.41
208.42 -lemma less_sinlD: "p \<sqsubseteq> sinl\<cdot>x \<Longrightarrow> \<exists>y. p = sinl\<cdot>y \<and> y \<sqsubseteq> x"
208.43 +lemma below_sinlD: "p \<sqsubseteq> sinl\<cdot>x \<Longrightarrow> \<exists>y. p = sinl\<cdot>y \<and> y \<sqsubseteq> x"
208.44 by (cases p, rule_tac x="\<bottom>" in exI, simp_all)
208.45
208.46 -lemma less_sinrD: "p \<sqsubseteq> sinr\<cdot>x \<Longrightarrow> \<exists>y. p = sinr\<cdot>y \<and> y \<sqsubseteq> x"
208.47 +lemma below_sinrD: "p \<sqsubseteq> sinr\<cdot>x \<Longrightarrow> \<exists>y. p = sinr\<cdot>y \<and> y \<sqsubseteq> x"
208.48 by (cases p, rule_tac x="\<bottom>" in exI, simp_all)
208.49
208.50 subsection {* Case analysis combinator *}
208.51 @@ -207,8 +207,8 @@
208.52 instance "++" :: (flat, flat) flat
208.53 apply (intro_classes, clarify)
208.54 apply (rule_tac p=x in ssumE, simp)
208.55 -apply (rule_tac p=y in ssumE, simp_all add: flat_less_iff)
208.56 -apply (rule_tac p=y in ssumE, simp_all add: flat_less_iff)
208.57 +apply (rule_tac p=y in ssumE, simp_all add: flat_below_iff)
208.58 +apply (rule_tac p=y in ssumE, simp_all add: flat_below_iff)
208.59 done
208.60
208.61 subsection {* Strict sum is a bifinite domain *}
209.1 --- a/src/HOLCF/Sum_Cpo.thy Mon May 11 09:39:53 2009 +0200
209.2 +++ b/src/HOLCF/Sum_Cpo.thy Mon May 11 17:20:52 2009 +0200
209.3 @@ -10,28 +10,28 @@
209.4
209.5 subsection {* Ordering on type @{typ "'a + 'b"} *}
209.6
209.7 -instantiation "+" :: (sq_ord, sq_ord) sq_ord
209.8 +instantiation "+" :: (below, below) below
209.9 begin
209.10
209.11 -definition
209.12 - less_sum_def: "x \<sqsubseteq> y \<equiv> case x of
209.13 +definition below_sum_def:
209.14 + "x \<sqsubseteq> y \<equiv> case x of
209.15 Inl a \<Rightarrow> (case y of Inl b \<Rightarrow> a \<sqsubseteq> b | Inr b \<Rightarrow> False) |
209.16 Inr a \<Rightarrow> (case y of Inl b \<Rightarrow> False | Inr b \<Rightarrow> a \<sqsubseteq> b)"
209.17
209.18 instance ..
209.19 end
209.20
209.21 -lemma Inl_less_iff [simp]: "Inl x \<sqsubseteq> Inl y = x \<sqsubseteq> y"
209.22 -unfolding less_sum_def by simp
209.23 +lemma Inl_below_Inl [simp]: "Inl x \<sqsubseteq> Inl y = x \<sqsubseteq> y"
209.24 +unfolding below_sum_def by simp
209.25
209.26 -lemma Inr_less_iff [simp]: "Inr x \<sqsubseteq> Inr y = x \<sqsubseteq> y"
209.27 -unfolding less_sum_def by simp
209.28 +lemma Inr_below_Inr [simp]: "Inr x \<sqsubseteq> Inr y = x \<sqsubseteq> y"
209.29 +unfolding below_sum_def by simp
209.30
209.31 -lemma Inl_less_Inr [simp]: "\<not> Inl x \<sqsubseteq> Inr y"
209.32 -unfolding less_sum_def by simp
209.33 +lemma Inl_below_Inr [simp]: "\<not> Inl x \<sqsubseteq> Inr y"
209.34 +unfolding below_sum_def by simp
209.35
209.36 -lemma Inr_less_Inl [simp]: "\<not> Inr x \<sqsubseteq> Inl y"
209.37 -unfolding less_sum_def by simp
209.38 +lemma Inr_below_Inl [simp]: "\<not> Inr x \<sqsubseteq> Inl y"
209.39 +unfolding below_sum_def by simp
209.40
209.41 lemma Inl_mono: "x \<sqsubseteq> y \<Longrightarrow> Inl x \<sqsubseteq> Inl y"
209.42 by simp
209.43 @@ -39,20 +39,20 @@
209.44 lemma Inr_mono: "x \<sqsubseteq> y \<Longrightarrow> Inr x \<sqsubseteq> Inr y"
209.45 by simp
209.46
209.47 -lemma Inl_lessE: "\<lbrakk>Inl a \<sqsubseteq> x; \<And>b. \<lbrakk>x = Inl b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
209.48 +lemma Inl_belowE: "\<lbrakk>Inl a \<sqsubseteq> x; \<And>b. \<lbrakk>x = Inl b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
209.49 by (cases x, simp_all)
209.50
209.51 -lemma Inr_lessE: "\<lbrakk>Inr a \<sqsubseteq> x; \<And>b. \<lbrakk>x = Inr b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
209.52 +lemma Inr_belowE: "\<lbrakk>Inr a \<sqsubseteq> x; \<And>b. \<lbrakk>x = Inr b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
209.53 by (cases x, simp_all)
209.54
209.55 -lemmas sum_less_elims = Inl_lessE Inr_lessE
209.56 +lemmas sum_below_elims = Inl_belowE Inr_belowE
209.57
209.58 -lemma sum_less_cases:
209.59 +lemma sum_below_cases:
209.60 "\<lbrakk>x \<sqsubseteq> y;
209.61 \<And>a b. \<lbrakk>x = Inl a; y = Inl b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R;
209.62 \<And>a b. \<lbrakk>x = Inr a; y = Inr b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk>
209.63 \<Longrightarrow> R"
209.64 -by (cases x, safe elim!: sum_less_elims, auto)
209.65 +by (cases x, safe elim!: sum_below_elims, auto)
209.66
209.67 subsection {* Sum type is a complete partial order *}
209.68
209.69 @@ -64,18 +64,18 @@
209.70 next
209.71 fix x y :: "'a + 'b"
209.72 assume "x \<sqsubseteq> y" and "y \<sqsubseteq> x" thus "x = y"
209.73 - by (induct x, auto elim!: sum_less_elims intro: antisym_less)
209.74 + by (induct x, auto elim!: sum_below_elims intro: below_antisym)
209.75 next
209.76 fix x y z :: "'a + 'b"
209.77 assume "x \<sqsubseteq> y" and "y \<sqsubseteq> z" thus "x \<sqsubseteq> z"
209.78 - by (induct x, auto elim!: sum_less_elims intro: trans_less)
209.79 + by (induct x, auto elim!: sum_below_elims intro: below_trans)
209.80 qed
209.81
209.82 lemma monofun_inv_Inl: "monofun (\<lambda>p. THE a. p = Inl a)"
209.83 -by (rule monofunI, erule sum_less_cases, simp_all)
209.84 +by (rule monofunI, erule sum_below_cases, simp_all)
209.85
209.86 lemma monofun_inv_Inr: "monofun (\<lambda>p. THE b. p = Inr b)"
209.87 -by (rule monofunI, erule sum_less_cases, simp_all)
209.88 +by (rule monofunI, erule sum_below_cases, simp_all)
209.89
209.90 lemma sum_chain_cases:
209.91 assumes Y: "chain Y"
209.92 @@ -87,12 +87,12 @@
209.93 apply (rule ch2ch_monofun [OF monofun_inv_Inl Y])
209.94 apply (rule ext)
209.95 apply (cut_tac j=i in chain_mono [OF Y le0], simp)
209.96 - apply (erule Inl_lessE, simp)
209.97 + apply (erule Inl_belowE, simp)
209.98 apply (rule B)
209.99 apply (rule ch2ch_monofun [OF monofun_inv_Inr Y])
209.100 apply (rule ext)
209.101 apply (cut_tac j=i in chain_mono [OF Y le0], simp)
209.102 - apply (erule Inr_lessE, simp)
209.103 + apply (erule Inr_belowE, simp)
209.104 done
209.105
209.106 lemma is_lub_Inl: "range S <<| x \<Longrightarrow> range (\<lambda>i. Inl (S i)) <<| Inl x"
209.107 @@ -100,7 +100,7 @@
209.108 apply (rule ub_rangeI)
209.109 apply (simp add: is_ub_lub)
209.110 apply (frule ub_rangeD [where i=arbitrary])
209.111 - apply (erule Inl_lessE, simp)
209.112 + apply (erule Inl_belowE, simp)
209.113 apply (erule is_lub_lub)
209.114 apply (rule ub_rangeI)
209.115 apply (drule ub_rangeD, simp)
209.116 @@ -111,7 +111,7 @@
209.117 apply (rule ub_rangeI)
209.118 apply (simp add: is_ub_lub)
209.119 apply (frule ub_rangeD [where i=arbitrary])
209.120 - apply (erule Inr_lessE, simp)
209.121 + apply (erule Inr_belowE, simp)
209.122 apply (erule is_lub_lub)
209.123 apply (rule ub_rangeI)
209.124 apply (drule ub_rangeD, simp)
209.125 @@ -130,17 +130,14 @@
209.126
209.127 subsection {* Continuity of @{term Inl}, @{term Inr}, @{term sum_case} *}
209.128
209.129 -lemma cont2cont_Inl [simp]: "cont f \<Longrightarrow> cont (\<lambda>x. Inl (f x))"
209.130 -by (fast intro: contI is_lub_Inl elim: contE)
209.131 -
209.132 -lemma cont2cont_Inr [simp]: "cont f \<Longrightarrow> cont (\<lambda>x. Inr (f x))"
209.133 -by (fast intro: contI is_lub_Inr elim: contE)
209.134 -
209.135 lemma cont_Inl: "cont Inl"
209.136 -by (rule cont2cont_Inl [OF cont_id])
209.137 +by (intro contI is_lub_Inl cpo_lubI)
209.138
209.139 lemma cont_Inr: "cont Inr"
209.140 -by (rule cont2cont_Inr [OF cont_id])
209.141 +by (intro contI is_lub_Inr cpo_lubI)
209.142 +
209.143 +lemmas cont2cont_Inl [cont2cont] = cont_compose [OF cont_Inl]
209.144 +lemmas cont2cont_Inr [cont2cont] = cont_compose [OF cont_Inr]
209.145
209.146 lemmas ch2ch_Inl [simp] = ch2ch_cont [OF cont_Inl]
209.147 lemmas ch2ch_Inr [simp] = ch2ch_cont [OF cont_Inr]
209.148 @@ -161,16 +158,33 @@
209.149 apply (simp add: cont2contlubE [OF cont_Inr, symmetric] contE)
209.150 done
209.151
209.152 -lemma cont2cont_sum_case [simp]:
209.153 +lemma cont2cont_sum_case:
209.154 assumes f1: "\<And>a. cont (\<lambda>x. f x a)" and f2: "\<And>x. cont (\<lambda>a. f x a)"
209.155 assumes g1: "\<And>b. cont (\<lambda>x. g x b)" and g2: "\<And>x. cont (\<lambda>b. g x b)"
209.156 assumes h: "cont (\<lambda>x. h x)"
209.157 shows "cont (\<lambda>x. case h x of Inl a \<Rightarrow> f x a | Inr b \<Rightarrow> g x b)"
209.158 -apply (rule cont2cont_app2 [OF cont2cont_lambda _ h])
209.159 +apply (rule cont_apply [OF h])
209.160 +apply (rule cont_sum_case2 [OF f2 g2])
209.161 apply (rule cont_sum_case1 [OF f1 g1])
209.162 -apply (rule cont_sum_case2 [OF f2 g2])
209.163 done
209.164
209.165 +lemma cont2cont_sum_case' [cont2cont]:
209.166 + assumes f: "cont (\<lambda>p. f (fst p) (snd p))"
209.167 + assumes g: "cont (\<lambda>p. g (fst p) (snd p))"
209.168 + assumes h: "cont (\<lambda>x. h x)"
209.169 + shows "cont (\<lambda>x. case h x of Inl a \<Rightarrow> f x a | Inr b \<Rightarrow> g x b)"
209.170 +proof -
209.171 + note f1 = f [THEN cont_fst_snd_D1]
209.172 + note f2 = f [THEN cont_fst_snd_D2]
209.173 + note g1 = g [THEN cont_fst_snd_D1]
209.174 + note g2 = g [THEN cont_fst_snd_D2]
209.175 + show ?thesis
209.176 + apply (rule cont_apply [OF h])
209.177 + apply (rule cont_sum_case2 [OF f2 g2])
209.178 + apply (rule cont_sum_case1 [OF f1 g1])
209.179 + done
209.180 +qed
209.181 +
209.182 subsection {* Compactness and chain-finiteness *}
209.183
209.184 lemma compact_Inl: "compact a \<Longrightarrow> compact (Inl a)"
209.185 @@ -212,7 +226,7 @@
209.186 instance "+" :: (finite_po, finite_po) finite_po ..
209.187
209.188 instance "+" :: (discrete_cpo, discrete_cpo) discrete_cpo
209.189 -by intro_classes (simp add: less_sum_def split: sum.split)
209.190 +by intro_classes (simp add: below_sum_def split: sum.split)
209.191
209.192 subsection {* Sum type is a bifinite domain *}
209.193
210.1 --- a/src/HOLCF/Tools/adm_tac.ML Mon May 11 09:39:53 2009 +0200
210.2 +++ b/src/HOLCF/Tools/adm_tac.ML Mon May 11 17:20:52 2009 +0200
210.3 @@ -18,7 +18,7 @@
210.4 val adm_tac: Proof.context -> (int -> tactic) -> int -> tactic
210.5 end;
210.6
210.7 -structure Adm: ADM =
210.8 +structure Adm :> ADM =
210.9 struct
210.10
210.11
211.1 --- a/src/HOLCF/Tools/cont_consts.ML Mon May 11 09:39:53 2009 +0200
211.2 +++ b/src/HOLCF/Tools/cont_consts.ML Mon May 11 17:20:52 2009 +0200
211.3 @@ -8,18 +8,16 @@
211.4
211.5 signature CONT_CONSTS =
211.6 sig
211.7 - val add_consts: (bstring * string * mixfix) list -> theory -> theory
211.8 - val add_consts_i: (bstring * typ * mixfix) list -> theory -> theory
211.9 + val add_consts: (binding * string * mixfix) list -> theory -> theory
211.10 + val add_consts_i: (binding * typ * mixfix) list -> theory -> theory
211.11 end;
211.12
211.13 -structure ContConsts: CONT_CONSTS =
211.14 +structure ContConsts :> CONT_CONSTS =
211.15 struct
211.16
211.17
211.18 (* misc utils *)
211.19
211.20 -open HOLCFLogic;
211.21 -
211.22 fun first (x,_,_) = x;
211.23 fun second (_,x,_) = x;
211.24 fun third (_,_,x) = x;
211.25 @@ -51,29 +49,33 @@
211.26 declaration with the original name, type ...=>..., and the original mixfix
211.27 is generated and connected to the other declaration via some translation.
211.28 *)
211.29 -fun fix_mixfix (syn , T, mx as Infix p ) =
211.30 - (Syntax.const_name mx syn, T, InfixName (syn, p))
211.31 - | fix_mixfix (syn , T, mx as Infixl p ) =
211.32 - (Syntax.const_name mx syn, T, InfixlName (syn, p))
211.33 - | fix_mixfix (syn , T, mx as Infixr p ) =
211.34 - (Syntax.const_name mx syn, T, InfixrName (syn, p))
211.35 +fun const_binding mx = Binding.name o Syntax.const_name mx o Binding.name_of;
211.36 +
211.37 +fun fix_mixfix (syn , T, mx as Infix p ) =
211.38 + (const_binding mx syn, T, InfixName (Binding.name_of syn, p))
211.39 + | fix_mixfix (syn , T, mx as Infixl p ) =
211.40 + (const_binding mx syn, T, InfixlName (Binding.name_of syn, p))
211.41 + | fix_mixfix (syn , T, mx as Infixr p ) =
211.42 + (const_binding mx syn, T, InfixrName (Binding.name_of syn, p))
211.43 | fix_mixfix decl = decl;
211.44 +
211.45 fun transform decl = let
211.46 val (c, T, mx) = fix_mixfix decl;
211.47 - val c2 = "_cont_" ^ c;
211.48 + val c1 = Binding.name_of c;
211.49 + val c2 = "_cont_" ^ c1;
211.50 val n = Syntax.mixfix_args mx
211.51 - in ((c , T,NoSyn),
211.52 - (c2,change_arrow n T,mx ),
211.53 - trans_rules c2 c n mx) end;
211.54 + in ((c, T, NoSyn),
211.55 + (Binding.name c2, change_arrow n T, mx),
211.56 + trans_rules c2 c1 n mx) end;
211.57
211.58 -fun cfun_arity (Type(n,[_,T])) = if n = cfun_arrow then 1+cfun_arity T else 0
211.59 +fun cfun_arity (Type(n,[_,T])) = if n = @{type_name "->"} then 1+cfun_arity T else 0
211.60 | cfun_arity _ = 0;
211.61
211.62 fun is_contconst (_,_,NoSyn ) = false
211.63 | is_contconst (_,_,Binder _) = false
211.64 | is_contconst (c,T,mx ) = cfun_arity T >= Syntax.mixfix_args mx
211.65 handle ERROR msg => cat_error msg ("in mixfix annotation for " ^
211.66 - quote (Syntax.const_name mx c));
211.67 + quote (Syntax.const_name mx (Binding.name_of c)));
211.68
211.69
211.70 (* add_consts(_i) *)
211.71 @@ -85,7 +87,7 @@
211.72 val transformed_decls = map transform contconst_decls;
211.73 in
211.74 thy
211.75 - |> (Sign.add_consts_i o map (upd_first Binding.name))
211.76 + |> Sign.add_consts_i
211.77 (normal_decls @ map first transformed_decls @ map second transformed_decls)
211.78 |> Sign.add_trrules_i (maps third transformed_decls)
211.79 end;
211.80 @@ -100,7 +102,7 @@
211.81
211.82 val _ =
211.83 OuterSyntax.command "consts" "declare constants (HOLCF)" K.thy_decl
211.84 - (Scan.repeat1 P.const >> (Toplevel.theory o add_consts));
211.85 + (Scan.repeat1 P.const_binding >> (Toplevel.theory o add_consts));
211.86
211.87 end;
211.88
212.1 --- a/src/HOLCF/Tools/cont_proc.ML Mon May 11 09:39:53 2009 +0200
212.2 +++ b/src/HOLCF/Tools/cont_proc.ML Mon May 11 17:20:52 2009 +0200
212.3 @@ -12,7 +12,7 @@
212.4 val setup: theory -> theory
212.5 end;
212.6
212.7 -structure ContProc: CONT_PROC =
212.8 +structure ContProc :> CONT_PROC =
212.9 struct
212.10
212.11 (** theory context references **)
213.1 --- a/src/HOLCF/Tools/domain/domain_axioms.ML Mon May 11 09:39:53 2009 +0200
213.2 +++ b/src/HOLCF/Tools/domain/domain_axioms.ML Mon May 11 17:20:52 2009 +0200
213.3 @@ -4,7 +4,14 @@
213.4 Syntax generator for domain command.
213.5 *)
213.6
213.7 -structure Domain_Axioms = struct
213.8 +signature DOMAIN_AXIOMS =
213.9 +sig
213.10 + val add_axioms : bstring -> Domain_Library.eq list -> theory -> theory
213.11 +end;
213.12 +
213.13 +
213.14 +structure Domain_Axioms :> DOMAIN_AXIOMS =
213.15 +struct
213.16
213.17 local
213.18
213.19 @@ -60,14 +67,18 @@
213.20 (if con'=con then TT else FF) args)) cons))
213.21 in map ddef cons end;
213.22
213.23 - val mat_defs = let
213.24 - fun mdef (con,_) = (mat_name con ^"_def",%%:(mat_name con) ==
213.25 - list_ccomb(%%:(dname^"_when"),map
213.26 - (fn (con',args) => (List.foldr /\#
213.27 - (if con'=con
213.28 - then mk_return (mk_ctuple (map (bound_arg args) args))
213.29 - else mk_fail) args)) cons))
213.30 - in map mdef cons end;
213.31 + val mat_defs =
213.32 + let
213.33 + fun mdef (con,_) =
213.34 + let
213.35 + val k = Bound 0
213.36 + val x = Bound 1
213.37 + fun one_con (con', args') =
213.38 + if con'=con then k else List.foldr /\# mk_fail args'
213.39 + val w = list_ccomb(%%:(dname^"_when"), map one_con cons)
213.40 + val rhs = /\ "x" (/\ "k" (w ` x))
213.41 + in (mat_name con ^"_def", %%:(mat_name con) == rhs) end
213.42 + in map mdef cons end;
213.43
213.44 val pat_defs =
213.45 let
213.46 @@ -135,7 +146,7 @@
213.47
213.48 in (* local *)
213.49
213.50 -fun add_axioms (comp_dnam, eqs : eq list) thy' = let
213.51 +fun add_axioms comp_dnam (eqs : eq list) thy' = let
213.52 val comp_dname = Sign.full_bname thy' comp_dnam;
213.53 val dnames = map (fst o fst) eqs;
213.54 val x_name = idx_name dnames "x";
214.1 --- a/src/HOLCF/Tools/domain/domain_extender.ML Mon May 11 09:39:53 2009 +0200
214.2 +++ b/src/HOLCF/Tools/domain/domain_extender.ML Mon May 11 17:20:52 2009 +0200
214.3 @@ -1,55 +1,40 @@
214.4 (* Title: HOLCF/Tools/domain/domain_extender.ML
214.5 - ID: $Id$
214.6 Author: David von Oheimb
214.7
214.8 Theory extender for domain command, including theory syntax.
214.9 -
214.10 -###TODO:
214.11 -
214.12 -this definition
214.13 -domain empty = silly empty
214.14 -yields
214.15 -Exception-
214.16 - TERM
214.17 - ("typ_of_term: bad encoding of type",
214.18 - [Abs ("uu", "_", Const ("NONE", "_"))]) raised
214.19 -but this works fine:
214.20 -domain Empty = silly Empty
214.21 -
214.22 -strange syntax errors are produced for:
214.23 -domain xx = xx ("x yy")
214.24 -domain 'a foo = foo (sel::"'a")
214.25 -and bar = bar ("'a dummy")
214.26 -
214.27 *)
214.28
214.29 signature DOMAIN_EXTENDER =
214.30 sig
214.31 - val add_domain: string * ((bstring * string list) *
214.32 - (string * mixfix * (bool * string option * string) list) list) list
214.33 + val add_domain_cmd: string -> (string list * binding * mixfix *
214.34 + (binding * (bool * binding option * string) list * mixfix) list) list
214.35 -> theory -> theory
214.36 - val add_domain_i: string * ((bstring * string list) *
214.37 - (string * mixfix * (bool * string option * typ) list) list) list
214.38 + val add_domain: string -> (string list * binding * mixfix *
214.39 + (binding * (bool * binding option * typ) list * mixfix) list) list
214.40 -> theory -> theory
214.41 end;
214.42
214.43 -structure Domain_Extender: DOMAIN_EXTENDER =
214.44 +structure Domain_Extender :> DOMAIN_EXTENDER =
214.45 struct
214.46
214.47 open Domain_Library;
214.48
214.49 (* ----- general testing and preprocessing of constructor list -------------- *)
214.50 -fun check_and_sort_domain (dtnvs: (string * typ list) list,
214.51 - cons'' : ((string * mixfix * (bool * string option * typ) list) list) list) sg =
214.52 +fun check_and_sort_domain
214.53 + (dtnvs : (string * typ list) list)
214.54 + (cons'' : ((binding * (bool * binding option * typ) list * mixfix) list) list)
214.55 + (sg : theory)
214.56 + : ((string * typ list) *
214.57 + (binding * (bool * binding option * typ) list * mixfix) list) list =
214.58 let
214.59 val defaultS = Sign.defaultS sg;
214.60 val test_dupl_typs = (case duplicates (op =) (map fst dtnvs) of
214.61 [] => false | dups => error ("Duplicate types: " ^ commas_quote dups));
214.62 - val test_dupl_cons = (case duplicates (op =) (map first (List.concat cons'')) of
214.63 + val test_dupl_cons = (case duplicates (op =) (map (Binding.name_of o first) (List.concat cons'')) of
214.64 [] => false | dups => error ("Duplicate constructors: "
214.65 ^ commas_quote dups));
214.66 - val test_dupl_sels = (case duplicates (op =) (List.mapPartial second
214.67 - (List.concat (map third (List.concat cons'')))) of
214.68 + val test_dupl_sels = (case duplicates (op =) (map Binding.name_of (List.mapPartial second
214.69 + (List.concat (map second (List.concat cons''))))) of
214.70 [] => false | dups => error("Duplicate selectors: "^commas_quote dups));
214.71 val test_dupl_tvars = exists(fn s=>case duplicates (op =) (map(fst o dest_TFree)s)of
214.72 [] => false | dups => error("Duplicate type arguments: "
214.73 @@ -90,26 +75,31 @@
214.74 | analyse indirect (TVar _) = Imposs "extender:analyse";
214.75 fun check_pcpo T = if pcpo_type sg T then T
214.76 else error("Constructor argument type is not of sort pcpo: "^string_of_typ sg T);
214.77 - val analyse_con = upd_third (map (upd_third (check_pcpo o analyse false)));
214.78 + val analyse_con = upd_second (map (upd_third (check_pcpo o analyse false)));
214.79 in ((dname,distinct_typevars), map analyse_con cons') end;
214.80 in ListPair.map analyse_equation (dtnvs,cons'')
214.81 end; (* let *)
214.82
214.83 (* ----- calls for building new thy and thms -------------------------------- *)
214.84
214.85 -fun gen_add_domain prep_typ (comp_dnam, eqs''') thy''' =
214.86 +fun gen_add_domain
214.87 + (prep_typ : theory -> 'a -> typ)
214.88 + (comp_dnam : string)
214.89 + (eqs''' : (string list * binding * mixfix *
214.90 + (binding * (bool * binding option * 'a) list * mixfix) list) list)
214.91 + (thy''' : theory) =
214.92 let
214.93 - val dtnvs = map ((fn (dname,vs) =>
214.94 - (Sign.full_bname thy''' dname, map (Syntax.read_typ_global thy''') vs))
214.95 - o fst) eqs''';
214.96 - val cons''' = map snd eqs''';
214.97 - fun thy_type (dname,tvars) = (Binding.name (Long_Name.base_name dname), length tvars, NoSyn);
214.98 - fun thy_arity (dname,tvars) = (dname, map (snd o dest_TFree) tvars, pcpoS);
214.99 - val thy'' = thy''' |> Sign.add_types (map thy_type dtnvs)
214.100 + val dtnvs = map (fn (vs,dname:binding,mx,_) =>
214.101 + (dname, map (Syntax.read_typ_global thy''') vs, mx)) eqs''';
214.102 + val cons''' = map (fn (_,_,_,cons) => cons) eqs''';
214.103 + fun thy_type (dname,tvars,mx) = (dname, length tvars, mx);
214.104 + fun thy_arity (dname,tvars,mx) = (Sign.full_name thy''' dname, map (snd o dest_TFree) tvars, pcpoS);
214.105 + val thy'' = thy''' |> Sign.add_types (map thy_type dtnvs)
214.106 |> fold (AxClass.axiomatize_arity o thy_arity) dtnvs;
214.107 - val cons'' = map (map (upd_third (map (upd_third (prep_typ thy''))))) cons''';
214.108 - val eqs' = check_and_sort_domain (dtnvs,cons'') thy'';
214.109 - val thy' = thy'' |> Domain_Syntax.add_syntax (comp_dnam,eqs');
214.110 + val cons'' = map (map (upd_second (map (upd_third (prep_typ thy''))))) cons''';
214.111 + val dtnvs' = map (fn (dname,vs,mx) => (Sign.full_name thy''' dname,vs)) dtnvs;
214.112 + val eqs' : ((string * typ list) * (binding * (bool * binding option * typ) list * mixfix) list) list = check_and_sort_domain dtnvs' cons'' thy'';
214.113 + val thy' = thy'' |> Domain_Syntax.add_syntax comp_dnam eqs';
214.114 val dts = map (Type o fst) eqs';
214.115 val new_dts = map (fn ((s,Ts),_) => (s, map (fst o dest_TFree) Ts)) eqs';
214.116 fun strip ss = Library.drop (find_index_eq "'" ss +1, ss);
214.117 @@ -118,16 +108,16 @@
214.118 in if Symbol.is_letter c then c else "t" end
214.119 | typid (TFree (id,_) ) = hd (strip (tl (Symbol.explode id)))
214.120 | typid (TVar ((id,_),_)) = hd (tl (Symbol.explode id));
214.121 - fun one_con (con,mx,args) =
214.122 - ((Syntax.const_name mx con),
214.123 + fun one_con (con,args,mx) =
214.124 + ((Syntax.const_name mx (Binding.name_of con)),
214.125 ListPair.map (fn ((lazy,sel,tp),vn) => ((lazy,
214.126 find_index_eq tp dts,
214.127 DatatypeAux.dtyp_of_typ new_dts tp),
214.128 - sel,vn))
214.129 + Option.map Binding.name_of sel,vn))
214.130 (args,(mk_var_names(map (typid o third) args)))
214.131 ) : cons;
214.132 val eqs = map (fn (dtnvs,cons') => (dtnvs, map one_con cons')) eqs' : eq list;
214.133 - val thy = thy' |> Domain_Axioms.add_axioms (comp_dnam,eqs);
214.134 + val thy = thy' |> Domain_Axioms.add_axioms comp_dnam eqs;
214.135 val ((rewss, take_rews), theorems_thy) = thy |> fold_map (fn eq =>
214.136 Domain_Theorems.theorems (eq, eqs)) eqs
214.137 ||>> Domain_Theorems.comp_theorems (comp_dnam, eqs);
214.138 @@ -138,8 +128,8 @@
214.139 |> Sign.parent_path
214.140 end;
214.141
214.142 -val add_domain_i = gen_add_domain Sign.certify_typ;
214.143 -val add_domain = gen_add_domain Syntax.read_typ_global;
214.144 +val add_domain = gen_add_domain Sign.certify_typ;
214.145 +val add_domain_cmd = gen_add_domain Syntax.read_typ_global;
214.146
214.147
214.148 (** outer syntax **)
214.149 @@ -148,33 +138,47 @@
214.150
214.151 val _ = OuterKeyword.keyword "lazy";
214.152
214.153 -val dest_decl =
214.154 +val dest_decl : (bool * binding option * string) parser =
214.155 P.$$$ "(" |-- Scan.optional (P.$$$ "lazy" >> K true) false --
214.156 - (P.name >> SOME) -- (P.$$$ "::" |-- P.typ) --| P.$$$ ")" >> P.triple1
214.157 + (P.binding >> SOME) -- (P.$$$ "::" |-- P.typ) --| P.$$$ ")" >> P.triple1
214.158 || P.$$$ "(" |-- P.$$$ "lazy" |-- P.typ --| P.$$$ ")"
214.159 >> (fn t => (true,NONE,t))
214.160 || P.typ >> (fn t => (false,NONE,t));
214.161
214.162 val cons_decl =
214.163 - P.name -- Scan.repeat dest_decl -- P.opt_mixfix
214.164 - >> (fn ((c, ds), mx) => (c, mx, ds));
214.165 + P.binding -- Scan.repeat dest_decl -- P.opt_mixfix;
214.166
214.167 -val type_var' = (P.type_ident ^^
214.168 - Scan.optional (P.$$$ "::" ^^ P.!!! P.sort) "");
214.169 -val type_args' = type_var' >> single ||
214.170 - P.$$$ "(" |-- P.!!! (P.list1 type_var' --| P.$$$ ")") ||
214.171 - Scan.succeed [];
214.172 +val type_var' =
214.173 + (P.type_ident ^^ Scan.optional (P.$$$ "::" ^^ P.!!! P.sort) "");
214.174
214.175 -val domain_decl = (type_args' -- P.name >> Library.swap) --
214.176 - (P.$$$ "=" |-- P.enum1 "|" cons_decl);
214.177 +val type_args' =
214.178 + type_var' >> single ||
214.179 + P.$$$ "(" |-- P.!!! (P.list1 type_var' --| P.$$$ ")") ||
214.180 + Scan.succeed [];
214.181 +
214.182 +val domain_decl =
214.183 + (type_args' -- P.binding -- P.opt_infix) --
214.184 + (P.$$$ "=" |-- P.enum1 "|" cons_decl);
214.185 +
214.186 val domains_decl =
214.187 - Scan.option (P.$$$ "(" |-- P.name --| P.$$$ ")") -- P.and_list1 domain_decl
214.188 - >> (fn (opt_name, doms) =>
214.189 - (case opt_name of NONE => space_implode "_" (map (#1 o #1) doms) | SOME s => s, doms));
214.190 + Scan.option (P.$$$ "(" |-- P.name --| P.$$$ ")") --
214.191 + P.and_list1 domain_decl;
214.192 +
214.193 +fun mk_domain (opt_name : string option, doms : (((string list * binding) * mixfix) *
214.194 + ((binding * (bool * binding option * string) list) * mixfix) list) list ) =
214.195 + let
214.196 + val names = map (fn (((_, t), _), _) => Binding.name_of t) doms;
214.197 + val specs : (string list * binding * mixfix *
214.198 + (binding * (bool * binding option * string) list * mixfix) list) list =
214.199 + map (fn (((vs, t), mx), cons) =>
214.200 + (vs, t, mx, map (fn ((c, ds), mx) => (c, ds, mx)) cons)) doms;
214.201 + val comp_dnam =
214.202 + case opt_name of NONE => space_implode "_" names | SOME s => s;
214.203 + in add_domain_cmd comp_dnam specs end;
214.204
214.205 val _ =
214.206 OuterSyntax.command "domain" "define recursive domains (HOLCF)" K.thy_decl
214.207 - (domains_decl >> (Toplevel.theory o add_domain));
214.208 + (domains_decl >> (Toplevel.theory o mk_domain));
214.209
214.210 end;
214.211
215.1 --- a/src/HOLCF/Tools/domain/domain_library.ML Mon May 11 09:39:53 2009 +0200
215.2 +++ b/src/HOLCF/Tools/domain/domain_library.ML Mon May 11 17:20:52 2009 +0200
215.3 @@ -30,11 +30,129 @@
215.4 | _ => [thm];
215.5 in map zero_var_indexes (at thm) end;
215.6
215.7 +(* infix syntax *)
215.8 +
215.9 +infixr 5 -->;
215.10 +infixr 6 ->>;
215.11 +infixr 0 ===>;
215.12 +infixr 0 ==>;
215.13 +infix 0 ==;
215.14 +infix 1 ===;
215.15 +infix 1 ~=;
215.16 +infix 1 <<;
215.17 +infix 1 ~<<;
215.18 +
215.19 +infix 9 ` ;
215.20 +infix 9 `% ;
215.21 +infix 9 `%%;
215.22 +
215.23 +
215.24 (* ----- specific support for domain ---------------------------------------- *)
215.25
215.26 -structure Domain_Library = struct
215.27 +signature DOMAIN_LIBRARY =
215.28 +sig
215.29 + val Imposs : string -> 'a;
215.30 + val pcpo_type : theory -> typ -> bool;
215.31 + val string_of_typ : theory -> typ -> string;
215.32
215.33 -open HOLCFLogic;
215.34 + (* Creating HOLCF types *)
215.35 + val mk_cfunT : typ * typ -> typ;
215.36 + val ->> : typ * typ -> typ;
215.37 + val mk_ssumT : typ * typ -> typ;
215.38 + val mk_sprodT : typ * typ -> typ;
215.39 + val mk_uT : typ -> typ;
215.40 + val oneT : typ;
215.41 + val trT : typ;
215.42 + val mk_maybeT : typ -> typ;
215.43 + val mk_ctupleT : typ list -> typ;
215.44 + val mk_TFree : string -> typ;
215.45 + val pcpoS : sort;
215.46 +
215.47 + (* Creating HOLCF terms *)
215.48 + val %: : string -> term;
215.49 + val %%: : string -> term;
215.50 + val ` : term * term -> term;
215.51 + val `% : term * string -> term;
215.52 + val /\ : string -> term -> term;
215.53 + val UU : term;
215.54 + val TT : term;
215.55 + val FF : term;
215.56 + val mk_up : term -> term;
215.57 + val mk_sinl : term -> term;
215.58 + val mk_sinr : term -> term;
215.59 + val mk_stuple : term list -> term;
215.60 + val mk_ctuple : term list -> term;
215.61 + val mk_fix : term -> term;
215.62 + val mk_iterate : term * term * term -> term;
215.63 + val mk_fail : term;
215.64 + val mk_return : term -> term;
215.65 + val cproj : term -> 'a list -> int -> term;
215.66 + val list_ccomb : term * term list -> term;
215.67 + val con_app : string -> ('a * 'b * string) list -> term;
215.68 + val con_app2 : string -> ('a -> term) -> 'a list -> term;
215.69 + val proj : term -> 'a list -> int -> term;
215.70 + val prj : ('a -> 'b -> 'a) -> ('a -> 'b -> 'a) -> 'a -> 'b list -> int -> 'a;
215.71 + val mk_ctuple_pat : term list -> term;
215.72 + val mk_branch : term -> term;
215.73 +
215.74 + (* Creating propositions *)
215.75 + val mk_conj : term * term -> term;
215.76 + val mk_disj : term * term -> term;
215.77 + val mk_imp : term * term -> term;
215.78 + val mk_lam : string * term -> term;
215.79 + val mk_all : string * term -> term;
215.80 + val mk_ex : string * term -> term;
215.81 + val mk_constrain : typ * term -> term;
215.82 + val mk_constrainall : string * typ * term -> term;
215.83 + val === : term * term -> term;
215.84 + val << : term * term -> term;
215.85 + val ~<< : term * term -> term;
215.86 + val strict : term -> term;
215.87 + val defined : term -> term;
215.88 + val mk_adm : term -> term;
215.89 + val mk_compact : term -> term;
215.90 + val lift : ('a -> term) -> 'a list * term -> term;
215.91 + val lift_defined : ('a -> term) -> 'a list * term -> term;
215.92 +
215.93 + (* Creating meta-propositions *)
215.94 + val mk_trp : term -> term; (* HOLogic.mk_Trueprop *)
215.95 + val == : term * term -> term;
215.96 + val ===> : term * term -> term;
215.97 + val ==> : term * term -> term;
215.98 + val mk_All : string * term -> term;
215.99 +
215.100 + (* Domain specifications *)
215.101 + type arg = (bool * int * DatatypeAux.dtyp) * string option * string;
215.102 + type cons = string * arg list;
215.103 + type eq = (string * typ list) * cons list;
215.104 + val is_lazy : arg -> bool;
215.105 + val rec_of : arg -> int;
215.106 + val sel_of : arg -> string option;
215.107 + val vname : arg -> string;
215.108 + val upd_vname : (string -> string) -> arg -> arg;
215.109 + val is_rec : arg -> bool;
215.110 + val is_nonlazy_rec : arg -> bool;
215.111 + val nonlazy : arg list -> string list;
215.112 + val nonlazy_rec : arg list -> string list;
215.113 + val %# : arg -> term;
215.114 + val /\# : arg * term -> term;
215.115 + val when_body : cons list -> (int * int -> term) -> term;
215.116 + val when_funs : 'a list -> string list;
215.117 + val bound_arg : ''a list -> ''a -> term; (* ''a = arg or string *)
215.118 + val idx_name : 'a list -> string -> int -> string;
215.119 + val app_rec_arg : (int -> term) -> arg -> term;
215.120 +
215.121 + (* Name mangling *)
215.122 + val strip_esc : string -> string;
215.123 + val extern_name : string -> string;
215.124 + val dis_name : string -> string;
215.125 + val mat_name : string -> string;
215.126 + val pat_name : string -> string;
215.127 + val mk_var_names : string list -> string list;
215.128 +end;
215.129 +
215.130 +structure Domain_Library :> DOMAIN_LIBRARY =
215.131 +struct
215.132
215.133 exception Impossible of string;
215.134 fun Imposs msg = raise Impossible ("Domain:"^msg);
215.135 @@ -72,19 +190,24 @@
215.136 | index_vnames([],occupied) = [];
215.137 in index_vnames(map nonreserved ids, [("O",0),("o",0)]) end;
215.138
215.139 -fun pcpo_type sg t = Sign.of_sort sg (Sign.certify_typ sg t, pcpoS);
215.140 +fun pcpo_type sg t = Sign.of_sort sg (Sign.certify_typ sg t, @{sort pcpo});
215.141 fun string_of_typ sg = Syntax.string_of_typ_global sg o Sign.certify_typ sg;
215.142
215.143 (* ----- constructor list handling ----- *)
215.144
215.145 -type cons = (string * (* operator name of constr *)
215.146 - ((bool*int*DatatypeAux.dtyp)* (* (lazy,recursive element or ~1) *)
215.147 - string option* (* selector name *)
215.148 - string) (* argument name *)
215.149 - list); (* argument list *)
215.150 -type eq = (string * (* name of abstracted type *)
215.151 - typ list) * (* arguments of abstracted type *)
215.152 - cons list; (* represented type, as a constructor list *)
215.153 +type arg =
215.154 + (bool * int * DatatypeAux.dtyp) * (* (lazy,recursive element or ~1) *)
215.155 + string option * (* selector name *)
215.156 + string; (* argument name *)
215.157 +
215.158 +type cons =
215.159 + string * (* operator name of constr *)
215.160 + arg list; (* argument list *)
215.161 +
215.162 +type eq =
215.163 + (string * (* name of abstracted type *)
215.164 + typ list) * (* arguments of abstracted type *)
215.165 + cons list; (* represented type, as a constructor list *)
215.166
215.167 fun rec_of arg = second (first arg);
215.168 fun is_lazy arg = first (first arg);
215.169 @@ -98,7 +221,16 @@
215.170
215.171 (* ----- support for type and mixfix expressions ----- *)
215.172
215.173 -infixr 5 -->;
215.174 +fun mk_uT T = Type(@{type_name "u"}, [T]);
215.175 +fun mk_cfunT (T, U) = Type(@{type_name "->"}, [T, U]);
215.176 +fun mk_sprodT (T, U) = Type(@{type_name "**"}, [T, U]);
215.177 +fun mk_ssumT (T, U) = Type(@{type_name "++"}, [T, U]);
215.178 +val oneT = @{typ one};
215.179 +val trT = @{typ tr};
215.180 +
215.181 +val op ->> = mk_cfunT;
215.182 +
215.183 +fun mk_TFree s = TFree ("'" ^ s, @{sort pcpo});
215.184
215.185 (* ----- support for term expressions ----- *)
215.186
215.187 @@ -125,7 +257,7 @@
215.188 infix 0 ==; fun S == T = %%:"==" $ S $ T;
215.189 infix 1 ===; fun S === T = %%:"op =" $ S $ T;
215.190 infix 1 ~=; fun S ~= T = HOLogic.mk_not (S === T);
215.191 -infix 1 <<; fun S << T = %%: @{const_name Porder.sq_le} $ S $ T;
215.192 +infix 1 <<; fun S << T = %%: @{const_name Porder.below} $ S $ T;
215.193 infix 1 ~<<; fun S ~<< T = HOLogic.mk_not (S << T);
215.194
215.195 infix 9 ` ; fun f ` x = %%: @{const_name Rep_CFun} $ f $ x;
216.1 --- a/src/HOLCF/Tools/domain/domain_syntax.ML Mon May 11 09:39:53 2009 +0200
216.2 +++ b/src/HOLCF/Tools/domain/domain_syntax.ML Mon May 11 17:20:52 2009 +0200
216.3 @@ -4,32 +4,42 @@
216.4 Syntax generator for domain command.
216.5 *)
216.6
216.7 -structure Domain_Syntax = struct
216.8 +signature DOMAIN_SYNTAX =
216.9 +sig
216.10 + val add_syntax: string -> ((string * typ list) *
216.11 + (binding * (bool * binding option * typ) list * mixfix) list) list
216.12 + -> theory -> theory
216.13 +end;
216.14 +
216.15 +
216.16 +structure Domain_Syntax :> DOMAIN_SYNTAX =
216.17 +struct
216.18
216.19 local
216.20
216.21 open Domain_Library;
216.22 infixr 5 -->; infixr 6 ->>;
216.23 fun calc_syntax dtypeprod ((dname, typevars),
216.24 - (cons': (string * mixfix * (bool * string option * typ) list) list)) =
216.25 + (cons': (binding * (bool * binding option * typ) list * mixfix) list)) : ((binding * typ * mixfix) list * ast Syntax.trrule list) =
216.26 let
216.27 (* ----- constants concerning the isomorphism ------------------------------- *)
216.28
216.29 local
216.30 fun opt_lazy (lazy,_,t) = if lazy then mk_uT t else t
216.31 - fun prod (_,_,args) = if args = [] then oneT
216.32 - else foldr1 mk_sprodT (map opt_lazy args);
216.33 + fun prod (_,args,_) = case args of [] => oneT
216.34 + | _ => foldr1 mk_sprodT (map opt_lazy args);
216.35 fun freetvar s = let val tvar = mk_TFree s in
216.36 if tvar mem typevars then freetvar ("t"^s) else tvar end;
216.37 - fun when_type (_ ,_,args) = List.foldr (op ->>) (freetvar "t") (map third args);
216.38 + fun when_type (_,args,_) = List.foldr (op ->>) (freetvar "t") (map third args);
216.39 in
216.40 val dtype = Type(dname,typevars);
216.41 val dtype2 = foldr1 mk_ssumT (map prod cons');
216.42 val dnam = Long_Name.base_name dname;
216.43 - val const_rep = (dnam^"_rep" , dtype ->> dtype2, NoSyn);
216.44 - val const_abs = (dnam^"_abs" , dtype2 ->> dtype , NoSyn);
216.45 - val const_when = (dnam^"_when", List.foldr (op ->>) (dtype ->> freetvar "t") (map when_type cons'), NoSyn);
216.46 - val const_copy = (dnam^"_copy", dtypeprod ->> dtype ->> dtype , NoSyn);
216.47 + fun dbind s = Binding.name (dnam ^ s);
216.48 + val const_rep = (dbind "_rep" , dtype ->> dtype2, NoSyn);
216.49 + val const_abs = (dbind "_abs" , dtype2 ->> dtype , NoSyn);
216.50 + val const_when = (dbind "_when", List.foldr (op ->>) (dtype ->> freetvar "t") (map when_type cons'), NoSyn);
216.51 + val const_copy = (dbind "_copy", dtypeprod ->> dtype ->> dtype , NoSyn);
216.52 end;
216.53
216.54 (* ----- constants concerning constructors, discriminators, and selectors --- *)
216.55 @@ -40,23 +50,28 @@
216.56 else c::esc cs
216.57 | esc [] = []
216.58 in implode o esc o Symbol.explode end;
216.59 - fun con (name,s,args) = (name, List.foldr (op ->>) dtype (map third args),s);
216.60 - fun dis (con ,s,_ ) = (dis_name_ con, dtype->>trT,
216.61 - Mixfix(escape ("is_" ^ con), [], Syntax.max_pri));
216.62 + fun dis_name_ con = Binding.name ("is_" ^ strip_esc (Binding.name_of con));
216.63 + fun mat_name_ con = Binding.name ("match_" ^ strip_esc (Binding.name_of con));
216.64 + fun pat_name_ con = Binding.name (strip_esc (Binding.name_of con) ^ "_pat");
216.65 + fun con (name,args,mx) = (name, List.foldr (op ->>) dtype (map third args), mx);
216.66 + fun dis (con,args,mx) = (dis_name_ con, dtype->>trT,
216.67 + Mixfix(escape ("is_" ^ Binding.name_of con), [], Syntax.max_pri));
216.68 (* strictly speaking, these constants have one argument,
216.69 but the mixfix (without arguments) is introduced only
216.70 to generate parse rules for non-alphanumeric names*)
216.71 - fun mat (con ,s,args) = (mat_name_ con, dtype->>mk_maybeT(mk_ctupleT(map third args)),
216.72 - Mixfix(escape ("match_" ^ con), [], Syntax.max_pri));
216.73 - fun sel1 (_,sel,typ) = Option.map (fn s => (s,dtype ->> typ,NoSyn)) sel;
216.74 - fun sel (_ ,_,args) = List.mapPartial sel1 args;
216.75 fun freetvar s n = let val tvar = mk_TFree (s ^ string_of_int n) in
216.76 if tvar mem typevars then freetvar ("t"^s) n else tvar end;
216.77 + fun mk_matT (a,bs,c) = a ->> foldr (op ->>) (mk_maybeT c) bs ->> mk_maybeT c;
216.78 + fun mat (con,args,mx) = (mat_name_ con,
216.79 + mk_matT(dtype, map third args, freetvar "t" 1),
216.80 + Mixfix(escape ("match_" ^ Binding.name_of con), [], Syntax.max_pri));
216.81 + fun sel1 (_,sel,typ) = Option.map (fn s => (s,dtype ->> typ,NoSyn)) sel;
216.82 + fun sel (con,args,mx) = List.mapPartial sel1 args;
216.83 fun mk_patT (a,b) = a ->> mk_maybeT b;
216.84 fun pat_arg_typ n arg = mk_patT (third arg, freetvar "t" n);
216.85 - fun pat (con ,s,args) = (pat_name_ con, (mapn pat_arg_typ 1 args) --->
216.86 + fun pat (con,args,mx) = (pat_name_ con, (mapn pat_arg_typ 1 args) --->
216.87 mk_patT (dtype, mk_ctupleT (map (freetvar "t") (1 upto length args))),
216.88 - Mixfix(escape (con ^ "_pat"), [], Syntax.max_pri));
216.89 + Mixfix(escape (Binding.name_of con ^ "_pat"), [], Syntax.max_pri));
216.90
216.91 in
216.92 val consts_con = map con cons';
216.93 @@ -68,14 +83,14 @@
216.94
216.95 (* ----- constants concerning induction ------------------------------------- *)
216.96
216.97 - val const_take = (dnam^"_take" , HOLogic.natT-->dtype->>dtype, NoSyn);
216.98 - val const_finite = (dnam^"_finite", dtype-->HOLogic.boolT , NoSyn);
216.99 + val const_take = (dbind "_take" , HOLogic.natT-->dtype->>dtype, NoSyn);
216.100 + val const_finite = (dbind "_finite", dtype-->HOLogic.boolT , NoSyn);
216.101
216.102 (* ----- case translation --------------------------------------------------- *)
216.103
216.104 local open Syntax in
216.105 local
216.106 - fun c_ast con mx = Constant (Syntax.const_name mx con);
216.107 + fun c_ast con mx = Constant (Syntax.const_name mx (Binding.name_of con));
216.108 fun expvar n = Variable ("e"^(string_of_int n));
216.109 fun argvar n m _ = Variable ("a"^(string_of_int n)^"_"^
216.110 (string_of_int m));
216.111 @@ -83,9 +98,9 @@
216.112 fun app s (l,r) = mk_appl (Constant s) [l,r];
216.113 val cabs = app "_cabs";
216.114 val capp = app "Rep_CFun";
216.115 - fun con1 n (con,mx,args) = Library.foldl capp (c_ast con mx, argvars n args);
216.116 - fun case1 n (con,mx,args) = app "_case1" (con1 n (con,mx,args), expvar n);
216.117 - fun arg1 n (con,_,args) = List.foldr cabs (expvar n) (argvars n args);
216.118 + fun con1 n (con,args,mx) = Library.foldl capp (c_ast con mx, argvars n args);
216.119 + fun case1 n (con,args,mx) = app "_case1" (con1 n (con,args,mx), expvar n);
216.120 + fun arg1 n (con,args,_) = List.foldr cabs (expvar n) (argvars n args);
216.121 fun when1 n m = if n = m then arg1 n else K (Constant "UU");
216.122
216.123 fun app_var x = mk_appl (Constant "_variable") [x, Variable "rhs"];
216.124 @@ -101,10 +116,10 @@
216.125 (cabs (con1 n (con,mx,args), expvar n),
216.126 Library.foldl capp (Constant (dnam^"_when"), mapn (when1 n) 1 cons'))) 1 cons';
216.127
216.128 - val Case_trans = List.concat (map (fn (con,mx,args) =>
216.129 + val Case_trans = List.concat (map (fn (con,args,mx) =>
216.130 let
216.131 val cname = c_ast con mx;
216.132 - val pname = Constant (pat_name_ con);
216.133 + val pname = Constant (strip_esc (Binding.name_of con) ^ "_pat");
216.134 val ns = 1 upto length args;
216.135 val xs = map (fn n => Variable ("x"^(string_of_int n))) ns;
216.136 val ps = map (fn n => Variable ("p"^(string_of_int n))) ns;
216.137 @@ -130,16 +145,19 @@
216.138
216.139 in (* local *)
216.140
216.141 -fun add_syntax (comp_dnam,eqs': ((string * typ list) *
216.142 - (string * mixfix * (bool * string option * typ) list) list) list) thy'' =
216.143 +fun add_syntax
216.144 + (comp_dnam : string)
216.145 + (eqs' : ((string * typ list) *
216.146 + (binding * (bool * binding option * typ) list * mixfix) list) list)
216.147 + (thy'' : theory) =
216.148 let
216.149 val dtypes = map (Type o fst) eqs';
216.150 val boolT = HOLogic.boolT;
216.151 val funprod = foldr1 HOLogic.mk_prodT (map (fn tp => tp ->> tp ) dtypes);
216.152 val relprod = foldr1 HOLogic.mk_prodT (map (fn tp => tp --> tp --> boolT) dtypes);
216.153 - val const_copy = (comp_dnam^"_copy" ,funprod ->> funprod, NoSyn);
216.154 - val const_bisim = (comp_dnam^"_bisim" ,relprod --> boolT , NoSyn);
216.155 - val ctt = map (calc_syntax funprod) eqs';
216.156 + val const_copy = (Binding.name (comp_dnam^"_copy"), funprod ->> funprod, NoSyn);
216.157 + val const_bisim = (Binding.name (comp_dnam^"_bisim"), relprod --> boolT, NoSyn);
216.158 + val ctt : ((binding * typ * mixfix) list * ast Syntax.trrule list) list = map (calc_syntax funprod) eqs';
216.159 in thy'' |> ContConsts.add_consts_i (List.concat (map fst ctt) @
216.160 (if length eqs'>1 then [const_copy] else[])@
216.161 [const_bisim])
217.1 --- a/src/HOLCF/Tools/domain/domain_theorems.ML Mon May 11 09:39:53 2009 +0200
217.2 +++ b/src/HOLCF/Tools/domain/domain_theorems.ML Mon May 11 17:20:52 2009 +0200
217.3 @@ -8,7 +8,14 @@
217.4
217.5 val HOLCF_ss = @{simpset};
217.6
217.7 -structure Domain_Theorems = struct
217.8 +signature DOMAIN_THEOREMS =
217.9 +sig
217.10 + val theorems: Domain_Library.eq * Domain_Library.eq list -> theory -> thm list * theory;
217.11 + val comp_theorems: bstring * Domain_Library.eq list -> theory -> thm list * theory;
217.12 +end;
217.13 +
217.14 +structure Domain_Theorems :> DOMAIN_THEOREMS =
217.15 +struct
217.16
217.17 val quiet_mode = ref false;
217.18 val trace_domain = ref false;
217.19 @@ -22,7 +29,7 @@
217.20 val adm_all = @{thm adm_all};
217.21 val adm_conj = @{thm adm_conj};
217.22 val adm_subst = @{thm adm_subst};
217.23 -val antisym_less_inverse = @{thm antisym_less_inverse};
217.24 +val antisym_less_inverse = @{thm below_antisym_inverse};
217.25 val beta_cfun = @{thm beta_cfun};
217.26 val cfun_arg_cong = @{thm cfun_arg_cong};
217.27 val ch2ch_Rep_CFunL = @{thm ch2ch_Rep_CFunL};
217.28 @@ -37,12 +44,12 @@
217.29 val contlub_cfun_fun = @{thm contlub_cfun_fun};
217.30 val fix_def2 = @{thm fix_def2};
217.31 val injection_eq = @{thm injection_eq};
217.32 -val injection_less = @{thm injection_less};
217.33 +val injection_less = @{thm injection_below};
217.34 val lub_equal = @{thm lub_equal};
217.35 val monofun_cfun_arg = @{thm monofun_cfun_arg};
217.36 val retraction_strict = @{thm retraction_strict};
217.37 val spair_eq = @{thm spair_eq};
217.38 -val spair_less = @{thm spair_less};
217.39 +val spair_less = @{thm spair_below};
217.40 val sscase1 = @{thm sscase1};
217.41 val ssplit1 = @{thm ssplit1};
217.42 val strictify1 = @{thm strictify1};
217.43 @@ -114,7 +121,7 @@
217.44
217.45 val all2E = @{lemma "!x y . P x y ==> (P x y ==> R) ==> R" by simp}
217.46
217.47 -val dist_eqI = @{lemma "!!x::'a::po. ~ x << y ==> x ~= y" by (blast dest!: antisym_less_inverse)}
217.48 +val dist_eqI = @{lemma "!!x::'a::po. ~ x << y ==> x ~= y" by (blast dest!: below_antisym_inverse)}
217.49
217.50 in
217.51
217.52 @@ -314,8 +321,8 @@
217.53 local
217.54 fun mat_strict (con, _) =
217.55 let
217.56 - val goal = mk_trp (strict (%%:(mat_name con)));
217.57 - val tacs = [rtac when_strict 1];
217.58 + val goal = mk_trp (%%:(mat_name con) ` UU ` %:"rhs" === UU);
217.59 + val tacs = [asm_simp_tac (HOLCF_ss addsimps [when_strict]) 1];
217.60 in pg axs_mat_def goal (K tacs) end;
217.61
217.62 val _ = trace " Proving mat_stricts...";
217.63 @@ -323,10 +330,10 @@
217.64
217.65 fun one_mat c (con, args) =
217.66 let
217.67 - val lhs = %%:(mat_name c) ` con_app con args;
217.68 + val lhs = %%:(mat_name c) ` con_app con args ` %:"rhs";
217.69 val rhs =
217.70 if con = c
217.71 - then mk_return (mk_ctuple (map %# args))
217.72 + then list_ccomb (%:"rhs", map %# args)
217.73 else mk_fail;
217.74 val goal = lift_defined %: (nonlazy args, mk_trp (lhs === rhs));
217.75 val tacs = [asm_simp_tac (HOLCF_ss addsimps when_rews) 1];
217.76 @@ -374,30 +381,32 @@
217.77 end;
217.78
217.79 local
217.80 - val rev_contrapos = @{thm rev_contrapos};
217.81 fun con_strict (con, args) =
217.82 let
217.83 + val rules = abs_strict :: @{thms con_strict_rules};
217.84 fun one_strict vn =
217.85 let
217.86 fun f arg = if vname arg = vn then UU else %# arg;
217.87 val goal = mk_trp (con_app2 con f args === UU);
217.88 - val tacs = [asm_simp_tac (HOLCF_ss addsimps [abs_strict]) 1];
217.89 + val tacs = [simp_tac (HOL_basic_ss addsimps rules) 1];
217.90 in pg con_appls goal (K tacs) end;
217.91 in map one_strict (nonlazy args) end;
217.92
217.93 fun con_defin (con, args) =
217.94 let
217.95 - val concl = mk_trp (defined (con_app con args));
217.96 - val goal = lift_defined %: (nonlazy args, concl);
217.97 - fun tacs ctxt = [
217.98 - rtac @{thm rev_contrapos} 1,
217.99 - eres_inst_tac ctxt [(("f", 0), dis_name con)] cfun_arg_cong 1,
217.100 - asm_simp_tac (HOLCF_ss addsimps dis_rews) 1];
217.101 - in pg [] goal tacs end;
217.102 + fun iff_disj (t, []) = HOLogic.mk_not t
217.103 + | iff_disj (t, ts) = t === foldr1 HOLogic.mk_disj ts;
217.104 + val lhs = con_app con args === UU;
217.105 + val rhss = map (fn x => %:x === UU) (nonlazy args);
217.106 + val goal = mk_trp (iff_disj (lhs, rhss));
217.107 + val rule1 = iso_locale RS @{thm iso.abs_defined_iff};
217.108 + val rules = rule1 :: @{thms con_defined_iff_rules};
217.109 + val tacs = [simp_tac (HOL_ss addsimps rules) 1];
217.110 + in pg con_appls goal (K tacs) end;
217.111 in
217.112 val _ = trace " Proving con_stricts...";
217.113 val con_stricts = maps con_strict cons;
217.114 - val _ = trace " Proving pat_defins...";
217.115 + val _ = trace " Proving con_defins...";
217.116 val con_defins = map con_defin cons;
217.117 val con_rews = con_stricts @ con_defins;
217.118 end;
217.119 @@ -488,7 +497,6 @@
217.120 end;
217.121
217.122 val sel_rews = sel_stricts @ sel_defins @ sel_apps;
217.123 -val rev_contrapos = @{thm rev_contrapos};
217.124
217.125 val _ = trace " Proving dist_les...";
217.126 val distincts_le =
217.127 @@ -607,23 +615,22 @@
217.128 in
217.129 thy
217.130 |> Sign.add_path (Long_Name.base_name dname)
217.131 - |> (snd o PureThy.add_thmss [
217.132 - ((Binding.name "iso_rews" , iso_rews ), [Simplifier.simp_add]),
217.133 - ((Binding.name "exhaust" , [exhaust] ), []),
217.134 - ((Binding.name "casedist" , [casedist]), [Induct.cases_type dname]),
217.135 - ((Binding.name "when_rews", when_rews ), [Simplifier.simp_add]),
217.136 - ((Binding.name "compacts", con_compacts), [Simplifier.simp_add]),
217.137 - ((Binding.name "con_rews", con_rews), [Simplifier.simp_add]),
217.138 - ((Binding.name "sel_rews", sel_rews), [Simplifier.simp_add]),
217.139 - ((Binding.name "dis_rews", dis_rews), [Simplifier.simp_add]),
217.140 - ((Binding.name "pat_rews", pat_rews), [Simplifier.simp_add]),
217.141 - ((Binding.name "dist_les", dist_les), [Simplifier.simp_add]),
217.142 - ((Binding.name "dist_eqs", dist_eqs), [Simplifier.simp_add]),
217.143 - ((Binding.name "inverts" , inverts ), [Simplifier.simp_add]),
217.144 - ((Binding.name "injects" , injects ), [Simplifier.simp_add]),
217.145 - ((Binding.name "copy_rews", copy_rews), [Simplifier.simp_add]),
217.146 - ((Binding.name "match_rews", mat_rews), [Simplifier.simp_add])
217.147 - ])
217.148 + |> snd o PureThy.add_thmss [
217.149 + ((Binding.name "iso_rews" , iso_rews ), [Simplifier.simp_add]),
217.150 + ((Binding.name "exhaust" , [exhaust] ), []),
217.151 + ((Binding.name "casedist" , [casedist] ), [Induct.cases_type dname]),
217.152 + ((Binding.name "when_rews" , when_rews ), [Simplifier.simp_add]),
217.153 + ((Binding.name "compacts" , con_compacts), [Simplifier.simp_add]),
217.154 + ((Binding.name "con_rews" , con_rews ), [Simplifier.simp_add]),
217.155 + ((Binding.name "sel_rews" , sel_rews ), [Simplifier.simp_add]),
217.156 + ((Binding.name "dis_rews" , dis_rews ), [Simplifier.simp_add]),
217.157 + ((Binding.name "pat_rews" , pat_rews ), [Simplifier.simp_add]),
217.158 + ((Binding.name "dist_les" , dist_les ), [Simplifier.simp_add]),
217.159 + ((Binding.name "dist_eqs" , dist_eqs ), [Simplifier.simp_add]),
217.160 + ((Binding.name "inverts" , inverts ), [Simplifier.simp_add]),
217.161 + ((Binding.name "injects" , injects ), [Simplifier.simp_add]),
217.162 + ((Binding.name "copy_rews" , copy_rews ), [Simplifier.simp_add]),
217.163 + ((Binding.name "match_rews", mat_rews ), [Simplifier.simp_add])]
217.164 |> Sign.parent_path
217.165 |> pair (iso_rews @ when_rews @ con_rews @ sel_rews @ dis_rews @
217.166 pat_rews @ dist_les @ dist_eqs @ copy_rews)
217.167 @@ -1003,14 +1010,14 @@
217.168 fun ind_rule (dname, rule) = ((Binding.empty, [rule]), [Induct.induct_type dname]);
217.169
217.170 in thy |> Sign.add_path comp_dnam
217.171 - |> (snd o (PureThy.add_thmss (map (Thm.no_attributes o apfst Binding.name) [
217.172 - ("take_rews" , take_rews ),
217.173 - ("take_lemmas", take_lemmas),
217.174 - ("finites" , finites ),
217.175 - ("finite_ind", [finite_ind]),
217.176 - ("ind" , [ind ]),
217.177 - ("coind" , [coind ])])))
217.178 - |> (snd o (PureThy.add_thmss (map ind_rule (dnames ~~ inducts))))
217.179 + |> snd o PureThy.add_thmss [
217.180 + ((Binding.name "take_rews" , take_rews ), [Simplifier.simp_add]),
217.181 + ((Binding.name "take_lemmas", take_lemmas ), []),
217.182 + ((Binding.name "finites" , finites ), []),
217.183 + ((Binding.name "finite_ind" , [finite_ind]), []),
217.184 + ((Binding.name "ind" , [ind] ), []),
217.185 + ((Binding.name "coind" , [coind] ), [])]
217.186 + |> snd o PureThy.add_thmss (map ind_rule (dnames ~~ inducts))
217.187 |> Sign.parent_path |> pair take_rews
217.188 end; (* let *)
217.189 end; (* local *)
218.1 --- a/src/HOLCF/Tools/fixrec_package.ML Mon May 11 09:39:53 2009 +0200
218.2 +++ b/src/HOLCF/Tools/fixrec_package.ML Mon May 11 17:20:52 2009 +0200
218.3 @@ -16,7 +16,7 @@
218.4 val setup: theory -> theory
218.5 end;
218.6
218.7 -structure FixrecPackage: FIXREC_PACKAGE =
218.8 +structure FixrecPackage :> FIXREC_PACKAGE =
218.9 struct
218.10
218.11 val fix_eq2 = @{thm fix_eq2};
218.12 @@ -36,6 +36,8 @@
218.13
218.14 infixr 6 ->>; val (op ->>) = cfunT;
218.15
218.16 +fun cfunsT (Ts, U) = foldr cfunT U Ts;
218.17 +
218.18 fun dest_cfunT (Type(@{type_name "->"}, [T, U])) = (T, U)
218.19 | dest_cfunT T = raise TYPE ("dest_cfunT", [T], []);
218.20
218.21 @@ -57,7 +59,9 @@
218.22 | tupleT [T] = T
218.23 | tupleT (T :: Ts) = HOLogic.mk_prodT (T, tupleT Ts);
218.24
218.25 -fun matchT T = body_cfun T ->> maybeT (tupleT (binder_cfun T));
218.26 +fun matchT (T, U) =
218.27 + body_cfun T ->> cfunsT (binder_cfun T, U) ->> U;
218.28 +
218.29
218.30 (*************************************************************************)
218.31 (***************************** building terms ****************************)
218.32 @@ -240,10 +244,10 @@
218.33 fun result_type (Type(@{type_name "->"},[_,T])) (x::xs) = result_type T xs
218.34 | result_type T _ = T;
218.35 val v = Free(n, result_type T vs);
218.36 - val m = Const(match_name c, matchT T);
218.37 - val k = lambda_ctuple vs rhs;
218.38 + val m = Const(match_name c, matchT (T, fastype_of rhs));
218.39 + val k = big_lambdas vs rhs;
218.40 in
218.41 - (mk_bind (m`v, k), v, n::taken)
218.42 + (m`v`k, v, n::taken)
218.43 end
218.44 | Free(n,_) => fixrec_err ("expected constructor, found free variable " ^ quote n)
218.45 | _ => fixrec_err "pre_build: invalid pattern";
219.1 --- a/src/HOLCF/Tools/pcpodef_package.ML Mon May 11 09:39:53 2009 +0200
219.2 +++ b/src/HOLCF/Tools/pcpodef_package.ML Mon May 11 17:20:52 2009 +0200
219.3 @@ -17,7 +17,7 @@
219.4 * (binding * binding) option -> theory -> Proof.state
219.5 end;
219.6
219.7 -structure PcpodefPackage: PCPODEF_PACKAGE =
219.8 +structure PcpodefPackage :> PCPODEF_PACKAGE =
219.9 struct
219.10
219.11 (** type definitions **)
219.12 @@ -66,9 +66,9 @@
219.13 NONE => (Binding.prefix_name "Rep_" name, Binding.prefix_name "Abs_" name)
219.14 | SOME morphs => morphs);
219.15 val RepC = Const (full Rep_name, newT --> oldT);
219.16 - fun lessC T = Const (@{const_name sq_le}, T --> T --> HOLogic.boolT);
219.17 - val less_def = Logic.mk_equals (lessC newT,
219.18 - Abs ("x", newT, Abs ("y", newT, lessC oldT $ (RepC $ Bound 1) $ (RepC $ Bound 0))));
219.19 + fun belowC T = Const (@{const_name below}, T --> T --> HOLogic.boolT);
219.20 + val below_def = Logic.mk_equals (belowC newT,
219.21 + Abs ("x", newT, Abs ("y", newT, belowC oldT $ (RepC $ Bound 1) $ (RepC $ Bound 0))));
219.22
219.23 fun make_po tac thy1 =
219.24 let
219.25 @@ -76,22 +76,22 @@
219.26 |> TypedefPackage.add_typedef def (SOME name) (t, vs, mx) set opt_morphs tac;
219.27 val lthy3 = thy2
219.28 |> TheoryTarget.instantiation ([full_tname], lhs_tfrees, @{sort po});
219.29 - val less_def' = Syntax.check_term lthy3 less_def;
219.30 - val ((_, (_, less_definition')), lthy4) = lthy3
219.31 + val below_def' = Syntax.check_term lthy3 below_def;
219.32 + val ((_, (_, below_definition')), lthy4) = lthy3
219.33 |> Specification.definition (NONE,
219.34 - ((Binding.prefix_name "less_" (Binding.suffix_name "_def" name), []), less_def'));
219.35 + ((Binding.prefix_name "below_" (Binding.suffix_name "_def" name), []), below_def'));
219.36 val ctxt_thy = ProofContext.init (ProofContext.theory_of lthy4);
219.37 - val less_definition = singleton (ProofContext.export lthy4 ctxt_thy) less_definition';
219.38 + val below_definition = singleton (ProofContext.export lthy4 ctxt_thy) below_definition';
219.39 val thy5 = lthy4
219.40 |> Class.prove_instantiation_instance
219.41 - (K (Tactic.rtac (@{thm typedef_po} OF [type_definition, less_definition]) 1))
219.42 + (K (Tactic.rtac (@{thm typedef_po} OF [type_definition, below_definition]) 1))
219.43 |> LocalTheory.exit_global;
219.44 - in ((type_definition, less_definition, set_def), thy5) end;
219.45 + in ((type_definition, below_definition, set_def), thy5) end;
219.46
219.47 - fun make_cpo admissible (type_def, less_def, set_def) theory =
219.48 + fun make_cpo admissible (type_def, below_def, set_def) theory =
219.49 let
219.50 val admissible' = fold_rule (the_list set_def) admissible;
219.51 - val cpo_thms = map (Thm.transfer theory) [type_def, less_def, admissible'];
219.52 + val cpo_thms = map (Thm.transfer theory) [type_def, below_def, admissible'];
219.53 val theory' = theory
219.54 |> AxClass.prove_arity (full_tname, lhs_sorts, @{sort cpo})
219.55 (Tactic.rtac (@{thm typedef_cpo} OF cpo_thms) 1);
219.56 @@ -110,10 +110,10 @@
219.57 |> Sign.parent_path
219.58 end;
219.59
219.60 - fun make_pcpo UU_mem (type_def, less_def, set_def) theory =
219.61 + fun make_pcpo UU_mem (type_def, below_def, set_def) theory =
219.62 let
219.63 val UU_mem' = fold_rule (the_list set_def) UU_mem;
219.64 - val pcpo_thms = map (Thm.transfer theory) [type_def, less_def, UU_mem'];
219.65 + val pcpo_thms = map (Thm.transfer theory) [type_def, below_def, UU_mem'];
219.66 val theory' = theory
219.67 |> AxClass.prove_arity (full_tname, lhs_sorts, @{sort pcpo})
219.68 (Tactic.rtac (@{thm typedef_pcpo} OF pcpo_thms) 1);
220.1 --- a/src/HOLCF/Tr.thy Mon May 11 09:39:53 2009 +0200
220.2 +++ b/src/HOLCF/Tr.thy Mon May 11 17:20:52 2009 +0200
220.3 @@ -37,7 +37,7 @@
220.4
220.5 text {* distinctness for type @{typ tr} *}
220.6
220.7 -lemma dist_less_tr [simp]:
220.8 +lemma dist_below_tr [simp]:
220.9 "\<not> TT \<sqsubseteq> \<bottom>" "\<not> FF \<sqsubseteq> \<bottom>" "\<not> TT \<sqsubseteq> FF" "\<not> FF \<sqsubseteq> TT"
220.10 unfolding TT_def FF_def by simp_all
220.11
220.12 @@ -45,16 +45,16 @@
220.13 "TT \<noteq> \<bottom>" "FF \<noteq> \<bottom>" "TT \<noteq> FF" "\<bottom> \<noteq> TT" "\<bottom> \<noteq> FF" "FF \<noteq> TT"
220.14 unfolding TT_def FF_def by simp_all
220.15
220.16 -lemma TT_less_iff [simp]: "TT \<sqsubseteq> x \<longleftrightarrow> x = TT"
220.17 +lemma TT_below_iff [simp]: "TT \<sqsubseteq> x \<longleftrightarrow> x = TT"
220.18 by (induct x rule: tr_induct) simp_all
220.19
220.20 -lemma FF_less_iff [simp]: "FF \<sqsubseteq> x \<longleftrightarrow> x = FF"
220.21 +lemma FF_below_iff [simp]: "FF \<sqsubseteq> x \<longleftrightarrow> x = FF"
220.22 by (induct x rule: tr_induct) simp_all
220.23
220.24 -lemma not_less_TT_iff [simp]: "\<not> (x \<sqsubseteq> TT) \<longleftrightarrow> x = FF"
220.25 +lemma not_below_TT_iff [simp]: "\<not> (x \<sqsubseteq> TT) \<longleftrightarrow> x = FF"
220.26 by (induct x rule: tr_induct) simp_all
220.27
220.28 -lemma not_less_FF_iff [simp]: "\<not> (x \<sqsubseteq> FF) \<longleftrightarrow> x = TT"
220.29 +lemma not_below_FF_iff [simp]: "\<not> (x \<sqsubseteq> FF) \<longleftrightarrow> x = TT"
220.30 by (induct x rule: tr_induct) simp_all
220.31
220.32
221.1 --- a/src/HOLCF/Universal.thy Mon May 11 09:39:53 2009 +0200
221.2 +++ b/src/HOLCF/Universal.thy Mon May 11 17:20:52 2009 +0200
221.3 @@ -251,7 +251,7 @@
221.4 typedef (open) udom = "{S. udom.ideal S}"
221.5 by (fast intro: udom.ideal_principal)
221.6
221.7 -instantiation udom :: sq_ord
221.8 +instantiation udom :: below
221.9 begin
221.10
221.11 definition
221.12 @@ -262,16 +262,16 @@
221.13
221.14 instance udom :: po
221.15 by (rule udom.typedef_ideal_po
221.16 - [OF type_definition_udom sq_le_udom_def])
221.17 + [OF type_definition_udom below_udom_def])
221.18
221.19 instance udom :: cpo
221.20 by (rule udom.typedef_ideal_cpo
221.21 - [OF type_definition_udom sq_le_udom_def])
221.22 + [OF type_definition_udom below_udom_def])
221.23
221.24 lemma Rep_udom_lub:
221.25 "chain Y \<Longrightarrow> Rep_udom (\<Squnion>i. Y i) = (\<Union>i. Rep_udom (Y i))"
221.26 by (rule udom.typedef_ideal_rep_contlub
221.27 - [OF type_definition_udom sq_le_udom_def])
221.28 + [OF type_definition_udom below_udom_def])
221.29
221.30 lemma ideal_Rep_udom: "udom.ideal (Rep_udom xs)"
221.31 by (rule Rep_udom [unfolded mem_Collect_eq])
221.32 @@ -291,7 +291,7 @@
221.33 apply (rule ideal_Rep_udom)
221.34 apply (erule Rep_udom_lub)
221.35 apply (rule Rep_udom_principal)
221.36 -apply (simp only: sq_le_udom_def)
221.37 +apply (simp only: below_udom_def)
221.38 done
221.39
221.40 text {* Universal domain is pointed *}
221.41 @@ -359,9 +359,9 @@
221.42 assume "y \<in> insert a A" and "(if x \<sqsubseteq> a then a else x) \<sqsubseteq> y"
221.43 thus "(if x \<sqsubseteq> a then a else x) = y"
221.44 apply auto
221.45 - apply (frule (1) trans_less)
221.46 + apply (frule (1) below_trans)
221.47 apply (frule (1) x_eq)
221.48 - apply (rule antisym_less, assumption)
221.49 + apply (rule below_antisym, assumption)
221.50 apply simp
221.51 apply (erule (1) x_eq)
221.52 done
221.53 @@ -503,7 +503,7 @@
221.54 done
221.55
221.56 lemma rank_leD: "rank x \<le> n \<Longrightarrow> cb_take n x = x"
221.57 -apply (rule antisym_less [OF cb_take_less])
221.58 +apply (rule below_antisym [OF cb_take_less])
221.59 apply (subst compact_approx_rank [symmetric])
221.60 apply (erule cb_take_chain_le)
221.61 done
221.62 @@ -727,7 +727,7 @@
221.63 apply (rule IH)
221.64 apply (simp add: less_max_iff_disj)
221.65 apply (erule place_sub_less)
221.66 - apply (erule rev_trans_less)
221.67 + apply (erule rev_below_trans)
221.68 apply (rule sub_below)
221.69 done
221.70 qed
221.71 @@ -779,9 +779,9 @@
221.72
221.73 lemma basis_prj_mono: "ubasis_le a b \<Longrightarrow> basis_prj a \<sqsubseteq> basis_prj b"
221.74 proof (induct a b rule: ubasis_le.induct)
221.75 - case (ubasis_le_refl a) show ?case by (rule refl_less)
221.76 + case (ubasis_le_refl a) show ?case by (rule below_refl)
221.77 next
221.78 - case (ubasis_le_trans a b c) thus ?case by - (rule trans_less)
221.79 + case (ubasis_le_trans a b c) thus ?case by - (rule below_trans)
221.80 next
221.81 case (ubasis_le_lower S a i) thus ?case
221.82 apply (cases "node i a S \<in> range (basis_emb :: 'a compact_basis \<Rightarrow> nat)")
222.1 --- a/src/HOLCF/Up.thy Mon May 11 09:39:53 2009 +0200
222.2 +++ b/src/HOLCF/Up.thy Mon May 11 17:20:52 2009 +0200
222.3 @@ -26,11 +26,11 @@
222.4
222.5 subsection {* Ordering on lifted cpo *}
222.6
222.7 -instantiation u :: (cpo) sq_ord
222.8 +instantiation u :: (cpo) below
222.9 begin
222.10
222.11 definition
222.12 - less_up_def:
222.13 + below_up_def:
222.14 "(op \<sqsubseteq>) \<equiv> (\<lambda>x y. case x of Ibottom \<Rightarrow> True | Iup a \<Rightarrow>
222.15 (case y of Ibottom \<Rightarrow> False | Iup b \<Rightarrow> a \<sqsubseteq> b))"
222.16
222.17 @@ -38,13 +38,13 @@
222.18 end
222.19
222.20 lemma minimal_up [iff]: "Ibottom \<sqsubseteq> z"
222.21 -by (simp add: less_up_def)
222.22 +by (simp add: below_up_def)
222.23
222.24 -lemma not_Iup_less [iff]: "\<not> Iup x \<sqsubseteq> Ibottom"
222.25 -by (simp add: less_up_def)
222.26 +lemma not_Iup_below [iff]: "\<not> Iup x \<sqsubseteq> Ibottom"
222.27 +by (simp add: below_up_def)
222.28
222.29 -lemma Iup_less [iff]: "(Iup x \<sqsubseteq> Iup y) = (x \<sqsubseteq> y)"
222.30 -by (simp add: less_up_def)
222.31 +lemma Iup_below [iff]: "(Iup x \<sqsubseteq> Iup y) = (x \<sqsubseteq> y)"
222.32 +by (simp add: below_up_def)
222.33
222.34 subsection {* Lifted cpo is a partial order *}
222.35
222.36 @@ -52,17 +52,17 @@
222.37 proof
222.38 fix x :: "'a u"
222.39 show "x \<sqsubseteq> x"
222.40 - unfolding less_up_def by (simp split: u.split)
222.41 + unfolding below_up_def by (simp split: u.split)
222.42 next
222.43 fix x y :: "'a u"
222.44 assume "x \<sqsubseteq> y" "y \<sqsubseteq> x" thus "x = y"
222.45 - unfolding less_up_def
222.46 - by (auto split: u.split_asm intro: antisym_less)
222.47 + unfolding below_up_def
222.48 + by (auto split: u.split_asm intro: below_antisym)
222.49 next
222.50 fix x y z :: "'a u"
222.51 assume "x \<sqsubseteq> y" "y \<sqsubseteq> z" thus "x \<sqsubseteq> z"
222.52 - unfolding less_up_def
222.53 - by (auto split: u.split_asm intro: trans_less)
222.54 + unfolding below_up_def
222.55 + by (auto split: u.split_asm intro: below_trans)
222.56 qed
222.57
222.58 lemma u_UNIV: "UNIV = insert Ibottom (range Iup)"
222.59 @@ -78,7 +78,7 @@
222.60 "range S <<| x \<Longrightarrow> range (\<lambda>i. Iup (S i)) <<| Iup x"
222.61 apply (rule is_lubI)
222.62 apply (rule ub_rangeI)
222.63 -apply (subst Iup_less)
222.64 +apply (subst Iup_below)
222.65 apply (erule is_ub_lub)
222.66 apply (case_tac u)
222.67 apply (drule ub_rangeD)
222.68 @@ -112,7 +112,7 @@
222.69 lemma up_lemma4:
222.70 "\<lbrakk>chain Y; Y j \<noteq> Ibottom\<rbrakk> \<Longrightarrow> chain (\<lambda>i. THE a. Iup a = Y (i + j))"
222.71 apply (rule chainI)
222.72 -apply (rule Iup_less [THEN iffD1])
222.73 +apply (rule Iup_below [THEN iffD1])
222.74 apply (subst up_lemma3, assumption+)+
222.75 apply (simp add: chainE)
222.76 done
222.77 @@ -235,9 +235,9 @@
222.78 by (simp add: up_def cont_Iup inst_up_pcpo)
222.79
222.80 lemma not_up_less_UU: "\<not> up\<cdot>x \<sqsubseteq> \<bottom>"
222.81 -by simp
222.82 +by simp (* FIXME: remove? *)
222.83
222.84 -lemma up_less [simp]: "(up\<cdot>x \<sqsubseteq> up\<cdot>y) = (x \<sqsubseteq> y)"
222.85 +lemma up_below [simp]: "up\<cdot>x \<sqsubseteq> up\<cdot>y \<longleftrightarrow> x \<sqsubseteq> y"
222.86 by (simp add: up_def cont_Iup)
222.87
222.88 lemma upE [cases type: u]: "\<lbrakk>p = \<bottom> \<Longrightarrow> Q; \<And>x. p = up\<cdot>x \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
223.1 --- a/src/HOLCF/UpperPD.thy Mon May 11 09:39:53 2009 +0200
223.2 +++ b/src/HOLCF/UpperPD.thy Mon May 11 17:20:52 2009 +0200
223.3 @@ -23,7 +23,7 @@
223.4 apply (drule (1) bspec, erule bexE)
223.5 apply (drule (1) bspec, erule bexE)
223.6 apply (erule rev_bexI)
223.7 -apply (erule (1) trans_less)
223.8 +apply (erule (1) below_trans)
223.9 done
223.10
223.11 interpretation upper_le: preorder upper_le
223.12 @@ -38,7 +38,7 @@
223.13 lemma PDPlus_upper_mono: "\<lbrakk>s \<le>\<sharp> t; u \<le>\<sharp> v\<rbrakk> \<Longrightarrow> PDPlus s u \<le>\<sharp> PDPlus t v"
223.14 unfolding upper_le_def Rep_PDPlus by fast
223.15
223.16 -lemma PDPlus_upper_less: "PDPlus t u \<le>\<sharp> t"
223.17 +lemma PDPlus_upper_le: "PDPlus t u \<le>\<sharp> t"
223.18 unfolding upper_le_def Rep_PDPlus by fast
223.19
223.20 lemma upper_le_PDUnit_PDUnit_iff [simp]:
223.21 @@ -97,7 +97,7 @@
223.22 "{S::'a pd_basis set. upper_le.ideal S}"
223.23 by (fast intro: upper_le.ideal_principal)
223.24
223.25 -instantiation upper_pd :: (profinite) sq_ord
223.26 +instantiation upper_pd :: (profinite) below
223.27 begin
223.28
223.29 definition
223.30 @@ -108,16 +108,16 @@
223.31
223.32 instance upper_pd :: (profinite) po
223.33 by (rule upper_le.typedef_ideal_po
223.34 - [OF type_definition_upper_pd sq_le_upper_pd_def])
223.35 + [OF type_definition_upper_pd below_upper_pd_def])
223.36
223.37 instance upper_pd :: (profinite) cpo
223.38 by (rule upper_le.typedef_ideal_cpo
223.39 - [OF type_definition_upper_pd sq_le_upper_pd_def])
223.40 + [OF type_definition_upper_pd below_upper_pd_def])
223.41
223.42 lemma Rep_upper_pd_lub:
223.43 "chain Y \<Longrightarrow> Rep_upper_pd (\<Squnion>i. Y i) = (\<Union>i. Rep_upper_pd (Y i))"
223.44 by (rule upper_le.typedef_ideal_rep_contlub
223.45 - [OF type_definition_upper_pd sq_le_upper_pd_def])
223.46 + [OF type_definition_upper_pd below_upper_pd_def])
223.47
223.48 lemma ideal_Rep_upper_pd: "upper_le.ideal (Rep_upper_pd xs)"
223.49 by (rule Rep_upper_pd [unfolded mem_Collect_eq])
223.50 @@ -143,7 +143,7 @@
223.51 apply (rule ideal_Rep_upper_pd)
223.52 apply (erule Rep_upper_pd_lub)
223.53 apply (rule Rep_upper_principal)
223.54 -apply (simp only: sq_le_upper_pd_def)
223.55 +apply (simp only: below_upper_pd_def)
223.56 done
223.57
223.58 text {* Upper powerdomain is pointed *}
223.59 @@ -262,28 +262,28 @@
223.60 lemmas upper_plus_aci =
223.61 upper_plus_ac upper_plus_absorb upper_plus_left_absorb
223.62
223.63 -lemma upper_plus_less1: "xs +\<sharp> ys \<sqsubseteq> xs"
223.64 +lemma upper_plus_below1: "xs +\<sharp> ys \<sqsubseteq> xs"
223.65 apply (induct xs ys rule: upper_pd.principal_induct2, simp, simp)
223.66 -apply (simp add: PDPlus_upper_less)
223.67 +apply (simp add: PDPlus_upper_le)
223.68 done
223.69
223.70 -lemma upper_plus_less2: "xs +\<sharp> ys \<sqsubseteq> ys"
223.71 -by (subst upper_plus_commute, rule upper_plus_less1)
223.72 +lemma upper_plus_below2: "xs +\<sharp> ys \<sqsubseteq> ys"
223.73 +by (subst upper_plus_commute, rule upper_plus_below1)
223.74
223.75 lemma upper_plus_greatest: "\<lbrakk>xs \<sqsubseteq> ys; xs \<sqsubseteq> zs\<rbrakk> \<Longrightarrow> xs \<sqsubseteq> ys +\<sharp> zs"
223.76 apply (subst upper_plus_absorb [of xs, symmetric])
223.77 apply (erule (1) monofun_cfun [OF monofun_cfun_arg])
223.78 done
223.79
223.80 -lemma upper_less_plus_iff:
223.81 +lemma upper_below_plus_iff:
223.82 "xs \<sqsubseteq> ys +\<sharp> zs \<longleftrightarrow> xs \<sqsubseteq> ys \<and> xs \<sqsubseteq> zs"
223.83 apply safe
223.84 -apply (erule trans_less [OF _ upper_plus_less1])
223.85 -apply (erule trans_less [OF _ upper_plus_less2])
223.86 +apply (erule below_trans [OF _ upper_plus_below1])
223.87 +apply (erule below_trans [OF _ upper_plus_below2])
223.88 apply (erule (1) upper_plus_greatest)
223.89 done
223.90
223.91 -lemma upper_plus_less_unit_iff:
223.92 +lemma upper_plus_below_unit_iff:
223.93 "xs +\<sharp> ys \<sqsubseteq> {z}\<sharp> \<longleftrightarrow> xs \<sqsubseteq> {z}\<sharp> \<or> ys \<sqsubseteq> {z}\<sharp>"
223.94 apply (rule iffI)
223.95 apply (subgoal_tac
223.96 @@ -297,13 +297,13 @@
223.97 apply simp
223.98 apply simp
223.99 apply (erule disjE)
223.100 - apply (erule trans_less [OF upper_plus_less1])
223.101 - apply (erule trans_less [OF upper_plus_less2])
223.102 + apply (erule below_trans [OF upper_plus_below1])
223.103 + apply (erule below_trans [OF upper_plus_below2])
223.104 done
223.105
223.106 -lemma upper_unit_less_iff [simp]: "{x}\<sharp> \<sqsubseteq> {y}\<sharp> \<longleftrightarrow> x \<sqsubseteq> y"
223.107 +lemma upper_unit_below_iff [simp]: "{x}\<sharp> \<sqsubseteq> {y}\<sharp> \<longleftrightarrow> x \<sqsubseteq> y"
223.108 apply (rule iffI)
223.109 - apply (rule profinite_less_ext)
223.110 + apply (rule profinite_below_ext)
223.111 apply (drule_tac f="approx i" in monofun_cfun_arg, simp)
223.112 apply (cut_tac x="approx i\<cdot>x" in compact_basis.compact_imp_principal, simp)
223.113 apply (cut_tac x="approx i\<cdot>y" in compact_basis.compact_imp_principal, simp)
223.114 @@ -311,10 +311,10 @@
223.115 apply (erule monofun_cfun_arg)
223.116 done
223.117
223.118 -lemmas upper_pd_less_simps =
223.119 - upper_unit_less_iff
223.120 - upper_less_plus_iff
223.121 - upper_plus_less_unit_iff
223.122 +lemmas upper_pd_below_simps =
223.123 + upper_unit_below_iff
223.124 + upper_below_plus_iff
223.125 + upper_plus_below_unit_iff
223.126
223.127 lemma upper_unit_eq_iff [simp]: "{x}\<sharp> = {y}\<sharp> \<longleftrightarrow> x = y"
223.128 unfolding po_eq_conv by simp
223.129 @@ -323,10 +323,10 @@
223.130 unfolding inst_upper_pd_pcpo Rep_compact_bot [symmetric] by simp
223.131
223.132 lemma upper_plus_strict1 [simp]: "\<bottom> +\<sharp> ys = \<bottom>"
223.133 -by (rule UU_I, rule upper_plus_less1)
223.134 +by (rule UU_I, rule upper_plus_below1)
223.135
223.136 lemma upper_plus_strict2 [simp]: "xs +\<sharp> \<bottom> = \<bottom>"
223.137 -by (rule UU_I, rule upper_plus_less2)
223.138 +by (rule UU_I, rule upper_plus_below2)
223.139
223.140 lemma upper_unit_strict_iff [simp]: "{x}\<sharp> = \<bottom> \<longleftrightarrow> x = \<bottom>"
223.141 unfolding upper_unit_strict [symmetric] by (rule upper_unit_eq_iff)
223.142 @@ -407,11 +407,11 @@
223.143
223.144 lemma upper_bind_basis_mono:
223.145 "t \<le>\<sharp> u \<Longrightarrow> upper_bind_basis t \<sqsubseteq> upper_bind_basis u"
223.146 -unfolding expand_cfun_less
223.147 +unfolding expand_cfun_below
223.148 apply (erule upper_le_induct, safe)
223.149 apply (simp add: monofun_cfun)
223.150 -apply (simp add: trans_less [OF upper_plus_less1])
223.151 -apply (simp add: upper_less_plus_iff)
223.152 +apply (simp add: below_trans [OF upper_plus_below1])
223.153 +apply (simp add: upper_below_plus_iff)
223.154 done
223.155
223.156 definition
224.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
224.2 +++ b/src/HOLCF/ex/Domain_ex.thy Mon May 11 17:20:52 2009 +0200
224.3 @@ -0,0 +1,221 @@
224.4 +(* Title: HOLCF/ex/Domain_ex.thy
224.5 + Author: Brian Huffman
224.6 +*)
224.7 +
224.8 +header {* Domain package examples *}
224.9 +
224.10 +theory Domain_ex
224.11 +imports HOLCF
224.12 +begin
224.13 +
224.14 +text {* Domain constructors are strict by default. *}
224.15 +
224.16 +domain d1 = d1a | d1b "d1" "d1"
224.17 +
224.18 +lemma "d1b\<cdot>\<bottom>\<cdot>y = \<bottom>" by simp
224.19 +
224.20 +text {* Constructors can be made lazy using the @{text "lazy"} keyword. *}
224.21 +
224.22 +domain d2 = d2a | d2b (lazy "d2")
224.23 +
224.24 +lemma "d2b\<cdot>x \<noteq> \<bottom>" by simp
224.25 +
224.26 +text {* Strict and lazy arguments may be mixed arbitrarily. *}
224.27 +
224.28 +domain d3 = d3a | d3b (lazy "d2") "d2"
224.29 +
224.30 +lemma "P (d3b\<cdot>x\<cdot>y = \<bottom>) \<longleftrightarrow> P (y = \<bottom>)" by simp
224.31 +
224.32 +text {* Selectors can be used with strict or lazy constructor arguments. *}
224.33 +
224.34 +domain d4 = d4a | d4b (lazy d4b_left :: "d2") (d4b_right :: "d2")
224.35 +
224.36 +lemma "y \<noteq> \<bottom> \<Longrightarrow> d4b_left\<cdot>(d4b\<cdot>x\<cdot>y) = x" by simp
224.37 +
224.38 +text {* Mixfix declarations can be given for data constructors. *}
224.39 +
224.40 +domain d5 = d5a | d5b (lazy "d5") "d5" (infixl ":#:" 70)
224.41 +
224.42 +lemma "d5a \<noteq> x :#: y :#: z" by simp
224.43 +
224.44 +text {* Mixfix declarations can also be given for type constructors. *}
224.45 +
224.46 +domain ('a, 'b) lazypair (infixl ":*:" 25) =
224.47 + lpair (lazy lfst :: 'a) (lazy lsnd :: 'b) (infixl ":*:" 75)
224.48 +
224.49 +lemma "\<forall>p::('a :*: 'b). p \<sqsubseteq> lfst\<cdot>p :*: lsnd\<cdot>p"
224.50 +by (rule allI, case_tac p, simp_all)
224.51 +
224.52 +text {* Non-recursive constructor arguments can have arbitrary types. *}
224.53 +
224.54 +domain ('a, 'b) d6 = d6 "int lift" "'a \<oplus> 'b u" (lazy "('a :*: 'b) \<times> ('b \<rightarrow> 'a)")
224.55 +
224.56 +text {*
224.57 + Indirect recusion is allowed for sums, products, lifting, and the
224.58 + continuous function space. However, the domain package currently
224.59 + generates induction rules that are too weak. A fix is planned for
224.60 + the next release.
224.61 +*}
224.62 +
224.63 +domain 'a d7 = d7a "'a d7 \<oplus> int lift" | d7b "'a \<otimes> 'a d7" | d7c "'a d7 \<rightarrow> 'a"
224.64 +
224.65 +thm d7.ind -- "note the lack of inductive hypotheses"
224.66 +
224.67 +text {*
224.68 + Indirect recursion using previously-defined datatypes is currently
224.69 + not allowed. This restriction should go away by the next release.
224.70 +*}
224.71 +(*
224.72 +domain 'a slist = SNil | SCons 'a "'a slist"
224.73 +domain 'a stree = STip | SBranch "'a stree slist" -- "illegal indirect recursion"
224.74 +*)
224.75 +
224.76 +text {* Mutually-recursive datatypes can be defined using the @{text "and"} keyword. *}
224.77 +
224.78 +domain d8 = d8a | d8b "d9" and d9 = d9a | d9b (lazy "d8")
224.79 +
224.80 +text {* Non-regular recursion is not allowed. *}
224.81 +(*
224.82 +domain ('a, 'b) altlist = ANil | ACons 'a "('b, 'a) altlist"
224.83 + -- "illegal direct recursion with different arguments"
224.84 +domain 'a nest = Nest1 'a | Nest2 "'a nest nest"
224.85 + -- "illegal direct recursion with different arguments"
224.86 +*)
224.87 +
224.88 +text {*
224.89 + Mutually-recursive datatypes must have all the same type arguments,
224.90 + not necessarily in the same order.
224.91 +*}
224.92 +
224.93 +domain ('a, 'b) list1 = Nil1 | Cons1 'a "('b, 'a) list2"
224.94 + and ('b, 'a) list2 = Nil2 | Cons2 'b "('a, 'b) list1"
224.95 +
224.96 +text {* Induction rules for flat datatypes have no admissibility side-condition. *}
224.97 +
224.98 +domain 'a flattree = Tip | Branch "'a flattree" "'a flattree"
224.99 +
224.100 +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"
224.101 +by (rule flattree.ind) -- "no admissibility requirement"
224.102 +
224.103 +text {* Trivial datatypes will produce a warning message. *}
224.104 +
224.105 +domain triv = triv1 triv triv
224.106 + -- "domain Domain_ex.triv is empty!"
224.107 +
224.108 +lemma "(x::triv) = \<bottom>" by (induct x, simp_all)
224.109 +
224.110 +
224.111 +subsection {* Generated constants and theorems *}
224.112 +
224.113 +domain 'a tree = Leaf (lazy 'a) | Node (left :: "'a tree") (lazy right :: "'a tree")
224.114 +
224.115 +lemmas tree_abs_defined_iff =
224.116 + iso.abs_defined_iff [OF iso.intro [OF tree.abs_iso tree.rep_iso]]
224.117 +
224.118 +text {* Rules about ismorphism *}
224.119 +term tree_rep
224.120 +term tree_abs
224.121 +thm tree.rep_iso
224.122 +thm tree.abs_iso
224.123 +thm tree.iso_rews
224.124 +
224.125 +text {* Rules about constructors *}
224.126 +term Leaf
224.127 +term Node
224.128 +thm tree.Leaf_def tree.Node_def
224.129 +thm tree.exhaust
224.130 +thm tree.casedist
224.131 +thm tree.compacts
224.132 +thm tree.con_rews
224.133 +thm tree.dist_les
224.134 +thm tree.dist_eqs
224.135 +thm tree.inverts
224.136 +thm tree.injects
224.137 +
224.138 +text {* Rules about case combinator *}
224.139 +term tree_when
224.140 +thm tree.when_def
224.141 +thm tree.when_rews
224.142 +
224.143 +text {* Rules about selectors *}
224.144 +term left
224.145 +term right
224.146 +thm tree.sel_rews
224.147 +
224.148 +text {* Rules about discriminators *}
224.149 +term is_Leaf
224.150 +term is_Node
224.151 +thm tree.dis_rews
224.152 +
224.153 +text {* Rules about pattern match combinators *}
224.154 +term Leaf_pat
224.155 +term Node_pat
224.156 +thm tree.pat_rews
224.157 +
224.158 +text {* Rules about monadic pattern match combinators *}
224.159 +term match_Leaf
224.160 +term match_Node
224.161 +thm tree.match_rews
224.162 +
224.163 +text {* Rules about copy function *}
224.164 +term tree_copy
224.165 +thm tree.copy_def
224.166 +thm tree.copy_rews
224.167 +
224.168 +text {* Rules about take function *}
224.169 +term tree_take
224.170 +thm tree.take_def
224.171 +thm tree.take_rews
224.172 +thm tree.take_lemmas
224.173 +thm tree.finite_ind
224.174 +
224.175 +text {* Rules about finiteness predicate *}
224.176 +term tree_finite
224.177 +thm tree.finite_def
224.178 +thm tree.finites
224.179 +
224.180 +text {* Rules about bisimulation predicate *}
224.181 +term tree_bisim
224.182 +thm tree.bisim_def
224.183 +thm tree.coind
224.184 +
224.185 +text {* Induction rule *}
224.186 +thm tree.ind
224.187 +
224.188 +
224.189 +subsection {* Known bugs *}
224.190 +
224.191 +text {* Declaring a mixfix with spaces causes some strange parse errors. *}
224.192 +(*
224.193 +domain xx = xx ("x y")
224.194 + -- "Inner syntax error: unexpected end of input"
224.195 +
224.196 +domain 'a foo = foo (sel::"'a") ("a b")
224.197 + -- {* Inner syntax error at "= UU" *}
224.198 +*)
224.199 +
224.200 +text {*
224.201 + I don't know what is going on here. The failed proof has to do with
224.202 + the finiteness predicate.
224.203 +*}
224.204 +(*
224.205 +domain foo = Foo (lazy "bar") and bar = Bar
224.206 + -- "Tactic failed."
224.207 +*)
224.208 +
224.209 +text {* Declaring class constraints on the LHS is currently broken. *}
224.210 +(*
224.211 +domain ('a::cpo) box = Box (lazy 'a)
224.212 + -- "Malformed YXML encoding: multiple results"
224.213 +*)
224.214 +
224.215 +text {*
224.216 + Class constraints on the RHS are not supported yet. This feature is
224.217 + planned to replace the old-style LHS class constraints.
224.218 +*}
224.219 +(*
224.220 +domain 'a box = Box (lazy "'a::cpo")
224.221 + -- {* Inconsistent sort constraint for type variable "'a" *}
224.222 +*)
224.223 +
224.224 +end
225.1 --- a/src/HOLCF/ex/Fixrec_ex.thy Mon May 11 09:39:53 2009 +0200
225.2 +++ b/src/HOLCF/ex/Fixrec_ex.thy Mon May 11 17:20:52 2009 +0200
225.3 @@ -8,7 +8,7 @@
225.4 imports HOLCF
225.5 begin
225.6
225.7 -subsection {* basic fixrec examples *}
225.8 +subsection {* Basic @{text fixrec} examples *}
225.9
225.10 text {*
225.11 Fixrec patterns can mention any constructor defined by the domain
225.12 @@ -16,31 +16,31 @@
225.13 cpair, spair, sinl, sinr, up, ONE, TT, FF.
225.14 *}
225.15
225.16 -text {* typical usage is with lazy constructors *}
225.17 +text {* Typical usage is with lazy constructors. *}
225.18
225.19 fixrec down :: "'a u \<rightarrow> 'a"
225.20 where "down\<cdot>(up\<cdot>x) = x"
225.21
225.22 -text {* with strict constructors, rewrite rules may require side conditions *}
225.23 +text {* With strict constructors, rewrite rules may require side conditions. *}
225.24
225.25 fixrec from_sinl :: "'a \<oplus> 'b \<rightarrow> 'a"
225.26 where "x \<noteq> \<bottom> \<Longrightarrow> from_sinl\<cdot>(sinl\<cdot>x) = x"
225.27
225.28 -text {* lifting can turn a strict constructor into a lazy one *}
225.29 +text {* Lifting can turn a strict constructor into a lazy one. *}
225.30
225.31 fixrec from_sinl_up :: "'a u \<oplus> 'b \<rightarrow> 'a"
225.32 where "from_sinl_up\<cdot>(sinl\<cdot>(up\<cdot>x)) = x"
225.33
225.34
225.35 -subsection {* fixpat examples *}
225.36 +subsection {* Examples using @{text fixpat} *}
225.37
225.38 -text {* a type of lazy lists *}
225.39 +text {* A type of lazy lists. *}
225.40
225.41 domain 'a llist = lNil | lCons (lazy 'a) (lazy "'a llist")
225.42
225.43 -text {* zip function for lazy lists *}
225.44 +text {* A zip function for lazy lists. *}
225.45
225.46 -text {* notice that the patterns are not exhaustive *}
225.47 +text {* Notice that the patterns are not exhaustive. *}
225.48
225.49 fixrec
225.50 lzip :: "'a llist \<rightarrow> 'b llist \<rightarrow> ('a \<times> 'b) llist"
225.51 @@ -48,24 +48,59 @@
225.52 "lzip\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>(lCons\<cdot>y\<cdot>ys) = lCons\<cdot><x,y>\<cdot>(lzip\<cdot>xs\<cdot>ys)"
225.53 | "lzip\<cdot>lNil\<cdot>lNil = lNil"
225.54
225.55 -text {* fixpat is useful for producing strictness theorems *}
225.56 -text {* note that pattern matching is done in left-to-right order *}
225.57 +text {* @{text fixpat} is useful for producing strictness theorems. *}
225.58 +text {* Note that pattern matching is done in left-to-right order. *}
225.59
225.60 fixpat lzip_stricts [simp]:
225.61 "lzip\<cdot>\<bottom>\<cdot>ys"
225.62 "lzip\<cdot>lNil\<cdot>\<bottom>"
225.63 "lzip\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>\<bottom>"
225.64
225.65 -text {* fixpat can also produce rules for missing cases *}
225.66 +text {* @{text fixpat} can also produce rules for missing cases. *}
225.67
225.68 fixpat lzip_undefs [simp]:
225.69 "lzip\<cdot>lNil\<cdot>(lCons\<cdot>y\<cdot>ys)"
225.70 "lzip\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>lNil"
225.71
225.72
225.73 -subsection {* skipping proofs of rewrite rules *}
225.74 +subsection {* Pattern matching with bottoms *}
225.75
225.76 -text {* another zip function for lazy lists *}
225.77 +text {*
225.78 + As an alternative to using @{text fixpat}, it is also possible to
225.79 + use bottom as a constructor pattern. When using a bottom pattern,
225.80 + the right-hand-side must also be bottom; otherwise, @{text fixrec}
225.81 + will not be able to prove the equation.
225.82 +*}
225.83 +
225.84 +fixrec
225.85 + from_sinr_up :: "'a \<oplus> 'b\<^sub>\<bottom> \<rightarrow> 'b"
225.86 +where
225.87 + "from_sinr_up\<cdot>\<bottom> = \<bottom>"
225.88 +| "from_sinr_up\<cdot>(sinr\<cdot>(up\<cdot>x)) = x"
225.89 +
225.90 +text {*
225.91 + If the function is already strict in that argument, then the bottom
225.92 + pattern does not change the meaning of the function. For example,
225.93 + in the definition of @{term from_sinr_up}, the first equation is
225.94 + actually redundant, and could have been proven separately by
225.95 + @{text fixpat}.
225.96 +*}
225.97 +
225.98 +text {*
225.99 + A bottom pattern can also be used to make a function strict in a
225.100 + certain argument, similar to a bang-pattern in Haskell.
225.101 +*}
225.102 +
225.103 +fixrec
225.104 + seq :: "'a \<rightarrow> 'b \<rightarrow> 'b"
225.105 +where
225.106 + "seq\<cdot>\<bottom>\<cdot>y = \<bottom>"
225.107 +| "x \<noteq> \<bottom> \<Longrightarrow> seq\<cdot>x\<cdot>y = y"
225.108 +
225.109 +
225.110 +subsection {* Skipping proofs of rewrite rules *}
225.111 +
225.112 +text {* Another zip function for lazy lists. *}
225.113
225.114 text {*
225.115 Notice that this version has overlapping patterns.
225.116 @@ -85,7 +120,7 @@
225.117 does not produce any simp rules.
225.118 *}
225.119
225.120 -text {* simp rules can be generated later using fixpat *}
225.121 +text {* Simp rules can be generated later using @{text fixpat}. *}
225.122
225.123 fixpat lzip2_simps [simp]:
225.124 "lzip2\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>(lCons\<cdot>y\<cdot>ys)"
225.125 @@ -97,16 +132,17 @@
225.126 "lzip2\<cdot>\<bottom>\<cdot>ys"
225.127 "lzip2\<cdot>(lCons\<cdot>x\<cdot>xs)\<cdot>\<bottom>"
225.128
225.129 -subsection {* mutual recursion with fixrec *}
225.130
225.131 -text {* tree and forest types *}
225.132 +subsection {* Mutual recursion with @{text fixrec} *}
225.133 +
225.134 +text {* Tree and forest types. *}
225.135
225.136 domain 'a tree = Leaf (lazy 'a) | Branch (lazy "'a forest")
225.137 and 'a forest = Empty | Trees (lazy "'a tree") "'a forest"
225.138
225.139 text {*
225.140 To define mutually recursive functions, separate the equations
225.141 - for each function using the keyword "and".
225.142 + for each function using the keyword @{text "and"}.
225.143 *}
225.144
225.145 fixrec
225.146 @@ -125,10 +161,13 @@
225.147
225.148 text {*
225.149 Theorems generated:
225.150 - map_tree_def map_forest_def
225.151 - map_tree_unfold map_forest_unfold
225.152 - map_tree_simps map_forest_simps
225.153 - map_tree_map_forest_induct
225.154 + @{text map_tree_def}
225.155 + @{text map_forest_def}
225.156 + @{text map_tree_unfold}
225.157 + @{text map_forest_unfold}
225.158 + @{text map_tree_simps}
225.159 + @{text map_forest_simps}
225.160 + @{text map_tree_map_forest_induct}
225.161 *}
225.162
225.163 end
226.1 --- a/src/HOLCF/ex/ROOT.ML Mon May 11 09:39:53 2009 +0200
226.2 +++ b/src/HOLCF/ex/ROOT.ML Mon May 11 17:20:52 2009 +0200
226.3 @@ -4,4 +4,4 @@
226.4 *)
226.5
226.6 use_thys ["Dnat", "Stream", "Dagstuhl", "Focus_ex", "Fix2", "Hoare",
226.7 - "Loop", "Fixrec_ex", "Powerdomain_ex"];
226.8 + "Loop", "Fixrec_ex", "Powerdomain_ex", "Domain_ex"];
227.1 --- a/src/HOLCF/ex/Stream.thy Mon May 11 09:39:53 2009 +0200
227.2 +++ b/src/HOLCF/ex/Stream.thy Mon May 11 17:20:52 2009 +0200
227.3 @@ -64,10 +64,10 @@
227.4 section "scons"
227.5
227.6 lemma scons_eq_UU: "(a && s = UU) = (a = UU)"
227.7 -by (auto, erule contrapos_pp, simp)
227.8 +by simp
227.9
227.10 lemma scons_not_empty: "[| a && x = UU; a ~= UU |] ==> R"
227.11 -by auto
227.12 +by simp
227.13
227.14 lemma stream_exhaust_eq: "(x ~= UU) = (EX a y. a ~= UU & x = a && y)"
227.15 by (auto,insert stream.exhaust [of x],auto)
227.16 @@ -382,7 +382,6 @@
227.17
227.18 lemma slen_scons_eq_rev: "(#x < Fin (Suc (Suc n))) = (!a y. x ~= a && y | a = \<bottom> | #y < Fin (Suc n))"
227.19 apply (rule stream.casedist [of x], auto)
227.20 - apply ((*drule sym,*) drule scons_eq_UU [THEN iffD1],auto)
227.21 apply (simp add: zero_inat_def)
227.22 apply (case_tac "#s") apply (simp_all add: iSuc_Fin)
227.23 apply (case_tac "#s") apply (simp_all add: iSuc_Fin)
227.24 @@ -874,7 +873,6 @@
227.25 lemma slen_sconc_finite1:
227.26 "[| #(x ooo y) = Infty; Fin n = #x |] ==> #y = Infty"
227.27 apply (case_tac "#y ~= Infty",auto)
227.28 -apply (simp only: slen_infinite [symmetric])
227.29 apply (drule_tac y=y in rt_sconc1)
227.30 apply (insert stream_finite_i_rt [of n "x ooo y"])
227.31 by (simp add: slen_infinite)
227.32 @@ -889,16 +887,15 @@
227.33 apply (drule ex_sconc,auto)
227.34 apply (erule contrapos_pp)
227.35 apply (insert stream_finite_i_rt)
227.36 - apply (simp add: slen_infinite,auto)
227.37 + apply (fastsimp simp add: slen_infinite,auto)
227.38 by (simp add: sconc_def)
227.39
227.40 lemma sconc_finite: "(#x~=Infty & #y~=Infty) = (#(x ooo y)~=Infty)"
227.41 apply auto
227.42 - apply (case_tac "#x",auto)
227.43 - apply (erule contrapos_pp,simp)
227.44 - apply (erule slen_sconc_finite1,simp)
227.45 - apply (drule slen_sconc_infinite1 [of _ y],simp)
227.46 -by (drule slen_sconc_infinite2 [of _ x],simp)
227.47 + apply (metis not_Infty_eq slen_sconc_finite1)
227.48 + apply (metis not_Infty_eq slen_sconc_infinite1)
227.49 +apply (metis not_Infty_eq slen_sconc_infinite2)
227.50 +done
227.51
227.52 (* ----------------------------------------------------------------------- *)
227.53
228.1 --- a/src/Provers/Arith/cancel_div_mod.ML Mon May 11 09:39:53 2009 +0200
228.2 +++ b/src/Provers/Arith/cancel_div_mod.ML Mon May 11 17:20:52 2009 +0200
228.3 @@ -69,7 +69,7 @@
228.4
228.5 fun cancel ss t pq =
228.6 let val teqt' = Data.prove_eq_sums ss (t, rearrange t pq)
228.7 - in hd(Data.div_mod_eqs RL [teqt' RS transitive_thm]) end;
228.8 + in hd (Data.div_mod_eqs RL [teqt' RS transitive_thm]) end;
228.9
228.10 fun proc ss t =
228.11 let val (divs,mods) = coll_div_mod t ([],[])
229.1 --- a/src/Pure/General/symbol.ML Mon May 11 09:39:53 2009 +0200
229.2 +++ b/src/Pure/General/symbol.ML Mon May 11 17:20:52 2009 +0200
229.3 @@ -18,6 +18,7 @@
229.4 val is_symbolic: symbol -> bool
229.5 val is_printable: symbol -> bool
229.6 val is_utf8_trailer: symbol -> bool
229.7 + val name_of: symbol -> string
229.8 val eof: symbol
229.9 val is_eof: symbol -> bool
229.10 val not_eof: symbol -> bool
229.11 @@ -135,6 +136,10 @@
229.12 fun is_regular s =
229.13 not_eof s andalso s <> sync andalso s <> malformed andalso s <> end_malformed;
229.14
229.15 +fun name_of s = if is_symbolic s
229.16 + then (unsuffix ">" o unprefix "\\<") s
229.17 + else error (malformed_msg s);
229.18 +
229.19
229.20 (* ascii symbols *)
229.21
230.1 --- a/src/Pure/IsaMakefile Mon May 11 09:39:53 2009 +0200
230.2 +++ b/src/Pure/IsaMakefile Mon May 11 17:20:52 2009 +0200
230.3 @@ -40,9 +40,8 @@
230.4
230.5 Pure: $(OUT)/Pure
230.6
230.7 -$(OUT)/Pure: $(BOOTSTRAP_FILES) ../Tools/auto_solve.ML \
230.8 - ../Tools/quickcheck.ML Concurrent/ROOT.ML Concurrent/future.ML \
230.9 - Concurrent/mailbox.ML Concurrent/par_list.ML \
230.10 +$(OUT)/Pure: $(BOOTSTRAP_FILES) Concurrent/ROOT.ML \
230.11 + Concurrent/future.ML Concurrent/mailbox.ML Concurrent/par_list.ML \
230.12 Concurrent/par_list_dummy.ML Concurrent/simple_thread.ML \
230.13 Concurrent/synchronized.ML Concurrent/task_queue.ML General/ROOT.ML \
230.14 General/alist.ML General/antiquote.ML General/balanced_tree.ML \
231.1 --- a/src/Pure/Isar/class_target.ML Mon May 11 09:39:53 2009 +0200
231.2 +++ b/src/Pure/Isar/class_target.ML Mon May 11 17:20:52 2009 +0200
231.3 @@ -278,7 +278,8 @@
231.4 val classrel = Goal.prove_global thy [] [] (Logic.mk_classrel (sub, sup))
231.5 (K tac);
231.6 val diff_sort = Sign.complete_sort thy [sup]
231.7 - |> subtract (op =) (Sign.complete_sort thy [sub]);
231.8 + |> subtract (op =) (Sign.complete_sort thy [sub])
231.9 + |> filter (is_class thy);
231.10 in
231.11 thy
231.12 |> AxClass.add_classrel classrel
232.1 --- a/src/Pure/Isar/code.ML Mon May 11 09:39:53 2009 +0200
232.2 +++ b/src/Pure/Isar/code.ML Mon May 11 17:20:52 2009 +0200
232.3 @@ -8,7 +8,7 @@
232.4 signature CODE =
232.5 sig
232.6 val add_eqn: thm -> theory -> theory
232.7 - val add_nonlinear_eqn: thm -> theory -> theory
232.8 + val add_nbe_eqn: thm -> theory -> theory
232.9 val add_default_eqn: thm -> theory -> theory
232.10 val add_default_eqn_attribute: attribute
232.11 val add_default_eqn_attrib: Attrib.src
232.12 @@ -20,6 +20,8 @@
232.13 val add_inline: thm -> theory -> theory
232.14 val add_functrans: string * (theory -> (thm * bool) list -> (thm * bool) list option) -> theory -> theory
232.15 val del_functrans: string -> theory -> theory
232.16 + val simple_functrans: (theory -> thm list -> thm list option)
232.17 + -> theory -> (thm * bool) list -> (thm * bool) list option
232.18 val add_datatype: (string * typ) list -> theory -> theory
232.19 val add_datatype_cmd: string list -> theory -> theory
232.20 val type_interpretation:
232.21 @@ -29,8 +31,6 @@
232.22 val add_undefined: string -> theory -> theory
232.23 val purge_data: theory -> theory
232.24
232.25 - val coregular_algebra: theory -> Sorts.algebra
232.26 - val operational_algebra: theory -> (sort -> sort) * Sorts.algebra
232.27 val these_eqns: theory -> string -> (thm * bool) list
232.28 val these_raw_eqns: theory -> string -> (thm * bool) list
232.29 val get_datatype: theory -> string -> ((string * sort) list * (string * typ list) list)
232.30 @@ -111,7 +111,7 @@
232.31 (* code equations *)
232.32
232.33 type eqns = bool * (thm * bool) list lazy;
232.34 - (*default flag, theorems with linear flag (perhaps lazy)*)
232.35 + (*default flag, theorems with proper flag (perhaps lazy)*)
232.36
232.37 fun pretty_lthms ctxt r = case Lazy.peek r
232.38 of SOME thms => map (ProofContext.pretty_thm ctxt o fst) (Exn.release thms)
232.39 @@ -124,18 +124,18 @@
232.40 val thy_ref = Theory.check_thy thy;
232.41 in Lazy.lazy (fn () => (f (Theory.deref thy_ref) o Lazy.force) r) end;
232.42
232.43 -fun add_drop_redundant thy (thm, linear) thms =
232.44 +fun add_drop_redundant thy (thm, proper) thms =
232.45 let
232.46 val args_of = snd o strip_comb o fst o Logic.dest_equals o Thm.plain_prop_of;
232.47 val args = args_of thm;
232.48 val incr_idx = Logic.incr_indexes ([], Thm.maxidx_of thm + 1);
232.49 fun matches_args args' = length args <= length args' andalso
232.50 Pattern.matchess thy (args, (map incr_idx o curry Library.take (length args)) args');
232.51 - fun drop (thm', linear') = if (linear orelse not linear')
232.52 + fun drop (thm', proper') = if (proper orelse not proper')
232.53 andalso matches_args (args_of thm') then
232.54 (warning ("Code generator: dropping redundant code equation\n" ^ Display.string_of_thm thm'); true)
232.55 else false;
232.56 - in (thm, linear) :: filter_out drop thms end;
232.57 + in (thm, proper) :: filter_out drop thms end;
232.58
232.59 fun add_thm thy _ thm (false, thms) = (false, Lazy.map_force (add_drop_redundant thy thm) thms)
232.60 | add_thm thy true thm (true, thms) = (true, Lazy.map_force (fn thms => thms @ [thm]) thms)
232.61 @@ -458,49 +458,6 @@
232.62 cons (Thm.ctyp_of thy (TVar (x_i, sort)), Thm.ctyp_of thy ty)) env [];
232.63 in map (Thm.instantiate (instT, [])) thms' end;
232.64
232.65 -fun check_linear (eqn as (thm, linear)) =
232.66 - if linear then eqn else Code_Unit.bad_thm
232.67 - ("Duplicate variables on left hand side of code equation:\n"
232.68 - ^ Display.string_of_thm thm);
232.69 -
232.70 -fun mk_eqn thy linear =
232.71 - Code_Unit.error_thm ((if linear then check_linear else I) o Code_Unit.mk_eqn thy);
232.72 -fun mk_syntactic_eqn thy = Code_Unit.warning_thm (Code_Unit.mk_eqn thy);
232.73 -fun mk_default_eqn thy = Code_Unit.try_thm (check_linear o Code_Unit.mk_eqn thy);
232.74 -
232.75 -
232.76 -(** operational sort algebra and class discipline **)
232.77 -
232.78 -local
232.79 -
232.80 -fun arity_constraints thy algebra (class, tyco) =
232.81 - let
232.82 - val base_constraints = Sorts.mg_domain algebra tyco [class];
232.83 - val classparam_constraints = Sorts.complete_sort algebra [class]
232.84 - |> maps (map fst o these o try (#params o AxClass.get_info thy))
232.85 - |> map_filter (fn c => try (AxClass.param_of_inst thy) (c, tyco))
232.86 - |> maps (map fst o get_eqns thy)
232.87 - |> map (map (snd o dest_TVar) o Sign.const_typargs thy o Code_Unit.const_typ_eqn);
232.88 - val inter_sorts = map2 (curry (Sorts.inter_sort algebra));
232.89 - in fold inter_sorts classparam_constraints base_constraints end;
232.90 -
232.91 -fun retrieve_algebra thy operational =
232.92 - Sorts.subalgebra (Syntax.pp_global thy) operational
232.93 - (SOME o arity_constraints thy (Sign.classes_of thy))
232.94 - (Sign.classes_of thy);
232.95 -
232.96 -in
232.97 -
232.98 -fun coregular_algebra thy = retrieve_algebra thy (K true) |> snd;
232.99 -fun operational_algebra thy =
232.100 - let
232.101 - fun add_iff_operational class =
232.102 - can (AxClass.get_info thy) class ? cons class;
232.103 - val operational_classes = fold add_iff_operational (Sign.all_classes thy) []
232.104 - in retrieve_algebra thy (member (op =) operational_classes) end;
232.105 -
232.106 -end; (*local*)
232.107 -
232.108
232.109 (** interfaces and attributes **)
232.110
232.111 @@ -522,51 +479,47 @@
232.112 then SOME tyco else NONE
232.113 | _ => NONE;
232.114
232.115 -fun recheck_eqn thy = Code_Unit.error_thm
232.116 - (Code_Unit.assert_linear (is_some o get_datatype_of_constr thy) o apfst (Code_Unit.assert_eqn thy));
232.117 +fun is_constr thy = is_some o get_datatype_of_constr thy;
232.118
232.119 -fun recheck_eqns_const thy c eqns =
232.120 +fun assert_eqn thy = Code_Unit.assert_eqn thy (is_constr thy);
232.121 +
232.122 +fun assert_eqns_const thy c eqns =
232.123 let
232.124 - fun cert (eqn as (thm, _)) = if c = Code_Unit.const_eqn thm
232.125 + fun cert (eqn as (thm, _)) = if c = Code_Unit.const_eqn thy thm
232.126 then eqn else error ("Wrong head of code equation,\nexpected constant "
232.127 ^ Code_Unit.string_of_const thy c ^ "\n" ^ Display.string_of_thm thm)
232.128 - in map (cert o recheck_eqn thy) eqns end;
232.129 + in map (cert o assert_eqn thy) eqns end;
232.130
232.131 fun change_eqns delete c f = (map_exec_purge (SOME [c]) o map_eqns
232.132 o (if delete then Symtab.map_entry c else Symtab.map_default (c, ((false, (true, Lazy.value [])), [])))
232.133 o apfst) (fn (_, eqns) => (true, f eqns));
232.134
232.135 -fun gen_add_eqn linear default thm thy =
232.136 - case (if default then mk_default_eqn thy else SOME o mk_eqn thy linear) thm
232.137 - of SOME (thm, _) =>
232.138 - let
232.139 - val c = Code_Unit.const_eqn thm;
232.140 - val _ = if not default andalso (is_some o AxClass.class_of_param thy) c
232.141 - then error ("Rejected polymorphic code equation for overloaded constant:\n"
232.142 - ^ Display.string_of_thm thm)
232.143 - else ();
232.144 - val _ = if not default andalso (is_some o get_datatype_of_constr thy) c
232.145 - then error ("Rejected code equation for datatype constructor:\n"
232.146 - ^ Display.string_of_thm thm)
232.147 - else ();
232.148 - in change_eqns false c (add_thm thy default (thm, linear)) thy end
232.149 +fun gen_add_eqn default (eqn as (thm, _)) thy =
232.150 + let val c = Code_Unit.const_eqn thy thm
232.151 + in change_eqns false c (add_thm thy default eqn) thy end;
232.152 +
232.153 +fun add_eqn thm thy =
232.154 + gen_add_eqn false (Code_Unit.mk_eqn thy (is_constr thy) (thm, true)) thy;
232.155 +
232.156 +fun add_default_eqn thm thy =
232.157 + case Code_Unit.mk_eqn_liberal thy (is_constr thy) thm
232.158 + of SOME eqn => gen_add_eqn true eqn thy
232.159 | NONE => thy;
232.160
232.161 -val add_eqn = gen_add_eqn true false;
232.162 -val add_default_eqn = gen_add_eqn true true;
232.163 -val add_nonlinear_eqn = gen_add_eqn false false;
232.164 +fun add_nbe_eqn thm thy =
232.165 + gen_add_eqn false (Code_Unit.mk_eqn thy (is_constr thy) (thm, false)) thy;
232.166
232.167 fun add_eqnl (c, lthms) thy =
232.168 let
232.169 - val lthms' = certificate thy (fn thy => recheck_eqns_const thy c) lthms;
232.170 + val lthms' = certificate thy (fn thy => assert_eqns_const thy c) lthms;
232.171 in change_eqns false c (add_lthms lthms') thy end;
232.172
232.173 val add_default_eqn_attribute = Thm.declaration_attribute
232.174 (fn thm => Context.mapping (add_default_eqn thm) I);
232.175 val add_default_eqn_attrib = Attrib.internal (K add_default_eqn_attribute);
232.176
232.177 -fun del_eqn thm thy = case mk_syntactic_eqn thy thm
232.178 - of SOME (thm, _) => change_eqns true (Code_Unit.const_eqn thm) (del_thm thm) thy
232.179 +fun del_eqn thm thy = case Code_Unit.mk_eqn_liberal thy (is_constr thy) thm
232.180 + of SOME (thm, _) => change_eqns true (Code_Unit.const_eqn thy thm) (del_thm thm) thy
232.181 | NONE => thy;
232.182
232.183 fun del_eqns c = change_eqns true c (K (false, Lazy.value []));
232.184 @@ -588,9 +541,9 @@
232.185 then insert (op =) c else I) cases []) cases;
232.186 in
232.187 thy
232.188 + |> fold (del_eqns o fst) cs
232.189 |> map_exec_purge NONE
232.190 ((map_dtyps o Symtab.map_default (tyco, [])) (cons (serial (), vs_cos))
232.191 - #> map_eqns (fold (Symtab.delete_safe o fst) cs)
232.192 #> (map_cases o apfst) drop_outdated_cases)
232.193 |> TypeInterpretation.data (tyco, serial ())
232.194 end;
232.195 @@ -606,7 +559,7 @@
232.196 fun add_case thm thy =
232.197 let
232.198 val (c, (k, case_pats)) = Code_Unit.case_cert thm;
232.199 - val _ = case filter (is_none o get_datatype_of_constr thy) case_pats
232.200 + val _ = case filter_out (is_constr thy) case_pats
232.201 of [] => ()
232.202 | cs => error ("Non-constructor(s) in case certificate: " ^ commas (map quote cs));
232.203 val entry = (1 + Int.max (1, length case_pats), (k, case_pats))
232.204 @@ -631,6 +584,10 @@
232.205 (map_exec_purge NONE o map_thmproc o apsnd)
232.206 (delete_force "function transformer" name);
232.207
232.208 +fun simple_functrans f thy eqns = case f thy (map fst eqns)
232.209 + of SOME thms' => SOME (map (rpair (forall snd eqns)) thms')
232.210 + | NONE => NONE;
232.211 +
232.212 val _ = Context.>> (Context.map_theory
232.213 (let
232.214 fun mk_attribute f = Thm.declaration_attribute (fn thm => Context.mapping (f thm) I);
232.215 @@ -642,7 +599,7 @@
232.216 in
232.217 TypeInterpretation.init
232.218 #> add_del_attribute ("", (add_eqn, del_eqn))
232.219 - #> add_simple_attribute ("nbe", add_nonlinear_eqn)
232.220 + #> add_simple_attribute ("nbe", add_nbe_eqn)
232.221 #> add_del_attribute ("inline", (add_inline, del_inline))
232.222 #> add_del_attribute ("post", (add_post, del_post))
232.223 end));
232.224 @@ -656,9 +613,7 @@
232.225 | apply_functrans thy c [] eqns = eqns
232.226 | apply_functrans thy c functrans eqns = eqns
232.227 |> perhaps (perhaps_loop (perhaps_apply functrans))
232.228 - |> (map o apfst) (AxClass.unoverload thy)
232.229 - |> recheck_eqns_const thy c
232.230 - |> (map o apfst) (AxClass.overload thy);
232.231 + |> assert_eqns_const thy c;
232.232
232.233 fun rhs_conv conv thm = Thm.transitive thm ((conv o Thm.rhs_of) thm);
232.234
232.235 @@ -669,16 +624,17 @@
232.236 #> Logic.dest_equals
232.237 #> snd;
232.238
232.239 -fun preprocess thy functrans c eqns =
232.240 +fun preprocess thy c eqns =
232.241 let
232.242 val pre = (Simplifier.theory_context thy o #pre o the_thmproc o the_exec) thy;
232.243 + val functrans = (map (fn (_, (_, f)) => f thy) o #functrans
232.244 + o the_thmproc o the_exec) thy;
232.245 in
232.246 eqns
232.247 - |> (map o apfst) (AxClass.overload thy)
232.248 |> apply_functrans thy c functrans
232.249 |> (map o apfst) (Code_Unit.rewrite_eqn pre)
232.250 |> (map o apfst) (AxClass.unoverload thy)
232.251 - |> map (recheck_eqn thy)
232.252 + |> map (assert_eqn thy)
232.253 |> burrow_fst (common_typ_eqns thy)
232.254 end;
232.255
232.256 @@ -712,14 +668,9 @@
232.257 |> burrow_fst (common_typ_eqns thy);
232.258
232.259 fun these_eqns thy c =
232.260 - let
232.261 - val functrans = (map (fn (_, (_, f)) => f thy) o #functrans
232.262 - o the_thmproc o the_exec) thy;
232.263 - in
232.264 - get_eqns thy c
232.265 - |> (map o apfst) (Thm.transfer thy)
232.266 - |> preprocess thy functrans c
232.267 - end;
232.268 + get_eqns thy c
232.269 + |> (map o apfst) (Thm.transfer thy)
232.270 + |> preprocess thy c;
232.271
232.272 fun default_typscheme thy c =
232.273 let
232.274 @@ -728,10 +679,10 @@
232.275 fun strip_sorts (vs, ty) = (map (fn (v, _) => (v, [])) vs, ty);
232.276 in case AxClass.class_of_param thy c
232.277 of SOME class => ([(Name.aT, [class])], snd (the_const_typscheme c))
232.278 - | NONE => if is_some (get_datatype_of_constr thy c)
232.279 + | NONE => if is_constr thy c
232.280 then strip_sorts (the_const_typscheme c)
232.281 else case get_eqns thy c
232.282 - of (thm, _) :: _ => snd (Code_Unit.head_eqn thy (Drule.zero_var_indexes thm))
232.283 + of (thm, _) :: _ => (Code_Unit.typscheme_eqn thy o Drule.zero_var_indexes) thm
232.284 | [] => strip_sorts (the_const_typscheme c) end;
232.285
232.286 end; (*local*)
233.1 --- a/src/Pure/Isar/code_unit.ML Mon May 11 09:39:53 2009 +0200
233.2 +++ b/src/Pure/Isar/code_unit.ML Mon May 11 17:20:52 2009 +0200
233.3 @@ -6,12 +6,6 @@
233.4
233.5 signature CODE_UNIT =
233.6 sig
233.7 - (*generic non-sense*)
233.8 - val bad_thm: string -> 'a
233.9 - val error_thm: ('a -> 'b) -> 'a -> 'b
233.10 - val warning_thm: ('a -> 'b) -> 'a -> 'b option
233.11 - val try_thm: ('a -> 'b) -> 'a -> 'b option
233.12 -
233.13 (*typ instantiations*)
233.14 val typscheme: theory -> string * typ -> (string * sort) list * typ
233.15 val inst_thm: theory -> sort Vartab.table -> thm -> thm
233.16 @@ -35,17 +29,17 @@
233.17 -> string * ((string * sort) list * (string * typ list) list)
233.18
233.19 (*code equations*)
233.20 - val assert_eqn: theory -> thm -> thm
233.21 - val mk_eqn: theory -> thm -> thm * bool
233.22 - val assert_linear: (string -> bool) -> thm * bool -> thm * bool
233.23 - val const_eqn: thm -> string
233.24 - val const_typ_eqn: thm -> string * typ
233.25 - val head_eqn: theory -> thm -> string * ((string * sort) list * typ)
233.26 + val mk_eqn: theory -> (string -> bool) -> thm * bool -> thm * bool
233.27 + val mk_eqn_liberal: theory -> (string -> bool) -> thm -> (thm * bool) option
233.28 + val assert_eqn: theory -> (string -> bool) -> thm * bool -> thm * bool
233.29 + val const_eqn: theory -> thm -> string
233.30 + val const_typ_eqn: thm -> string * typ
233.31 + val typscheme_eqn: theory -> thm -> (string * sort) list * typ
233.32 val expand_eta: theory -> int -> thm -> thm
233.33 val rewrite_eqn: simpset -> thm -> thm
233.34 val rewrite_head: thm list -> thm -> thm
233.35 val norm_args: theory -> thm list -> thm list
233.36 - val norm_varnames: theory -> (string -> string) -> (string -> string) -> thm list -> thm list
233.37 + val norm_varnames: theory -> thm list -> thm list
233.38
233.39 (*case certificates*)
233.40 val case_cert: thm -> string * (int * string list)
233.41 @@ -57,13 +51,6 @@
233.42
233.43 (* auxiliary *)
233.44
233.45 -exception BAD_THM of string;
233.46 -fun bad_thm msg = raise BAD_THM msg;
233.47 -fun error_thm f thm = f thm handle BAD_THM msg => error msg;
233.48 -fun warning_thm f thm = SOME (f thm) handle BAD_THM msg
233.49 - => (warning ("code generator: " ^ msg); NONE);
233.50 -fun try_thm f thm = SOME (f thm) handle BAD_THM _ => NONE;
233.51 -
233.52 fun string_of_typ thy = setmp show_sorts true (Syntax.string_of_typ_global thy);
233.53 fun string_of_const thy c = case AxClass.inst_of_param thy c
233.54 of SOME (c, tyco) => Sign.extern_const thy c ^ " " ^ enclose "[" "]" (Sign.extern_type thy tyco)
233.55 @@ -161,9 +148,10 @@
233.56 |> map (Conv.fconv_rule Drule.beta_eta_conversion)
233.57 end;
233.58
233.59 -fun canonical_tvars thy purify_tvar thm =
233.60 +fun canonical_tvars thy thm =
233.61 let
233.62 val ctyp = Thm.ctyp_of thy;
233.63 + val purify_tvar = unprefix "'" #> Name.desymbolize false #> prefix "'";
233.64 fun tvars_subst_for thm = (fold_types o fold_atyps)
233.65 (fn TVar (v_i as (v, _), sort) => let
233.66 val v' = purify_tvar v
233.67 @@ -180,9 +168,10 @@
233.68 val (_, inst) = fold mk_inst (tvars_subst_for thm) (maxidx + 1, []);
233.69 in Thm.instantiate (inst, []) thm end;
233.70
233.71 -fun canonical_vars thy purify_var thm =
233.72 +fun canonical_vars thy thm =
233.73 let
233.74 val cterm = Thm.cterm_of thy;
233.75 + val purify_var = Name.desymbolize false;
233.76 fun vars_subst_for thm = fold_aterms
233.77 (fn Var (v_i as (v, _), ty) => let
233.78 val v' = purify_var v
233.79 @@ -199,13 +188,14 @@
233.80 val (_, inst) = fold mk_inst (vars_subst_for thm) (maxidx + 1, []);
233.81 in Thm.instantiate ([], inst) thm end;
233.82
233.83 -fun canonical_absvars purify_var thm =
233.84 +fun canonical_absvars thm =
233.85 let
233.86 val t = Thm.plain_prop_of thm;
233.87 + val purify_var = Name.desymbolize false;
233.88 val t' = Term.map_abs_vars purify_var t;
233.89 in Thm.rename_boundvars t t' thm end;
233.90
233.91 -fun norm_varnames thy purify_tvar purify_var thms =
233.92 +fun norm_varnames thy thms =
233.93 let
233.94 fun burrow_thms f [] = []
233.95 | burrow_thms f thms =
233.96 @@ -215,10 +205,10 @@
233.97 |> Conjunction.elim_balanced (length thms)
233.98 in
233.99 thms
233.100 - |> map (canonical_vars thy purify_var)
233.101 - |> map (canonical_absvars purify_var)
233.102 + |> map (canonical_vars thy)
233.103 + |> map canonical_absvars
233.104 |> map Drule.zero_var_indexes
233.105 - |> burrow_thms (canonical_tvars thy purify_tvar)
233.106 + |> burrow_thms (canonical_tvars thy)
233.107 |> Drule.zero_var_indexes_list
233.108 end;
233.109
233.110 @@ -320,85 +310,96 @@
233.111
233.112 (* code equations *)
233.113
233.114 -fun assert_eqn thy thm =
233.115 +exception BAD_THM of string;
233.116 +fun bad_thm msg = raise BAD_THM msg;
233.117 +fun error_thm f thm = f thm handle BAD_THM msg => error msg;
233.118 +fun try_thm f thm = SOME (f thm) handle BAD_THM _ => NONE;
233.119 +
233.120 +fun is_linear thm =
233.121 + let val (_, args) = (strip_comb o fst o Logic.dest_equals o Thm.plain_prop_of) thm
233.122 + in not (has_duplicates (op =) ((fold o fold_aterms)
233.123 + (fn Var (v, _) => cons v | _ => I) args [])) end;
233.124 +
233.125 +fun gen_assert_eqn thy is_constr_head is_constr_pat (thm, proper) =
233.126 let
233.127 val (lhs, rhs) = (Logic.dest_equals o Thm.plain_prop_of) thm
233.128 handle TERM _ => bad_thm ("Not an equation: " ^ Display.string_of_thm thm)
233.129 - | THM _ => bad_thm ("Not an equation: " ^ Display.string_of_thm thm);
233.130 + | THM _ => bad_thm ("Not an equation: " ^ Display.string_of_thm thm);
233.131 fun vars_of t = fold_aterms (fn Var (v, _) => insert (op =) v
233.132 - | Free _ => bad_thm ("Illegal free variable in rewrite theorem\n"
233.133 + | Free _ => bad_thm ("Illegal free variable in equation\n"
233.134 ^ Display.string_of_thm thm)
233.135 | _ => I) t [];
233.136 fun tvars_of t = fold_term_types (fn _ =>
233.137 fold_atyps (fn TVar (v, _) => insert (op =) v
233.138 | TFree _ => bad_thm
233.139 - ("Illegal free type variable in rewrite theorem\n" ^ Display.string_of_thm thm))) t [];
233.140 + ("Illegal free type variable in equation\n" ^ Display.string_of_thm thm))) t [];
233.141 val lhs_vs = vars_of lhs;
233.142 val rhs_vs = vars_of rhs;
233.143 val lhs_tvs = tvars_of lhs;
233.144 val rhs_tvs = tvars_of rhs;
233.145 val _ = if null (subtract (op =) lhs_vs rhs_vs)
233.146 then ()
233.147 - else bad_thm ("Free variables on right hand side of rewrite theorem\n"
233.148 + else bad_thm ("Free variables on right hand side of equation\n"
233.149 ^ Display.string_of_thm thm);
233.150 val _ = if null (subtract (op =) lhs_tvs rhs_tvs)
233.151 then ()
233.152 - else bad_thm ("Free type variables on right hand side of rewrite theorem\n"
233.153 + else bad_thm ("Free type variables on right hand side of equation\n"
233.154 ^ Display.string_of_thm thm) val (head, args) = (strip_comb o fst o Logic.dest_equals o Thm.plain_prop_of) thm;
233.155 - val (c, ty) = case head of Const c_ty => c_ty | _ =>
233.156 - bad_thm ("Equation not headed by constant\n" ^ Display.string_of_thm thm);
233.157 + val (c, ty) = case head
233.158 + of Const (c_ty as (_, ty)) => (AxClass.unoverload_const thy c_ty, ty)
233.159 + | _ => bad_thm ("Equation not headed by constant\n" ^ Display.string_of_thm thm);
233.160 fun check _ (Abs _) = bad_thm
233.161 ("Abstraction on left hand side of equation\n"
233.162 ^ Display.string_of_thm thm)
233.163 | check 0 (Var _) = ()
233.164 | check _ (Var _) = bad_thm
233.165 - ("Variable with application on left hand side of code equation\n"
233.166 + ("Variable with application on left hand side of equation\n"
233.167 ^ Display.string_of_thm thm)
233.168 | check n (t1 $ t2) = (check (n+1) t1; check 0 t2)
233.169 - | check n (Const (_, ty)) = if n <> (length o fst o strip_type) ty
233.170 - then bad_thm
233.171 - ("Partially applied constant on left hand side of equation\n"
233.172 - ^ Display.string_of_thm thm)
233.173 - else ();
233.174 + | check n (Const (c_ty as (c, ty))) = if n = (length o fst o strip_type) ty
233.175 + then if not proper orelse is_constr_pat (AxClass.unoverload_const thy c_ty)
233.176 + then ()
233.177 + else bad_thm (quote c ^ " is not a constructor, on left hand side of equation\n"
233.178 + ^ Display.string_of_thm thm)
233.179 + else bad_thm
233.180 + ("Partially applied constant " ^ quote c ^ " on left hand side of equation\n"
233.181 + ^ Display.string_of_thm thm);
233.182 val _ = map (check 0) args;
233.183 + val _ = if not proper orelse is_linear thm then ()
233.184 + else bad_thm ("Duplicate variables on left hand side of equation\n"
233.185 + ^ Display.string_of_thm thm);
233.186 + val _ = if (is_none o AxClass.class_of_param thy) c
233.187 + then ()
233.188 + else bad_thm ("Polymorphic constant as head in equation\n"
233.189 + ^ Display.string_of_thm thm)
233.190 + val _ = if not (is_constr_head c)
233.191 + then ()
233.192 + else bad_thm ("Constructor as head in equation\n"
233.193 + ^ Display.string_of_thm thm)
233.194 val ty_decl = Sign.the_const_type thy c;
233.195 val _ = if Sign.typ_equiv thy (Type.strip_sorts ty_decl, Type.strip_sorts ty)
233.196 then () else bad_thm ("Type\n" ^ string_of_typ thy ty
233.197 - ^ "\nof code equation\n"
233.198 + ^ "\nof equation\n"
233.199 ^ Display.string_of_thm thm
233.200 ^ "\nis incompatible with declared function type\n"
233.201 ^ string_of_typ thy ty_decl)
233.202 - in thm end;
233.203 + in (thm, proper) end;
233.204
233.205 -fun add_linear thm =
233.206 - let
233.207 - val (_, args) = (strip_comb o fst o Logic.dest_equals o Thm.plain_prop_of) thm;
233.208 - val linear = not (has_duplicates (op =)
233.209 - ((fold o fold_aterms) (fn Var (v, _) => cons v | _ => I) args []))
233.210 - in (thm, linear) end;
233.211 -
233.212 -fun assert_pat is_cons thm =
233.213 - let
233.214 - val args = (snd o strip_comb o fst o Logic.dest_equals o Thm.plain_prop_of) thm;
233.215 - val _ = (map o map_aterms) (fn t as Const (c, _) => if is_cons c then t
233.216 - else bad_thm ("Not a constructor on left hand side of equation: "
233.217 - ^ quote c ^ ",\n in equation\n" ^ Display.string_of_thm thm)
233.218 - | t => t) args;
233.219 - in thm end;
233.220 -
233.221 -fun assert_linear is_cons (thm, false) = (thm, false)
233.222 - | assert_linear is_cons (thm, true) = if snd (add_linear (assert_pat is_cons thm)) then (thm, true)
233.223 - else bad_thm
233.224 - ("Duplicate variables on left hand side of code equation:\n"
233.225 - ^ Display.string_of_thm thm);
233.226 -
233.227 -
233.228 -fun mk_eqn thy = add_linear o assert_eqn thy o AxClass.unoverload thy
233.229 - o LocalDefs.meta_rewrite_rule (ProofContext.init thy);
233.230 +fun assert_eqn thy is_constr = error_thm (gen_assert_eqn thy is_constr is_constr);
233.231
233.232 val const_typ_eqn = dest_Const o fst o strip_comb o fst o Logic.dest_equals o Thm.plain_prop_of;
233.233 -val const_eqn = fst o const_typ_eqn;
233.234 -fun head_eqn thy thm = let val (c, ty) = const_typ_eqn thm in (c, typscheme thy (c, ty)) end;
233.235 +
233.236 +fun typscheme_eqn thy = typscheme thy o const_typ_eqn;
233.237 +
233.238 +(*these are permissive wrt. to overloaded constants!*)
233.239 +fun mk_eqn thy is_constr_head = error_thm (gen_assert_eqn thy is_constr_head (K true)) o
233.240 + apfst (LocalDefs.meta_rewrite_rule (ProofContext.init thy));
233.241 +
233.242 +fun mk_eqn_liberal thy is_constr_head = Option.map (fn (thm, _) => (thm, is_linear thm))
233.243 + o try_thm (gen_assert_eqn thy is_constr_head (K true))
233.244 + o rpair false o LocalDefs.meta_rewrite_rule (ProofContext.init thy);
233.245 +
233.246 +fun const_eqn thy = AxClass.unoverload_const thy o const_typ_eqn;
233.247
233.248
233.249 (* case cerificates *)
234.1 --- a/src/Pure/ProofGeneral/ROOT.ML Mon May 11 09:39:53 2009 +0200
234.2 +++ b/src/Pure/ProofGeneral/ROOT.ML Mon May 11 17:20:52 2009 +0200
234.3 @@ -14,11 +14,7 @@
234.4
234.5 use "pgip_isabelle.ML";
234.6
234.7 -(use
234.8 - |> setmp Proofterm.proofs 1
234.9 - |> setmp quick_and_dirty true
234.10 - |> setmp auto_quickcheck true
234.11 - |> setmp auto_solve true) "preferences.ML";
234.12 +use "preferences.ML";
234.13
234.14 use "pgip_parser.ML";
234.15
235.1 --- a/src/Pure/ProofGeneral/preferences.ML Mon May 11 09:39:53 2009 +0200
235.2 +++ b/src/Pure/ProofGeneral/preferences.ML Mon May 11 17:20:52 2009 +0200
235.3 @@ -6,6 +6,10 @@
235.4
235.5 signature PREFERENCES =
235.6 sig
235.7 + val category_display: string
235.8 + val category_advanced_display: string
235.9 + val category_tracing: string
235.10 + val category_proof: string
235.11 type preference =
235.12 {name: string,
235.13 descr: string,
235.14 @@ -29,6 +33,14 @@
235.15 structure Preferences: PREFERENCES =
235.16 struct
235.17
235.18 +(* categories *)
235.19 +
235.20 +val category_display = "Display";
235.21 +val category_advanced_display = "Advanced Display";
235.22 +val category_tracing = "Tracing";
235.23 +val category_proof = "Proof"
235.24 +
235.25 +
235.26 (* preferences and preference tables *)
235.27
235.28 type preference =
235.29 @@ -66,11 +78,11 @@
235.30
235.31 (* preferences of Pure *)
235.32
235.33 -val proof_pref =
235.34 +val proof_pref = setmp Proofterm.proofs 1 (fn () =>
235.35 let
235.36 fun get () = PgipTypes.bool_to_pgstring (! Proofterm.proofs >= 2);
235.37 fun set s = Proofterm.proofs := (if PgipTypes.read_pgipbool s then 2 else 1);
235.38 - in mkpref get set PgipTypes.Pgipbool "full-proofs" "Record full proof objects internally" end;
235.39 + in mkpref get set PgipTypes.Pgipbool "full-proofs" "Record full proof objects internally" end) ();
235.40
235.41 val thm_depsN = "thm_deps";
235.42 val thm_deps_pref =
235.43 @@ -145,24 +157,13 @@
235.44 bool_pref Toplevel.debug
235.45 "debugging"
235.46 "Whether to enable debugging.",
235.47 - bool_pref Quickcheck.auto
235.48 - "auto-quickcheck"
235.49 - "Whether to enable quickcheck automatically.",
235.50 - nat_pref Quickcheck.auto_time_limit
235.51 - "auto-quickcheck-time-limit"
235.52 - "Time limit for automatic quickcheck (in milliseconds).",
235.53 - bool_pref AutoSolve.auto
235.54 - "auto-solve"
235.55 - "Try to solve newly declared lemmas with existing theorems.",
235.56 - nat_pref AutoSolve.auto_time_limit
235.57 - "auto-solve-time-limit"
235.58 - "Time limit for seeking automatic solutions (in milliseconds).",
235.59 thm_deps_pref];
235.60
235.61 val proof_preferences =
235.62 - [bool_pref quick_and_dirty
235.63 - "quick-and-dirty"
235.64 - "Take a few short cuts",
235.65 + [setmp quick_and_dirty true (fn () =>
235.66 + bool_pref quick_and_dirty
235.67 + "quick-and-dirty"
235.68 + "Take a few short cuts") (),
235.69 bool_pref Toplevel.skip_proofs
235.70 "skip-proofs"
235.71 "Skip over proofs (interactive-only)",
235.72 @@ -175,10 +176,10 @@
235.73 "Check proofs in parallel"];
235.74
235.75 val pure_preferences =
235.76 - [("Display", display_preferences),
235.77 - ("Advanced Display", advanced_display_preferences),
235.78 - ("Tracing", tracing_preferences),
235.79 - ("Proof", proof_preferences)];
235.80 + [(category_display, display_preferences),
235.81 + (category_advanced_display, advanced_display_preferences),
235.82 + (category_tracing, tracing_preferences),
235.83 + (category_proof, proof_preferences)];
235.84
235.85
235.86 (* table of categories and preferences; names must be unique *)
235.87 @@ -203,6 +204,6 @@
235.88 else
235.89 if exists (fn {name, ...} => name = #name pref) prefs
235.90 then (warning ("Preference already exists: " ^ quote (#name pref)); (cat, prefs))
235.91 - else (cat, pref :: prefs));
235.92 + else (cat, prefs @ [pref]));
235.93
235.94 end;
236.1 --- a/src/Pure/Tools/ROOT.ML Mon May 11 09:39:53 2009 +0200
236.2 +++ b/src/Pure/Tools/ROOT.ML Mon May 11 17:20:52 2009 +0200
236.3 @@ -1,16 +1,9 @@
236.4 -(* Title: Pure/Tools/ROOT.ML
236.5 -
236.6 -Miscellaneous tools and packages for Pure Isabelle.
236.7 -*)
236.8 +(* Miscellaneous tools and packages for Pure Isabelle *)
236.9
236.10 use "named_thms.ML";
236.11
236.12 -(*basic XML support*)
236.13 use "xml_syntax.ML";
236.14
236.15 use "find_theorems.ML";
236.16 use "find_consts.ML";
236.17
236.18 -(*quickcheck/autosolve needed here because of pg preferences*)
236.19 -use "../../Tools/quickcheck.ML";
236.20 -use "../../Tools/auto_solve.ML";
237.1 --- a/src/Pure/Tools/find_theorems.ML Mon May 11 09:39:53 2009 +0200
237.2 +++ b/src/Pure/Tools/find_theorems.ML Mon May 11 17:20:52 2009 +0200
237.3 @@ -7,7 +7,7 @@
237.4 signature FIND_THEOREMS =
237.5 sig
237.6 datatype 'term criterion =
237.7 - Name of string | Intro | Elim | Dest | Solves | Simp of 'term |
237.8 + Name of string | Intro | IntroIff | Elim | Dest | Solves | Simp of 'term |
237.9 Pattern of 'term
237.10 val tac_limit: int ref
237.11 val limit: int ref
237.12 @@ -24,11 +24,12 @@
237.13 (** search criteria **)
237.14
237.15 datatype 'term criterion =
237.16 - Name of string | Intro | Elim | Dest | Solves | Simp of 'term |
237.17 + Name of string | Intro | IntroIff | Elim | Dest | Solves | Simp of 'term |
237.18 Pattern of 'term;
237.19
237.20 fun read_criterion _ (Name name) = Name name
237.21 | read_criterion _ Intro = Intro
237.22 + | read_criterion _ IntroIff = IntroIff
237.23 | read_criterion _ Elim = Elim
237.24 | read_criterion _ Dest = Dest
237.25 | read_criterion _ Solves = Solves
237.26 @@ -42,6 +43,7 @@
237.27 (case c of
237.28 Name name => Pretty.str (prfx "name: " ^ quote name)
237.29 | Intro => Pretty.str (prfx "intro")
237.30 + | IntroIff => Pretty.str (prfx "introiff")
237.31 | Elim => Pretty.str (prfx "elim")
237.32 | Dest => Pretty.str (prfx "dest")
237.33 | Solves => Pretty.str (prfx "solves")
237.34 @@ -74,17 +76,40 @@
237.35
237.36 fun is_nontrivial thy = Term.is_Const o Term.head_of o ObjectLogic.drop_judgment thy;
237.37
237.38 +(* Note: ("op =" : "bool --> bool --> bool") does not exist in Pure. *)
237.39 +fun is_Iff c =
237.40 + (case dest_Const c of
237.41 + ("op =", ty) =>
237.42 + (ty
237.43 + |> strip_type
237.44 + |> swap
237.45 + |> (op ::)
237.46 + |> map (fst o dest_Type)
237.47 + |> forall (curry (op =) "bool")
237.48 + handle TYPE _ => false)
237.49 + | _ => false);
237.50 +
237.51 (*extract terms from term_src, refine them to the parts that concern us,
237.52 if po try match them against obj else vice versa.
237.53 trivial matches are ignored.
237.54 returns: smallest substitution size*)
237.55 -fun is_matching_thm (extract_terms, refine_term) ctxt po obj term_src =
237.56 +fun is_matching_thm doiff (extract_terms, refine_term) ctxt po obj term_src =
237.57 let
237.58 val thy = ProofContext.theory_of ctxt;
237.59
237.60 + val chkmatch = obj |> (if po then rpair else pair) #> Pattern.matches thy;
237.61 fun matches pat =
237.62 - is_nontrivial thy pat andalso
237.63 - Pattern.matches thy (if po then (pat, obj) else (obj, pat));
237.64 + let
237.65 + val jpat = ObjectLogic.drop_judgment thy pat;
237.66 + val c = Term.head_of jpat;
237.67 + val pats =
237.68 + if Term.is_Const c
237.69 + then if doiff andalso is_Iff c
237.70 + then pat :: map (ObjectLogic.ensure_propT thy) ((snd o strip_comb) jpat)
237.71 + |> filter (is_nontrivial thy)
237.72 + else [pat]
237.73 + else [];
237.74 + in filter chkmatch pats end;
237.75
237.76 fun substsize pat =
237.77 let val (_, subst) =
237.78 @@ -96,7 +121,9 @@
237.79
237.80 val match_thm = matches o refine_term;
237.81 in
237.82 - map (substsize o refine_term) (filter match_thm (extract_terms term_src))
237.83 + map match_thm (extract_terms term_src)
237.84 + |> flat
237.85 + |> map substsize
237.86 |> bestmatch
237.87 end;
237.88
237.89 @@ -117,7 +144,7 @@
237.90 hd o Logic.strip_imp_prems);
237.91 val prems = Logic.prems_of_goal goal 1;
237.92
237.93 - fun try_subst prem = is_matching_thm extract_dest ctxt true prem thm;
237.94 + fun try_subst prem = is_matching_thm false extract_dest ctxt true prem thm;
237.95 val successful = prems |> map_filter try_subst;
237.96 in
237.97 (*if possible, keep best substitution (one with smallest size)*)
237.98 @@ -127,11 +154,11 @@
237.99 then SOME (Thm.nprems_of thm - 1, foldr1 Int.min successful) else NONE
237.100 end;
237.101
237.102 -fun filter_intro ctxt goal (_, thm) =
237.103 +fun filter_intro doiff ctxt goal (_, thm) =
237.104 let
237.105 val extract_intro = (single o Thm.full_prop_of, Logic.strip_imp_concl);
237.106 val concl = Logic.concl_of_goal goal 1;
237.107 - val ss = is_matching_thm extract_intro ctxt true concl thm;
237.108 + val ss = is_matching_thm doiff extract_intro ctxt true concl thm;
237.109 in
237.110 if is_some ss then SOME (Thm.nprems_of thm, the ss) else NONE
237.111 end;
237.112 @@ -148,7 +175,7 @@
237.113 val rule_tree = combine rule_mp rule_concl;
237.114 fun goal_tree prem = combine prem goal_concl;
237.115 fun try_subst prem =
237.116 - is_matching_thm (single, I) ctxt true (goal_tree prem) rule_tree;
237.117 + is_matching_thm false (single, I) ctxt true (goal_tree prem) rule_tree;
237.118 val successful = prems |> map_filter try_subst;
237.119 in
237.120 (*elim rules always have assumptions, so an elim with one
237.121 @@ -183,7 +210,7 @@
237.122 val mksimps = Simplifier.mksimps (Simplifier.local_simpset_of ctxt);
237.123 val extract_simp =
237.124 (map Thm.full_prop_of o mksimps, #1 o Logic.dest_equals o Logic.strip_imp_concl);
237.125 - val ss = is_matching_thm extract_simp ctxt false t thm;
237.126 + val ss = is_matching_thm false extract_simp ctxt false t thm;
237.127 in
237.128 if is_some ss then SOME (Thm.nprems_of thm, the ss) else NONE
237.129 end;
237.130 @@ -233,7 +260,8 @@
237.131 | filter_crit _ NONE Elim = err_no_goal "elim"
237.132 | filter_crit _ NONE Dest = err_no_goal "dest"
237.133 | filter_crit _ NONE Solves = err_no_goal "solves"
237.134 - | filter_crit ctxt (SOME goal) Intro = apfst (filter_intro ctxt (fix_goal goal))
237.135 + | filter_crit ctxt (SOME goal) Intro = apfst (filter_intro false ctxt (fix_goal goal))
237.136 + | filter_crit ctxt (SOME goal) IntroIff = apfst (filter_intro true ctxt (fix_goal goal))
237.137 | filter_crit ctxt (SOME goal) Elim = apfst (filter_elim ctxt (fix_goal goal))
237.138 | filter_crit ctxt (SOME goal) Dest = apfst (filter_dest ctxt (fix_goal goal))
237.139 | filter_crit ctxt (SOME goal) Solves = apfst (filter_solves ctxt goal)
237.140 @@ -428,6 +456,7 @@
237.141 val criterion =
237.142 P.reserved "name" |-- P.!!! (P.$$$ ":" |-- P.xname) >> Name ||
237.143 P.reserved "intro" >> K Intro ||
237.144 + P.reserved "introiff" >> K IntroIff ||
237.145 P.reserved "elim" >> K Elim ||
237.146 P.reserved "dest" >> K Dest ||
237.147 P.reserved "solves" >> K Solves ||
238.1 --- a/src/Pure/axclass.ML Mon May 11 09:39:53 2009 +0200
238.2 +++ b/src/Pure/axclass.ML Mon May 11 17:20:52 2009 +0200
238.3 @@ -286,74 +286,6 @@
238.4 handle TYPE (msg, _, _) => error msg;
238.5
238.6
238.7 -(* primitive rules *)
238.8 -
238.9 -fun add_classrel th thy =
238.10 - let
238.11 - fun err () = raise THM ("add_classrel: malformed class relation", 0, [th]);
238.12 - val prop = Thm.plain_prop_of (Thm.transfer thy th);
238.13 - val rel = Logic.dest_classrel prop handle TERM _ => err ();
238.14 - val (c1, c2) = cert_classrel thy rel handle TYPE _ => err ();
238.15 - in
238.16 - thy
238.17 - |> Sign.primitive_classrel (c1, c2)
238.18 - |> put_classrel ((c1, c2), Thm.close_derivation (Drule.unconstrainTs th))
238.19 - |> perhaps complete_arities
238.20 - end;
238.21 -
238.22 -fun add_arity th thy =
238.23 - let
238.24 - fun err () = raise THM ("add_arity: malformed type arity", 0, [th]);
238.25 - val prop = Thm.plain_prop_of (Thm.transfer thy th);
238.26 - val (t, Ss, c) = Logic.dest_arity prop handle TERM _ => err ();
238.27 - val _ = map (Sign.certify_sort thy) Ss = Ss orelse err ();
238.28 - val _ = case filter_out (fn c => can (get_inst_param thy) (c, t)) (params_of thy c)
238.29 - of [] => ()
238.30 - | cs => Output.legacy_feature
238.31 - ("Missing specifications for overloaded parameters " ^ commas_quote cs)
238.32 - val th' = Drule.unconstrainTs th;
238.33 - in
238.34 - thy
238.35 - |> Sign.primitive_arity (t, Ss, [c])
238.36 - |> put_arity ((t, Ss, c), th')
238.37 - end;
238.38 -
238.39 -
238.40 -(* tactical proofs *)
238.41 -
238.42 -fun prove_classrel raw_rel tac thy =
238.43 - let
238.44 - val ctxt = ProofContext.init thy;
238.45 - val (c1, c2) = cert_classrel thy raw_rel;
238.46 - val th = Goal.prove ctxt [] [] (Logic.mk_classrel (c1, c2)) (K tac) handle ERROR msg =>
238.47 - cat_error msg ("The error(s) above occurred while trying to prove class relation " ^
238.48 - quote (Syntax.string_of_classrel ctxt [c1, c2]));
238.49 - in
238.50 - thy
238.51 - |> PureThy.add_thms [((Binding.name
238.52 - (prefix classrel_prefix (Logic.name_classrel (c1, c2))), th), [])]
238.53 - |-> (fn [th'] => add_classrel th')
238.54 - end;
238.55 -
238.56 -fun prove_arity raw_arity tac thy =
238.57 - let
238.58 - val ctxt = ProofContext.init thy;
238.59 - val arity = Sign.cert_arity thy raw_arity;
238.60 - val names = map (prefix arity_prefix) (Logic.name_arities arity);
238.61 - val props = Logic.mk_arities arity;
238.62 - val ths = Goal.prove_multi ctxt [] [] props
238.63 - (fn _ => Goal.precise_conjunction_tac (length props) 1 THEN tac) handle ERROR msg =>
238.64 - cat_error msg ("The error(s) above occurred while trying to prove type arity " ^
238.65 - quote (Syntax.string_of_arity ctxt arity));
238.66 - in
238.67 - thy
238.68 - |> PureThy.add_thms (map (rpair []) (map Binding.name names ~~ ths))
238.69 - |-> fold add_arity
238.70 - end;
238.71 -
238.72 -
238.73 -(* instance parameters and overloaded definitions *)
238.74 -
238.75 (* declaration and definition of instances of overloaded constants *)
238.76
238.77 fun declare_overloaded (c, T) thy =
238.78 @@ -398,6 +330,74 @@
238.79 end;
238.80
238.81
238.82 +(* primitive rules *)
238.83 +
238.84 +fun add_classrel th thy =
238.85 + let
238.86 + fun err () = raise THM ("add_classrel: malformed class relation", 0, [th]);
238.87 + val prop = Thm.plain_prop_of (Thm.transfer thy th);
238.88 + val rel = Logic.dest_classrel prop handle TERM _ => err ();
238.89 + val (c1, c2) = cert_classrel thy rel handle TYPE _ => err ();
238.90 + in
238.91 + thy
238.92 + |> Sign.primitive_classrel (c1, c2)
238.93 + |> put_classrel ((c1, c2), Thm.close_derivation (Drule.unconstrainTs th))
238.94 + |> perhaps complete_arities
238.95 + end;
238.96 +
238.97 +fun add_arity th thy =
238.98 + let
238.99 + fun err () = raise THM ("add_arity: malformed type arity", 0, [th]);
238.100 + val prop = Thm.plain_prop_of (Thm.transfer thy th);
238.101 + val (t, Ss, c) = Logic.dest_arity prop handle TERM _ => err ();
238.102 + val T = Type (t, map TFree (Name.names Name.context Name.aT Ss));
238.103 + val missing_params = Sign.complete_sort thy [c]
238.104 + |> maps (these o Option.map #params o try (get_info thy))
238.105 + |> filter_out (fn (const, _) => can (get_inst_param thy) (const, t))
238.106 + |> (map o apsnd o map_atyps) (K T);
238.107 + val _ = map (Sign.certify_sort thy) Ss = Ss orelse err ();
238.108 + val th' = Drule.unconstrainTs th;
238.109 + in
238.110 + thy
238.111 + |> fold (snd oo declare_overloaded) missing_params
238.112 + |> Sign.primitive_arity (t, Ss, [c])
238.113 + |> put_arity ((t, Ss, c), th')
238.114 + end;
238.115 +
238.116 +
238.117 +(* tactical proofs *)
238.118 +
238.119 +fun prove_classrel raw_rel tac thy =
238.120 + let
238.121 + val ctxt = ProofContext.init thy;
238.122 + val (c1, c2) = cert_classrel thy raw_rel;
238.123 + val th = Goal.prove ctxt [] [] (Logic.mk_classrel (c1, c2)) (K tac) handle ERROR msg =>
238.124 + cat_error msg ("The error(s) above occurred while trying to prove class relation " ^
238.125 + quote (Syntax.string_of_classrel ctxt [c1, c2]));
238.126 + in
238.127 + thy
238.128 + |> PureThy.add_thms [((Binding.name
238.129 + (prefix classrel_prefix (Logic.name_classrel (c1, c2))), th), [])]
238.130 + |-> (fn [th'] => add_classrel th')
238.131 + end;
238.132 +
238.133 +fun prove_arity raw_arity tac thy =
238.134 + let
238.135 + val ctxt = ProofContext.init thy;
238.136 + val arity = Sign.cert_arity thy raw_arity;
238.137 + val names = map (prefix arity_prefix) (Logic.name_arities arity);
238.138 + val props = Logic.mk_arities arity;
238.139 + val ths = Goal.prove_multi ctxt [] [] props
238.140 + (fn _ => Goal.precise_conjunction_tac (length props) 1 THEN tac) handle ERROR msg =>
238.141 + cat_error msg ("The error(s) above occurred while trying to prove type arity " ^
238.142 + quote (Syntax.string_of_arity ctxt arity));
238.143 + in
238.144 + thy
238.145 + |> PureThy.add_thms (map (rpair []) (map Binding.name names ~~ ths))
238.146 + |-> fold add_arity
238.147 + end;
238.148 +
238.149 +
238.150
238.151 (** class definitions **)
238.152
239.1 --- a/src/Pure/name.ML Mon May 11 09:39:53 2009 +0200
239.2 +++ b/src/Pure/name.ML Mon May 11 17:20:52 2009 +0200
239.3 @@ -28,6 +28,7 @@
239.4 val variants: string list -> context -> string list * context
239.5 val variant_list: string list -> string list -> string list
239.6 val variant: string list -> string -> string
239.7 + val desymbolize: bool -> string -> string
239.8 end;
239.9
239.10 structure Name: NAME =
239.11 @@ -144,4 +145,31 @@
239.12 fun variant_list used names = #1 (make_context used |> variants names);
239.13 fun variant used = singleton (variant_list used);
239.14
239.15 +
239.16 +(* names conforming to typical requirements of identifiers in the world outside *)
239.17 +
239.18 +fun desymbolize upper "" = if upper then "X" else "x"
239.19 + | desymbolize upper s =
239.20 + let
239.21 + val xs as (x :: _) = Symbol.explode s;
239.22 + val ys = if Symbol.is_ascii_letter x orelse Symbol.is_symbolic x then xs
239.23 + else "x" :: xs;
239.24 + fun is_valid x =
239.25 + Symbol.is_ascii_letter x orelse Symbol.is_ascii_digit x orelse x = "'";
239.26 + fun sep [] = []
239.27 + | sep (xs as "_" :: _) = xs
239.28 + | sep xs = "_" :: xs;
239.29 + fun desep ("_" :: xs) = xs
239.30 + | desep xs = xs;
239.31 + fun desymb x xs = if is_valid x
239.32 + then x :: xs
239.33 + else if Symbol.is_symbolic x
239.34 + then "_" :: explode (Symbol.name_of x) @ sep xs
239.35 + else
239.36 + sep xs
239.37 + fun upper_lower cs = if upper then nth_map 0 Symbol.to_ascii_upper cs
239.38 + else (if forall Symbol.is_ascii_upper cs
239.39 + then map else nth_map 0) Symbol.to_ascii_lower cs;
239.40 + in fold_rev desymb ys [] |> desep |> upper_lower |> implode end;
239.41 +
239.42 end;
240.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
240.2 +++ b/src/Tools/Code_Generator.thy Mon May 11 17:20:52 2009 +0200
240.3 @@ -0,0 +1,27 @@
240.4 +(* Title: Tools/Code_Generator.thy
240.5 + Author: Florian Haftmann, TU Muenchen
240.6 +*)
240.7 +
240.8 +header {* Loading the code generator modules *}
240.9 +
240.10 +theory Code_Generator
240.11 +imports Pure
240.12 +uses
240.13 + "~~/src/Tools/value.ML"
240.14 + "~~/src/Tools/quickcheck.ML"
240.15 + "~~/src/Tools/code/code_wellsorted.ML"
240.16 + "~~/src/Tools/code/code_thingol.ML"
240.17 + "~~/src/Tools/code/code_printer.ML"
240.18 + "~~/src/Tools/code/code_target.ML"
240.19 + "~~/src/Tools/code/code_ml.ML"
240.20 + "~~/src/Tools/code/code_haskell.ML"
240.21 + "~~/src/Tools/nbe.ML"
240.22 +begin
240.23 +
240.24 +setup {*
240.25 + Code_ML.setup
240.26 + #> Code_Haskell.setup
240.27 + #> Nbe.setup
240.28 +*}
240.29 +
240.30 +end
240.31 \ No newline at end of file
241.1 --- a/src/Tools/auto_solve.ML Mon May 11 09:39:53 2009 +0200
241.2 +++ b/src/Tools/auto_solve.ML Mon May 11 17:20:52 2009 +0200
241.3 @@ -14,18 +14,34 @@
241.4 val auto : bool ref
241.5 val auto_time_limit : int ref
241.6 val limit : int ref
241.7 -
241.8 - val seek_solution : bool -> Proof.state -> Proof.state
241.9 end;
241.10
241.11 structure AutoSolve : AUTO_SOLVE =
241.12 struct
241.13
241.14 +(* preferences *)
241.15 +
241.16 val auto = ref false;
241.17 val auto_time_limit = ref 2500;
241.18 val limit = ref 5;
241.19
241.20 -fun seek_solution int state =
241.21 +val _ =
241.22 + ProofGeneralPgip.add_preference Preferences.category_tracing
241.23 + (setmp auto true (fn () =>
241.24 + Preferences.bool_pref auto
241.25 + "auto-solve"
241.26 + "Try to solve newly declared lemmas with existing theorems.") ());
241.27 +
241.28 +val _ =
241.29 + ProofGeneralPgip.add_preference Preferences.category_tracing
241.30 + (Preferences.nat_pref auto_time_limit
241.31 + "auto-solve-time-limit"
241.32 + "Time limit for seeking automatic solutions (in milliseconds).");
241.33 +
241.34 +
241.35 +(* hook *)
241.36 +
241.37 +val _ = Context.>> (Specification.add_theorem_hook (fn int => fn state =>
241.38 let
241.39 val ctxt = Proof.context_of state;
241.40
241.41 @@ -76,12 +92,10 @@
241.42 if int andalso ! auto andalso not (! Toplevel.quiet)
241.43 then go ()
241.44 else state
241.45 - end;
241.46 + end));
241.47
241.48 end;
241.49
241.50 -val _ = Context.>> (Specification.add_theorem_hook AutoSolve.seek_solution);
241.51 -
241.52 val auto_solve = AutoSolve.auto;
241.53 val auto_solve_time_limit = AutoSolve.auto_time_limit;
241.54
242.1 --- a/src/Tools/code/code_funcgr.ML Mon May 11 09:39:53 2009 +0200
242.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
242.3 @@ -1,335 +0,0 @@
242.4 -(* Title: Tools/code/code_funcgr.ML
242.5 - Author: Florian Haftmann, TU Muenchen
242.6 -
242.7 -Retrieving, normalizing and structuring code equations in graph
242.8 -with explicit dependencies.
242.9 -
242.10 -Legacy. To be replaced by Tools/code/code_wellsorted.ML
242.11 -*)
242.12 -
242.13 -signature CODE_WELLSORTED =
242.14 -sig
242.15 - type T
242.16 - val eqns: T -> string -> (thm * bool) list
242.17 - val typ: T -> string -> (string * sort) list * typ
242.18 - val all: T -> string list
242.19 - val pretty: theory -> T -> Pretty.T
242.20 - val make: theory -> string list
242.21 - -> ((sort -> sort) * Sorts.algebra) * T
242.22 - val eval_conv: theory
242.23 - -> (term -> term * (((sort -> sort) * Sorts.algebra) -> T -> thm)) -> cterm -> thm
242.24 - val eval_term: theory
242.25 - -> (term -> term * (((sort -> sort) * Sorts.algebra) -> T -> 'a)) -> term -> 'a
242.26 - val timing: bool ref
242.27 -end
242.28 -
242.29 -structure Code_Wellsorted : CODE_WELLSORTED =
242.30 -struct
242.31 -
242.32 -(** the graph type **)
242.33 -
242.34 -type T = (((string * sort) list * typ) * (thm * bool) list) Graph.T;
242.35 -
242.36 -fun eqns funcgr =
242.37 - these o Option.map snd o try (Graph.get_node funcgr);
242.38 -
242.39 -fun typ funcgr =
242.40 - fst o Graph.get_node funcgr;
242.41 -
242.42 -fun all funcgr = Graph.keys funcgr;
242.43 -
242.44 -fun pretty thy funcgr =
242.45 - AList.make (snd o Graph.get_node funcgr) (Graph.keys funcgr)
242.46 - |> (map o apfst) (Code_Unit.string_of_const thy)
242.47 - |> sort (string_ord o pairself fst)
242.48 - |> map (fn (s, thms) =>
242.49 - (Pretty.block o Pretty.fbreaks) (
242.50 - Pretty.str s
242.51 - :: map (Display.pretty_thm o fst) thms
242.52 - ))
242.53 - |> Pretty.chunks;
242.54 -
242.55 -
242.56 -(** generic combinators **)
242.57 -
242.58 -fun fold_consts f thms =
242.59 - thms
242.60 - |> maps (op :: o swap o apfst (snd o strip_comb) o Logic.dest_equals o Thm.plain_prop_of)
242.61 - |> (fold o fold_aterms) (fn Const c => f c | _ => I);
242.62 -
242.63 -fun consts_of (const, []) = []
242.64 - | consts_of (const, thms as _ :: _) =
242.65 - let
242.66 - fun the_const (c, _) = if c = const then I else insert (op =) c
242.67 - in fold_consts the_const (map fst thms) [] end;
242.68 -
242.69 -fun insts_of thy algebra tys sorts =
242.70 - let
242.71 - fun class_relation (x, _) _ = x;
242.72 - fun type_constructor tyco xs class =
242.73 - (tyco, class) :: (maps o maps) fst xs;
242.74 - fun type_variable (TVar (_, sort)) = map (pair []) sort
242.75 - | type_variable (TFree (_, sort)) = map (pair []) sort;
242.76 - fun of_sort_deriv ty sort =
242.77 - Sorts.of_sort_derivation (Syntax.pp_global thy) algebra
242.78 - { class_relation = class_relation, type_constructor = type_constructor,
242.79 - type_variable = type_variable }
242.80 - (ty, sort) handle Sorts.CLASS_ERROR _ => [] (*permissive!*)
242.81 - in (flat o flat) (map2 of_sort_deriv tys sorts) end;
242.82 -
242.83 -fun meets_of thy algebra =
242.84 - let
242.85 - fun meet_of ty sort tab =
242.86 - Sorts.meet_sort algebra (ty, sort) tab
242.87 - handle Sorts.CLASS_ERROR _ => tab (*permissive!*);
242.88 - in fold2 meet_of end;
242.89 -
242.90 -
242.91 -(** graph algorithm **)
242.92 -
242.93 -val timing = ref false;
242.94 -
242.95 -local
242.96 -
242.97 -fun resort_thms thy algebra typ_of thms =
242.98 - let
242.99 - val cs = fold_consts (insert (op =)) thms [];
242.100 - fun meets (c, ty) = case typ_of c
242.101 - of SOME (vs, _) =>
242.102 - meets_of thy algebra (Sign.const_typargs thy (c, ty)) (map snd vs)
242.103 - | NONE => I;
242.104 - val tab = fold meets cs Vartab.empty;
242.105 - in map (Code_Unit.inst_thm thy tab) thms end;
242.106 -
242.107 -fun resort_eqnss thy algebra funcgr =
242.108 - let
242.109 - val typ_funcgr = try (fst o Graph.get_node funcgr);
242.110 - val resort_dep = (apsnd o burrow_fst) (resort_thms thy algebra typ_funcgr);
242.111 - fun resort_rec typ_of (c, []) = (true, (c, []))
242.112 - | resort_rec typ_of (c, thms as (thm, _) :: _) = if is_some (AxClass.inst_of_param thy c)
242.113 - then (true, (c, thms))
242.114 - else let
242.115 - val (_, (vs, ty)) = Code_Unit.head_eqn thy thm;
242.116 - val thms' as (thm', _) :: _ = burrow_fst (resort_thms thy algebra typ_of) thms
242.117 - val (_, (vs', ty')) = Code_Unit.head_eqn thy thm'; (*FIXME simplify check*)
242.118 - in (Sign.typ_equiv thy (ty, ty'), (c, thms')) end;
242.119 - fun resort_recs eqnss =
242.120 - let
242.121 - fun typ_of c = case these (AList.lookup (op =) eqnss c)
242.122 - of (thm, _) :: _ => (SOME o snd o Code_Unit.head_eqn thy) thm
242.123 - | [] => NONE;
242.124 - val (unchangeds, eqnss') = split_list (map (resort_rec typ_of) eqnss);
242.125 - val unchanged = fold (fn x => fn y => x andalso y) unchangeds true;
242.126 - in (unchanged, eqnss') end;
242.127 - fun resort_rec_until eqnss =
242.128 - let
242.129 - val (unchanged, eqnss') = resort_recs eqnss;
242.130 - in if unchanged then eqnss' else resort_rec_until eqnss' end;
242.131 - in map resort_dep #> resort_rec_until end;
242.132 -
242.133 -fun instances_of thy algebra insts =
242.134 - let
242.135 - val thy_classes = (#classes o Sorts.rep_algebra o Sign.classes_of) thy;
242.136 - fun all_classparams tyco class =
242.137 - these (try (#params o AxClass.get_info thy) class)
242.138 - |> map_filter (fn (c, _) => try (AxClass.param_of_inst thy) (c, tyco))
242.139 - in
242.140 - Symtab.empty
242.141 - |> fold (fn (tyco, class) =>
242.142 - Symtab.map_default (tyco, []) (insert (op =) class)) insts
242.143 - |> (fn tab => Symtab.fold (fn (tyco, classes) => append (maps (all_classparams tyco)
242.144 - (Graph.all_succs thy_classes classes))) tab [])
242.145 - end;
242.146 -
242.147 -fun instances_of_consts thy algebra funcgr consts =
242.148 - let
242.149 - fun inst (cexpr as (c, ty)) = insts_of thy algebra
242.150 - (Sign.const_typargs thy (c, ty)) ((map snd o fst) (typ funcgr c));
242.151 - in
242.152 - []
242.153 - |> fold (fold (insert (op =)) o inst) consts
242.154 - |> instances_of thy algebra
242.155 - end;
242.156 -
242.157 -fun ensure_const' thy algebra funcgr const auxgr =
242.158 - if can (Graph.get_node funcgr) const
242.159 - then (NONE, auxgr)
242.160 - else if can (Graph.get_node auxgr) const
242.161 - then (SOME const, auxgr)
242.162 - else if is_some (Code.get_datatype_of_constr thy const) then
242.163 - auxgr
242.164 - |> Graph.new_node (const, [])
242.165 - |> pair (SOME const)
242.166 - else let
242.167 - val thms = Code.these_eqns thy const
242.168 - |> burrow_fst (Code_Unit.norm_args thy)
242.169 - |> burrow_fst (Code_Unit.norm_varnames thy Code_Name.purify_tvar Code_Name.purify_var);
242.170 - val rhs = consts_of (const, thms);
242.171 - in
242.172 - auxgr
242.173 - |> Graph.new_node (const, thms)
242.174 - |> fold_map (ensure_const thy algebra funcgr) rhs
242.175 - |-> (fn rhs' => fold (fn SOME const' => Graph.add_edge (const, const')
242.176 - | NONE => I) rhs')
242.177 - |> pair (SOME const)
242.178 - end
242.179 -and ensure_const thy algebra funcgr const =
242.180 - let
242.181 - val timeap = if !timing
242.182 - then Output.timeap_msg ("time for " ^ Code_Unit.string_of_const thy const)
242.183 - else I;
242.184 - in timeap (ensure_const' thy algebra funcgr const) end;
242.185 -
242.186 -fun merge_eqnss thy algebra raw_eqnss funcgr =
242.187 - let
242.188 - val eqnss = raw_eqnss
242.189 - |> resort_eqnss thy algebra funcgr
242.190 - |> filter_out (can (Graph.get_node funcgr) o fst);
242.191 - fun typ_eqn c [] = Code.default_typscheme thy c
242.192 - | typ_eqn c (thms as (thm, _) :: _) = (snd o Code_Unit.head_eqn thy) thm;
242.193 - fun add_eqns (const, thms) =
242.194 - Graph.new_node (const, (typ_eqn const thms, thms));
242.195 - fun add_deps (eqns as (const, thms)) funcgr =
242.196 - let
242.197 - val deps = consts_of eqns;
242.198 - val insts = instances_of_consts thy algebra funcgr
242.199 - (fold_consts (insert (op =)) (map fst thms) []);
242.200 - in
242.201 - funcgr
242.202 - |> ensure_consts thy algebra insts
242.203 - |> fold (curry Graph.add_edge const) deps
242.204 - |> fold (curry Graph.add_edge const) insts
242.205 - end;
242.206 - in
242.207 - funcgr
242.208 - |> fold add_eqns eqnss
242.209 - |> fold add_deps eqnss
242.210 - end
242.211 -and ensure_consts thy algebra cs funcgr =
242.212 - let
242.213 - val auxgr = Graph.empty
242.214 - |> fold (snd oo ensure_const thy algebra funcgr) cs;
242.215 - in
242.216 - funcgr
242.217 - |> fold (merge_eqnss thy algebra)
242.218 - (map (AList.make (Graph.get_node auxgr))
242.219 - (rev (Graph.strong_conn auxgr)))
242.220 - end;
242.221 -
242.222 -in
242.223 -
242.224 -(** retrieval interfaces **)
242.225 -
242.226 -val ensure_consts = ensure_consts;
242.227 -
242.228 -fun proto_eval thy cterm_of evaluator_lift evaluator proto_ct funcgr =
242.229 - let
242.230 - val ct = cterm_of proto_ct;
242.231 - val _ = Sign.no_vars (Syntax.pp_global thy) (Thm.term_of ct);
242.232 - val _ = Term.fold_types (Type.no_tvars #> K I) (Thm.term_of ct) ();
242.233 - fun consts_of t =
242.234 - fold_aterms (fn Const c_ty => cons c_ty | _ => I) t [];
242.235 - val algebra = Code.coregular_algebra thy;
242.236 - val thm = Code.preprocess_conv thy ct;
242.237 - val ct' = Thm.rhs_of thm;
242.238 - val t' = Thm.term_of ct';
242.239 - val consts = map fst (consts_of t');
242.240 - val funcgr' = ensure_consts thy algebra consts funcgr;
242.241 - val (t'', evaluator_funcgr) = evaluator t';
242.242 - val consts' = consts_of t'';
242.243 - val dicts = instances_of_consts thy algebra funcgr' consts';
242.244 - val funcgr'' = ensure_consts thy algebra dicts funcgr';
242.245 - in (evaluator_lift (evaluator_funcgr (Code.operational_algebra thy)) thm funcgr'', funcgr'') end;
242.246 -
242.247 -fun proto_eval_conv thy =
242.248 - let
242.249 - fun evaluator_lift evaluator thm1 funcgr =
242.250 - let
242.251 - val thm2 = evaluator funcgr;
242.252 - val thm3 = Code.postprocess_conv thy (Thm.rhs_of thm2);
242.253 - in
242.254 - Thm.transitive thm1 (Thm.transitive thm2 thm3) handle THM _ =>
242.255 - error ("could not construct evaluation proof:\n"
242.256 - ^ (cat_lines o map Display.string_of_thm) [thm1, thm2, thm3])
242.257 - end;
242.258 - in proto_eval thy I evaluator_lift end;
242.259 -
242.260 -fun proto_eval_term thy =
242.261 - let
242.262 - fun evaluator_lift evaluator _ funcgr = evaluator funcgr;
242.263 - in proto_eval thy (Thm.cterm_of thy) evaluator_lift end;
242.264 -
242.265 -end; (*local*)
242.266 -
242.267 -structure Funcgr = CodeDataFun
242.268 -(
242.269 - type T = T;
242.270 - val empty = Graph.empty;
242.271 - fun purge _ cs funcgr =
242.272 - Graph.del_nodes ((Graph.all_preds funcgr
242.273 - o filter (can (Graph.get_node funcgr))) cs) funcgr;
242.274 -);
242.275 -
242.276 -fun make thy =
242.277 - pair (Code.operational_algebra thy)
242.278 - o Funcgr.change thy o ensure_consts thy (Code.coregular_algebra thy);
242.279 -
242.280 -fun eval_conv thy f =
242.281 - fst o Funcgr.change_yield thy o proto_eval_conv thy f;
242.282 -
242.283 -fun eval_term thy f =
242.284 - fst o Funcgr.change_yield thy o proto_eval_term thy f;
242.285 -
242.286 -
242.287 -(** diagnostic commands **)
242.288 -
242.289 -fun code_depgr thy consts =
242.290 - let
242.291 - val (_, gr) = make thy consts;
242.292 - val select = Graph.all_succs gr consts;
242.293 - in
242.294 - gr
242.295 - |> not (null consts) ? Graph.subgraph (member (op =) select)
242.296 - |> Graph.map_nodes ((apsnd o map o apfst) (AxClass.overload thy))
242.297 - end;
242.298 -
242.299 -fun code_thms thy = Pretty.writeln o pretty thy o code_depgr thy;
242.300 -
242.301 -fun code_deps thy consts =
242.302 - let
242.303 - val gr = code_depgr thy consts;
242.304 - fun mk_entry (const, (_, (_, parents))) =
242.305 - let
242.306 - val name = Code_Unit.string_of_const thy const;
242.307 - val nameparents = map (Code_Unit.string_of_const thy) parents;
242.308 - in { name = name, ID = name, dir = "", unfold = true,
242.309 - path = "", parents = nameparents }
242.310 - end;
242.311 - val prgr = Graph.fold ((fn x => fn xs => xs @ [x]) o mk_entry) gr [];
242.312 - in Present.display_graph prgr end;
242.313 -
242.314 -local
242.315 -
242.316 -structure P = OuterParse
242.317 -and K = OuterKeyword
242.318 -
242.319 -fun code_thms_cmd thy = code_thms thy o op @ o Code_Name.read_const_exprs thy;
242.320 -fun code_deps_cmd thy = code_deps thy o op @ o Code_Name.read_const_exprs thy;
242.321 -
242.322 -in
242.323 -
242.324 -val _ =
242.325 - OuterSyntax.improper_command "code_thms" "print system of code equations for code" OuterKeyword.diag
242.326 - (Scan.repeat P.term_group
242.327 - >> (fn cs => Toplevel.no_timing o Toplevel.unknown_theory
242.328 - o Toplevel.keep ((fn thy => code_thms_cmd thy cs) o Toplevel.theory_of)));
242.329 -
242.330 -val _ =
242.331 - OuterSyntax.improper_command "code_deps" "visualize dependencies of code equations for code" OuterKeyword.diag
242.332 - (Scan.repeat P.term_group
242.333 - >> (fn cs => Toplevel.no_timing o Toplevel.unknown_theory
242.334 - o Toplevel.keep ((fn thy => code_deps_cmd thy cs) o Toplevel.theory_of)));
242.335 -
242.336 -end;
242.337 -
242.338 -end; (*struct*)
243.1 --- a/src/Tools/code/code_haskell.ML Mon May 11 09:39:53 2009 +0200
243.2 +++ b/src/Tools/code/code_haskell.ML Mon May 11 17:20:52 2009 +0200
243.3 @@ -31,7 +31,7 @@
243.4 | pr_bind ((SOME v, SOME p), _) = brackets [str v, str "@", p];
243.5 in gen_pr_bind pr_bind pr_term end;
243.6
243.7 -fun pr_haskell_stmt naming labelled_name syntax_class syntax_tyco syntax_const
243.8 +fun pr_haskell_stmt labelled_name syntax_class syntax_tyco syntax_const
243.9 init_syms deresolve is_cons contr_classparam_typs deriving_show =
243.10 let
243.11 val deresolve_base = Long_Name.base_name o deresolve;
243.12 @@ -96,7 +96,7 @@
243.13 (str o deresolve) c :: map2 pr_term_anno ts_fingerprint (curry Library.take (length ts) tys)
243.14 else (str o deresolve) c :: map (pr_term tyvars thm vars BR) ts
243.15 end
243.16 - and pr_app tyvars = gen_pr_app (pr_app' tyvars) (pr_term tyvars) syntax_const naming
243.17 + and pr_app tyvars = gen_pr_app (pr_app' tyvars) (pr_term tyvars) syntax_const
243.18 and pr_bind tyvars = pr_haskell_bind (pr_term tyvars)
243.19 and pr_case tyvars thm vars fxy (cases as ((_, [_]), _)) =
243.20 let
243.21 @@ -261,7 +261,7 @@
243.22 val vars = init_syms
243.23 |> Code_Printer.intro_vars (the_list const)
243.24 |> Code_Printer.intro_vars vs;
243.25 - val lhs = IConst (classparam, ([], tys)) `$$ map IVar vs;
243.26 + val lhs = IConst (classparam, (([], []), tys)) `$$ map IVar vs;
243.27 (*dictionaries are not relevant at this late stage*)
243.28 in
243.29 semicolon [
243.30 @@ -336,7 +336,7 @@
243.31
243.32 fun serialize_haskell module_prefix raw_module_name string_classes labelled_name
243.33 raw_reserved_names includes raw_module_alias
243.34 - syntax_class syntax_tyco syntax_const naming program cs destination =
243.35 + syntax_class syntax_tyco syntax_const program cs destination =
243.36 let
243.37 val stmt_names = Code_Target.stmt_names_of_destination destination;
243.38 val module_name = if null stmt_names then raw_module_name else SOME "Code";
243.39 @@ -358,7 +358,7 @@
243.40 | deriv' _ (ITyVar _) = true
243.41 in deriv [] tyco end;
243.42 val reserved_names = Code_Printer.make_vars reserved_names;
243.43 - fun pr_stmt qualified = pr_haskell_stmt naming labelled_name
243.44 + fun pr_stmt qualified = pr_haskell_stmt labelled_name
243.45 syntax_class syntax_tyco syntax_const reserved_names
243.46 (if qualified then deresolver else Long_Name.base_name o deresolver)
243.47 is_cons contr_classparam_typs
243.48 @@ -469,14 +469,14 @@
243.49 | pr_monad pr_bind pr (SOME (bind, false), t) vars = vars
243.50 |> pr_bind NOBR bind
243.51 |>> (fn p => semicolon [str "let", p, str "=", pr vars NOBR t]);
243.52 - fun pretty pr naming thm vars fxy [(t1, _), (t2, _)] = case dest_bind t1 t2
243.53 + fun pretty _ [c_bind'] pr thm vars fxy [(t1, _), (t2, _)] = case dest_bind t1 t2
243.54 of SOME (bind, t') => let
243.55 - val (binds, t'') = implode_monad ((the o Code_Thingol.lookup_const naming) c_bind) t'
243.56 + val (binds, t'') = implode_monad c_bind' t'
243.57 val (ps, vars') = fold_map (pr_monad (pr_haskell_bind (K pr) thm) pr) (bind :: binds) vars;
243.58 in (brackify fxy o single o Pretty.enclose "do {" "}" o Pretty.breaks) (ps @| pr vars' NOBR t'') end
243.59 | NONE => brackify_infix (1, L) fxy
243.60 [pr vars (INFX (1, L)) t1, str ">>=", pr vars (INFX (1, X)) t2]
243.61 - in (2, pretty) end;
243.62 + in (2, ([c_bind], pretty)) end;
243.63
243.64 fun add_monad target' raw_c_bind thy =
243.65 let
244.1 --- a/src/Tools/code/code_ml.ML Mon May 11 09:39:53 2009 +0200
244.2 +++ b/src/Tools/code/code_ml.ML Mon May 11 17:20:52 2009 +0200
244.3 @@ -6,8 +6,9 @@
244.4
244.5 signature CODE_ML =
244.6 sig
244.7 - val eval_term: string * (unit -> 'a) option ref
244.8 - -> theory -> term -> string list -> 'a
244.9 + val eval: string option -> string * (unit -> 'a) option ref
244.10 + -> ((term -> term) -> 'a -> 'a) -> theory -> term -> string list -> 'a
244.11 + val target_Eval: string
244.12 val setup: theory -> theory
244.13 end;
244.14
244.15 @@ -22,6 +23,7 @@
244.16
244.17 val target_SML = "SML";
244.18 val target_OCaml = "OCaml";
244.19 +val target_Eval = "Eval";
244.20
244.21 datatype ml_stmt =
244.22 MLExc of string * int
244.23 @@ -43,7 +45,7 @@
244.24
244.25 (** SML serailizer **)
244.26
244.27 -fun pr_sml_stmt naming labelled_name syntax_tyco syntax_const reserved_names deresolve is_cons =
244.28 +fun pr_sml_stmt labelled_name syntax_tyco syntax_const reserved_names deresolve is_cons =
244.29 let
244.30 val pr_label_classrel = translate_string (fn "." => "__" | c => c)
244.31 o Long_Name.qualifier;
244.32 @@ -107,7 +109,7 @@
244.33 then pr_case is_closure thm vars fxy cases
244.34 else pr_app is_closure thm vars fxy c_ts
244.35 | NONE => pr_case is_closure thm vars fxy cases)
244.36 - and pr_app' is_closure thm vars (app as ((c, (iss, tys)), ts)) =
244.37 + and pr_app' is_closure thm vars (app as ((c, ((_, iss), tys)), ts)) =
244.38 if is_cons c then
244.39 let
244.40 val k = length tys
244.41 @@ -122,7 +124,7 @@
244.42 (str o deresolve) c
244.43 :: (map (pr_dicts BR) o filter_out null) iss @ map (pr_term is_closure thm vars BR) ts
244.44 and pr_app is_closure thm vars = gen_pr_app (pr_app' is_closure) (pr_term is_closure)
244.45 - syntax_const naming thm vars
244.46 + syntax_const thm vars
244.47 and pr_bind' ((NONE, NONE), _) = str "_"
244.48 | pr_bind' ((SOME v, NONE), _) = str v
244.49 | pr_bind' ((NONE, SOME p), _) = p
244.50 @@ -358,7 +360,7 @@
244.51
244.52 (** OCaml serializer **)
244.53
244.54 -fun pr_ocaml_stmt naming labelled_name syntax_tyco syntax_const reserved_names deresolve is_cons =
244.55 +fun pr_ocaml_stmt labelled_name syntax_tyco syntax_const reserved_names deresolve is_cons =
244.56 let
244.57 fun pr_dicts fxy ds =
244.58 let
244.59 @@ -412,7 +414,7 @@
244.60 then pr_case is_closure thm vars fxy cases
244.61 else pr_app is_closure thm vars fxy c_ts
244.62 | NONE => pr_case is_closure thm vars fxy cases)
244.63 - and pr_app' is_closure thm vars (app as ((c, (iss, tys)), ts)) =
244.64 + and pr_app' is_closure thm vars (app as ((c, ((_, iss), tys)), ts)) =
244.65 if is_cons c then
244.66 if length tys = length ts
244.67 then case ts
244.68 @@ -426,7 +428,7 @@
244.69 else (str o deresolve) c
244.70 :: ((map (pr_dicts BR) o filter_out null) iss @ map (pr_term is_closure thm vars BR) ts)
244.71 and pr_app is_closure = gen_pr_app (pr_app' is_closure) (pr_term is_closure)
244.72 - syntax_const naming
244.73 + syntax_const
244.74 and pr_bind' ((NONE, NONE), _) = str "_"
244.75 | pr_bind' ((SOME v, NONE), _) = str v
244.76 | pr_bind' ((NONE, SOME p), _) = p
244.77 @@ -907,36 +909,38 @@
244.78 in (deresolver, nodes) end;
244.79
244.80 fun serialize_ml target compile pr_module pr_stmt raw_module_name labelled_name reserved_names includes raw_module_alias
244.81 - _ syntax_tyco syntax_const naming program cs destination =
244.82 + _ syntax_tyco syntax_const program stmt_names destination =
244.83 let
244.84 val is_cons = Code_Thingol.is_cons program;
244.85 - val stmt_names = Code_Target.stmt_names_of_destination destination;
244.86 - val module_name = if null stmt_names then raw_module_name else SOME "Code";
244.87 + val present_stmt_names = Code_Target.stmt_names_of_destination destination;
244.88 + val is_present = not (null present_stmt_names);
244.89 + val module_name = if is_present then SOME "Code" else raw_module_name;
244.90 val (deresolver, nodes) = ml_node_of_program labelled_name module_name
244.91 reserved_names raw_module_alias program;
244.92 val reserved_names = Code_Printer.make_vars reserved_names;
244.93 fun pr_node prefix (Dummy _) =
244.94 NONE
244.95 - | pr_node prefix (Stmt (_, stmt)) = if null stmt_names orelse
244.96 - (not o null o filter (member (op =) stmt_names) o stmt_names_of) stmt then SOME
244.97 - (pr_stmt naming labelled_name syntax_tyco syntax_const reserved_names
244.98 + | pr_node prefix (Stmt (_, stmt)) = if is_present andalso
244.99 + (null o filter (member (op =) present_stmt_names) o stmt_names_of) stmt
244.100 + then NONE
244.101 + else SOME
244.102 + (pr_stmt labelled_name syntax_tyco syntax_const reserved_names
244.103 (deresolver prefix) is_cons stmt)
244.104 - else NONE
244.105 | pr_node prefix (Module (module_name, (_, nodes))) =
244.106 separate (str "")
244.107 ((map_filter (pr_node (prefix @ [module_name]) o Graph.get_node nodes)
244.108 o rev o flat o Graph.strong_conn) nodes)
244.109 - |> (if null stmt_names then pr_module module_name else Pretty.chunks)
244.110 + |> (if is_present then Pretty.chunks else pr_module module_name)
244.111 |> SOME;
244.112 - val cs' = (map o try)
244.113 - (deresolver (if is_some module_name then the_list module_name else [])) cs;
244.114 + val stmt_names' = (map o try)
244.115 + (deresolver (if is_some module_name then the_list module_name else [])) stmt_names;
244.116 val p = Pretty.chunks (separate (str "") (map snd includes @ (map_filter
244.117 (pr_node [] o Graph.get_node nodes) o rev o flat o Graph.strong_conn) nodes));
244.118 in
244.119 Code_Target.mk_serialization target
244.120 (case compile of SOME compile => SOME (compile o Code_Target.code_of_pretty) | NONE => NONE)
244.121 (fn NONE => Code_Target.code_writeln | SOME file => File.write file o Code_Target.code_of_pretty)
244.122 - (rpair cs' o Code_Target.code_of_pretty) p destination
244.123 + (rpair stmt_names' o Code_Target.code_of_pretty) p destination
244.124 end;
244.125
244.126 end; (*local*)
244.127 @@ -944,20 +948,17 @@
244.128
244.129 (** ML (system language) code for evaluation and instrumentalization **)
244.130
244.131 -fun ml_code_of thy = Code_Target.serialize_custom thy (target_SML,
244.132 +fun eval_code_of some_target thy = Code_Target.serialize_custom thy (the_default target_Eval some_target,
244.133 (fn _ => fn [] => serialize_ml target_SML (SOME (K ())) (K Pretty.chunks) pr_sml_stmt (SOME ""),
244.134 literals_sml));
244.135
244.136
244.137 (* evaluation *)
244.138
244.139 -fun eval eval'' term_of reff thy ct args =
244.140 +fun eval some_target reff postproc thy t args =
244.141 let
244.142 val ctxt = ProofContext.init thy;
244.143 - val _ = if null (Term.add_frees (term_of ct) []) then () else error ("Term "
244.144 - ^ quote (Syntax.string_of_term_global thy (term_of ct))
244.145 - ^ " to be evaluated contains free variables");
244.146 - fun eval' naming program ((vs, ty), t) deps =
244.147 + fun evaluator naming program ((_, (_, ty)), t) deps =
244.148 let
244.149 val _ = if Code_Thingol.contains_dictvar t then
244.150 error "Term to be evaluated contains free dictionaries" else ();
244.151 @@ -966,13 +967,11 @@
244.152 |> Graph.new_node (value_name,
244.153 Code_Thingol.Fun (Term.dummy_patternN, (([], ty), [(([], t), (Drule.dummy_thm, true))])))
244.154 |> fold (curry Graph.add_edge value_name) deps;
244.155 - val (value_code, [SOME value_name']) = ml_code_of thy naming program' [value_name];
244.156 + val (value_code, [SOME value_name']) = eval_code_of some_target thy naming program' [value_name];
244.157 val sml_code = "let\n" ^ value_code ^ "\nin " ^ value_name'
244.158 ^ space_implode " " (map (enclose "(" ")") args) ^ " end";
244.159 in ML_Context.evaluate ctxt false reff sml_code end;
244.160 - in eval'' thy (rpair eval') ct end;
244.161 -
244.162 -fun eval_term reff = eval Code_Thingol.eval_term I reff;
244.163 + in Code_Thingol.eval thy I postproc evaluator t end;
244.164
244.165
244.166 (* instrumentalization by antiquotation *)
244.167 @@ -981,42 +980,69 @@
244.168
244.169 structure CodeAntiqData = ProofDataFun
244.170 (
244.171 - type T = string list * (bool * (string * (string * (string * string) list) lazy));
244.172 - fun init _ = ([], (true, ("", Lazy.value ("", []))));
244.173 + type T = (string list * string list) * (bool * (string
244.174 + * (string * ((string * string) list * (string * string) list)) lazy));
244.175 + fun init _ = (([], []), (true, ("", Lazy.value ("", ([], [])))));
244.176 );
244.177
244.178 val is_first_occ = fst o snd o CodeAntiqData.get;
244.179
244.180 -fun delayed_code thy consts () =
244.181 +fun delayed_code thy tycos consts () =
244.182 let
244.183 val (consts', (naming, program)) = Code_Thingol.consts_program thy consts;
244.184 - val (ml_code, consts'') = ml_code_of thy naming program consts';
244.185 - val const_tab = map2 (fn const => fn NONE =>
244.186 - error ("Constant " ^ (quote o Code_Unit.string_of_const thy) const
244.187 - ^ "\nhas a user-defined serialization")
244.188 - | SOME const' => (const, const')) consts consts''
244.189 - in (ml_code, const_tab) end;
244.190 + val tycos' = map (the o Code_Thingol.lookup_tyco naming) tycos;
244.191 + val (ml_code, target_names) = eval_code_of NONE thy naming program (consts' @ tycos');
244.192 + val (consts'', tycos'') = chop (length consts') target_names;
244.193 + val consts_map = map2 (fn const => fn NONE =>
244.194 + error ("Constant " ^ (quote o Code_Unit.string_of_const thy) const
244.195 + ^ "\nhas a user-defined serialization")
244.196 + | SOME const'' => (const, const'')) consts consts''
244.197 + val tycos_map = map2 (fn tyco => fn NONE =>
244.198 + error ("Type " ^ (quote o Sign.extern_type thy) tyco
244.199 + ^ "\nhas a user-defined serialization")
244.200 + | SOME tyco'' => (tyco, tyco'')) tycos tycos'';
244.201 + in (ml_code, (tycos_map, consts_map)) end;
244.202
244.203 -fun register_const const ctxt =
244.204 +fun register_code new_tycos new_consts ctxt =
244.205 let
244.206 - val (consts, (_, (struct_name, _))) = CodeAntiqData.get ctxt;
244.207 - val consts' = insert (op =) const consts;
244.208 + val ((tycos, consts), (_, (struct_name, _))) = CodeAntiqData.get ctxt;
244.209 + val tycos' = fold (insert (op =)) new_tycos tycos;
244.210 + val consts' = fold (insert (op =)) new_consts consts;
244.211 val (struct_name', ctxt') = if struct_name = ""
244.212 then ML_Antiquote.variant "Code" ctxt
244.213 else (struct_name, ctxt);
244.214 - val acc_code = Lazy.lazy (delayed_code (ProofContext.theory_of ctxt) consts');
244.215 - in CodeAntiqData.put (consts', (false, (struct_name', acc_code))) ctxt' end;
244.216 + val acc_code = Lazy.lazy (delayed_code (ProofContext.theory_of ctxt) tycos' consts');
244.217 + in CodeAntiqData.put ((tycos', consts'), (false, (struct_name', acc_code))) ctxt' end;
244.218
244.219 -fun print_code struct_name is_first const ctxt =
244.220 +fun register_const const = register_code [] [const];
244.221 +
244.222 +fun register_datatype tyco constrs = register_code [tyco] constrs;
244.223 +
244.224 +fun print_const const all_struct_name tycos_map consts_map =
244.225 + (Long_Name.append all_struct_name o the o AList.lookup (op =) consts_map) const;
244.226 +
244.227 +fun print_datatype tyco constrs all_struct_name tycos_map consts_map =
244.228 let
244.229 - val (consts, (_, (struct_code_name, acc_code))) = CodeAntiqData.get ctxt;
244.230 - val (raw_ml_code, consts_map) = Lazy.force acc_code;
244.231 - val const'' = Long_Name.append (Long_Name.append struct_name struct_code_name)
244.232 - ((the o AList.lookup (op =) consts_map) const);
244.233 + val upperize = implode o nth_map 0 Symbol.to_ascii_upper o explode;
244.234 + fun check_base name name'' =
244.235 + if upperize (Long_Name.base_name name) = upperize name''
244.236 + then () else error ("Name as printed " ^ quote name''
244.237 + ^ "\ndiffers from logical base name " ^ quote (Long_Name.base_name name) ^ "; sorry.");
244.238 + val tyco'' = (the o AList.lookup (op =) tycos_map) tyco;
244.239 + val constrs'' = map (the o AList.lookup (op =) consts_map) constrs;
244.240 + val _ = check_base tyco tyco'';
244.241 + val _ = map2 check_base constrs constrs'';
244.242 + in "datatype " ^ tyco'' ^ " = datatype " ^ Long_Name.append all_struct_name tyco'' end;
244.243 +
244.244 +fun print_code struct_name is_first print_it ctxt =
244.245 + let
244.246 + val (_, (_, (struct_code_name, acc_code))) = CodeAntiqData.get ctxt;
244.247 + val (raw_ml_code, (tycos_map, consts_map)) = Lazy.force acc_code;
244.248 val ml_code = if is_first then "\nstructure " ^ struct_code_name
244.249 ^ " =\nstruct\n\n" ^ raw_ml_code ^ "\nend;\n\n"
244.250 else "";
244.251 - in (ml_code, const'') end;
244.252 + val all_struct_name = Long_Name.append struct_name struct_code_name;
244.253 + in (ml_code, print_it all_struct_name tycos_map consts_map) end;
244.254
244.255 in
244.256
244.257 @@ -1025,7 +1051,19 @@
244.258 val const = Code_Unit.check_const (ProofContext.theory_of background) raw_const;
244.259 val is_first = is_first_occ background;
244.260 val background' = register_const const background;
244.261 - in (print_code struct_name is_first const, background') end;
244.262 + in (print_code struct_name is_first (print_const const), background') end;
244.263 +
244.264 +fun ml_code_datatype_antiq (raw_tyco, raw_constrs) {struct_name, background} =
244.265 + let
244.266 + val thy = ProofContext.theory_of background;
244.267 + val tyco = Sign.intern_type thy raw_tyco;
244.268 + val constrs = map (Code_Unit.check_const thy) raw_constrs;
244.269 + val constrs' = (map fst o snd o Code.get_datatype thy) tyco;
244.270 + val _ = if gen_eq_set (op =) (constrs, constrs') then ()
244.271 + else error ("Type " ^ quote tyco ^ ": given constructors diverge from real constructors")
244.272 + val is_first = is_first_occ background;
244.273 + val background' = register_datatype tyco constrs background;
244.274 + in (print_code struct_name is_first (print_datatype tyco constrs), background') end;
244.275
244.276 end; (*local*)
244.277
244.278 @@ -1033,6 +1071,10 @@
244.279 (** Isar setup **)
244.280
244.281 val _ = ML_Context.add_antiq "code" (fn _ => Args.term >> ml_code_antiq);
244.282 +val _ = ML_Context.add_antiq "code_datatype" (fn _ =>
244.283 + (Args.tyname --| Scan.lift (Args.$$$ "=")
244.284 + -- (Args.term ::: Scan.repeat (Scan.lift (Args.$$$ "|") |-- Args.term)))
244.285 + >> ml_code_datatype_antiq);
244.286
244.287 fun isar_seri_sml module_name =
244.288 Code_Target.parse_args (Scan.succeed ())
244.289 @@ -1048,6 +1090,7 @@
244.290 val setup =
244.291 Code_Target.add_target (target_SML, (isar_seri_sml, literals_sml))
244.292 #> Code_Target.add_target (target_OCaml, (isar_seri_ocaml, literals_ocaml))
244.293 + #> Code_Target.extend_target (target_Eval, (target_SML, K I))
244.294 #> Code_Target.add_syntax_tyco target_SML "fun" (SOME (2, fn pr_typ => fn fxy => fn [ty1, ty2] =>
244.295 brackify_infix (1, R) fxy [
244.296 pr_typ (INFX (1, X)) ty1,
245.1 --- a/src/Tools/code/code_name.ML Mon May 11 09:39:53 2009 +0200
245.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
245.3 @@ -1,104 +0,0 @@
245.4 -(* Title: Tools/code/code_name.ML
245.5 - Author: Florian Haftmann, TU Muenchen
245.6 -
245.7 -Some code generator infrastructure concerning names.
245.8 -*)
245.9 -
245.10 -signature CODE_NAME =
245.11 -sig
245.12 - val purify_var: string -> string
245.13 - val purify_tvar: string -> string
245.14 - val purify_base: string -> string
245.15 - val check_modulename: string -> string
245.16 -
245.17 - val read_const_exprs: theory -> string list -> string list * string list
245.18 -end;
245.19 -
245.20 -structure Code_Name: CODE_NAME =
245.21 -struct
245.22 -
245.23 -(** purification **)
245.24 -
245.25 -fun purify_name upper =
245.26 - let
245.27 - fun is_valid s = Symbol.is_ascii_letter s orelse Symbol.is_ascii_digit s orelse s = "'";
245.28 - val is_junk = not o is_valid andf Symbol.is_regular;
245.29 - val junk = Scan.many is_junk;
245.30 - val scan_valids = Symbol.scanner "Malformed input"
245.31 - ((junk |--
245.32 - (Scan.optional (Scan.one Symbol.is_ascii_letter) "x" ^^ (Scan.many is_valid >> implode)
245.33 - --| junk))
245.34 - ::: Scan.repeat ((Scan.many1 is_valid >> implode) --| junk));
245.35 - fun upper_lower cs = if upper then nth_map 0 Symbol.to_ascii_upper cs
245.36 - else (if forall Symbol.is_ascii_upper cs
245.37 - then map else nth_map 0) Symbol.to_ascii_lower cs;
245.38 - in
245.39 - explode
245.40 - #> scan_valids
245.41 - #> space_implode "_"
245.42 - #> explode
245.43 - #> upper_lower
245.44 - #> implode
245.45 - end;
245.46 -
245.47 -fun purify_var "" = "x"
245.48 - | purify_var v = purify_name false v;
245.49 -
245.50 -fun purify_tvar "" = "'a"
245.51 - | purify_tvar v =
245.52 - (unprefix "'" #> explode #> filter Symbol.is_ascii_letter #> cons "'" #> implode) v;
245.53 -
245.54 -val purify_prefix =
245.55 - explode
245.56 - (*FIMXE should disappear as soon as hierarchical theory name spaces are available*)
245.57 - #> Symbol.scanner "Malformed name"
245.58 - (Scan.repeat ($$ "_" |-- $$ "_" >> (fn _ => ".") || Scan.one Symbol.is_regular))
245.59 - #> implode
245.60 - #> Long_Name.explode
245.61 - #> map (purify_name true);
245.62 -
245.63 -(*FIMXE non-canonical function treating non-canonical names*)
245.64 -fun purify_base "op &" = "and"
245.65 - | purify_base "op |" = "or"
245.66 - | purify_base "op -->" = "implies"
245.67 - | purify_base "op :" = "member"
245.68 - | purify_base "*" = "product"
245.69 - | purify_base "+" = "sum"
245.70 - | purify_base s = if String.isPrefix "op =" s
245.71 - then "eq" ^ purify_name false s
245.72 - else purify_name false s;
245.73 -
245.74 -fun check_modulename mn =
245.75 - let
245.76 - val mns = Long_Name.explode mn;
245.77 - val mns' = map (purify_name true) mns;
245.78 - in
245.79 - if mns' = mns then mn else error ("Invalid module name: " ^ quote mn ^ "\n"
245.80 - ^ "perhaps try " ^ quote (Long_Name.implode mns'))
245.81 - end;
245.82 -
245.83 -
245.84 -(** misc **)
245.85 -
245.86 -fun read_const_exprs thy =
245.87 - let
245.88 - fun consts_of some_thyname =
245.89 - let
245.90 - val thy' = case some_thyname
245.91 - of SOME thyname => ThyInfo.the_theory thyname thy
245.92 - | NONE => thy;
245.93 - val cs = Symtab.fold (fn (c, (_, NONE)) => cons c | _ => I)
245.94 - ((snd o #constants o Consts.dest o #consts o Sign.rep_sg) thy') [];
245.95 - fun belongs_here c =
245.96 - not (exists (fn thy'' => Sign.declared_const thy'' c) (Theory.parents_of thy'))
245.97 - in case some_thyname
245.98 - of NONE => cs
245.99 - | SOME thyname => filter belongs_here cs
245.100 - end;
245.101 - fun read_const_expr "*" = ([], consts_of NONE)
245.102 - | read_const_expr s = if String.isSuffix ".*" s
245.103 - then ([], consts_of (SOME (unsuffix ".*" s)))
245.104 - else ([Code_Unit.read_const thy s], []);
245.105 - in pairself flat o split_list o map read_const_expr end;
245.106 -
245.107 -end;
246.1 --- a/src/Tools/code/code_printer.ML Mon May 11 09:39:53 2009 +0200
246.2 +++ b/src/Tools/code/code_printer.ML Mon May 11 17:20:52 2009 +0200
246.3 @@ -23,6 +23,17 @@
246.4 val intro_vars: string list -> var_ctxt -> var_ctxt
246.5 val lookup_var: var_ctxt -> string -> string
246.6
246.7 + type literals
246.8 + val Literals: { literal_char: string -> string, literal_string: string -> string,
246.9 + literal_numeral: bool -> int -> string,
246.10 + literal_list: Pretty.T list -> Pretty.T, infix_cons: int * string }
246.11 + -> literals
246.12 + val literal_char: literals -> string -> string
246.13 + val literal_string: literals -> string -> string
246.14 + val literal_numeral: literals -> bool -> int -> string
246.15 + val literal_list: literals -> Pretty.T list -> Pretty.T
246.16 + val infix_cons: literals -> int * string
246.17 +
246.18 type lrx
246.19 val L: lrx
246.20 val R: lrx
246.21 @@ -41,6 +52,7 @@
246.22 type dict = Code_Thingol.dict
246.23 type tyco_syntax
246.24 type const_syntax
246.25 + type proto_const_syntax
246.26 val parse_infix: ('a -> 'b) -> lrx * int -> string
246.27 -> int * ((fixity -> 'b -> Pretty.T)
246.28 -> fixity -> 'a list -> Pretty.T)
246.29 @@ -48,26 +60,18 @@
246.30 -> (int * ((fixity -> 'b -> Pretty.T)
246.31 -> fixity -> 'a list -> Pretty.T)) option * OuterParse.token list
246.32 val simple_const_syntax: (int * ((fixity -> iterm -> Pretty.T)
246.33 - -> fixity -> (iterm * itype) list -> Pretty.T)) option -> const_syntax option
246.34 + -> fixity -> (iterm * itype) list -> Pretty.T)) option -> proto_const_syntax option
246.35 + val activate_const_syntax: theory -> literals
246.36 + -> proto_const_syntax -> Code_Thingol.naming -> const_syntax * Code_Thingol.naming
246.37 val gen_pr_app: (thm -> var_ctxt -> const * iterm list -> Pretty.T list)
246.38 -> (thm -> var_ctxt -> fixity -> iterm -> Pretty.T)
246.39 - -> (string -> const_syntax option) -> Code_Thingol.naming
246.40 + -> (string -> const_syntax option)
246.41 -> thm -> var_ctxt -> fixity -> const * iterm list -> Pretty.T
246.42 val gen_pr_bind: ((string option * Pretty.T option) * itype -> Pretty.T)
246.43 -> (thm -> var_ctxt -> fixity -> iterm -> Pretty.T)
246.44 -> thm -> fixity
246.45 -> (string option * iterm option) * itype -> var_ctxt -> Pretty.T * var_ctxt
246.46
246.47 - type literals
246.48 - val Literals: { literal_char: string -> string, literal_string: string -> string,
246.49 - literal_numeral: bool -> int -> string, literal_list: Pretty.T list -> Pretty.T, infix_cons: int * string }
246.50 - -> literals
246.51 - val literal_char: literals -> string -> string
246.52 - val literal_string: literals -> string -> string
246.53 - val literal_numeral: literals -> bool -> int -> string
246.54 - val literal_list: literals -> Pretty.T list -> Pretty.T
246.55 - val infix_cons: literals -> int * string
246.56 -
246.57 val mk_name_module: Name.context -> string option -> (string -> string option)
246.58 -> 'a Graph.T -> string -> string
246.59 val dest_name: string -> string * string
246.60 @@ -115,6 +119,25 @@
246.61 val first_lower = implode o nth_map 0 Symbol.to_ascii_lower o explode;
246.62
246.63
246.64 +(** pretty literals **)
246.65 +
246.66 +datatype literals = Literals of {
246.67 + literal_char: string -> string,
246.68 + literal_string: string -> string,
246.69 + literal_numeral: bool -> int -> string,
246.70 + literal_list: Pretty.T list -> Pretty.T,
246.71 + infix_cons: int * string
246.72 +};
246.73 +
246.74 +fun dest_Literals (Literals lits) = lits;
246.75 +
246.76 +val literal_char = #literal_char o dest_Literals;
246.77 +val literal_string = #literal_string o dest_Literals;
246.78 +val literal_numeral = #literal_numeral o dest_Literals;
246.79 +val literal_list = #literal_list o dest_Literals;
246.80 +val infix_cons = #infix_cons o dest_Literals;
246.81 +
246.82 +
246.83 (** syntax printer **)
246.84
246.85 (* binding priorities *)
246.86 @@ -158,17 +181,25 @@
246.87 type tyco_syntax = int * ((fixity -> itype -> Pretty.T)
246.88 -> fixity -> itype list -> Pretty.T);
246.89 type const_syntax = int * ((var_ctxt -> fixity -> iterm -> Pretty.T)
246.90 - -> Code_Thingol.naming -> thm -> var_ctxt -> fixity -> (iterm * itype) list -> Pretty.T);
246.91 + -> thm -> var_ctxt -> fixity -> (iterm * itype) list -> Pretty.T);
246.92 +type proto_const_syntax = int * (string list * (literals -> string list
246.93 + -> (var_ctxt -> fixity -> iterm -> Pretty.T)
246.94 + -> thm -> var_ctxt -> fixity -> (iterm * itype) list -> Pretty.T));
246.95
246.96 -fun simple_const_syntax x = (Option.map o apsnd)
246.97 - (fn pretty => fn pr => fn naming => fn thm => fn vars => pretty (pr vars)) x;
246.98 +fun simple_const_syntax (SOME (n, f)) = SOME (n,
246.99 + ([], (fn _ => fn _ => fn pr => fn thm => fn vars => f (pr vars))))
246.100 + | simple_const_syntax NONE = NONE;
246.101
246.102 -fun gen_pr_app pr_app pr_term syntax_const naming thm vars fxy (app as ((c, (_, tys)), ts)) =
246.103 +fun activate_const_syntax thy literals (n, (cs, f)) naming =
246.104 + fold_map (Code_Thingol.ensure_declared_const thy) cs naming
246.105 + |-> (fn cs' => pair (n, f literals cs'));
246.106 +
246.107 +fun gen_pr_app pr_app pr_term syntax_const thm vars fxy (app as ((c, (_, tys)), ts)) =
246.108 case syntax_const c
246.109 of NONE => brackify fxy (pr_app thm vars app)
246.110 | SOME (k, pr) =>
246.111 let
246.112 - fun pr' fxy ts = pr (pr_term thm) naming thm vars fxy (ts ~~ curry Library.take k tys);
246.113 + fun pr' fxy ts = pr (pr_term thm) thm vars fxy (ts ~~ curry Library.take k tys);
246.114 in if k = length ts
246.115 then pr' fxy ts
246.116 else if k < length ts
246.117 @@ -253,25 +284,6 @@
246.118 val _ = List.app OuterKeyword.keyword [infixK, infixlK, infixrK];
246.119
246.120
246.121 -(** pretty literals **)
246.122 -
246.123 -datatype literals = Literals of {
246.124 - literal_char: string -> string,
246.125 - literal_string: string -> string,
246.126 - literal_numeral: bool -> int -> string,
246.127 - literal_list: Pretty.T list -> Pretty.T,
246.128 - infix_cons: int * string
246.129 -};
246.130 -
246.131 -fun dest_Literals (Literals lits) = lits;
246.132 -
246.133 -val literal_char = #literal_char o dest_Literals;
246.134 -val literal_string = #literal_string o dest_Literals;
246.135 -val literal_numeral = #literal_numeral o dest_Literals;
246.136 -val literal_list = #literal_list o dest_Literals;
246.137 -val infix_cons = #infix_cons o dest_Literals;
246.138 -
246.139 -
246.140 (** module name spaces **)
246.141
246.142 val dest_name =
247.1 --- a/src/Tools/code/code_target.ML Mon May 11 09:39:53 2009 +0200
247.2 +++ b/src/Tools/code/code_target.ML Mon May 11 17:20:52 2009 +0200
247.3 @@ -44,7 +44,7 @@
247.4 val add_syntax_class: string -> class -> string option -> theory -> theory
247.5 val add_syntax_inst: string -> string * class -> bool -> theory -> theory
247.6 val add_syntax_tyco: string -> string -> tyco_syntax option -> theory -> theory
247.7 - val add_syntax_const: string -> string -> const_syntax option -> theory -> theory
247.8 + val add_syntax_const: string -> string -> proto_const_syntax option -> theory -> theory
247.9 val add_reserved: string -> string -> theory -> theory
247.10 end;
247.11
247.12 @@ -68,7 +68,7 @@
247.13 fun compile f = (code_setmp f Compile; ());
247.14 fun export f = (code_setmp f Export; ());
247.15 fun file p f = (code_setmp f (File p); ());
247.16 -fun string cs f = fst (the (code_setmp f (String cs)));
247.17 +fun string stmts f = fst (the (code_setmp f (String stmts)));
247.18
247.19 fun stmt_names_of_destination (String stmts) = stmts
247.20 | stmt_names_of_destination _ = [];
247.21 @@ -86,7 +86,7 @@
247.22 class: string Symtab.table,
247.23 instance: unit Symreltab.table,
247.24 tyco: tyco_syntax Symtab.table,
247.25 - const: const_syntax Symtab.table
247.26 + const: proto_const_syntax Symtab.table
247.27 };
247.28
247.29 fun mk_name_syntax_table ((class, instance), (tyco, const)) =
247.30 @@ -112,7 +112,6 @@
247.31 -> (string -> string option) (*class syntax*)
247.32 -> (string -> tyco_syntax option)
247.33 -> (string -> const_syntax option)
247.34 - -> Code_Thingol.naming
247.35 -> Code_Thingol.program
247.36 -> string list (*selected statements*)
247.37 -> serialization;
247.38 @@ -323,8 +322,15 @@
247.39 val add_include = gen_add_include Code_Unit.check_const;
247.40 val add_include_cmd = gen_add_include Code_Unit.read_const;
247.41
247.42 -fun add_module_alias target =
247.43 - map_module_alias target o Symtab.update o apsnd Code_Name.check_modulename;
247.44 +fun add_module_alias target (thyname, modlname) =
247.45 + let
247.46 + val xs = Long_Name.explode modlname;
247.47 + val xs' = map (Name.desymbolize true) xs;
247.48 + in if xs' = xs
247.49 + then map_module_alias target (Symtab.update (thyname, modlname))
247.50 + else error ("Invalid module name: " ^ quote modlname ^ "\n"
247.51 + ^ "perhaps try " ^ quote (Long_Name.implode xs'))
247.52 + end;
247.53
247.54 fun gen_allow_abort prep_const raw_c thy =
247.55 let
247.56 @@ -395,19 +401,34 @@
247.57 val Code_Thingol.Datatype (tyco, _) = Graph.get_node program tyco
247.58 in quote (Sign.extern_type thy tyco ^ " :: " ^ Sign.extern_class thy class) end
247.59
247.60 -fun invoke_serializer thy abortable serializer reserved abs_includes
247.61 +fun activate_syntax lookup_name src_tab = Symtab.empty
247.62 + |> fold_map (fn thing_identifier => fn tab => case lookup_name thing_identifier
247.63 + of SOME name => (SOME name,
247.64 + Symtab.update_new (name, the (Symtab.lookup src_tab thing_identifier)) tab)
247.65 + | NONE => (NONE, tab)) (Symtab.keys src_tab)
247.66 + |>> map_filter I;
247.67 +
247.68 +fun activate_const_syntax thy literals src_tab naming = (Symtab.empty, naming)
247.69 + |> fold_map (fn thing_identifier => fn (tab, naming) =>
247.70 + case Code_Thingol.lookup_const naming thing_identifier
247.71 + of SOME name => let
247.72 + val (syn, naming') = Code_Printer.activate_const_syntax thy
247.73 + literals (the (Symtab.lookup src_tab thing_identifier)) naming
247.74 + in (SOME name, (Symtab.update_new (name, syn) tab, naming')) end
247.75 + | NONE => (NONE, (tab, naming))) (Symtab.keys src_tab)
247.76 + |>> map_filter I;
247.77 +
247.78 +fun invoke_serializer thy abortable serializer literals reserved abs_includes
247.79 module_alias class instance tyco const module args naming program2 names1 =
247.80 let
247.81 - fun distill_names lookup_name src_tab = Symtab.empty
247.82 - |> fold_map (fn thing_identifier => fn tab => case lookup_name naming thing_identifier
247.83 - of SOME name => (SOME name, Symtab.update_new (name, the (Symtab.lookup src_tab thing_identifier)) tab)
247.84 - | NONE => (NONE, tab)) (Symtab.keys src_tab)
247.85 - |>> map_filter I;
247.86 - val (names_class, class') = distill_names Code_Thingol.lookup_class class;
247.87 + val (names_class, class') =
247.88 + activate_syntax (Code_Thingol.lookup_class naming) class;
247.89 val names_inst = map_filter (Code_Thingol.lookup_instance naming)
247.90 (Symreltab.keys instance);
247.91 - val (names_tyco, tyco') = distill_names Code_Thingol.lookup_tyco tyco;
247.92 - val (names_const, const') = distill_names Code_Thingol.lookup_const const;
247.93 + val (names_tyco, tyco') =
247.94 + activate_syntax (Code_Thingol.lookup_tyco naming) tyco;
247.95 + val (names_const, (const', _)) =
247.96 + activate_const_syntax thy literals const naming;
247.97 val names_hidden = names_class @ names_inst @ names_tyco @ names_const;
247.98 val names2 = subtract (op =) names_hidden names1;
247.99 val program3 = Graph.subgraph (not o member (op =) names_hidden) program2;
247.100 @@ -422,7 +443,7 @@
247.101 serializer module args (labelled_name thy program2) reserved includes
247.102 (Symtab.lookup module_alias) (Symtab.lookup class')
247.103 (Symtab.lookup tyco') (Symtab.lookup const')
247.104 - naming program4 names2
247.105 + program4 names2
247.106 end;
247.107
247.108 fun mount_serializer thy alt_serializer target module args naming program names =
247.109 @@ -453,8 +474,9 @@
247.110 ((Symtab.dest o the_includes) data);
247.111 val module_alias = the_module_alias data;
247.112 val { class, instance, tyco, const } = the_name_syntax data;
247.113 + val literals = the_literals thy target;
247.114 in
247.115 - invoke_serializer thy abortable serializer reserved
247.116 + invoke_serializer thy abortable serializer literals reserved
247.117 includes module_alias class instance tyco const module args naming (modify program) names
247.118 end;
247.119
247.120 @@ -495,7 +517,7 @@
247.121
247.122 fun read_const_exprs thy cs =
247.123 let
247.124 - val (cs1, cs2) = Code_Name.read_const_exprs thy cs;
247.125 + val (cs1, cs2) = Code_Thingol.read_const_exprs thy cs;
247.126 val (names3, (naming, program)) = Code_Thingol.consts_program thy cs2;
247.127 val names4 = transitivly_non_empty_funs thy naming program;
247.128 val cs5 = map_filter
248.1 --- a/src/Tools/code/code_thingol.ML Mon May 11 09:39:53 2009 +0200
248.2 +++ b/src/Tools/code/code_thingol.ML Mon May 11 17:20:52 2009 +0200
248.3 @@ -20,7 +20,7 @@
248.4 datatype itype =
248.5 `%% of string * itype list
248.6 | ITyVar of vname;
248.7 - type const = string * (dict list list * itype list (*types of arguments*))
248.8 + type const = string * ((itype list * dict list list) * itype list (*types of arguments*))
248.9 datatype iterm =
248.10 IConst of const
248.11 | IVar of vname
248.12 @@ -44,11 +44,10 @@
248.13 val unfold_abs: iterm -> ((vname * iterm option) * itype) list * iterm
248.14 val split_let: iterm -> (((iterm * itype) * iterm) * iterm) option
248.15 val unfold_let: iterm -> ((iterm * itype) * iterm) list * iterm
248.16 - val unfold_const_app: iterm ->
248.17 - ((string * (dict list list * itype list)) * iterm list) option
248.18 + val unfold_const_app: iterm -> (const * iterm list) option
248.19 val collapse_let: ((vname * itype) * iterm) * iterm
248.20 -> (iterm * itype) * (iterm * iterm) list
248.21 - val eta_expand: int -> (string * (dict list list * itype list)) * iterm list -> iterm
248.22 + val eta_expand: int -> const * iterm list -> iterm
248.23 val contains_dictvar: iterm -> bool
248.24 val locally_monomorphic: iterm -> bool
248.25 val fold_constnames: (string -> 'a -> 'a) -> iterm -> 'a -> 'a
248.26 @@ -62,6 +61,7 @@
248.27 val lookup_tyco: naming -> string -> string option
248.28 val lookup_instance: naming -> class * string -> string option
248.29 val lookup_const: naming -> string -> string option
248.30 + val ensure_declared_const: theory -> string -> naming -> string * naming
248.31
248.32 datatype stmt =
248.33 NoStmt
248.34 @@ -81,13 +81,14 @@
248.35 val is_cons: program -> string -> bool
248.36 val contr_classparam_typs: program -> string -> itype option list
248.37
248.38 + val read_const_exprs: theory -> string list -> string list * string list
248.39 val consts_program: theory -> string list -> string list * (naming * program)
248.40 val cached_program: theory -> naming * program
248.41 - val eval_conv: theory
248.42 - -> (term -> term * (naming -> program -> typscheme * iterm -> string list -> thm))
248.43 + val eval_conv: theory -> (sort -> sort)
248.44 + -> (naming -> program -> ((string * sort) list * typscheme) * iterm -> string list -> cterm -> thm)
248.45 -> cterm -> thm
248.46 - val eval_term: theory
248.47 - -> (term -> term * (naming -> program -> typscheme * iterm -> string list -> 'a))
248.48 + val eval: theory -> (sort -> sort) -> ((term -> term) -> 'a -> 'a)
248.49 + -> (naming -> program -> ((string * sort) list * typscheme) * iterm -> string list -> 'a)
248.50 -> term -> 'a
248.51 end;
248.52
248.53 @@ -121,7 +122,7 @@
248.54 `%% of string * itype list
248.55 | ITyVar of vname;
248.56
248.57 -type const = string * (dict list list * itype list (*types of arguments*))
248.58 +type const = string * ((itype list * dict list list) * itype list (*types of arguments*))
248.59
248.60 datatype iterm =
248.61 IConst of const
248.62 @@ -211,7 +212,7 @@
248.63 | contains (DictVar _) = K true;
248.64 in
248.65 fold_aiterms
248.66 - (fn IConst (_, (dss, _)) => (fold o fold) contains dss | _ => I) t false
248.67 + (fn IConst (_, ((_, dss), _)) => (fold o fold) contains dss | _ => I) t false
248.68 end;
248.69
248.70 fun locally_monomorphic (IConst _) = false
248.71 @@ -239,10 +240,18 @@
248.72 | NONE => (case Code.get_datatype_of_constr thy c
248.73 of SOME dtco => thyname_of_tyco thy dtco
248.74 | NONE => thyname_of thy (Consts.the_tags (Sign.consts_of thy)) c);
248.75 + fun purify_base "op &" = "and"
248.76 + | purify_base "op |" = "or"
248.77 + | purify_base "op -->" = "implies"
248.78 + | purify_base "op :" = "member"
248.79 + | purify_base "op =" = "eq"
248.80 + | purify_base "*" = "product"
248.81 + | purify_base "+" = "sum"
248.82 + | purify_base s = Name.desymbolize false s;
248.83 fun namify thy get_basename get_thyname name =
248.84 let
248.85 val prefix = get_thyname thy name;
248.86 - val base = (Code_Name.purify_base o get_basename) name;
248.87 + val base = (purify_base o get_basename) name;
248.88 in Long_Name.append prefix base end;
248.89 in
248.90
248.91 @@ -351,6 +360,11 @@
248.92 fun declare_const thy = declare thy map_const
248.93 lookup_const Symtab.update_new namify_const;
248.94
248.95 +fun ensure_declared_const thy const naming =
248.96 + case lookup_const naming const
248.97 + of SOME const' => (const', naming)
248.98 + | NONE => declare_const thy const naming;
248.99 +
248.100 val unfold_fun = unfoldr
248.101 (fn "Pure.fun.tyco" `%% [ty1, ty2] => SOME (ty1, ty2)
248.102 | _ => NONE); (*depends on suffix_tyco and namify_tyco!*)
248.103 @@ -459,7 +473,45 @@
248.104
248.105 (* translation *)
248.106
248.107 -fun ensure_class thy (algbr as (_, algebra)) funcgr class =
248.108 +fun ensure_tyco thy algbr funcgr tyco =
248.109 + let
248.110 + val stmt_datatype =
248.111 + let
248.112 + val (vs, cos) = Code.get_datatype thy tyco;
248.113 + in
248.114 + fold_map (translate_tyvar_sort thy algbr funcgr) vs
248.115 + ##>> fold_map (fn (c, tys) =>
248.116 + ensure_const thy algbr funcgr c
248.117 + ##>> fold_map (translate_typ thy algbr funcgr) tys) cos
248.118 + #>> (fn info => Datatype (tyco, info))
248.119 + end;
248.120 + in ensure_stmt lookup_tyco (declare_tyco thy) stmt_datatype tyco end
248.121 +and ensure_const thy algbr funcgr c =
248.122 + let
248.123 + fun stmt_datatypecons tyco =
248.124 + ensure_tyco thy algbr funcgr tyco
248.125 + #>> (fn tyco => Datatypecons (c, tyco));
248.126 + fun stmt_classparam class =
248.127 + ensure_class thy algbr funcgr class
248.128 + #>> (fn class => Classparam (c, class));
248.129 + fun stmt_fun ((vs, ty), raw_thms) =
248.130 + let
248.131 + val thms = if null (Term.add_tfreesT ty []) orelse (null o fst o strip_type) ty
248.132 + then raw_thms
248.133 + else (map o apfst) (Code_Unit.expand_eta thy 1) raw_thms;
248.134 + in
248.135 + fold_map (translate_tyvar_sort thy algbr funcgr) vs
248.136 + ##>> translate_typ thy algbr funcgr ty
248.137 + ##>> fold_map (translate_eq thy algbr funcgr) thms
248.138 + #>> (fn info => Fun (c, info))
248.139 + end;
248.140 + val stmt_const = case Code.get_datatype_of_constr thy c
248.141 + of SOME tyco => stmt_datatypecons tyco
248.142 + | NONE => (case AxClass.class_of_param thy c
248.143 + of SOME class => stmt_classparam class
248.144 + | NONE => stmt_fun (Code_Wellsorted.typ funcgr c, Code_Wellsorted.eqns funcgr c))
248.145 + in ensure_stmt lookup_const (declare_const thy) stmt_const c end
248.146 +and ensure_class thy (algbr as (_, algebra)) funcgr class =
248.147 let
248.148 val superclasses = (Sorts.minimize_sort algebra o Sorts.super_classes algebra) class;
248.149 val cs = #params (AxClass.get_info thy class);
248.150 @@ -477,65 +529,6 @@
248.151 ##>> ensure_class thy algbr funcgr superclass
248.152 #>> Classrel;
248.153 in ensure_stmt lookup_classrel (declare_classrel thy) stmt_classrel (subclass, superclass) end
248.154 -and ensure_tyco thy algbr funcgr tyco =
248.155 - let
248.156 - val stmt_datatype =
248.157 - let
248.158 - val (vs, cos) = Code.get_datatype thy tyco;
248.159 - in
248.160 - fold_map (translate_tyvar_sort thy algbr funcgr) vs
248.161 - ##>> fold_map (fn (c, tys) =>
248.162 - ensure_const thy algbr funcgr c
248.163 - ##>> fold_map (translate_typ thy algbr funcgr) tys) cos
248.164 - #>> (fn info => Datatype (tyco, info))
248.165 - end;
248.166 - in ensure_stmt lookup_tyco (declare_tyco thy) stmt_datatype tyco end
248.167 -and translate_tyvar_sort thy (algbr as (proj_sort, _)) funcgr (v, sort) =
248.168 - fold_map (ensure_class thy algbr funcgr) (proj_sort sort)
248.169 - #>> (fn sort => (unprefix "'" v, sort))
248.170 -and translate_typ thy algbr funcgr (TFree (v, _)) =
248.171 - pair (ITyVar (unprefix "'" v))
248.172 - | translate_typ thy algbr funcgr (Type (tyco, tys)) =
248.173 - ensure_tyco thy algbr funcgr tyco
248.174 - ##>> fold_map (translate_typ thy algbr funcgr) tys
248.175 - #>> (fn (tyco, tys) => tyco `%% tys)
248.176 -and translate_dicts thy (algbr as (proj_sort, algebra)) funcgr thm (ty, sort) =
248.177 - let
248.178 - val pp = Syntax.pp_global thy;
248.179 - datatype typarg =
248.180 - Global of (class * string) * typarg list list
248.181 - | Local of (class * class) list * (string * (int * sort));
248.182 - fun class_relation (Global ((_, tyco), yss), _) class =
248.183 - Global ((class, tyco), yss)
248.184 - | class_relation (Local (classrels, v), subclass) superclass =
248.185 - Local ((subclass, superclass) :: classrels, v);
248.186 - fun type_constructor tyco yss class =
248.187 - Global ((class, tyco), (map o map) fst yss);
248.188 - fun type_variable (TFree (v, sort)) =
248.189 - let
248.190 - val sort' = proj_sort sort;
248.191 - in map_index (fn (n, class) => (Local ([], (v, (n, sort'))), class)) sort' end;
248.192 - val typargs = Sorts.of_sort_derivation pp algebra
248.193 - {class_relation = class_relation, type_constructor = type_constructor,
248.194 - type_variable = type_variable} (ty, proj_sort sort)
248.195 - handle Sorts.CLASS_ERROR e => not_wellsorted thy thm ty sort e;
248.196 - fun mk_dict (Global (inst, yss)) =
248.197 - ensure_inst thy algbr funcgr inst
248.198 - ##>> (fold_map o fold_map) mk_dict yss
248.199 - #>> (fn (inst, dss) => DictConst (inst, dss))
248.200 - | mk_dict (Local (classrels, (v, (k, sort)))) =
248.201 - fold_map (ensure_classrel thy algbr funcgr) classrels
248.202 - #>> (fn classrels => DictVar (classrels, (unprefix "'" v, (k, length sort))))
248.203 - in fold_map mk_dict typargs end
248.204 -and translate_eq thy algbr funcgr (thm, linear) =
248.205 - let
248.206 - val (args, rhs) = (apfst (snd o strip_comb) o Logic.dest_equals
248.207 - o Logic.unvarify o prop_of) thm;
248.208 - in
248.209 - fold_map (translate_term thy algbr funcgr (SOME thm)) args
248.210 - ##>> translate_term thy algbr funcgr (SOME thm) rhs
248.211 - #>> rpair (thm, linear)
248.212 - end
248.213 and ensure_inst thy (algbr as (_, algebra)) funcgr (class, tyco) =
248.214 let
248.215 val superclasses = (Sorts.minimize_sort algebra o Sorts.super_classes algebra) class;
248.216 @@ -572,31 +565,12 @@
248.217 #>> (fn ((((class, tyco), arity), superarities), classparams) =>
248.218 Classinst ((class, (tyco, arity)), (superarities, classparams)));
248.219 in ensure_stmt lookup_instance (declare_instance thy) stmt_inst (class, tyco) end
248.220 -and ensure_const thy algbr funcgr c =
248.221 - let
248.222 - fun stmt_datatypecons tyco =
248.223 +and translate_typ thy algbr funcgr (TFree (v, _)) =
248.224 + pair (ITyVar (unprefix "'" v))
248.225 + | translate_typ thy algbr funcgr (Type (tyco, tys)) =
248.226 ensure_tyco thy algbr funcgr tyco
248.227 - #>> (fn tyco => Datatypecons (c, tyco));
248.228 - fun stmt_classparam class =
248.229 - ensure_class thy algbr funcgr class
248.230 - #>> (fn class => Classparam (c, class));
248.231 - fun stmt_fun ((vs, ty), raw_thms) =
248.232 - let
248.233 - val thms = if null (Term.add_tfreesT ty []) orelse (null o fst o strip_type) ty
248.234 - then raw_thms
248.235 - else (map o apfst) (Code_Unit.expand_eta thy 1) raw_thms;
248.236 - in
248.237 - fold_map (translate_tyvar_sort thy algbr funcgr) vs
248.238 - ##>> translate_typ thy algbr funcgr ty
248.239 - ##>> fold_map (translate_eq thy algbr funcgr) thms
248.240 - #>> (fn info => Fun (c, info))
248.241 - end;
248.242 - val stmt_const = case Code.get_datatype_of_constr thy c
248.243 - of SOME tyco => stmt_datatypecons tyco
248.244 - | NONE => (case AxClass.class_of_param thy c
248.245 - of SOME class => stmt_classparam class
248.246 - | NONE => stmt_fun (Code_Wellsorted.typ funcgr c, Code_Wellsorted.eqns funcgr c))
248.247 - in ensure_stmt lookup_const (declare_const thy) stmt_const c end
248.248 + ##>> fold_map (translate_typ thy algbr funcgr) tys
248.249 + #>> (fn (tyco, tys) => tyco `%% tys)
248.250 and translate_term thy algbr funcgr thm (Const (c, ty)) =
248.251 translate_app thy algbr funcgr thm ((c, ty), [])
248.252 | translate_term thy algbr funcgr thm (Free (v, _)) =
248.253 @@ -617,6 +591,15 @@
248.254 translate_term thy algbr funcgr thm t'
248.255 ##>> fold_map (translate_term thy algbr funcgr thm) ts
248.256 #>> (fn (t, ts) => t `$$ ts)
248.257 +and translate_eq thy algbr funcgr (thm, proper) =
248.258 + let
248.259 + val (args, rhs) = (apfst (snd o strip_comb) o Logic.dest_equals
248.260 + o Logic.unvarify o prop_of) thm;
248.261 + in
248.262 + fold_map (translate_term thy algbr funcgr (SOME thm)) args
248.263 + ##>> translate_term thy algbr funcgr (SOME thm) rhs
248.264 + #>> rpair (thm, proper)
248.265 + end
248.266 and translate_const thy algbr funcgr thm (c, ty) =
248.267 let
248.268 val tys = Sign.const_typargs thy (c, ty);
248.269 @@ -624,9 +607,10 @@
248.270 val tys_args = (fst o Term.strip_type) ty;
248.271 in
248.272 ensure_const thy algbr funcgr c
248.273 + ##>> fold_map (translate_typ thy algbr funcgr) tys
248.274 ##>> fold_map (translate_dicts thy algbr funcgr thm) (tys ~~ sorts)
248.275 ##>> fold_map (translate_typ thy algbr funcgr) tys_args
248.276 - #>> (fn ((c, iss), tys) => IConst (c, (iss, tys)))
248.277 + #>> (fn (((c, tys), iss), tys_args) => IConst (c, ((tys, iss), tys_args)))
248.278 end
248.279 and translate_app_const thy algbr funcgr thm (c_ty, ts) =
248.280 translate_const thy algbr funcgr thm c_ty
248.281 @@ -695,7 +679,38 @@
248.282 and translate_app thy algbr funcgr thm (c_ty_ts as ((c, _), _)) =
248.283 case Code.get_case_scheme thy c
248.284 of SOME case_scheme => translate_app_case thy algbr funcgr thm case_scheme c_ty_ts
248.285 - | NONE => translate_app_const thy algbr funcgr thm c_ty_ts;
248.286 + | NONE => translate_app_const thy algbr funcgr thm c_ty_ts
248.287 +and translate_tyvar_sort thy (algbr as (proj_sort, _)) funcgr (v, sort) =
248.288 + fold_map (ensure_class thy algbr funcgr) (proj_sort sort)
248.289 + #>> (fn sort => (unprefix "'" v, sort))
248.290 +and translate_dicts thy (algbr as (proj_sort, algebra)) funcgr thm (ty, sort) =
248.291 + let
248.292 + val pp = Syntax.pp_global thy;
248.293 + datatype typarg =
248.294 + Global of (class * string) * typarg list list
248.295 + | Local of (class * class) list * (string * (int * sort));
248.296 + fun class_relation (Global ((_, tyco), yss), _) class =
248.297 + Global ((class, tyco), yss)
248.298 + | class_relation (Local (classrels, v), subclass) superclass =
248.299 + Local ((subclass, superclass) :: classrels, v);
248.300 + fun type_constructor tyco yss class =
248.301 + Global ((class, tyco), (map o map) fst yss);
248.302 + fun type_variable (TFree (v, sort)) =
248.303 + let
248.304 + val sort' = proj_sort sort;
248.305 + in map_index (fn (n, class) => (Local ([], (v, (n, sort'))), class)) sort' end;
248.306 + val typargs = Sorts.of_sort_derivation pp algebra
248.307 + {class_relation = class_relation, type_constructor = type_constructor,
248.308 + type_variable = type_variable} (ty, proj_sort sort)
248.309 + handle Sorts.CLASS_ERROR e => not_wellsorted thy thm ty sort e;
248.310 + fun mk_dict (Global (inst, yss)) =
248.311 + ensure_inst thy algbr funcgr inst
248.312 + ##>> (fold_map o fold_map) mk_dict yss
248.313 + #>> (fn (inst, dss) => DictConst (inst, dss))
248.314 + | mk_dict (Local (classrels, (v, (k, sort)))) =
248.315 + fold_map (ensure_classrel thy algbr funcgr) classrels
248.316 + #>> (fn classrels => DictVar (classrels, (unprefix "'" v, (k, length sort))))
248.317 + in fold_map mk_dict typargs end;
248.318
248.319
248.320 (* store *)
248.321 @@ -733,14 +748,14 @@
248.322 fun generate_consts thy algebra funcgr =
248.323 fold_map (ensure_const thy algebra funcgr);
248.324 in
248.325 - invoke_generation thy (Code_Wellsorted.make thy cs) generate_consts cs
248.326 + invoke_generation thy (Code_Wellsorted.obtain thy cs []) generate_consts cs
248.327 |-> project_consts
248.328 end;
248.329
248.330
248.331 (* value evaluation *)
248.332
248.333 -fun ensure_value thy algbr funcgr t =
248.334 +fun ensure_value thy algbr funcgr t =
248.335 let
248.336 val ty = fastype_of t;
248.337 val vs = fold_term_types (K (fold_atyps (insert (eq_fst op =)
248.338 @@ -753,31 +768,107 @@
248.339 (Term.dummy_patternN, ((vs, ty), [(([], t), (Drule.dummy_thm, true))])));
248.340 fun term_value (dep, (naming, program1)) =
248.341 let
248.342 - val Fun (_, ((vs, ty), [(([], t), _)])) =
248.343 + val Fun (_, (vs_ty, [(([], t), _)])) =
248.344 Graph.get_node program1 Term.dummy_patternN;
248.345 val deps = Graph.imm_succs program1 Term.dummy_patternN;
248.346 val program2 = Graph.del_nodes [Term.dummy_patternN] program1;
248.347 val deps_all = Graph.all_succs program2 deps;
248.348 val program3 = Graph.subgraph (member (op =) deps_all) program2;
248.349 - in (((naming, program3), (((vs, ty), t), deps)), (dep, (naming, program2))) end;
248.350 + in (((naming, program3), ((vs_ty, t), deps)), (dep, (naming, program2))) end;
248.351 in
248.352 ensure_stmt ((K o K) NONE) pair stmt_value Term.dummy_patternN
248.353 #> snd
248.354 #> term_value
248.355 end;
248.356
248.357 -fun eval thy evaluator t =
248.358 +fun base_evaluator thy evaluator algebra funcgr vs t =
248.359 let
248.360 - val (t', evaluator'') = evaluator t;
248.361 - fun evaluator' algebra funcgr =
248.362 + val (((naming, program), (((vs', ty'), t'), deps)), _) =
248.363 + invoke_generation thy (algebra, funcgr) ensure_value t;
248.364 + val vs'' = map (fn (v, _) => (v, (the o AList.lookup (op =) vs o prefix "'") v)) vs';
248.365 + in evaluator naming program ((vs'', (vs', ty')), t') deps end;
248.366 +
248.367 +fun eval_conv thy prep_sort = Code_Wellsorted.eval_conv thy prep_sort o base_evaluator thy;
248.368 +fun eval thy prep_sort postproc = Code_Wellsorted.eval thy prep_sort postproc o base_evaluator thy;
248.369 +
248.370 +
248.371 +(** diagnostic commands **)
248.372 +
248.373 +fun read_const_exprs thy =
248.374 + let
248.375 + fun consts_of some_thyname =
248.376 let
248.377 - val (((naming, program), (vs_ty_t, deps)), _) =
248.378 - invoke_generation thy (algebra, funcgr) ensure_value t';
248.379 - in evaluator'' naming program vs_ty_t deps end;
248.380 - in (t', evaluator') end
248.381 + val thy' = case some_thyname
248.382 + of SOME thyname => ThyInfo.the_theory thyname thy
248.383 + | NONE => thy;
248.384 + val cs = Symtab.fold (fn (c, (_, NONE)) => cons c | _ => I)
248.385 + ((snd o #constants o Consts.dest o #consts o Sign.rep_sg) thy') [];
248.386 + fun belongs_here c =
248.387 + not (exists (fn thy'' => Sign.declared_const thy'' c) (Theory.parents_of thy'))
248.388 + in case some_thyname
248.389 + of NONE => cs
248.390 + | SOME thyname => filter belongs_here cs
248.391 + end;
248.392 + fun read_const_expr "*" = ([], consts_of NONE)
248.393 + | read_const_expr s = if String.isSuffix ".*" s
248.394 + then ([], consts_of (SOME (unsuffix ".*" s)))
248.395 + else ([Code_Unit.read_const thy s], []);
248.396 + in pairself flat o split_list o map read_const_expr end;
248.397
248.398 -fun eval_conv thy = Code_Wellsorted.eval_conv thy o eval thy;
248.399 -fun eval_term thy = Code_Wellsorted.eval_term thy o eval thy;
248.400 +fun code_depgr thy consts =
248.401 + let
248.402 + val (_, eqngr) = Code_Wellsorted.obtain thy consts [];
248.403 + val select = Graph.all_succs eqngr consts;
248.404 + in
248.405 + eqngr
248.406 + |> not (null consts) ? Graph.subgraph (member (op =) select)
248.407 + |> Graph.map_nodes ((apsnd o map o apfst) (AxClass.overload thy))
248.408 + end;
248.409 +
248.410 +fun code_thms thy = Pretty.writeln o Code_Wellsorted.pretty thy o code_depgr thy;
248.411 +
248.412 +fun code_deps thy consts =
248.413 + let
248.414 + val eqngr = code_depgr thy consts;
248.415 + val constss = Graph.strong_conn eqngr;
248.416 + val mapping = Symtab.empty |> fold (fn consts => fold (fn const =>
248.417 + Symtab.update (const, consts)) consts) constss;
248.418 + fun succs consts = consts
248.419 + |> maps (Graph.imm_succs eqngr)
248.420 + |> subtract (op =) consts
248.421 + |> map (the o Symtab.lookup mapping)
248.422 + |> distinct (op =);
248.423 + val conn = [] |> fold (fn consts => cons (consts, succs consts)) constss;
248.424 + fun namify consts = map (Code_Unit.string_of_const thy) consts
248.425 + |> commas;
248.426 + val prgr = map (fn (consts, constss) =>
248.427 + { name = namify consts, ID = namify consts, dir = "", unfold = true,
248.428 + path = "", parents = map namify constss }) conn;
248.429 + in Present.display_graph prgr end;
248.430 +
248.431 +local
248.432 +
248.433 +structure P = OuterParse
248.434 +and K = OuterKeyword
248.435 +
248.436 +fun code_thms_cmd thy = code_thms thy o op @ o read_const_exprs thy;
248.437 +fun code_deps_cmd thy = code_deps thy o op @ o read_const_exprs thy;
248.438 +
248.439 +in
248.440 +
248.441 +val _ =
248.442 + OuterSyntax.improper_command "code_thms" "print system of code equations for code" OuterKeyword.diag
248.443 + (Scan.repeat P.term_group
248.444 + >> (fn cs => Toplevel.no_timing o Toplevel.unknown_theory
248.445 + o Toplevel.keep ((fn thy => code_thms_cmd thy cs) o Toplevel.theory_of)));
248.446 +
248.447 +val _ =
248.448 + OuterSyntax.improper_command "code_deps" "visualize dependencies of code equations for code" OuterKeyword.diag
248.449 + (Scan.repeat P.term_group
248.450 + >> (fn cs => Toplevel.no_timing o Toplevel.unknown_theory
248.451 + o Toplevel.keep ((fn thy => code_deps_cmd thy cs) o Toplevel.theory_of)));
248.452 +
248.453 +end;
248.454
248.455 end; (*struct*)
248.456
249.1 --- a/src/Tools/code/code_wellsorted.ML Mon May 11 09:39:53 2009 +0200
249.2 +++ b/src/Tools/code/code_wellsorted.ML Mon May 11 17:20:52 2009 +0200
249.3 @@ -7,25 +7,26 @@
249.4
249.5 signature CODE_WELLSORTED =
249.6 sig
249.7 - type T
249.8 - val eqns: T -> string -> (thm * bool) list
249.9 - val typ: T -> string -> (string * sort) list * typ
249.10 - val all: T -> string list
249.11 - val pretty: theory -> T -> Pretty.T
249.12 - val make: theory -> string list
249.13 - -> ((sort -> sort) * Sorts.algebra) * T
249.14 - val eval_conv: theory
249.15 - -> (term -> term * (((sort -> sort) * Sorts.algebra) -> T -> thm)) -> cterm -> thm
249.16 - val eval_term: theory
249.17 - -> (term -> term * (((sort -> sort) * Sorts.algebra) -> T -> 'a)) -> term -> 'a
249.18 + type code_algebra
249.19 + type code_graph
249.20 + val eqns: code_graph -> string -> (thm * bool) list
249.21 + val typ: code_graph -> string -> (string * sort) list * typ
249.22 + val all: code_graph -> string list
249.23 + val pretty: theory -> code_graph -> Pretty.T
249.24 + val obtain: theory -> string list -> term list -> code_algebra * code_graph
249.25 + val eval_conv: theory -> (sort -> sort)
249.26 + -> (code_algebra -> code_graph -> (string * sort) list -> term -> cterm -> thm) -> cterm -> thm
249.27 + val eval: theory -> (sort -> sort) -> ((term -> term) -> 'a -> 'a)
249.28 + -> (code_algebra -> code_graph -> (string * sort) list -> term -> 'a) -> term -> 'a
249.29 end
249.30
249.31 structure Code_Wellsorted : CODE_WELLSORTED =
249.32 struct
249.33
249.34 -(** the equation graph type **)
249.35 +(** the algebra and code equation graph types **)
249.36
249.37 -type T = (((string * sort) list * typ) * (thm * bool) list) Graph.T;
249.38 +type code_algebra = (sort -> sort) * Sorts.algebra;
249.39 +type code_graph = (((string * sort) list * typ) * (thm * bool) list) Graph.T;
249.40
249.41 fun eqns eqngr = these o Option.map snd o try (Graph.get_node eqngr);
249.42 fun typ eqngr = fst o Graph.get_node eqngr;
249.43 @@ -47,8 +48,10 @@
249.44
249.45 (* auxiliary *)
249.46
249.47 +fun is_proper_class thy = can (AxClass.get_info thy);
249.48 +
249.49 fun complete_proper_sort thy =
249.50 - Sign.complete_sort thy #> filter (can (AxClass.get_info thy));
249.51 + Sign.complete_sort thy #> filter (is_proper_class thy);
249.52
249.53 fun inst_params thy tyco =
249.54 map (fn (c, _) => AxClass.param_of_inst thy (c, tyco))
249.55 @@ -61,7 +64,7 @@
249.56 fun tyscm_rhss_of thy c eqns =
249.57 let
249.58 val tyscm = case eqns of [] => Code.default_typscheme thy c
249.59 - | ((thm, _) :: _) => (snd o Code_Unit.head_eqn thy) thm;
249.60 + | ((thm, _) :: _) => Code_Unit.typscheme_eqn thy thm;
249.61 val rhss = consts_of thy eqns;
249.62 in (tyscm, rhss) end;
249.63
249.64 @@ -104,7 +107,7 @@
249.65 | NONE => let
249.66 val eqns = Code.these_eqns thy c
249.67 |> burrow_fst (Code_Unit.norm_args thy)
249.68 - |> burrow_fst (Code_Unit.norm_varnames thy Code_Name.purify_tvar Code_Name.purify_var);
249.69 + |> burrow_fst (Code_Unit.norm_varnames thy);
249.70 val ((lhs, _), rhss) = tyscm_rhss_of thy c eqns;
249.71 in ((lhs, rhss), eqns) end;
249.72
249.73 @@ -232,8 +235,7 @@
249.74 ((class, tyco), map (fn k => (snd o Vargraph.get_node vardeps) (Inst (class, tyco), k))
249.75 (0 upto Sign.arity_number thy tyco - 1));
249.76
249.77 -fun add_eqs thy (proj_sort, algebra) vardeps
249.78 - (c, (proto_lhs, proto_eqns)) (rhss, eqngr) =
249.79 +fun add_eqs thy vardeps (c, (proto_lhs, proto_eqns)) (rhss, eqngr) =
249.80 if can (Graph.get_node eqngr) c then (rhss, eqngr)
249.81 else let
249.82 val lhs = map_index (fn (k, (v, _)) =>
249.83 @@ -246,72 +248,30 @@
249.84 val eqngr' = Graph.new_node (c, (tyscm, eqns)) eqngr;
249.85 in (map (pair c) rhss' @ rhss, eqngr') end;
249.86
249.87 -fun extend_arities_eqngr thy cs cs_rhss (arities, eqngr) =
249.88 +fun extend_arities_eqngr thy cs ts (arities, eqngr) =
249.89 let
249.90 - val cs_rhss' = (map o apsnd o map) (styp_of NONE) cs_rhss;
249.91 + val cs_rhss = (fold o fold_aterms) (fn Const (c_ty as (c, _)) =>
249.92 + insert (op =) (c, (map (styp_of NONE) o Sign.const_typargs thy) c_ty) | _ => I) ts [];
249.93 val (vardeps, (eqntab, insts)) = empty_vardeps_data
249.94 |> fold (assert_fun thy arities eqngr) cs
249.95 - |> fold (assert_rhs thy arities eqngr) cs_rhss';
249.96 + |> fold (assert_rhs thy arities eqngr) cs_rhss;
249.97 val arities' = fold (add_arity thy vardeps) insts arities;
249.98 val pp = Syntax.pp_global thy;
249.99 - val is_proper_class = can (AxClass.get_info thy);
249.100 - val (proj_sort, algebra) = Sorts.subalgebra pp is_proper_class
249.101 + val algebra = Sorts.subalgebra pp (is_proper_class thy)
249.102 (AList.lookup (op =) arities') (Sign.classes_of thy);
249.103 - val (rhss, eqngr') = Symtab.fold
249.104 - (add_eqs thy (proj_sort, algebra) vardeps) eqntab ([], eqngr);
249.105 - fun deps_of (c, rhs) = c ::
249.106 - maps (dicts_of thy (proj_sort, algebra))
249.107 - (rhs ~~ (map snd o fst o fst o Graph.get_node eqngr') c);
249.108 + val (rhss, eqngr') = Symtab.fold (add_eqs thy vardeps) eqntab ([], eqngr);
249.109 + fun deps_of (c, rhs) = c :: maps (dicts_of thy algebra)
249.110 + (rhs ~~ (map snd o fst o fst o Graph.get_node eqngr') c);
249.111 val eqngr'' = fold (fn (c, rhs) => fold
249.112 (curry Graph.add_edge c) (deps_of rhs)) rhss eqngr';
249.113 - in ((proj_sort, algebra), (arities', eqngr'')) end;
249.114 + in (algebra, (arities', eqngr'')) end;
249.115
249.116
249.117 -(** retrieval interfaces **)
249.118 -
249.119 -fun proto_eval thy cterm_of evaluator_lift evaluator proto_ct arities_eqngr =
249.120 - let
249.121 - val ct = cterm_of proto_ct;
249.122 - val _ = Sign.no_vars (Syntax.pp_global thy) (Thm.term_of ct);
249.123 - val _ = Term.fold_types (Type.no_tvars #> K I) (Thm.term_of ct) ();
249.124 - fun consts_of t =
249.125 - fold_aterms (fn Const c_ty => cons c_ty | _ => I) t [];
249.126 - val thm = Code.preprocess_conv thy ct;
249.127 - val ct' = Thm.rhs_of thm;
249.128 - val t' = Thm.term_of ct';
249.129 - val (t'', evaluator_eqngr) = evaluator t';
249.130 - val consts = map fst (consts_of t');
249.131 - val consts' = consts_of t'';
249.132 - val const_matches' = fold (fn (c, ty) =>
249.133 - insert (op =) (c, Sign.const_typargs thy (c, ty))) consts' [];
249.134 - val (algebra', arities_eqngr') =
249.135 - extend_arities_eqngr thy consts const_matches' arities_eqngr;
249.136 - in
249.137 - (evaluator_lift (evaluator_eqngr algebra') thm (snd arities_eqngr'),
249.138 - arities_eqngr')
249.139 - end;
249.140 -
249.141 -fun proto_eval_conv thy =
249.142 - let
249.143 - fun evaluator_lift evaluator thm1 eqngr =
249.144 - let
249.145 - val thm2 = evaluator eqngr;
249.146 - val thm3 = Code.postprocess_conv thy (Thm.rhs_of thm2);
249.147 - in
249.148 - Thm.transitive thm1 (Thm.transitive thm2 thm3) handle THM _ =>
249.149 - error ("could not construct evaluation proof:\n"
249.150 - ^ (cat_lines o map Display.string_of_thm) [thm1, thm2, thm3])
249.151 - end;
249.152 - in proto_eval thy I evaluator_lift end;
249.153 -
249.154 -fun proto_eval_term thy =
249.155 - let
249.156 - fun evaluator_lift evaluator _ eqngr = evaluator eqngr;
249.157 - in proto_eval thy (Thm.cterm_of thy) evaluator_lift end;
249.158 +(** store **)
249.159
249.160 structure Wellsorted = CodeDataFun
249.161 (
249.162 - type T = ((string * class) * sort list) list * T;
249.163 + type T = ((string * class) * sort list) list * code_graph;
249.164 val empty = ([], Graph.empty);
249.165 fun purge thy cs (arities, eqngr) =
249.166 let
249.167 @@ -327,71 +287,56 @@
249.168 in (arities', eqngr') end;
249.169 );
249.170
249.171 -fun make thy cs = apsnd snd
249.172 - (Wellsorted.change_yield thy (extend_arities_eqngr thy cs []));
249.173
249.174 -fun eval_conv thy f =
249.175 - fst o Wellsorted.change_yield thy o proto_eval_conv thy f;
249.176 +(** retrieval interfaces **)
249.177
249.178 -fun eval_term thy f =
249.179 - fst o Wellsorted.change_yield thy o proto_eval_term thy f;
249.180 +fun obtain thy cs ts = apsnd snd
249.181 + (Wellsorted.change_yield thy (extend_arities_eqngr thy cs ts));
249.182
249.183 +fun prepare_sorts_typ prep_sort
249.184 + = map_type_tfree (fn (v, sort) => TFree (v, prep_sort sort));
249.185
249.186 -(** diagnostic commands **)
249.187 +fun prepare_sorts prep_sort (Const (c, ty)) =
249.188 + Const (c, prepare_sorts_typ prep_sort ty)
249.189 + | prepare_sorts prep_sort (t1 $ t2) =
249.190 + prepare_sorts prep_sort t1 $ prepare_sorts prep_sort t2
249.191 + | prepare_sorts prep_sort (Abs (v, ty, t)) =
249.192 + Abs (v, prepare_sorts_typ prep_sort ty, prepare_sorts prep_sort t)
249.193 + | prepare_sorts _ (t as Bound _) = t;
249.194
249.195 -fun code_depgr thy consts =
249.196 +fun gen_eval thy cterm_of conclude_evaluation prep_sort evaluator proto_ct =
249.197 let
249.198 - val (_, eqngr) = make thy consts;
249.199 - val select = Graph.all_succs eqngr consts;
249.200 - in
249.201 - eqngr
249.202 - |> not (null consts) ? Graph.subgraph (member (op =) select)
249.203 - |> Graph.map_nodes ((apsnd o map o apfst) (AxClass.overload thy))
249.204 - end;
249.205 + val pp = Syntax.pp_global thy;
249.206 + val ct = cterm_of proto_ct;
249.207 + val _ = (Sign.no_frees pp o map_types (K dummyT) o Sign.no_vars pp)
249.208 + (Thm.term_of ct);
249.209 + val thm = Code.preprocess_conv thy ct;
249.210 + val ct' = Thm.rhs_of thm;
249.211 + val t' = Thm.term_of ct';
249.212 + val vs = Term.add_tfrees t' [];
249.213 + val consts = fold_aterms
249.214 + (fn Const (c, _) => insert (op =) c | _ => I) t' [];
249.215 +
249.216 + val t'' = prepare_sorts prep_sort t';
249.217 + val (algebra', eqngr') = obtain thy consts [t''];
249.218 + in conclude_evaluation (evaluator algebra' eqngr' vs t'' ct') thm end;
249.219
249.220 -fun code_thms thy = Pretty.writeln o pretty thy o code_depgr thy;
249.221 +fun simple_evaluator evaluator algebra eqngr vs t ct =
249.222 + evaluator algebra eqngr vs t;
249.223
249.224 -fun code_deps thy consts =
249.225 +fun eval_conv thy =
249.226 let
249.227 - val eqngr = code_depgr thy consts;
249.228 - val constss = Graph.strong_conn eqngr;
249.229 - val mapping = Symtab.empty |> fold (fn consts => fold (fn const =>
249.230 - Symtab.update (const, consts)) consts) constss;
249.231 - fun succs consts = consts
249.232 - |> maps (Graph.imm_succs eqngr)
249.233 - |> subtract (op =) consts
249.234 - |> map (the o Symtab.lookup mapping)
249.235 - |> distinct (op =);
249.236 - val conn = [] |> fold (fn consts => cons (consts, succs consts)) constss;
249.237 - fun namify consts = map (Code_Unit.string_of_const thy) consts
249.238 - |> commas;
249.239 - val prgr = map (fn (consts, constss) =>
249.240 - { name = namify consts, ID = namify consts, dir = "", unfold = true,
249.241 - path = "", parents = map namify constss }) conn;
249.242 - in Present.display_graph prgr end;
249.243 + fun conclude_evaluation thm2 thm1 =
249.244 + let
249.245 + val thm3 = Code.postprocess_conv thy (Thm.rhs_of thm2);
249.246 + in
249.247 + Thm.transitive thm1 (Thm.transitive thm2 thm3) handle THM _ =>
249.248 + error ("could not construct evaluation proof:\n"
249.249 + ^ (cat_lines o map Display.string_of_thm) [thm1, thm2, thm3])
249.250 + end;
249.251 + in gen_eval thy I conclude_evaluation end;
249.252
249.253 -local
249.254 -
249.255 -structure P = OuterParse
249.256 -and K = OuterKeyword
249.257 -
249.258 -fun code_thms_cmd thy = code_thms thy o op @ o Code_Name.read_const_exprs thy;
249.259 -fun code_deps_cmd thy = code_deps thy o op @ o Code_Name.read_const_exprs thy;
249.260 -
249.261 -in
249.262 -
249.263 -val _ =
249.264 - OuterSyntax.improper_command "code_thms" "print system of code equations for code" OuterKeyword.diag
249.265 - (Scan.repeat P.term_group
249.266 - >> (fn cs => Toplevel.no_timing o Toplevel.unknown_theory
249.267 - o Toplevel.keep ((fn thy => code_thms_cmd thy cs) o Toplevel.theory_of)));
249.268 -
249.269 -val _ =
249.270 - OuterSyntax.improper_command "code_deps" "visualize dependencies of code equations for code" OuterKeyword.diag
249.271 - (Scan.repeat P.term_group
249.272 - >> (fn cs => Toplevel.no_timing o Toplevel.unknown_theory
249.273 - o Toplevel.keep ((fn thy => code_deps_cmd thy cs) o Toplevel.theory_of)));
249.274 -
249.275 -end;
249.276 +fun eval thy prep_sort postproc evaluator = gen_eval thy (Thm.cterm_of thy)
249.277 + (K o postproc (Code.postprocess_term thy)) prep_sort (simple_evaluator evaluator);
249.278
249.279 end; (*struct*)
250.1 --- a/src/Tools/nbe.ML Mon May 11 09:39:53 2009 +0200
250.2 +++ b/src/Tools/nbe.ML Mon May 11 17:20:52 2009 +0200
250.3 @@ -7,11 +7,10 @@
250.4 signature NBE =
250.5 sig
250.6 val norm_conv: cterm -> thm
250.7 - val norm_term: theory -> term -> term
250.8 + val norm: theory -> term -> term
250.9
250.10 datatype Univ =
250.11 Const of int * Univ list (*named (uninterpreted) constants*)
250.12 - | Free of string * Univ list (*free (uninterpreted) variables*)
250.13 | DFree of string * int (*free (uninterpreted) dictionary parameters*)
250.14 | BVar of int * Univ list
250.15 | Abs of (int * (Univ list -> Univ)) * Univ list
250.16 @@ -57,14 +56,12 @@
250.17
250.18 datatype Univ =
250.19 Const of int * Univ list (*named (uninterpreted) constants*)
250.20 - | Free of string * Univ list (*free variables*)
250.21 | DFree of string * int (*free (uninterpreted) dictionary parameters*)
250.22 | BVar of int * Univ list (*bound variables, named*)
250.23 | Abs of (int * (Univ list -> Univ)) * Univ list
250.24 (*abstractions as closures*);
250.25
250.26 fun same (Const (k, xs)) (Const (l, ys)) = k = l andalso sames xs ys
250.27 - | same (Free (s, xs)) (Free (t, ys)) = s = t andalso sames xs ys
250.28 | same (DFree (s, k)) (DFree (t, l)) = s = t andalso k = l
250.29 | same (BVar (k, xs)) (BVar (l, ys)) = k = l andalso sames xs ys
250.30 | same _ _ = false
250.31 @@ -80,7 +77,6 @@
250.32 | GREATER => Abs ((k, f), ys @ xs) (*note: reverse convention also for apps!*)
250.33 end
250.34 | apps (Const (name, xs)) ys = Const (name, ys @ xs)
250.35 - | apps (Free (name, xs)) ys = Free (name, ys @ xs)
250.36 | apps (BVar (n, xs)) ys = BVar (n, ys @ xs);
250.37
250.38
250.39 @@ -194,7 +190,7 @@
250.40 let
250.41 val (t', ts) = Code_Thingol.unfold_app t
250.42 in of_iapp match_cont t' (fold_rev (cons o of_iterm NONE) ts []) end
250.43 - and of_iapp match_cont (IConst (c, (dss, _))) ts = constapp c dss ts
250.44 + and of_iapp match_cont (IConst (c, ((_, dss), _))) ts = constapp c dss ts
250.45 | of_iapp match_cont (IVar v) ts = nbe_apps (nbe_bound v) ts
250.46 | of_iapp match_cont ((v, _) `|-> t) ts =
250.47 nbe_apps (nbe_abss 1 (ml_abs (ml_list [nbe_bound v]) (of_iterm NONE t))) ts
250.48 @@ -299,15 +295,15 @@
250.49 val params = Name.invent_list [] "d" (length names);
250.50 fun mk (k, name) =
250.51 (name, ([(v, [])],
250.52 - [([IConst (class, ([], [])) `$$ map IVar params], IVar (nth params k))]));
250.53 + [([IConst (class, (([], []), [])) `$$ map IVar params], IVar (nth params k))]));
250.54 in map_index mk names end
250.55 | eqns_of_stmt (_, Code_Thingol.Classrel _) =
250.56 []
250.57 | eqns_of_stmt (_, Code_Thingol.Classparam _) =
250.58 []
250.59 | eqns_of_stmt (inst, Code_Thingol.Classinst ((class, (_, arities)), (superinsts, instops))) =
250.60 - [(inst, (arities, [([], IConst (class, ([], [])) `$$
250.61 - map (fn (_, (_, (inst, dicts))) => IConst (inst, (dicts, []))) superinsts
250.62 + [(inst, (arities, [([], IConst (class, (([], []), [])) `$$
250.63 + map (fn (_, (_, (inst, dicts))) => IConst (inst, (([], dicts), []))) superinsts
250.64 @ map (IConst o snd o fst) instops)]))];
250.65
250.66 fun compile_stmts ctxt stmts_deps =
250.67 @@ -350,20 +346,27 @@
250.68
250.69 (* term evaluation *)
250.70
250.71 -fun eval_term ctxt gr deps ((vs, ty) : typscheme, t) =
250.72 +fun eval_term ctxt gr deps (vs : (string * sort) list, t) =
250.73 let
250.74 - val frees = Code_Thingol.fold_unbound_varnames (insert (op =)) t []
250.75 - val frees' = map (fn v => Free (v, [])) frees;
250.76 val dict_frees = maps (fn (v, sort) => map_index (curry DFree v o fst) sort) vs;
250.77 in
250.78 - ("", (vs, [(map IVar frees, t)]))
250.79 + ("", (vs, [([], t)]))
250.80 |> singleton (compile_eqnss ctxt gr deps)
250.81 |> snd
250.82 - |> (fn t => apps t (rev (dict_frees @ frees')))
250.83 + |> (fn t => apps t (rev dict_frees))
250.84 end;
250.85
250.86 (* reification *)
250.87
250.88 +fun typ_of_itype program vs (ityco `%% itys) =
250.89 + let
250.90 + val Code_Thingol.Datatype (tyco, _) = Graph.get_node program ityco;
250.91 + in Type (tyco, map (typ_of_itype program vs) itys) end
250.92 + | typ_of_itype program vs (ITyVar v) =
250.93 + let
250.94 + val sort = (the o AList.lookup (op =) vs) v;
250.95 + in TFree ("'" ^ v, sort) end;
250.96 +
250.97 fun term_of_univ thy program idx_tab t =
250.98 let
250.99 fun take_until f [] = []
250.100 @@ -390,8 +393,6 @@
250.101 val T' = map_type_tfree (fn (v, _) => TypeInfer.param typidx (v, [])) T;
250.102 val typidx' = typidx + 1;
250.103 in of_apps bounds (Term.Const (c, T'), ts') typidx' end
250.104 - | of_univ bounds (Free (name, ts)) typidx =
250.105 - of_apps bounds (Term.Free (name, dummyT), ts) typidx
250.106 | of_univ bounds (BVar (n, ts)) typidx =
250.107 of_apps bounds (Bound (bounds - n - 1), ts) typidx
250.108 | of_univ bounds (t as Abs _) typidx =
250.109 @@ -418,43 +419,37 @@
250.110
250.111 (* compilation, evaluation and reification *)
250.112
250.113 -fun compile_eval thy naming program vs_ty_t deps =
250.114 +fun compile_eval thy naming program vs_t deps =
250.115 let
250.116 val ctxt = ProofContext.init thy;
250.117 val (_, (gr, (_, idx_tab))) =
250.118 Nbe_Functions.change thy (ensure_stmts ctxt naming program o snd);
250.119 in
250.120 - vs_ty_t
250.121 + vs_t
250.122 |> eval_term ctxt gr deps
250.123 |> term_of_univ thy program idx_tab
250.124 end;
250.125
250.126 (* evaluation with type reconstruction *)
250.127
250.128 -fun eval thy t naming program vs_ty_t deps =
250.129 +fun normalize thy naming program ((vs0, (vs, ty)), t) deps =
250.130 let
250.131 fun subst_const f = map_aterms (fn t as Term.Const (c, ty) => Term.Const (f c, ty)
250.132 | t => t);
250.133 - val subst_triv_consts = subst_const (Code_Unit.resubst_alias thy);
250.134 - val ty = type_of t;
250.135 - val type_free = AList.lookup (op =)
250.136 - (map (fn (s, T) => (s, Term.Free (s, T))) (Term.add_frees t []));
250.137 - val type_frees = Term.map_aterms
250.138 - (fn (t as Term.Free (s, _)) => the_default t (type_free s) | t => t);
250.139 + val resubst_triv_consts = subst_const (Code_Unit.resubst_alias thy);
250.140 + val ty' = typ_of_itype program vs0 ty;
250.141 fun type_infer t =
250.142 singleton (TypeInfer.infer_types (Syntax.pp_global thy) (Sign.tsig_of thy) I
250.143 (try (Type.strip_sorts o Sign.the_const_type thy)) (K NONE) Name.context 0)
250.144 - (TypeInfer.constrain ty t);
250.145 + (TypeInfer.constrain ty' t);
250.146 fun check_tvars t = if null (Term.add_tvars t []) then t else
250.147 error ("Illegal schematic type variables in normalized term: "
250.148 ^ setmp show_types true (Syntax.string_of_term_global thy) t);
250.149 val string_of_term = setmp show_types true (Syntax.string_of_term_global thy);
250.150 in
250.151 - compile_eval thy naming program vs_ty_t deps
250.152 + compile_eval thy naming program (vs, t) deps
250.153 |> tracing (fn t => "Normalized:\n" ^ string_of_term t)
250.154 - |> subst_triv_consts
250.155 - |> type_frees
250.156 - |> tracing (fn t => "Vars typed:\n" ^ string_of_term t)
250.157 + |> resubst_triv_consts
250.158 |> type_infer
250.159 |> tracing (fn t => "Types inferred:\n" ^ string_of_term t)
250.160 |> check_tvars
250.161 @@ -463,39 +458,59 @@
250.162
250.163 (* evaluation oracle *)
250.164
250.165 -val (_, norm_oracle) = Context.>>> (Context.map_theory_result
250.166 - (Thm.add_oracle (Binding.name "norm", fn (thy, t, naming, program, vs_ty_t, deps) =>
250.167 - Thm.cterm_of thy (Logic.mk_equals (t, eval thy t naming program vs_ty_t deps)))));
250.168 +fun add_triv_classes thy = curry (Sorts.inter_sort (Sign.classes_of thy))
250.169 + (Code_Unit.triv_classes thy);
250.170
250.171 -fun add_triv_classes thy =
250.172 +fun mk_equals thy lhs raw_rhs =
250.173 let
250.174 - val inters = curry (Sorts.inter_sort (Sign.classes_of thy))
250.175 - (Code_Unit.triv_classes thy);
250.176 - fun map_sorts f = (map_types o map_atyps)
250.177 - (fn TVar (v, sort) => TVar (v, f sort)
250.178 - | TFree (v, sort) => TFree (v, f sort));
250.179 - in map_sorts inters end;
250.180 + val ty = Thm.typ_of (Thm.ctyp_of_term lhs);
250.181 + val eq = Thm.cterm_of thy (Term.Const ("==", ty --> ty --> propT));
250.182 + val rhs = Thm.cterm_of thy raw_rhs;
250.183 + in Thm.mk_binop eq lhs rhs end;
250.184
250.185 -fun norm_conv ct =
250.186 +val (_, raw_norm_oracle) = Context.>>> (Context.map_theory_result
250.187 + (Thm.add_oracle (Binding.name "norm", fn (thy, naming, program, vsp_ty_t, deps, ct) =>
250.188 + mk_equals thy ct (normalize thy naming program vsp_ty_t deps))));
250.189 +
250.190 +fun norm_oracle thy naming program vsp_ty_t deps ct =
250.191 + raw_norm_oracle (thy, naming, program, vsp_ty_t, deps, ct);
250.192 +
250.193 +fun no_frees_conv conv ct =
250.194 + let
250.195 + val frees = Thm.add_cterm_frees ct [];
250.196 + fun apply_beta free thm = Thm.combination thm (Thm.reflexive free)
250.197 + |> Conv.fconv_rule (Conv.arg_conv (Conv.try_conv (Thm.beta_conversion false)))
250.198 + |> Conv.fconv_rule (Conv.arg1_conv (Thm.beta_conversion false));
250.199 + in
250.200 + ct
250.201 + |> fold_rev Thm.cabs frees
250.202 + |> conv
250.203 + |> fold apply_beta frees
250.204 + end;
250.205 +
250.206 +fun no_frees_rew rew t =
250.207 + let
250.208 + val frees = map Free (Term.add_frees t []);
250.209 + in
250.210 + t
250.211 + |> fold_rev lambda frees
250.212 + |> rew
250.213 + |> (fn t' => Term.betapplys (t', frees))
250.214 + end;
250.215 +
250.216 +val norm_conv = no_frees_conv (fn ct =>
250.217 let
250.218 val thy = Thm.theory_of_cterm ct;
250.219 - fun evaluator' t naming program vs_ty_t deps =
250.220 - norm_oracle (thy, t, naming, program, vs_ty_t, deps);
250.221 - fun evaluator t = (add_triv_classes thy t, evaluator' t);
250.222 - in Code_Thingol.eval_conv thy evaluator ct end;
250.223 + in Code_Thingol.eval_conv thy (add_triv_classes thy) (norm_oracle thy) ct end);
250.224
250.225 -fun norm_term thy t =
250.226 - let
250.227 - fun evaluator' t naming program vs_ty_t deps = eval thy t naming program vs_ty_t deps;
250.228 - fun evaluator t = (add_triv_classes thy t, evaluator' t);
250.229 - in (Code.postprocess_term thy o Code_Thingol.eval_term thy evaluator) t end;
250.230 +fun norm thy = no_frees_rew (Code_Thingol.eval thy (add_triv_classes thy) I (normalize thy));
250.231
250.232 (* evaluation command *)
250.233
250.234 fun norm_print_term ctxt modes t =
250.235 let
250.236 val thy = ProofContext.theory_of ctxt;
250.237 - val t' = norm_term thy t;
250.238 + val t' = norm thy t;
250.239 val ty' = Term.type_of t';
250.240 val ctxt' = Variable.auto_fixes t ctxt;
250.241 val p = PrintMode.with_modes modes (fn () =>
250.242 @@ -510,8 +525,7 @@
250.243 let val ctxt = Toplevel.context_of state
250.244 in norm_print_term ctxt modes (Syntax.read_term ctxt s) end;
250.245
250.246 -val setup =
250.247 - Value.add_evaluator ("nbe", norm_term o ProofContext.theory_of);
250.248 +val setup = Value.add_evaluator ("nbe", norm o ProofContext.theory_of);
250.249
250.250 local structure P = OuterParse and K = OuterKeyword in
250.251
251.1 --- a/src/Tools/quickcheck.ML Mon May 11 09:39:53 2009 +0200
251.2 +++ b/src/Tools/quickcheck.ML Mon May 11 17:20:52 2009 +0200
251.3 @@ -6,28 +6,48 @@
251.4
251.5 signature QUICKCHECK =
251.6 sig
251.7 - val test_term: Proof.context -> bool -> string option -> int -> int -> term -> (string * term) list option;
251.8 - val add_generator: string * (Proof.context -> term -> int -> term list option) -> theory -> theory
251.9 val auto: bool ref
251.10 val auto_time_limit: int ref
251.11 + val test_term: Proof.context -> bool -> string option -> int -> int -> term ->
251.12 + (string * term) list option
251.13 + val add_generator: string * (Proof.context -> term -> int -> term list option) -> theory -> theory
251.14 end;
251.15
251.16 structure Quickcheck : QUICKCHECK =
251.17 struct
251.18
251.19 +(* preferences *)
251.20 +
251.21 +val auto = ref false;
251.22 +val auto_time_limit = ref 2500;
251.23 +
251.24 +val _ =
251.25 + ProofGeneralPgip.add_preference Preferences.category_tracing
251.26 + (setmp auto true (fn () =>
251.27 + Preferences.bool_pref auto
251.28 + "auto-quickcheck"
251.29 + "Whether to enable quickcheck automatically.") ());
251.30 +
251.31 +val _ =
251.32 + ProofGeneralPgip.add_preference Preferences.category_tracing
251.33 + (Preferences.nat_pref auto_time_limit
251.34 + "auto-quickcheck-time-limit"
251.35 + "Time limit for automatic quickcheck (in milliseconds).");
251.36 +
251.37 +
251.38 (* quickcheck configuration -- default parameters, test generators *)
251.39
251.40 datatype test_params = Test_Params of
251.41 { size: int, iterations: int, default_type: typ option };
251.42
251.43 -fun dest_test_params (Test_Params { size, iterations, default_type}) =
251.44 +fun dest_test_params (Test_Params { size, iterations, default_type }) =
251.45 ((size, iterations), default_type);
251.46 fun mk_test_params ((size, iterations), default_type) =
251.47 Test_Params { size = size, iterations = iterations, default_type = default_type };
251.48 fun map_test_params f (Test_Params { size, iterations, default_type}) =
251.49 mk_test_params (f ((size, iterations), default_type));
251.50 -fun merge_test_params (Test_Params {size = size1, iterations = iterations1, default_type = default_type1},
251.51 - Test_Params {size = size2, iterations = iterations2, default_type = default_type2}) =
251.52 +fun merge_test_params (Test_Params { size = size1, iterations = iterations1, default_type = default_type1 },
251.53 + Test_Params { size = size2, iterations = iterations2, default_type = default_type2 }) =
251.54 mk_test_params ((Int.max (size1, size2), Int.max (iterations1, iterations2)),
251.55 case default_type1 of NONE => default_type2 | _ => default_type1);
251.56
251.57 @@ -138,10 +158,7 @@
251.58
251.59 (* automatic testing *)
251.60
251.61 -val auto = ref false;
251.62 -val auto_time_limit = ref 5000;
251.63 -
251.64 -fun test_goal_auto int state =
251.65 +val _ = Context.>> (Specification.add_theorem_hook (fn int => fn state =>
251.66 let
251.67 val ctxt = Proof.context_of state;
251.68 val assms = map term_of (Assumption.all_assms_of ctxt);
251.69 @@ -162,12 +179,10 @@
251.70 if int andalso !auto andalso not (!Toplevel.quiet)
251.71 then test ()
251.72 else state
251.73 - end;
251.74 + end));
251.75
251.76 -val _ = Context.>> (Specification.add_theorem_hook test_goal_auto);
251.77
251.78 -
251.79 -(* Isar interfaces *)
251.80 +(* Isar commands *)
251.81
251.82 fun read_nat s = case (Library.read_int o Symbol.explode) s
251.83 of (k, []) => if k >= 0 then k