1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/Admin/MacOS/README Tue Dec 30 11:10:01 2008 +0100
1.3 @@ -0,0 +1,17 @@
1.4 +Isabelle application bundle for MacOS
1.5 +=====================================
1.6 +
1.7 +Requirements:
1.8 +
1.9 +* CocoaDialog http://cocoadialog.sourceforge.net/
1.10 +
1.11 +* Platypus http://www.sveinbjorn.org/platypus
1.12 +
1.13 +* AppHack 1.1 http://www.sveinbjorn.org/apphack
1.14 +
1.15 + Manual setup:
1.16 + File type: "Isabelle theory"
1.17 + Icon: "theory.icns"
1.18 + "Editor"
1.19 + Suffixes: "thy"
1.20 +
2.1 Binary file Admin/MacOS/isabelle.icns has changed
3.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
3.2 +++ b/Admin/MacOS/mk Tue Dec 30 11:10:01 2008 +0100
3.3 @@ -0,0 +1,19 @@
3.4 +#!/bin/bash
3.5 +#
3.6 +# Make Isabelle application bundle
3.7 +
3.8 +THIS="$(cd "$(dirname "$0")"; pwd)"
3.9 +
3.10 +PLATYPUS_APP="/Applications/Platypus-4.0/Platypus.app"
3.11 +COCOADIALOG_APP="/Applications/CocoaDialog.app"
3.12 +
3.13 +"$PLATYPUS_APP/Contents/Resources/platypus" \
3.14 + -a Isabelle -u Isabelle \
3.15 + -I "de.tum.in.isabelle" \
3.16 + -i "$THIS/isabelle.icns" \
3.17 + -D -X thy \
3.18 + -p /bin/bash \
3.19 + -c "$THIS/script" \
3.20 + -o None \
3.21 + -f "$COCOADIALOG_APP" \
3.22 + "$PWD/Isabelle.app"
4.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
4.2 +++ b/Admin/MacOS/script Tue Dec 30 11:10:01 2008 +0100
4.3 @@ -0,0 +1,78 @@
4.4 +#!/bin/bash
4.5 +#
4.6 +# Author: Makarius
4.7 +#
4.8 +# Isabelle application wrapper
4.9 +
4.10 +THIS="$(cd "$(dirname "$0")"; pwd)"
4.11 +THIS_APP="$(cd "$THIS/../.."; pwd)"
4.12 +SUPER_APP="$(cd "$THIS/../../.."; pwd)"
4.13 +
4.14 +
4.15 +# sane environment defaults
4.16 +cd "$HOME"
4.17 +PATH="$PATH:/opt/local/bin"
4.18 +
4.19 +
4.20 +# settings support
4.21 +
4.22 +function choosefrom ()
4.23 +{
4.24 + local RESULT=""
4.25 + local FILE=""
4.26 +
4.27 + for FILE in "$@"
4.28 + do
4.29 + [ -z "$RESULT" -a -e "$FILE" ] && RESULT="$FILE"
4.30 + done
4.31 +
4.32 + [ -z "$RESULT" ] && RESULT="$FILE"
4.33 + echo "$RESULT"
4.34 +}
4.35 +
4.36 +
4.37 +# Isabelle
4.38 +
4.39 +ISABELLE_TOOL="$(choosefrom \
4.40 + "$THIS/Isabelle/bin/isabelle" \
4.41 + "$SUPER_APP/Isabelle/bin/isabelle" \
4.42 + "$HOME/bin/isabelle" \
4.43 + isabelle)"
4.44 +
4.45 +
4.46 +# Proof General / Emacs
4.47 +
4.48 +PROOFGENERAL_EMACS="$(choosefrom \
4.49 + "$THIS/Emacs.app/Contents/MacOS/Emacs" \
4.50 + "$SUPER_APP/Emacs.app/Contents/MacOS/Emacs" \
4.51 + /Applications/Emacs.app/Contents/MacOS/Emacs \
4.52 + "")"
4.53 +
4.54 +if [ -n "$PROOFGENERAL_EMACS" ]; then
4.55 + PROOFGENERAL_OPTIONS="-p $PROOFGENERAL_EMACS $PROOFGENERAL_OPTIONS"
4.56 +fi
4.57 +
4.58 +
4.59 +# run interface with error feedback
4.60 +
4.61 +OUTPUT="/tmp/isabelle$$.out"
4.62 +
4.63 +( "$HOME/bin/isabelle" emacs "$@" ) > "$OUTPUT" 2>&1
4.64 +RC=$?
4.65 +
4.66 +if [ "$RC" != 0 ]; then
4.67 + echo >> "$OUTPUT"
4.68 + echo "Return code: $RC" >> "$OUTPUT"
4.69 +fi
4.70 +
4.71 +if [ $(stat -f "%z" "$OUTPUT") != 0 ]; then
4.72 + "$THIS/CocoaDialog.app/Contents/MacOS/CocoaDialog" textbox \
4.73 + --title "Isabelle" \
4.74 + --informative-text "Isabelle output" \
4.75 + --text-from-file "$OUTPUT" \
4.76 + --button1 "OK"
4.77 +fi
4.78 +
4.79 +rm -f "$OUTPUT"
4.80 +
4.81 +exit "$RC"
5.1 Binary file Admin/MacOS/theory.icns has changed
6.1 --- a/Admin/Mercurial/isabelle-style.diff Tue Dec 30 08:18:54 2008 +0100
6.2 +++ b/Admin/Mercurial/isabelle-style.diff Tue Dec 30 11:10:01 2008 +0100
6.3 @@ -13,23 +13,22 @@
6.4 > <div class="files">
6.5 > #files#
6.6 > </div>
6.7 -Only in isabelle: filelog.tmpl~
6.8 +diff -r gitweb/changeset.tmpl isabelle/changeset.tmpl
6.9 +19c19
6.10 +< <a class="title" href="{url}raw-rev/#node|short#">#desc|strip|escape|firstline# <span class="logtags">{inbranch%inbranchtag}{branches%branchtag}{tags%tagtag}</span></a>
6.11 +---
6.12 +> <a class="title" href="{url}raw-rev/#node|short#">#desc|strip|escape# <span class="logtags">{inbranch%inbranchtag}{branches%branchtag}{tags%tagtag}</span></a>
6.13 diff -r gitweb/map isabelle/map
6.14 -56,57c56,57
6.15 +29c29
6.16 +< annotateline = '<tr style="font-family:monospace" class="parity#parity#"><td class="linenr" style="text-align: right;"><a href="#url#annotate/#node|short#/#file|urlescape#{sessionvars%urlparameter}#l{targetline}" title="{node|short}: {desc|escape|firstline}">#author|user#@#rev#</a></td><td><pre><a class="linenr" href="##lineid#" id="#lineid#">#linenumber#</a></pre></td><td><pre>#line|escape#</pre></td></tr>'
6.17 +---
6.18 +> annotateline = '<tr style="font-family:monospace" class="parity#parity#"><td class="linenr" style="text-align: right;"><a href="#url#annotate/#node|short#/#file|urlescape#{sessionvars%urlparameter}#l{targetline}" title="{node|short}: {desc|escape}">#author|user#@#rev#</a></td><td><pre><a class="linenr" href="##lineid#" id="#lineid#">#linenumber#</a></pre></td><td><pre>#line|escape#</pre></td></tr>'
6.19 +59,60c59,60
6.20 < shortlogentry = '<tr class="parity#parity#"><td class="age"><i>#date|age# ago</i></td><td><i>#author|person#</i></td><td><a class="list" href="{url}rev/#node|short#{sessionvars%urlparameter}"><b>#desc|strip|firstline|escape#</b> <span class="logtags">{inbranch%inbranchtag}{branches%branchtag}{tags%tagtag}</span></a></td><td class="link" nowrap><a href="{url}rev/#node|short#{sessionvars%urlparameter}">changeset</a> | <a href="{url}file/#node|short#{sessionvars%urlparameter}">files</a></td></tr>'
6.21 < filelogentry = '<tr class="parity#parity#"><td class="age"><i>#date|age# ago</i></td><td><a class="list" href="{url}rev/#node|short#{sessionvars%urlparameter}"><b>#desc|strip|firstline|escape#</b></a></td><td class="link"><a href="{url}file/#node|short#/#file|urlescape#{sessionvars%urlparameter}">file</a> | <a href="{url}diff/#node|short#/#file|urlescape#{sessionvars%urlparameter}">diff</a> | <a href="{url}annotate/#node|short#/#file|urlescape#{sessionvars%urlparameter}">annotate</a> #rename%filelogrename#</td></tr>'
6.22 ---
6.23 > shortlogentry = '<tr class="parity#parity#"><td class="age"><i>#date|age# ago</i></td><td><i>#date|shortdate#</i></td><td><i>#author|person#</i></td><td><a class="list" href="{url}rev/#node|short#{sessionvars%urlparameter}"><b>#desc|strip|escape#</b> <span class="logtags">{inbranch%inbranchtag}{branches%branchtag}{tags%tagtag}</span></a></td><td class="link" nowrap><a href="{url}rev/#node|short#{sessionvars%urlparameter}">changeset</a> | <a href="{url}file/#node|short#{sessionvars%urlparameter}">files</a></td></tr>'
6.24 > filelogentry = '<tr class="parity#parity#"><td class="age"><i>#date|age# ago</i></td><td><i>#date|shortdate#</i></td><td><i>#author|person#</i></td><td><a class="list" href="{url}rev/#node|short#{sessionvars%urlparameter}"><b>#desc|strip|escape#</b></a></td><td class="link"><a href="{url}file/#node|short#/#file|urlescape#{sessionvars%urlparameter}">file</a> | <a href="{url}diff/#node|short#/#file|urlescape#{sessionvars%urlparameter}">diff</a> | <a href="{url}annotate/#node|short#/#file|urlescape#{sessionvars%urlparameter}">annotate</a> #rename%filelogrename#</td></tr>'
6.25 -Only in isabelle: map~
6.26 diff -r gitweb/summary.tmpl isabelle/summary.tmpl
6.27 -33d32
6.28 +34d33
6.29 < <tr><td>owner</td><td>#owner|obfuscate#</td></tr>
6.30 -49,55d47
6.31 -< <div><a class="title" href="#">branches</a></div>
6.32 -< <table cellspacing="0">
6.33 -< {branches%branchentry}
6.34 -< <tr class="light">
6.35 -< <td colspan="4"><a class="list" href="#">...</a></td>
6.36 -< </tr>
6.37 -< </table>
7.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
7.2 +++ b/Admin/Mercurial/misc.diff Tue Dec 30 11:10:01 2008 +0100
7.3 @@ -0,0 +1,20 @@
7.4 +diff -r hgweb/webcommands.py hgweb/webcommands.py
7.5 +653c653
7.6 +< desc = templatefilters.firstline(ctx.description())
7.7 +---
7.8 +> desc = ctx.description()
7.9 +diff -r templates/atom/changelogentry.tmpl templates/atom/changelogentry.tmpl
7.10 +2c2
7.11 +< <title>#desc|strip|firstline|strip|escape#</title>
7.12 +---
7.13 +> <title>#desc|strip|escape#</title>
7.14 +diff -r templates/rss/changelogentry.tmpl templates/rss/changelogentry.tmpl
7.15 +2c2
7.16 +< <title>#desc|strip|firstline|strip|escape#</title>
7.17 +---
7.18 +> <title>#desc|strip|escape#</title>
7.19 +diff -r templates/rss/filelogentry.tmpl templates/rss/filelogentry.tmpl
7.20 +2c2
7.21 +< <title>#desc|strip|firstline|strip|escape#</title>
7.22 +---
7.23 +> <title>#desc|strip|escape#</title>
8.1 --- a/Admin/build Tue Dec 30 08:18:54 2008 +0100
8.2 +++ b/Admin/build Tue Dec 30 11:10:01 2008 +0100
8.3 @@ -7,7 +7,7 @@
8.4 #paranoia setting for sunbroy
8.5 PATH="/usr/local/dist/DIR/j2sdk1.5.0/bin:$PATH"
8.6
8.7 -PATH="/home/scala/scala/bin:$PATH"
8.8 +PATH="/home/scala/current/bin:$PATH"
8.9
8.10
8.11 ## directory layout
8.12 @@ -101,15 +101,6 @@
8.13 pushd "$ISABELLE_HOME/src/Pure" >/dev/null
8.14 "$ISABELLE_TOOL" make jar || fail "Failed to build Pure.jar!"
8.15 popd >/dev/null
8.16 -
8.17 - if [ -d "$HOME/lib/jedit/current" ]; then
8.18 - pushd "$ISABELLE_HOME/lib/jedit/plugin" >/dev/null
8.19 - ./mk
8.20 - [ -f ../isabelle.jar ] || fail "Failed to build jEdit plugin!"
8.21 - popd >/dev/null
8.22 - else
8.23 - echo "Warning: skipping jedit plugin"
8.24 - fi
8.25 }
8.26
8.27
9.1 --- a/Admin/isatest/settings/at-mac-poly-5.1-para Tue Dec 30 08:18:54 2008 +0100
9.2 +++ b/Admin/isatest/settings/at-mac-poly-5.1-para Tue Dec 30 11:10:01 2008 +0100
9.3 @@ -4,7 +4,7 @@
9.4 ML_SYSTEM="polyml-5.2.1"
9.5 ML_PLATFORM="x86-darwin"
9.6 ML_HOME="$POLYML_HOME/$ML_PLATFORM"
9.7 - ML_OPTIONS="-H 2000"
9.8 + ML_OPTIONS="--immutable 800 --mutable 1200"
9.9
9.10
9.11 ISABELLE_HOME_USER=~/isabelle-at-mac-poly-e
10.1 --- a/CONTRIBUTORS Tue Dec 30 08:18:54 2008 +0100
10.2 +++ b/CONTRIBUTORS Tue Dec 30 11:10:01 2008 +0100
10.3 @@ -7,6 +7,9 @@
10.4 Contributions to this Isabelle version
10.5 --------------------------------------
10.6
10.7 +* December 2008: Armin Heller, TUM and Alexander Krauss, TUM
10.8 + Method "sizechange" for advanced termination proofs.
10.9 +
10.10 * November 2008: Timothy Bourke, NICTA
10.11 Performance improvement (factor 50) for find_theorems.
10.12
10.13 @@ -204,5 +207,3 @@
10.14 * 2004/2005: Tjark Weber, TUM
10.15 SAT solver method using zChaff.
10.16 Improved version of HOL/refute.
10.17 -
10.18 -$Id$
11.1 --- a/INSTALL Tue Dec 30 08:18:54 2008 +0100
11.2 +++ b/INSTALL Tue Dec 30 11:10:01 2008 +0100
11.3 @@ -85,6 +85,3 @@
11.4 Note that the site-wide Isabelle installation may already provide
11.5 Isabelle executables in some global bin directory (such as
11.6 /usr/local/bin).
11.7 -
11.8 -
11.9 -$Id$
12.1 --- a/NEWS Tue Dec 30 08:18:54 2008 +0100
12.2 +++ b/NEWS Tue Dec 30 11:10:01 2008 +0100
12.3 @@ -42,6 +42,11 @@
12.4 ISABELLE_HOME_USER can be changed in Isabelle/etc/settings of any
12.5 Isabelle distribution.
12.6
12.7 +* Proofs of fully specified statements are run in parallel on
12.8 +multi-core systems. A speedup factor of 2-3 can be expected on a
12.9 +regular 4-core machine, if the initial heap space is made reasonably
12.10 +large (cf. Poly/ML option -H). [Poly/ML 5.2.1 or later]
12.11 +
12.12 * The Isabelle System Manual (system) has been updated, with formally
12.13 checked references as hyperlinks.
12.14
12.15 @@ -55,8 +60,8 @@
12.16 * Removed exotic 'token_translation' command. INCOMPATIBILITY, use ML
12.17 interface instead.
12.18
12.19 -* There is a new lexical item "float" with syntax ["-"] digit+ "." digit+,
12.20 -without spaces.
12.21 +* There is a new syntactic category "float_const" for signed decimal
12.22 +fractions (e.g. 123.45 or -123.45).
12.23
12.24
12.25 *** Pure ***
12.26 @@ -152,11 +157,12 @@
12.27
12.28 *** HOL ***
12.29
12.30 -* Made repository layout more coherent with logical
12.31 -distribution structure:
12.32 +* Made source layout more coherent with logical distribution
12.33 +structure:
12.34
12.35 src/HOL/Library/RType.thy ~> src/HOL/Typerep.thy
12.36 src/HOL/Library/Code_Message.thy ~> src/HOL/
12.37 + src/HOL/Library/Dense_Linear_Order.thy ~> src/HOL/
12.38 src/HOL/Library/GCD.thy ~> src/HOL/
12.39 src/HOL/Library/Order_Relation.thy ~> src/HOL/
12.40 src/HOL/Library/Parity.thy ~> src/HOL/
12.41 @@ -172,6 +178,7 @@
12.42 src/HOL/Complex/Complex_Main.thy ~> src/HOL/
12.43 src/HOL/Complex/Complex.thy ~> src/HOL/
12.44 src/HOL/Complex/FrechetDeriv.thy ~> src/HOL/
12.45 + src/HOL/Complex/Fundamental_Theorem_Algebra.thy ~> src/HOL/
12.46 src/HOL/Hyperreal/Deriv.thy ~> src/HOL/
12.47 src/HOL/Hyperreal/Fact.thy ~> src/HOL/
12.48 src/HOL/Hyperreal/Integration.thy ~> src/HOL/
12.49 @@ -181,9 +188,12 @@
12.50 src/HOL/Hyperreal/MacLaurin.thy ~> src/HOL/
12.51 src/HOL/Hyperreal/NthRoot.thy ~> src/HOL/
12.52 src/HOL/Hyperreal/Series.thy ~> src/HOL/
12.53 + src/HOL/Hyperreal/SEQ.thy ~> src/HOL/
12.54 src/HOL/Hyperreal/Taylor.thy ~> src/HOL/
12.55 src/HOL/Hyperreal/Transcendental.thy ~> src/HOL/
12.56 src/HOL/Real/Float ~> src/HOL/Library/
12.57 + src/HOL/Real/HahnBanach ~> src/HOL/HahnBanach
12.58 + src/HOL/Real/RealVector.thy ~> src/HOL/
12.59
12.60 src/HOL/arith_data.ML ~> src/HOL/Tools
12.61 src/HOL/hologic.ML ~> src/HOL/Tools
12.62 @@ -239,6 +249,10 @@
12.63 mechanisms may be specified (currently, [SML], [code] or [nbe]). See
12.64 further src/HOL/ex/Eval_Examples.thy.
12.65
12.66 +* New method "sizechange" to automate termination proofs using (a
12.67 +modification of) the size-change principle. Requires SAT solver. See
12.68 +src/HOL/ex/Termination.thy for examples.
12.69 +
12.70 * HOL/Orderings: class "wellorder" moved here, with explicit induction
12.71 rule "less_induct" as assumption. For instantiation of "wellorder" by
12.72 means of predicate "wf", use rule wf_wellorderI. INCOMPATIBILITY.
12.73 @@ -388,6 +402,14 @@
12.74
12.75 *** ML ***
12.76
12.77 +* High-level support for concurrent ML programming, see
12.78 +src/Pure/Cuncurrent. The data-oriented model of "future values" is
12.79 +particularly convenient to organize independent functional
12.80 +computations. The concept of "synchronized variables" provides a
12.81 +higher-order interface for components with shared state, avoiding the
12.82 +delicate details of mutexes and condition variables. [Poly/ML 5.2.1
12.83 +or later]
12.84 +
12.85 * Simplified ML oracle interface Thm.add_oracle promotes 'a -> cterm
12.86 to 'a -> thm, while results are always tagged with an authentic oracle
12.87 name. The Isar command 'oracle' is now polymorphic, no argument type
12.88 @@ -857,8 +879,8 @@
12.89 print_mode_active, PrintMode.setmp etc. INCOMPATIBILITY.
12.90
12.91 * Functions system/system_out provide a robust way to invoke external
12.92 -shell commands, with propagation of interrupts (requires Poly/ML 5.2).
12.93 -Do not use OS.Process.system etc. from the basis library!
12.94 +shell commands, with propagation of interrupts (requires Poly/ML
12.95 +5.2.1). Do not use OS.Process.system etc. from the basis library!
12.96
12.97
12.98 *** System ***
12.99 @@ -5953,6 +5975,3 @@
12.100 types;
12.101
12.102 :mode=text:wrap=hard:maxLineLen=72:
12.103 -
12.104 -
12.105 -$Id$
13.1 --- a/build Tue Dec 30 08:18:54 2008 +0100
13.2 +++ b/build Tue Dec 30 11:10:01 2008 +0100
13.3 @@ -1,6 +1,5 @@
13.4 #!/usr/bin/env bash
13.5 #
13.6 -# $Id$
13.7 # Author: Markus Wenzel, TU Muenchen
13.8 #
13.9 # build - compile the Isabelle system and object-logics
14.1 --- a/doc-src/IsarAdvanced/Classes/style.sty Tue Dec 30 08:18:54 2008 +0100
14.2 +++ b/doc-src/IsarAdvanced/Classes/style.sty Tue Dec 30 11:10:01 2008 +0100
14.3 @@ -30,7 +30,7 @@
14.4
14.5 \pagestyle{headings}
14.6 \binperiod
14.7 -\underscoreon
14.8 +\underscoreoff
14.9
14.10 \renewcommand{\isadigit}[1]{\isamath{#1}}
14.11
15.1 --- a/doc-src/IsarAdvanced/Codegen/style.sty Tue Dec 30 08:18:54 2008 +0100
15.2 +++ b/doc-src/IsarAdvanced/Codegen/style.sty Tue Dec 30 11:10:01 2008 +0100
15.3 @@ -42,7 +42,7 @@
15.4
15.5 \pagestyle{headings}
15.6 \binperiod
15.7 -\underscoreon
15.8 +\underscoreoff
15.9
15.10 \renewcommand{\isadigit}[1]{\isamath{#1}}
15.11
16.1 --- a/doc-src/IsarImplementation/Thy/ML.thy Tue Dec 30 08:18:54 2008 +0100
16.2 +++ b/doc-src/IsarImplementation/Thy/ML.thy Tue Dec 30 11:10:01 2008 +0100
16.3 @@ -107,18 +107,23 @@
16.4 section {* Thread-safe programming *}
16.5
16.6 text {*
16.7 - Recent versions of Poly/ML (5.2 or later) support multithreaded
16.8 - execution based on native operating system threads of the underlying
16.9 - platform. Thus threads will actually be executed in parallel on
16.10 - multi-core systems. A speedup-factor of approximately 2--4 can be
16.11 - expected for large well-structured Isabelle sessions, where theories
16.12 - are organized as a graph with sufficiently many independent nodes.
16.13 + Recent versions of Poly/ML (5.2.1 or later) support robust
16.14 + multithreaded execution, based on native operating system threads of
16.15 + the underlying platform. Thus threads will actually be executed in
16.16 + parallel on multi-core systems. A speedup-factor of approximately
16.17 + 1.5--3 can be expected on a regular 4-core machine.\footnote{There
16.18 + is some inherent limitation of the speedup factor due to garbage
16.19 + collection, which is still sequential. It helps to provide initial
16.20 + heap space generously, using the \texttt{-H} option of Poly/ML.}
16.21 + Threads also help to organize advanced operations of the system,
16.22 + with explicit communication between sub-components, real-time
16.23 + conditions, time-outs etc.
16.24
16.25 - Threads lack the memory protection of separate processes, but
16.26 + Threads lack the memory protection of separate processes, and
16.27 operate concurrently on shared heap memory. This has the advantage
16.28 that results of independent computations are immediately available
16.29 - to other threads, without requiring explicit communication,
16.30 - reloading, or even recoding of data.
16.31 + to other threads, without requiring untyped character streams,
16.32 + awkward serialization etc.
16.33
16.34 On the other hand, some programming guidelines need to be observed
16.35 in order to make unprotected parallelism work out smoothly. While
16.36 @@ -143,27 +148,29 @@
16.37
16.38 \end{itemize}
16.39
16.40 - Note that ML bindings within the toplevel environment (@{verbatim
16.41 - "type"}, @{verbatim val}, @{verbatim "structure"} etc.) due to
16.42 - run-time invocation of the compiler are non-critical, because
16.43 - Isabelle/Isar incorporates such bindings within the theory or proof
16.44 - context.
16.45 -
16.46 The majority of tools implemented within the Isabelle/Isar framework
16.47 will not require any of these critical elements: nothing special
16.48 needs to be observed when staying in the purely functional fragment
16.49 of ML. Note that output via the official Isabelle channels does not
16.50 - even count as direct I/O in the above sense, so the operations @{ML
16.51 - "writeln"}, @{ML "warning"}, @{ML "tracing"} etc.\ are safe.
16.52 + count as direct I/O, so the operations @{ML "writeln"}, @{ML
16.53 + "warning"}, @{ML "tracing"} etc.\ are safe.
16.54
16.55 - \paragraph{Multithreading in Isabelle/Isar.} Our parallel execution
16.56 - model is centered around the theory loader. Whenever a given
16.57 - subgraph of theories needs to be updated, the system schedules a
16.58 - number of threads to process the sources as required, while
16.59 - observing their dependencies. Thus concurrency is limited to
16.60 - independent nodes according to the theory import relation.
16.61 + Moreover, ML bindings within the toplevel environment (@{verbatim
16.62 + "type"}, @{verbatim val}, @{verbatim "structure"} etc.) due to
16.63 + run-time invocation of the compiler are also safe, because
16.64 + Isabelle/Isar manages this as part of the theory or proof context.
16.65
16.66 - Any user-code that works relatively to the present background theory
16.67 + \paragraph{Multithreading in Isabelle/Isar.} The theory loader
16.68 + automatically exploits the overall parallelism of independent nodes
16.69 + in the development graph, as well as the inherent irrelevance of
16.70 + proofs for goals being fully specified in advance. This means,
16.71 + checking of individual Isar proofs is parallelized by default.
16.72 + Beyond that, very sophisticated proof tools may use local
16.73 + parallelism internally, via the general programming model of
16.74 + ``future values'' (see also @{"file"
16.75 + "~~/src/Pure/Concurrent/future.ML"}).
16.76 +
16.77 + Any ML code that works relatively to the present background theory
16.78 is already safe. Contextual data may be easily stored within the
16.79 theory or proof context, thanks to the generic data concept of
16.80 Isabelle/Isar (see \secref{sec:context-data}). This greatly
16.81 @@ -179,9 +186,13 @@
16.82 quickly, otherwise parallel execution performance may degrade
16.83 significantly.
16.84
16.85 - Despite this potential bottle-neck, we refrain from fine-grained
16.86 - locking mechanism within user-code: the restriction to a single lock
16.87 - prevents deadlocks without demanding special precautions.
16.88 + Despite this potential bottle-neck, centralized locking is
16.89 + convenient, because it prevents deadlocks without demanding special
16.90 + precautions. Explicit communication demands other means, though.
16.91 + The high-level abstraction of synchronized variables @{"file"
16.92 + "~~/src/Pure/Concurrent/synchronized.ML"} enables parallel
16.93 + components to communicate via shared state; see also @{"file"
16.94 + "~~/src/Pure/Concurrent/mailbox.ML"} as canonical example.
16.95
16.96 \paragraph{Good conduct of impure programs.} The following
16.97 guidelines enable non-functional programs to participate in
17.1 --- a/doc-src/IsarImplementation/Thy/document/ML.tex Tue Dec 30 08:18:54 2008 +0100
17.2 +++ b/doc-src/IsarImplementation/Thy/document/ML.tex Tue Dec 30 11:10:01 2008 +0100
17.3 @@ -128,18 +128,23 @@
17.4 \isamarkuptrue%
17.5 %
17.6 \begin{isamarkuptext}%
17.7 -Recent versions of Poly/ML (5.2 or later) support multithreaded
17.8 - execution based on native operating system threads of the underlying
17.9 - platform. Thus threads will actually be executed in parallel on
17.10 - multi-core systems. A speedup-factor of approximately 2--4 can be
17.11 - expected for large well-structured Isabelle sessions, where theories
17.12 - are organized as a graph with sufficiently many independent nodes.
17.13 +Recent versions of Poly/ML (5.2.1 or later) support robust
17.14 + multithreaded execution, based on native operating system threads of
17.15 + the underlying platform. Thus threads will actually be executed in
17.16 + parallel on multi-core systems. A speedup-factor of approximately
17.17 + 1.5--3 can be expected on a regular 4-core machine.\footnote{There
17.18 + is some inherent limitation of the speedup factor due to garbage
17.19 + collection, which is still sequential. It helps to provide initial
17.20 + heap space generously, using the \texttt{-H} option of Poly/ML.}
17.21 + Threads also help to organize advanced operations of the system,
17.22 + with explicit communication between sub-components, real-time
17.23 + conditions, time-outs etc.
17.24
17.25 - Threads lack the memory protection of separate processes, but
17.26 + Threads lack the memory protection of separate processes, and
17.27 operate concurrently on shared heap memory. This has the advantage
17.28 that results of independent computations are immediately available
17.29 - to other threads, without requiring explicit communication,
17.30 - reloading, or even recoding of data.
17.31 + to other threads, without requiring untyped character streams,
17.32 + awkward serialization etc.
17.33
17.34 On the other hand, some programming guidelines need to be observed
17.35 in order to make unprotected parallelism work out smoothly. While
17.36 @@ -163,25 +168,26 @@
17.37
17.38 \end{itemize}
17.39
17.40 - Note that ML bindings within the toplevel environment (\verb|type|, \verb|val|, \verb|structure| etc.) due to
17.41 - run-time invocation of the compiler are non-critical, because
17.42 - Isabelle/Isar incorporates such bindings within the theory or proof
17.43 - context.
17.44 -
17.45 The majority of tools implemented within the Isabelle/Isar framework
17.46 will not require any of these critical elements: nothing special
17.47 needs to be observed when staying in the purely functional fragment
17.48 of ML. Note that output via the official Isabelle channels does not
17.49 - even count as direct I/O in the above sense, so the operations \verb|writeln|, \verb|warning|, \verb|tracing| etc.\ are safe.
17.50 + count as direct I/O, so the operations \verb|writeln|, \verb|warning|, \verb|tracing| etc.\ are safe.
17.51
17.52 - \paragraph{Multithreading in Isabelle/Isar.} Our parallel execution
17.53 - model is centered around the theory loader. Whenever a given
17.54 - subgraph of theories needs to be updated, the system schedules a
17.55 - number of threads to process the sources as required, while
17.56 - observing their dependencies. Thus concurrency is limited to
17.57 - independent nodes according to the theory import relation.
17.58 + Moreover, ML bindings within the toplevel environment (\verb|type|, \verb|val|, \verb|structure| etc.) due to
17.59 + run-time invocation of the compiler are also safe, because
17.60 + Isabelle/Isar manages this as part of the theory or proof context.
17.61
17.62 - Any user-code that works relatively to the present background theory
17.63 + \paragraph{Multithreading in Isabelle/Isar.} The theory loader
17.64 + automatically exploits the overall parallelism of independent nodes
17.65 + in the development graph, as well as the inherent irrelevance of
17.66 + proofs for goals being fully specified in advance. This means,
17.67 + checking of individual Isar proofs is parallelized by default.
17.68 + Beyond that, very sophisticated proof tools may use local
17.69 + parallelism internally, via the general programming model of
17.70 + ``future values'' (see also \hyperlink{file.~~/src/Pure/Concurrent/future.ML}{\mbox{\isa{\isatt{{\isachartilde}{\isachartilde}{\isacharslash}src{\isacharslash}Pure{\isacharslash}Concurrent{\isacharslash}future{\isachardot}ML}}}}).
17.71 +
17.72 + Any ML code that works relatively to the present background theory
17.73 is already safe. Contextual data may be easily stored within the
17.74 theory or proof context, thanks to the generic data concept of
17.75 Isabelle/Isar (see \secref{sec:context-data}). This greatly
17.76 @@ -197,9 +203,11 @@
17.77 quickly, otherwise parallel execution performance may degrade
17.78 significantly.
17.79
17.80 - Despite this potential bottle-neck, we refrain from fine-grained
17.81 - locking mechanism within user-code: the restriction to a single lock
17.82 - prevents deadlocks without demanding special precautions.
17.83 + Despite this potential bottle-neck, centralized locking is
17.84 + convenient, because it prevents deadlocks without demanding special
17.85 + precautions. Explicit communication demands other means, though.
17.86 + The high-level abstraction of synchronized variables \hyperlink{file.~~/src/Pure/Concurrent/synchronized.ML}{\mbox{\isa{\isatt{{\isachartilde}{\isachartilde}{\isacharslash}src{\isacharslash}Pure{\isacharslash}Concurrent{\isacharslash}synchronized{\isachardot}ML}}}} enables parallel
17.87 + components to communicate via shared state; see also \hyperlink{file.~~/src/Pure/Concurrent/mailbox.ML}{\mbox{\isa{\isatt{{\isachartilde}{\isachartilde}{\isacharslash}src{\isacharslash}Pure{\isacharslash}Concurrent{\isacharslash}mailbox{\isachardot}ML}}}} as canonical example.
17.88
17.89 \paragraph{Good conduct of impure programs.} The following
17.90 guidelines enable non-functional programs to participate in
18.1 --- a/doc-src/IsarRef/Thy/HOL_Specific.thy Tue Dec 30 08:18:54 2008 +0100
18.2 +++ b/doc-src/IsarRef/Thy/HOL_Specific.thy Tue Dec 30 11:10:01 2008 +0100
18.3 @@ -804,12 +804,15 @@
18.4 @{command_def (HOL) "print_atps"}@{text "\<^sup>*"} & : & @{text "context \<rightarrow>"} \\
18.5 @{command_def (HOL) "atp_info"}@{text "\<^sup>*"} & : & @{text "any \<rightarrow>"} \\
18.6 @{command_def (HOL) "atp_kill"}@{text "\<^sup>*"} & : & @{text "any \<rightarrow>"} \\
18.7 + @{command_def (HOL) "atp_messages"}@{text "\<^sup>*"} & : & @{text "any \<rightarrow>"} \\
18.8 @{method_def (HOL) metis} & : & @{text method} \\
18.9 \end{matharray}
18.10
18.11 \begin{rail}
18.12 'sledgehammer' (nameref *)
18.13 ;
18.14 + 'atp\_messages' ('(' nat ')')?
18.15 + ;
18.16
18.17 'metis' thmrefs
18.18 ;
18.19 @@ -842,6 +845,12 @@
18.20 \item @{command (HOL) atp_kill} terminates all presently running
18.21 provers.
18.22
18.23 + \item @{command (HOL) atp_messages} displays recent messages issued
18.24 + by automated theorem provers. This allows to examine results that
18.25 + might have got lost due to the asynchronous nature of default
18.26 + @{command (HOL) sledgehammer} output. An optional message limit may
18.27 + be specified (default 5).
18.28 +
18.29 \item @{method (HOL) metis}~@{text "facts"} invokes the Metis prover
18.30 with the given facts. Metis is an automated proof tool of medium
18.31 strength, but is fully integrated into Isabelle/HOL, with explicit
19.1 --- a/doc-src/IsarRef/Thy/Inner_Syntax.thy Tue Dec 30 08:18:54 2008 +0100
19.2 +++ b/doc-src/IsarRef/Thy/Inner_Syntax.thy Tue Dec 30 11:10:01 2008 +0100
19.3 @@ -683,17 +683,23 @@
19.4 @{syntax_def (inner) tid} & = & @{syntax_ref typefree} \\
19.5 @{syntax_def (inner) tvar} & = & @{syntax_ref typevar} \\
19.6 @{syntax_def (inner) num} & = & @{syntax_ref nat}@{text " | "}@{verbatim "-"}@{syntax_ref nat} \\
19.7 + @{syntax_def (inner) float_token} & = & @{syntax_ref nat}@{verbatim "."}@{syntax_ref nat}@{text " | "}@{verbatim "-"}@{syntax_ref nat}@{verbatim "."}@{syntax_ref nat} \\
19.8 @{syntax_def (inner) xnum} & = & @{verbatim "#"}@{syntax_ref nat}@{text " | "}@{verbatim "#-"}@{syntax_ref nat} \\
19.9
19.10 @{syntax_def (inner) xstr} & = & @{verbatim "''"} @{text "\<dots>"} @{verbatim "''"} \\
19.11 \end{supertabular}
19.12 \end{center}
19.13
19.14 - The token categories @{syntax_ref (inner) num}, @{syntax_ref (inner)
19.15 - xnum}, and @{syntax_ref (inner) xstr} are not used in Pure.
19.16 - Object-logics may implement numerals and string constants by adding
19.17 - appropriate syntax declarations, together with some translation
19.18 - functions (e.g.\ see Isabelle/HOL).
19.19 + The token categories @{syntax (inner) num}, @{syntax (inner)
19.20 + float_token}, @{syntax (inner) xnum}, and @{syntax (inner) xstr} are
19.21 + not used in Pure. Object-logics may implement numerals and string
19.22 + constants by adding appropriate syntax declarations, together with
19.23 + some translation functions (e.g.\ see Isabelle/HOL).
19.24 +
19.25 + The derived categories @{syntax_def (inner) num_const} and
19.26 + @{syntax_def (inner) float_const} provide robust access to @{syntax
19.27 + (inner) num}, and @{syntax (inner) float_token}, respectively: the
19.28 + syntax tree holds a syntactic constant instead of a free variable.
19.29 *}
19.30
19.31
20.1 --- a/doc-src/IsarRef/Thy/document/HOL_Specific.tex Tue Dec 30 08:18:54 2008 +0100
20.2 +++ b/doc-src/IsarRef/Thy/document/HOL_Specific.tex Tue Dec 30 11:10:01 2008 +0100
20.3 @@ -814,12 +814,15 @@
20.4 \indexdef{HOL}{command}{print\_atps}\hypertarget{command.HOL.print-atps}{\hyperlink{command.HOL.print-atps}{\mbox{\isa{\isacommand{print{\isacharunderscore}atps}}}}}\isa{{\isachardoublequote}\isactrlsup {\isacharasterisk}{\isachardoublequote}} & : & \isa{{\isachardoublequote}context\ {\isasymrightarrow}{\isachardoublequote}} \\
20.5 \indexdef{HOL}{command}{atp\_info}\hypertarget{command.HOL.atp-info}{\hyperlink{command.HOL.atp-info}{\mbox{\isa{\isacommand{atp{\isacharunderscore}info}}}}}\isa{{\isachardoublequote}\isactrlsup {\isacharasterisk}{\isachardoublequote}} & : & \isa{{\isachardoublequote}any\ {\isasymrightarrow}{\isachardoublequote}} \\
20.6 \indexdef{HOL}{command}{atp\_kill}\hypertarget{command.HOL.atp-kill}{\hyperlink{command.HOL.atp-kill}{\mbox{\isa{\isacommand{atp{\isacharunderscore}kill}}}}}\isa{{\isachardoublequote}\isactrlsup {\isacharasterisk}{\isachardoublequote}} & : & \isa{{\isachardoublequote}any\ {\isasymrightarrow}{\isachardoublequote}} \\
20.7 + \indexdef{HOL}{command}{atp\_messages}\hypertarget{command.HOL.atp-messages}{\hyperlink{command.HOL.atp-messages}{\mbox{\isa{\isacommand{atp{\isacharunderscore}messages}}}}}\isa{{\isachardoublequote}\isactrlsup {\isacharasterisk}{\isachardoublequote}} & : & \isa{{\isachardoublequote}any\ {\isasymrightarrow}{\isachardoublequote}} \\
20.8 \indexdef{HOL}{method}{metis}\hypertarget{method.HOL.metis}{\hyperlink{method.HOL.metis}{\mbox{\isa{metis}}}} & : & \isa{method} \\
20.9 \end{matharray}
20.10
20.11 \begin{rail}
20.12 'sledgehammer' (nameref *)
20.13 ;
20.14 + 'atp\_messages' ('(' nat ')')?
20.15 + ;
20.16
20.17 'metis' thmrefs
20.18 ;
20.19 @@ -850,6 +853,12 @@
20.20 \item \hyperlink{command.HOL.atp-kill}{\mbox{\isa{\isacommand{atp{\isacharunderscore}kill}}}} terminates all presently running
20.21 provers.
20.22
20.23 + \item \hyperlink{command.HOL.atp-messages}{\mbox{\isa{\isacommand{atp{\isacharunderscore}messages}}}} displays recent messages issued
20.24 + by automated theorem provers. This allows to examine results that
20.25 + might have got lost due to the asynchronous nature of default
20.26 + \hyperlink{command.HOL.sledgehammer}{\mbox{\isa{\isacommand{sledgehammer}}}} output. An optional message limit may
20.27 + be specified (default 5).
20.28 +
20.29 \item \hyperlink{method.HOL.metis}{\mbox{\isa{metis}}}~\isa{{\isachardoublequote}facts{\isachardoublequote}} invokes the Metis prover
20.30 with the given facts. Metis is an automated proof tool of medium
20.31 strength, but is fully integrated into Isabelle/HOL, with explicit
21.1 --- a/doc-src/IsarRef/Thy/document/Inner_Syntax.tex Tue Dec 30 08:18:54 2008 +0100
21.2 +++ b/doc-src/IsarRef/Thy/document/Inner_Syntax.tex Tue Dec 30 11:10:01 2008 +0100
21.3 @@ -702,16 +702,21 @@
21.4 \indexdef{inner}{syntax}{tid}\hypertarget{syntax.inner.tid}{\hyperlink{syntax.inner.tid}{\mbox{\isa{tid}}}} & = & \indexref{}{syntax}{typefree}\hyperlink{syntax.typefree}{\mbox{\isa{typefree}}} \\
21.5 \indexdef{inner}{syntax}{tvar}\hypertarget{syntax.inner.tvar}{\hyperlink{syntax.inner.tvar}{\mbox{\isa{tvar}}}} & = & \indexref{}{syntax}{typevar}\hyperlink{syntax.typevar}{\mbox{\isa{typevar}}} \\
21.6 \indexdef{inner}{syntax}{num}\hypertarget{syntax.inner.num}{\hyperlink{syntax.inner.num}{\mbox{\isa{num}}}} & = & \indexref{}{syntax}{nat}\hyperlink{syntax.nat}{\mbox{\isa{nat}}}\isa{{\isachardoublequote}\ \ {\isacharbar}\ \ {\isachardoublequote}}\verb|-|\indexref{}{syntax}{nat}\hyperlink{syntax.nat}{\mbox{\isa{nat}}} \\
21.7 + \indexdef{inner}{syntax}{float\_token}\hypertarget{syntax.inner.float-token}{\hyperlink{syntax.inner.float-token}{\mbox{\isa{float{\isacharunderscore}token}}}} & = & \indexref{}{syntax}{nat}\hyperlink{syntax.nat}{\mbox{\isa{nat}}}\verb|.|\indexref{}{syntax}{nat}\hyperlink{syntax.nat}{\mbox{\isa{nat}}}\isa{{\isachardoublequote}\ \ {\isacharbar}\ \ {\isachardoublequote}}\verb|-|\indexref{}{syntax}{nat}\hyperlink{syntax.nat}{\mbox{\isa{nat}}}\verb|.|\indexref{}{syntax}{nat}\hyperlink{syntax.nat}{\mbox{\isa{nat}}} \\
21.8 \indexdef{inner}{syntax}{xnum}\hypertarget{syntax.inner.xnum}{\hyperlink{syntax.inner.xnum}{\mbox{\isa{xnum}}}} & = & \verb|#|\indexref{}{syntax}{nat}\hyperlink{syntax.nat}{\mbox{\isa{nat}}}\isa{{\isachardoublequote}\ \ {\isacharbar}\ \ {\isachardoublequote}}\verb|#-|\indexref{}{syntax}{nat}\hyperlink{syntax.nat}{\mbox{\isa{nat}}} \\
21.9
21.10 \indexdef{inner}{syntax}{xstr}\hypertarget{syntax.inner.xstr}{\hyperlink{syntax.inner.xstr}{\mbox{\isa{xstr}}}} & = & \verb|''| \isa{{\isachardoublequote}{\isasymdots}{\isachardoublequote}} \verb|''| \\
21.11 \end{supertabular}
21.12 \end{center}
21.13
21.14 - The token categories \indexref{inner}{syntax}{num}\hyperlink{syntax.inner.num}{\mbox{\isa{num}}}, \indexref{inner}{syntax}{xnum}\hyperlink{syntax.inner.xnum}{\mbox{\isa{xnum}}}, and \indexref{inner}{syntax}{xstr}\hyperlink{syntax.inner.xstr}{\mbox{\isa{xstr}}} are not used in Pure.
21.15 - Object-logics may implement numerals and string constants by adding
21.16 - appropriate syntax declarations, together with some translation
21.17 - functions (e.g.\ see Isabelle/HOL).%
21.18 + The token categories \hyperlink{syntax.inner.num}{\mbox{\isa{num}}}, \hyperlink{syntax.inner.float-token}{\mbox{\isa{float{\isacharunderscore}token}}}, \hyperlink{syntax.inner.xnum}{\mbox{\isa{xnum}}}, and \hyperlink{syntax.inner.xstr}{\mbox{\isa{xstr}}} are
21.19 + not used in Pure. Object-logics may implement numerals and string
21.20 + constants by adding appropriate syntax declarations, together with
21.21 + some translation functions (e.g.\ see Isabelle/HOL).
21.22 +
21.23 + The derived categories \indexdef{inner}{syntax}{num\_const}\hypertarget{syntax.inner.num-const}{\hyperlink{syntax.inner.num-const}{\mbox{\isa{num{\isacharunderscore}const}}}} and
21.24 + \indexdef{inner}{syntax}{float\_const}\hypertarget{syntax.inner.float-const}{\hyperlink{syntax.inner.float-const}{\mbox{\isa{float{\isacharunderscore}const}}}} provide robust access to \hyperlink{syntax.inner.num}{\mbox{\isa{num}}}, and \hyperlink{syntax.inner.float-token}{\mbox{\isa{float{\isacharunderscore}token}}}, respectively: the
21.25 + syntax tree holds a syntactic constant instead of a free variable.%
21.26 \end{isamarkuptext}%
21.27 \isamarkuptrue%
21.28 %
22.1 --- a/etc/isar-keywords-ZF.el Tue Dec 30 08:18:54 2008 +0100
22.2 +++ b/etc/isar-keywords-ZF.el Tue Dec 30 11:10:01 2008 +0100
22.3 @@ -200,7 +200,6 @@
22.4 "use"
22.5 "use_thy"
22.6 "using"
22.7 - "value"
22.8 "welcome"
22.9 "with"
22.10 "{"
22.11 @@ -323,7 +322,6 @@
22.12 "typ"
22.13 "unused_thms"
22.14 "use_thy"
22.15 - "value"
22.16 "welcome"))
22.17
22.18 (defconst isar-keywords-theory-begin
23.1 --- a/etc/isar-keywords.el Tue Dec 30 08:18:54 2008 +0100
23.2 +++ b/etc/isar-keywords.el Tue Dec 30 11:10:01 2008 +0100
23.3 @@ -32,6 +32,7 @@
23.4 "atom_decl"
23.5 "atp_info"
23.6 "atp_kill"
23.7 + "atp_messages"
23.8 "automaton"
23.9 "ax_specification"
23.10 "axclass"
23.11 @@ -334,6 +335,7 @@
23.12 "ML_val"
23.13 "atp_info"
23.14 "atp_kill"
23.15 + "atp_messages"
23.16 "cd"
23.17 "class_deps"
23.18 "code_deps"
24.1 --- a/etc/proofgeneral-settings.el Tue Dec 30 08:18:54 2008 +0100
24.2 +++ b/etc/proofgeneral-settings.el Tue Dec 30 11:10:01 2008 +0100
24.3 @@ -1,6 +1,3 @@
24.4 -;;;
24.5 -;;; $Id$
24.6 -;;;
24.7 ;;; Options for Proof General
24.8
24.9 ;; Examples for sensible settings:
25.1 --- a/etc/settings Tue Dec 30 08:18:54 2008 +0100
25.2 +++ b/etc/settings Tue Dec 30 11:10:01 2008 +0100
25.3 @@ -1,5 +1,4 @@
25.4 # -*- shell-script -*- :mode=shellscript:
25.5 -# $Id$
25.6 #
25.7 # Isabelle settings -- site defaults.
25.8 #
25.9 @@ -202,9 +201,8 @@
25.10 "/opt/ProofGeneral" \
25.11 "")
25.12
25.13 -PROOFGENERAL_EMACS=$(choosefrom /Applications/Emacs.app/Contents/MacOS/Emacs emacs22)
25.14 -PROOFGENERAL_OPTIONS="-p $PROOFGENERAL_EMACS"
25.15 -#PROOFGENERAL_OPTIONS="-m no_brackets -m no_type_brackets -x true -p $PROOFGENERAL_EMACS"
25.16 +PROOFGENERAL_OPTIONS=""
25.17 +#PROOFGENERAL_OPTIONS="-m no_brackets -m no_type_brackets"
25.18
25.19 # Automatic setup of remote fonts
25.20 #XSYMBOL_INSTALLFONTS="xset fp+ tcp/isafonts.informatik.tu-muenchen.de:7200"
26.1 --- a/etc/symbols Tue Dec 30 08:18:54 2008 +0100
26.2 +++ b/etc/symbols Tue Dec 30 11:10:01 2008 +0100
26.3 @@ -1,4 +1,3 @@
26.4 -# $Id$
26.5 # Default interpretation of some Isabelle symbols
26.6
26.7 \<zero> code: 0x01d7ec font: Isabelle
27.1 --- a/etc/user-settings.sample Tue Dec 30 08:18:54 2008 +0100
27.2 +++ b/etc/user-settings.sample Tue Dec 30 11:10:01 2008 +0100
27.3 @@ -1,5 +1,4 @@
27.4 # -*- shell-script -*-
27.5 -# $Id$
27.6 #
27.7 # Isabelle user settings sample -- for use in ~/.isabelle/etc/settings
27.8
28.1 --- a/lib/Tools/browser Tue Dec 30 08:18:54 2008 +0100
28.2 +++ b/lib/Tools/browser Tue Dec 30 11:10:01 2008 +0100
28.3 @@ -1,6 +1,5 @@
28.4 #!/usr/bin/env bash
28.5 #
28.6 -# $Id$
28.7 # Author: Markus Wenzel, TU Muenchen
28.8 #
28.9 # DESCRIPTION: Isabelle graph browser
29.1 --- a/lib/Tools/codegen Tue Dec 30 08:18:54 2008 +0100
29.2 +++ b/lib/Tools/codegen Tue Dec 30 11:10:01 2008 +0100
29.3 @@ -1,6 +1,5 @@
29.4 #!/usr/bin/env bash
29.5 #
29.6 -# $Id$
29.7 # Author: Florian Haftmann, TUM
29.8 #
29.9 # DESCRIPTION: issue code generation from shell
30.1 --- a/lib/Tools/dimacs2hol Tue Dec 30 08:18:54 2008 +0100
30.2 +++ b/lib/Tools/dimacs2hol Tue Dec 30 11:10:01 2008 +0100
30.3 @@ -1,8 +1,6 @@
30.4 #!/usr/bin/env bash
30.5 #
30.6 -# $Id$
30.7 # Author: Tjark Weber
30.8 -# Copyright 2004
30.9 #
30.10 # DESCRIPTION: convert DIMACS CNF files into Isabelle/HOL theories
30.11
31.1 --- a/lib/Tools/display Tue Dec 30 08:18:54 2008 +0100
31.2 +++ b/lib/Tools/display Tue Dec 30 11:10:01 2008 +0100
31.3 @@ -1,6 +1,5 @@
31.4 #!/usr/bin/env bash
31.5 #
31.6 -# $Id$
31.7 # Author: Markus Wenzel, TU Muenchen
31.8 #
31.9 # DESCRIPTION: display document (in DVI or PDF format)
32.1 --- a/lib/Tools/doc Tue Dec 30 08:18:54 2008 +0100
32.2 +++ b/lib/Tools/doc Tue Dec 30 11:10:01 2008 +0100
32.3 @@ -1,6 +1,5 @@
32.4 #!/usr/bin/env bash
32.5 #
32.6 -# $Id$
32.7 # Author: Markus Wenzel, TU Muenchen
32.8 #
32.9 # DESCRIPTION: view Isabelle documentation
33.1 --- a/lib/Tools/document Tue Dec 30 08:18:54 2008 +0100
33.2 +++ b/lib/Tools/document Tue Dec 30 11:10:01 2008 +0100
33.3 @@ -1,6 +1,5 @@
33.4 #!/usr/bin/env bash
33.5 #
33.6 -# $Id$
33.7 # Author: Markus Wenzel, TU Muenchen
33.8 #
33.9 # DESCRIPTION: prepare theory session document
34.1 --- a/lib/Tools/emacs Tue Dec 30 08:18:54 2008 +0100
34.2 +++ b/lib/Tools/emacs Tue Dec 30 11:10:01 2008 +0100
34.3 @@ -1,6 +1,5 @@
34.4 #!/usr/bin/env bash
34.5 #
34.6 -# $Id$
34.7 # Author: Makarius
34.8 #
34.9 # DESCRIPTION: Proof General / Emacs interface wrapper
35.1 --- a/lib/Tools/env Tue Dec 30 08:18:54 2008 +0100
35.2 +++ b/lib/Tools/env Tue Dec 30 11:10:01 2008 +0100
35.3 @@ -1,6 +1,5 @@
35.4 #!/usr/bin/env bash
35.5 #
35.6 -# $Id$
35.7 # Author: Markus Wenzel, TU Muenchen
35.8 #
35.9 # DESCRIPTION: run a program in a modified environment
36.1 --- a/lib/Tools/findlogics Tue Dec 30 08:18:54 2008 +0100
36.2 +++ b/lib/Tools/findlogics Tue Dec 30 11:10:01 2008 +0100
36.3 @@ -1,6 +1,5 @@
36.4 #!/usr/bin/env bash
36.5 #
36.6 -# $Id$
36.7 # Author: Markus Wenzel, TU Muenchen
36.8 #
36.9 # DESCRIPTION: collect heap names from ISABELLE_PATH
37.1 --- a/lib/Tools/getenv Tue Dec 30 08:18:54 2008 +0100
37.2 +++ b/lib/Tools/getenv Tue Dec 30 11:10:01 2008 +0100
37.3 @@ -1,6 +1,5 @@
37.4 #!/usr/bin/env bash
37.5 #
37.6 -# $Id$
37.7 # Author: Markus Wenzel, TU Muenchen
37.8 #
37.9 # DESCRIPTION: get values from Isabelle settings environment
38.1 --- a/lib/Tools/install Tue Dec 30 08:18:54 2008 +0100
38.2 +++ b/lib/Tools/install Tue Dec 30 11:10:01 2008 +0100
38.3 @@ -1,6 +1,5 @@
38.4 #!/usr/bin/env bash
38.5 #
38.6 -# $Id$
38.7 # Author: Markus Wenzel, TU Muenchen
38.8 #
38.9 # DESCRIPTION: install standalone Isabelle executables
39.1 --- a/lib/Tools/java Tue Dec 30 08:18:54 2008 +0100
39.2 +++ b/lib/Tools/java Tue Dec 30 11:10:01 2008 +0100
39.3 @@ -1,6 +1,5 @@
39.4 #!/usr/bin/env bash
39.5 #
39.6 -# $Id$
39.7 # Author: Makarius
39.8 #
39.9 # DESCRIPTION: invoke Java within the Isabelle environment
40.1 --- a/lib/Tools/jedit Tue Dec 30 08:18:54 2008 +0100
40.2 +++ b/lib/Tools/jedit Tue Dec 30 11:10:01 2008 +0100
40.3 @@ -1,6 +1,5 @@
40.4 #!/usr/bin/env bash
40.5 #
40.6 -# $Id$
40.7 # Author: Makarius
40.8 #
40.9 # DESCRIPTION: Isabelle/jEdit interface wrapper
41.1 --- a/lib/Tools/keywords Tue Dec 30 08:18:54 2008 +0100
41.2 +++ b/lib/Tools/keywords Tue Dec 30 11:10:01 2008 +0100
41.3 @@ -1,6 +1,5 @@
41.4 #!/usr/bin/env bash
41.5 #
41.6 -# $Id$
41.7 # Author: Makarius
41.8 #
41.9 # DESCRIPTION: generate outer syntax keyword files from session logs
42.1 --- a/lib/Tools/latex Tue Dec 30 08:18:54 2008 +0100
42.2 +++ b/lib/Tools/latex Tue Dec 30 11:10:01 2008 +0100
42.3 @@ -1,6 +1,5 @@
42.4 #!/usr/bin/env bash
42.5 #
42.6 -# $Id$
42.7 # Author: Markus Wenzel, TU Muenchen
42.8 #
42.9 # DESCRIPTION: run LaTeX (and related tools)
43.1 --- a/lib/Tools/logo Tue Dec 30 08:18:54 2008 +0100
43.2 +++ b/lib/Tools/logo Tue Dec 30 11:10:01 2008 +0100
43.3 @@ -1,6 +1,5 @@
43.4 #!/usr/bin/env bash
43.5 #
43.6 -# $Id$
43.7 # Author: Markus Wenzel, TU Muenchen
43.8 #
43.9 # DESCRIPTION: create an instance of the Isabelle logo
44.1 --- a/lib/Tools/make Tue Dec 30 08:18:54 2008 +0100
44.2 +++ b/lib/Tools/make Tue Dec 30 11:10:01 2008 +0100
44.3 @@ -1,6 +1,5 @@
44.4 #!/usr/bin/env bash
44.5 #
44.6 -# $Id$
44.7 # Author: Markus Wenzel, TU Muenchen
44.8 #
44.9 # DESCRIPTION: Isabelle make utility
45.1 --- a/lib/Tools/makeall Tue Dec 30 08:18:54 2008 +0100
45.2 +++ b/lib/Tools/makeall Tue Dec 30 11:10:01 2008 +0100
45.3 @@ -1,6 +1,5 @@
45.4 #!/usr/bin/env bash
45.5 #
45.6 -# $Id$
45.7 # Author: Markus Wenzel, TU Muenchen
45.8 #
45.9 # DESCRIPTION: apply make utility to all logics
46.1 --- a/lib/Tools/mkdir Tue Dec 30 08:18:54 2008 +0100
46.2 +++ b/lib/Tools/mkdir Tue Dec 30 11:10:01 2008 +0100
46.3 @@ -1,6 +1,5 @@
46.4 #!/usr/bin/env bash
46.5 #
46.6 -# $Id$
46.7 # Author: Markus Wenzel, TU Muenchen
46.8 #
46.9 # DESCRIPTION: prepare logic session directory
47.1 --- a/lib/Tools/mkfifo Tue Dec 30 08:18:54 2008 +0100
47.2 +++ b/lib/Tools/mkfifo Tue Dec 30 11:10:01 2008 +0100
47.3 @@ -1,6 +1,5 @@
47.4 #!/usr/bin/env bash
47.5 #
47.6 -# $Id$
47.7 # Author: Makarius
47.8 #
47.9 # DESCRIPTION: create named pipe
48.1 --- a/lib/Tools/mkproject Tue Dec 30 08:18:54 2008 +0100
48.2 +++ b/lib/Tools/mkproject Tue Dec 30 11:10:01 2008 +0100
48.3 @@ -1,7 +1,6 @@
48.4 #!/usr/bin/env bash
48.5 #
48.6 -# $Id$
48.7 -# Author: David Aspinall and Makarius Wenzel
48.8 +# Author: David Aspinall
48.9 #
48.10 # DESCRIPTION: prepare a session directory for PG-Eclipse
48.11
49.1 --- a/lib/Tools/print Tue Dec 30 08:18:54 2008 +0100
49.2 +++ b/lib/Tools/print Tue Dec 30 11:10:01 2008 +0100
49.3 @@ -1,6 +1,5 @@
49.4 #!/usr/bin/env bash
49.5 #
49.6 -# $Id$
49.7 # Author: Markus Wenzel, TU Muenchen
49.8 #
49.9 # DESCRIPTION: print document
50.1 --- a/lib/Tools/rmfifo Tue Dec 30 08:18:54 2008 +0100
50.2 +++ b/lib/Tools/rmfifo Tue Dec 30 11:10:01 2008 +0100
50.3 @@ -1,6 +1,5 @@
50.4 #!/usr/bin/env bash
50.5 #
50.6 -# $Id$
50.7 # Author: Makarius
50.8 #
50.9 # DESCRIPTION: remove named pipe
51.1 --- a/lib/Tools/scala Tue Dec 30 08:18:54 2008 +0100
51.2 +++ b/lib/Tools/scala Tue Dec 30 11:10:01 2008 +0100
51.3 @@ -1,6 +1,5 @@
51.4 #!/usr/bin/env bash
51.5 #
51.6 -# $Id$
51.7 # Author: Makarius
51.8 #
51.9 # DESCRIPTION: invoke Scala within the Isabelle environment
52.1 --- a/lib/Tools/tty Tue Dec 30 08:18:54 2008 +0100
52.2 +++ b/lib/Tools/tty Tue Dec 30 11:10:01 2008 +0100
52.3 @@ -1,6 +1,5 @@
52.4 #!/usr/bin/env bash
52.5 #
52.6 -# $Id$
52.7 # Author: Markus Wenzel, TU Muenchen
52.8 #
52.9 # DESCRIPTION: run Isabelle process with plain tty interaction
53.1 --- a/lib/Tools/unsymbolize Tue Dec 30 08:18:54 2008 +0100
53.2 +++ b/lib/Tools/unsymbolize Tue Dec 30 11:10:01 2008 +0100
53.3 @@ -1,6 +1,5 @@
53.4 #!/usr/bin/env bash
53.5 #
53.6 -# $Id$
53.7 # Author: Markus Wenzel, TU Muenchen
53.8 #
53.9 # DESCRIPTION: remove unreadable symbol names from sources
54.1 --- a/lib/Tools/usedir Tue Dec 30 08:18:54 2008 +0100
54.2 +++ b/lib/Tools/usedir Tue Dec 30 11:10:01 2008 +0100
54.3 @@ -1,6 +1,5 @@
54.4 #!/usr/bin/env bash
54.5 #
54.6 -# $Id$
54.7 # Author: Markus Wenzel, TU Muenchen
54.8 #
54.9 # DESCRIPTION: build object-logic or run examples
54.10 @@ -40,6 +39,11 @@
54.11 echo " ISABELLE_USEDIR_OPTIONS=$ISABELLE_USEDIR_OPTIONS"
54.12 echo " HOL_USEDIR_OPTIONS=$HOL_USEDIR_OPTIONS"
54.13 echo
54.14 + echo " ML_PLATFORM=$ML_PLATFORM"
54.15 + echo " ML_HOME=$ML_HOME"
54.16 + echo " ML_SYSTEM=$ML_SYSTEM"
54.17 + echo " ML_OPTIONS=$ML_OPTIONS"
54.18 + echo
54.19 exit 1
54.20 }
54.21
55.1 --- a/lib/Tools/version Tue Dec 30 08:18:54 2008 +0100
55.2 +++ b/lib/Tools/version Tue Dec 30 11:10:01 2008 +0100
55.3 @@ -1,6 +1,5 @@
55.4 #!/usr/bin/env bash
55.5 #
55.6 -# $Id$
55.7 # Author: Stefan Berghofer, TU Muenchen
55.8 #
55.9 # DESCRIPTION: display Isabelle version
56.1 --- a/lib/Tools/yxml Tue Dec 30 08:18:54 2008 +0100
56.2 +++ b/lib/Tools/yxml Tue Dec 30 11:10:01 2008 +0100
56.3 @@ -1,6 +1,5 @@
56.4 #!/usr/bin/env bash
56.5 #
56.6 -# $Id$
56.7 # Author: Makarius
56.8 #
56.9 # DESCRIPTION: simple XML to YXML converter
57.1 --- a/lib/jedit/isabelle.xml Tue Dec 30 08:18:54 2008 +0100
57.2 +++ b/lib/jedit/isabelle.xml Tue Dec 30 11:10:01 2008 +0100
57.3 @@ -56,6 +56,7 @@
57.4 <OPERATOR>atom_decl</OPERATOR>
57.5 <LABEL>atp_info</LABEL>
57.6 <LABEL>atp_kill</LABEL>
57.7 + <LABEL>atp_messages</LABEL>
57.8 <KEYWORD4>attach</KEYWORD4>
57.9 <OPERATOR>automaton</OPERATOR>
57.10 <KEYWORD4>avoids</KEYWORD4>
57.11 @@ -154,7 +155,6 @@
57.12 <KEYWORD4>if</KEYWORD4>
57.13 <KEYWORD4>imports</KEYWORD4>
57.14 <KEYWORD4>in</KEYWORD4>
57.15 - <KEYWORD4>includes</KEYWORD4>
57.16 <KEYWORD4>induction</KEYWORD4>
57.17 <OPERATOR>inductive</OPERATOR>
57.18 <KEYWORD1>inductive_cases</KEYWORD1>
57.19 @@ -286,6 +286,7 @@
57.20 <OPERATOR>statespace</OPERATOR>
57.21 <KEYWORD4>structure</KEYWORD4>
57.22 <OPERATOR>subclass</OPERATOR>
57.23 + <OPERATOR>sublocale</OPERATOR>
57.24 <OPERATOR>subsect</OPERATOR>
57.25 <OPERATOR>subsection</OPERATOR>
57.26 <OPERATOR>subsubsect</OPERATOR>
58.1 --- a/lib/scripts/dimacs2hol.pl Tue Dec 30 08:18:54 2008 +0100
58.2 +++ b/lib/scripts/dimacs2hol.pl Tue Dec 30 11:10:01 2008 +0100
58.3 @@ -1,5 +1,3 @@
58.4 -#
58.5 -# $Id$
58.6 #
58.7 # dimacs2hol.pl - convert files in DIMACS CNF format [1] into Isabelle/HOL
58.8 # theories
59.1 --- a/lib/scripts/feeder Tue Dec 30 08:18:54 2008 +0100
59.2 +++ b/lib/scripts/feeder Tue Dec 30 11:10:01 2008 +0100
59.3 @@ -1,6 +1,5 @@
59.4 #!/usr/bin/env bash
59.5 #
59.6 -# $Id$
59.7 # Author: Markus Wenzel, TU Muenchen
59.8 #
59.9 # feeder - feed isabelle session
60.1 --- a/lib/scripts/feeder.pl Tue Dec 30 08:18:54 2008 +0100
60.2 +++ b/lib/scripts/feeder.pl Tue Dec 30 11:10:01 2008 +0100
60.3 @@ -1,5 +1,4 @@
60.4 #
60.5 -# $Id$
60.6 # Author: Markus Wenzel, TU Muenchen
60.7 #
60.8 # feeder.pl - feed isabelle session
61.1 --- a/lib/scripts/fileident Tue Dec 30 08:18:54 2008 +0100
61.2 +++ b/lib/scripts/fileident Tue Dec 30 11:10:01 2008 +0100
61.3 @@ -1,7 +1,5 @@
61.4 #!/usr/bin/env bash
61.5 #
61.6 -# $Id$
61.7 -#
61.8 # fileident --- produce file identification based
61.9
61.10 FILE="$1"
62.1 --- a/lib/scripts/getsettings Tue Dec 30 08:18:54 2008 +0100
62.2 +++ b/lib/scripts/getsettings Tue Dec 30 11:10:01 2008 +0100
62.3 @@ -1,5 +1,5 @@
62.4 # -*- shell-script -*- :mode=shellscript:
62.5 -# $Id$
62.6 +#
62.7 # Author: Markus Wenzel, TU Muenchen
62.8 #
62.9 # getsettings - bash source script to augment current env.
63.1 --- a/lib/scripts/keywords.pl Tue Dec 30 08:18:54 2008 +0100
63.2 +++ b/lib/scripts/keywords.pl Tue Dec 30 11:10:01 2008 +0100
63.3 @@ -1,5 +1,4 @@
63.4 #
63.5 -# $Id$
63.6 # Author: Makarius
63.7 #
63.8 # keywords.pl - generate outer syntax keyword files from session logs
63.9 @@ -79,8 +78,6 @@
63.10 print ";; Generated from ${sessions}.\n";
63.11 print ";; *** DO NOT EDIT *** DO NOT EDIT *** DO NOT EDIT ***\n";
63.12 print ";;\n";
63.13 - print ";; \$", "Id\$\n";
63.14 - print ";;\n";
63.15
63.16 for my $kind (@kinds) {
63.17 my @names;
63.18 @@ -154,7 +151,6 @@
63.19 EOF
63.20 print "<!-- Generated from ${sessions}. -->\n";
63.21 print "<!-- *** DO NOT EDIT *** DO NOT EDIT *** DO NOT EDIT *** -->\n";
63.22 - print "<!-- \$", "Id\$ -->\n";
63.23 print <<'EOF';
63.24 <MODE>
63.25 <PROPS>
64.1 --- a/lib/scripts/polyml-platform Tue Dec 30 08:18:54 2008 +0100
64.2 +++ b/lib/scripts/polyml-platform Tue Dec 30 11:10:01 2008 +0100
64.3 @@ -1,7 +1,5 @@
64.4 #!/usr/bin/env bash
64.5 #
64.6 -# $Id$
64.7 -#
64.8 # polyml-platform --- determine Poly/ML's idea of current hardware and
64.9 # operating system type
64.10 #
65.1 --- a/lib/scripts/polyml-version Tue Dec 30 08:18:54 2008 +0100
65.2 +++ b/lib/scripts/polyml-version Tue Dec 30 11:10:01 2008 +0100
65.3 @@ -1,7 +1,5 @@
65.4 #!/usr/bin/env bash
65.5 #
65.6 -# $Id$
65.7 -#
65.8 # polyml-version --- determine Poly/ML runtime system version
65.9
65.10 echo -n polyml
66.1 --- a/lib/scripts/run-mosml Tue Dec 30 08:18:54 2008 +0100
66.2 +++ b/lib/scripts/run-mosml Tue Dec 30 11:10:01 2008 +0100
66.3 @@ -1,6 +1,5 @@
66.4 #!/usr/bin/env bash
66.5 #
66.6 -# $Id$
66.7 # Author: Markus Wenzel, TU Muenchen
66.8 #
66.9 # Moscow ML 2.00 startup script
67.1 --- a/lib/scripts/run-polyml Tue Dec 30 08:18:54 2008 +0100
67.2 +++ b/lib/scripts/run-polyml Tue Dec 30 11:10:01 2008 +0100
67.3 @@ -1,6 +1,5 @@
67.4 #!/usr/bin/env bash
67.5 #
67.6 -# $Id$
67.7 # Author: Makarius
67.8 #
67.9 # Poly/ML 5.1/5.2 startup script.
68.1 --- a/lib/scripts/run-polyml-4.1.3 Tue Dec 30 08:18:54 2008 +0100
68.2 +++ b/lib/scripts/run-polyml-4.1.3 Tue Dec 30 11:10:01 2008 +0100
68.3 @@ -1,6 +1,5 @@
68.4 #!/usr/bin/env bash
68.5 #
68.6 -# $Id$
68.7 # Author: Markus Wenzel, TU Muenchen
68.8 #
68.9 # Poly/ML 4.x startup script.
69.1 --- a/lib/scripts/run-polyml-4.1.4 Tue Dec 30 08:18:54 2008 +0100
69.2 +++ b/lib/scripts/run-polyml-4.1.4 Tue Dec 30 11:10:01 2008 +0100
69.3 @@ -1,6 +1,5 @@
69.4 #!/usr/bin/env bash
69.5 #
69.6 -# $Id$
69.7 # Author: Markus Wenzel, TU Muenchen
69.8 #
69.9 # Poly/ML 4.x startup script.
70.1 --- a/lib/scripts/run-polyml-4.2.0 Tue Dec 30 08:18:54 2008 +0100
70.2 +++ b/lib/scripts/run-polyml-4.2.0 Tue Dec 30 11:10:01 2008 +0100
70.3 @@ -1,6 +1,5 @@
70.4 #!/usr/bin/env bash
70.5 #
70.6 -# $Id$
70.7 # Author: Markus Wenzel, TU Muenchen
70.8 #
70.9 # Poly/ML 4.x startup script.
71.1 --- a/lib/scripts/run-polyml-5.0 Tue Dec 30 08:18:54 2008 +0100
71.2 +++ b/lib/scripts/run-polyml-5.0 Tue Dec 30 11:10:01 2008 +0100
71.3 @@ -1,6 +1,5 @@
71.4 #!/usr/bin/env bash
71.5 #
71.6 -# $Id$
71.7 # Author: Makarius
71.8 #
71.9 # Poly/ML 5.0 startup script.
72.1 --- a/lib/scripts/run-smlnj Tue Dec 30 08:18:54 2008 +0100
72.2 +++ b/lib/scripts/run-smlnj Tue Dec 30 11:10:01 2008 +0100
72.3 @@ -1,6 +1,5 @@
72.4 #!/usr/bin/env bash
72.5 #
72.6 -# $Id$
72.7 # Author: Markus Wenzel, TU Muenchen
72.8 #
72.9 # SML/NJ startup script (for 110 or later).
73.1 --- a/lib/scripts/system.pl Tue Dec 30 08:18:54 2008 +0100
73.2 +++ b/lib/scripts/system.pl Tue Dec 30 11:10:01 2008 +0100
73.3 @@ -1,5 +1,4 @@
73.4 #
73.5 -# $Id$
73.6 # Author: Makarius
73.7 #
73.8 # system.pl - invoke shell command line (with robust signal handling)
74.1 --- a/lib/scripts/timestart.bash Tue Dec 30 08:18:54 2008 +0100
74.2 +++ b/lib/scripts/timestart.bash Tue Dec 30 11:10:01 2008 +0100
74.3 @@ -1,5 +1,5 @@
74.4 # -*- shell-script -*-
74.5 -# $Id$
74.6 +#
74.7 # Author: Makarius
74.8 #
74.9 # timestart - setup bash environment for timing.
75.1 --- a/lib/scripts/timestop.bash Tue Dec 30 08:18:54 2008 +0100
75.2 +++ b/lib/scripts/timestop.bash Tue Dec 30 11:10:01 2008 +0100
75.3 @@ -1,5 +1,5 @@
75.4 # -*- shell-script -*-
75.5 -# $Id$
75.6 +#
75.7 # Author: Makarius
75.8 #
75.9 # timestop - report timing based on environment (cf. timestart.bash)
76.1 --- a/lib/scripts/unsymbolize.pl Tue Dec 30 08:18:54 2008 +0100
76.2 +++ b/lib/scripts/unsymbolize.pl Tue Dec 30 11:10:01 2008 +0100
76.3 @@ -1,5 +1,4 @@
76.4 #
76.5 -# $Id$
76.6 # Author: Markus Wenzel, TU Muenchen
76.7 #
76.8 # unsymbolize.pl - remove unreadable symbol names from sources
77.1 --- a/lib/scripts/yxml.pl Tue Dec 30 08:18:54 2008 +0100
77.2 +++ b/lib/scripts/yxml.pl Tue Dec 30 11:10:01 2008 +0100
77.3 @@ -1,5 +1,4 @@
77.4 #
77.5 -# $Id$
77.6 # Author: Makarius
77.7 #
77.8 # yxml.pl - simple XML to YXML converter
78.1 --- a/lib/texinputs/draft.tex Tue Dec 30 08:18:54 2008 +0100
78.2 +++ b/lib/texinputs/draft.tex Tue Dec 30 11:10:01 2008 +0100
78.3 @@ -1,5 +1,3 @@
78.4 -%%
78.5 -%% $Id$
78.6 %%
78.7 %% root for draft documents
78.8 %%
79.1 --- a/lib/texinputs/isabelle.sty Tue Dec 30 08:18:54 2008 +0100
79.2 +++ b/lib/texinputs/isabelle.sty Tue Dec 30 11:10:01 2008 +0100
79.3 @@ -1,5 +1,3 @@
79.4 -%%
79.5 -%% $Id$
79.6 %%
79.7 %% macros for Isabelle generated LaTeX output
79.8 %%
80.1 --- a/lib/texinputs/isabellesym.sty Tue Dec 30 08:18:54 2008 +0100
80.2 +++ b/lib/texinputs/isabellesym.sty Tue Dec 30 11:10:01 2008 +0100
80.3 @@ -1,5 +1,3 @@
80.4 -%%
80.5 -%% $Id$
80.6 %%
80.7 %% definitions of standard Isabelle symbols
80.8 %%
81.1 --- a/lib/texinputs/pdfsetup.sty Tue Dec 30 08:18:54 2008 +0100
81.2 +++ b/lib/texinputs/pdfsetup.sty Tue Dec 30 11:10:01 2008 +0100
81.3 @@ -1,5 +1,3 @@
81.4 -%%
81.5 -%% $Id$
81.6 %%
81.7 %% default hyperref setup (both for pdf and dvi output)
81.8 %%
82.1 --- a/src/HOL/Code_Setup.thy Tue Dec 30 08:18:54 2008 +0100
82.2 +++ b/src/HOL/Code_Setup.thy Tue Dec 30 11:10:01 2008 +0100
82.3 @@ -198,6 +198,10 @@
82.4
82.5 subsection {* Evaluation and normalization by evaluation *}
82.6
82.7 +setup {*
82.8 + Value.add_evaluator ("SML", Codegen.eval_term o ProofContext.theory_of)
82.9 +*}
82.10 +
82.11 ML {*
82.12 structure Eval_Method =
82.13 struct
82.14 @@ -240,6 +244,10 @@
82.15
82.16 subsection {* Quickcheck *}
82.17
82.18 +setup {*
82.19 + Quickcheck.add_generator ("SML", Codegen.test_term)
82.20 +*}
82.21 +
82.22 quickcheck_params [size = 5, iterations = 50]
82.23
82.24 end
83.1 --- a/src/HOL/Complex/Fundamental_Theorem_Algebra.thy Tue Dec 30 08:18:54 2008 +0100
83.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
83.3 @@ -1,1329 +0,0 @@
83.4 -(* Title: Fundamental_Theorem_Algebra.thy
83.5 - Author: Amine Chaieb
83.6 -*)
83.7 -
83.8 -header{*Fundamental Theorem of Algebra*}
83.9 -
83.10 -theory Fundamental_Theorem_Algebra
83.11 -imports "~~/src/HOL/Univ_Poly" "~~/src/HOL/Library/Dense_Linear_Order" "~~/src/HOL/Complex"
83.12 -begin
83.13 -
83.14 -subsection {* Square root of complex numbers *}
83.15 -definition csqrt :: "complex \<Rightarrow> complex" where
83.16 -"csqrt z = (if Im z = 0 then
83.17 - if 0 \<le> Re z then Complex (sqrt(Re z)) 0
83.18 - else Complex 0 (sqrt(- Re z))
83.19 - else Complex (sqrt((cmod z + Re z) /2))
83.20 - ((Im z / abs(Im z)) * sqrt((cmod z - Re z) /2)))"
83.21 -
83.22 -lemma csqrt[algebra]: "csqrt z ^ 2 = z"
83.23 -proof-
83.24 - obtain x y where xy: "z = Complex x y" by (cases z, simp_all)
83.25 - {assume y0: "y = 0"
83.26 - {assume x0: "x \<ge> 0"
83.27 - then have ?thesis using y0 xy real_sqrt_pow2[OF x0]
83.28 - by (simp add: csqrt_def power2_eq_square)}
83.29 - moreover
83.30 - {assume "\<not> x \<ge> 0" hence x0: "- x \<ge> 0" by arith
83.31 - then have ?thesis using y0 xy real_sqrt_pow2[OF x0]
83.32 - by (simp add: csqrt_def power2_eq_square) }
83.33 - ultimately have ?thesis by blast}
83.34 - moreover
83.35 - {assume y0: "y\<noteq>0"
83.36 - {fix x y
83.37 - let ?z = "Complex x y"
83.38 - from abs_Re_le_cmod[of ?z] have tha: "abs x \<le> cmod ?z" by auto
83.39 - hence "cmod ?z - x \<ge> 0" "cmod ?z + x \<ge> 0" by arith+
83.40 - hence "(sqrt (x * x + y * y) + x) / 2 \<ge> 0" "(sqrt (x * x + y * y) - x) / 2 \<ge> 0" by (simp_all add: power2_eq_square) }
83.41 - note th = this
83.42 - have sq4: "\<And>x::real. x^2 / 4 = (x / 2) ^ 2"
83.43 - by (simp add: power2_eq_square)
83.44 - from th[of x y]
83.45 - have sq4': "sqrt (((sqrt (x * x + y * y) + x)^2 / 4)) = (sqrt (x * x + y * y) + x) / 2" "sqrt (((sqrt (x * x + y * y) - x)^2 / 4)) = (sqrt (x * x + y * y) - x) / 2" unfolding sq4 by simp_all
83.46 - then have th1: "sqrt ((sqrt (x * x + y * y) + x) * (sqrt (x * x + y * y) + x) / 4) - sqrt ((sqrt (x * x + y * y) - x) * (sqrt (x * x + y * y) - x) / 4) = x"
83.47 - unfolding power2_eq_square by simp
83.48 - have "sqrt 4 = sqrt (2^2)" by simp
83.49 - hence sqrt4: "sqrt 4 = 2" by (simp only: real_sqrt_abs)
83.50 - have th2: "2 *(y * sqrt ((sqrt (x * x + y * y) - x) * (sqrt (x * x + y * y) + x) / 4)) / \<bar>y\<bar> = y"
83.51 - using iffD2[OF real_sqrt_pow2_iff sum_power2_ge_zero[of x y]] y0
83.52 - unfolding power2_eq_square
83.53 - by (simp add: ring_simps real_sqrt_divide sqrt4)
83.54 - from y0 xy have ?thesis apply (simp add: csqrt_def power2_eq_square)
83.55 - apply (simp add: real_sqrt_sum_squares_mult_ge_zero[of x y] real_sqrt_pow2[OF th(1)[of x y], unfolded power2_eq_square] real_sqrt_pow2[OF th(2)[of x y], unfolded power2_eq_square] real_sqrt_mult[symmetric])
83.56 - using th1 th2 ..}
83.57 - ultimately show ?thesis by blast
83.58 -qed
83.59 -
83.60 -
83.61 -subsection{* More lemmas about module of complex numbers *}
83.62 -
83.63 -lemma complex_of_real_power: "complex_of_real x ^ n = complex_of_real (x^n)"
83.64 - by (rule of_real_power [symmetric])
83.65 -
83.66 -lemma real_down2: "(0::real) < d1 \<Longrightarrow> 0 < d2 ==> EX e. 0 < e & e < d1 & e < d2"
83.67 - apply ferrack apply arith done
83.68 -
83.69 -text{* The triangle inequality for cmod *}
83.70 -lemma complex_mod_triangle_sub: "cmod w \<le> cmod (w + z) + norm z"
83.71 - using complex_mod_triangle_ineq2[of "w + z" "-z"] by auto
83.72 -
83.73 -subsection{* Basic lemmas about complex polynomials *}
83.74 -
83.75 -lemma poly_bound_exists:
83.76 - shows "\<exists>m. m > 0 \<and> (\<forall>z. cmod z <= r \<longrightarrow> cmod (poly p z) \<le> m)"
83.77 -proof(induct p)
83.78 - case Nil thus ?case by (rule exI[where x=1], simp)
83.79 -next
83.80 - case (Cons c cs)
83.81 - from Cons.hyps obtain m where m: "\<forall>z. cmod z \<le> r \<longrightarrow> cmod (poly cs z) \<le> m"
83.82 - by blast
83.83 - let ?k = " 1 + cmod c + \<bar>r * m\<bar>"
83.84 - have kp: "?k > 0" using abs_ge_zero[of "r*m"] norm_ge_zero[of c] by arith
83.85 - {fix z
83.86 - assume H: "cmod z \<le> r"
83.87 - from m H have th: "cmod (poly cs z) \<le> m" by blast
83.88 - from H have rp: "r \<ge> 0" using norm_ge_zero[of z] by arith
83.89 - have "cmod (poly (c # cs) z) \<le> cmod c + cmod (z* poly cs z)"
83.90 - using norm_triangle_ineq[of c "z* poly cs z"] by simp
83.91 - also have "\<dots> \<le> cmod c + r*m" using mult_mono[OF H th rp norm_ge_zero[of "poly cs z"]] by (simp add: norm_mult)
83.92 - also have "\<dots> \<le> ?k" by simp
83.93 - finally have "cmod (poly (c # cs) z) \<le> ?k" .}
83.94 - with kp show ?case by blast
83.95 -qed
83.96 -
83.97 -
83.98 -text{* Offsetting the variable in a polynomial gives another of same degree *}
83.99 - (* FIXME : Lemma holds also in locale --- fix it later *)
83.100 -lemma poly_offset_lemma:
83.101 - shows "\<exists>b q. (length q = length p) \<and> (\<forall>x. poly (b#q) (x::complex) = (a + x) * poly p x)"
83.102 -proof(induct p)
83.103 - case Nil thus ?case by simp
83.104 -next
83.105 - case (Cons c cs)
83.106 - from Cons.hyps obtain b q where
83.107 - bq: "length q = length cs" "\<forall>x. poly (b # q) x = (a + x) * poly cs x"
83.108 - by blast
83.109 - let ?b = "a*c"
83.110 - let ?q = "(b+c)#q"
83.111 - have lg: "length ?q = length (c#cs)" using bq(1) by simp
83.112 - {fix x
83.113 - from bq(2)[rule_format, of x]
83.114 - have "x*poly (b # q) x = x*((a + x) * poly cs x)" by simp
83.115 - hence "poly (?b# ?q) x = (a + x) * poly (c # cs) x"
83.116 - by (simp add: ring_simps)}
83.117 - with lg show ?case by blast
83.118 -qed
83.119 -
83.120 - (* FIXME : This one too*)
83.121 -lemma poly_offset: "\<exists> q. length q = length p \<and> (\<forall>x. poly q (x::complex) = poly p (a + x))"
83.122 -proof (induct p)
83.123 - case Nil thus ?case by simp
83.124 -next
83.125 - case (Cons c cs)
83.126 - from Cons.hyps obtain q where q: "length q = length cs" "\<forall>x. poly q x = poly cs (a + x)" by blast
83.127 - from poly_offset_lemma[of q a] obtain b p where
83.128 - bp: "length p = length q" "\<forall>x. poly (b # p) x = (a + x) * poly q x"
83.129 - by blast
83.130 - thus ?case using q bp by - (rule exI[where x="(c + b)#p"], simp)
83.131 -qed
83.132 -
83.133 -text{* An alternative useful formulation of completeness of the reals *}
83.134 -lemma real_sup_exists: assumes ex: "\<exists>x. P x" and bz: "\<exists>z. \<forall>x. P x \<longrightarrow> x < z"
83.135 - shows "\<exists>(s::real). \<forall>y. (\<exists>x. P x \<and> y < x) \<longleftrightarrow> y < s"
83.136 -proof-
83.137 - from ex bz obtain x Y where x: "P x" and Y: "\<And>x. P x \<Longrightarrow> x < Y" by blast
83.138 - from ex have thx:"\<exists>x. x \<in> Collect P" by blast
83.139 - from bz have thY: "\<exists>Y. isUb UNIV (Collect P) Y"
83.140 - by(auto simp add: isUb_def isLub_def setge_def setle_def leastP_def Ball_def order_le_less)
83.141 - from reals_complete[OF thx thY] obtain L where L: "isLub UNIV (Collect P) L"
83.142 - by blast
83.143 - from Y[OF x] have xY: "x < Y" .
83.144 - from L have L': "\<forall>x. P x \<longrightarrow> x \<le> L" by (auto simp add: isUb_def isLub_def setge_def setle_def leastP_def Ball_def)
83.145 - from Y have Y': "\<forall>x. P x \<longrightarrow> x \<le> Y"
83.146 - apply (clarsimp, atomize (full)) by auto
83.147 - from L Y' have "L \<le> Y" by (auto simp add: isUb_def isLub_def setge_def setle_def leastP_def Ball_def)
83.148 - {fix y
83.149 - {fix z assume z: "P z" "y < z"
83.150 - from L' z have "y < L" by auto }
83.151 - moreover
83.152 - {assume yL: "y < L" "\<forall>z. P z \<longrightarrow> \<not> y < z"
83.153 - hence nox: "\<forall>z. P z \<longrightarrow> y \<ge> z" by auto
83.154 - from nox L have "y \<ge> L" by (auto simp add: isUb_def isLub_def setge_def setle_def leastP_def Ball_def)
83.155 - with yL(1) have False by arith}
83.156 - ultimately have "(\<exists>x. P x \<and> y < x) \<longleftrightarrow> y < L" by blast}
83.157 - thus ?thesis by blast
83.158 -qed
83.159 -
83.160 -
83.161 -subsection{* Some theorems about Sequences*}
83.162 -text{* Given a binary function @{text "f:: nat \<Rightarrow> 'a \<Rightarrow> 'a"}, its values are uniquely determined by a function g *}
83.163 -
83.164 -lemma num_Axiom: "EX! g. g 0 = e \<and> (\<forall>n. g (Suc n) = f n (g n))"
83.165 - unfolding Ex1_def
83.166 - apply (rule_tac x="nat_rec e f" in exI)
83.167 - apply (rule conjI)+
83.168 -apply (rule def_nat_rec_0, simp)
83.169 -apply (rule allI, rule def_nat_rec_Suc, simp)
83.170 -apply (rule allI, rule impI, rule ext)
83.171 -apply (erule conjE)
83.172 -apply (induct_tac x)
83.173 -apply (simp add: nat_rec_0)
83.174 -apply (erule_tac x="n" in allE)
83.175 -apply (simp)
83.176 -done
83.177 -
83.178 - text{* An equivalent formulation of monotony -- Not used here, but might be useful *}
83.179 -lemma mono_Suc: "mono f = (\<forall>n. (f n :: 'a :: order) \<le> f (Suc n))"
83.180 -unfolding mono_def
83.181 -proof auto
83.182 - fix A B :: nat
83.183 - assume H: "\<forall>n. f n \<le> f (Suc n)" "A \<le> B"
83.184 - hence "\<exists>k. B = A + k" apply - apply (thin_tac "\<forall>n. f n \<le> f (Suc n)")
83.185 - by presburger
83.186 - then obtain k where k: "B = A + k" by blast
83.187 - {fix a k
83.188 - have "f a \<le> f (a + k)"
83.189 - proof (induct k)
83.190 - case 0 thus ?case by simp
83.191 - next
83.192 - case (Suc k)
83.193 - from Suc.hyps H(1)[rule_format, of "a + k"] show ?case by simp
83.194 - qed}
83.195 - with k show "f A \<le> f B" by blast
83.196 -qed
83.197 -
83.198 -text{* for any sequence, there is a mootonic subsequence *}
83.199 -lemma seq_monosub: "\<exists>f. subseq f \<and> monoseq (\<lambda> n. (s (f n)))"
83.200 -proof-
83.201 - {assume H: "\<forall>n. \<exists>p >n. \<forall> m\<ge>p. s m \<le> s p"
83.202 - let ?P = "\<lambda> p n. p > n \<and> (\<forall>m \<ge> p. s m \<le> s p)"
83.203 - from num_Axiom[of "SOME p. ?P p 0" "\<lambda>p n. SOME p. ?P p n"]
83.204 - obtain f where f: "f 0 = (SOME p. ?P p 0)" "\<forall>n. f (Suc n) = (SOME p. ?P p (f n))" by blast
83.205 - have "?P (f 0) 0" unfolding f(1) some_eq_ex[of "\<lambda>p. ?P p 0"]
83.206 - using H apply -
83.207 - apply (erule allE[where x=0], erule exE, rule_tac x="p" in exI)
83.208 - unfolding order_le_less by blast
83.209 - hence f0: "f 0 > 0" "\<forall>m \<ge> f 0. s m \<le> s (f 0)" by blast+
83.210 - {fix n
83.211 - have "?P (f (Suc n)) (f n)"
83.212 - unfolding f(2)[rule_format, of n] some_eq_ex[of "\<lambda>p. ?P p (f n)"]
83.213 - using H apply -
83.214 - apply (erule allE[where x="f n"], erule exE, rule_tac x="p" in exI)
83.215 - unfolding order_le_less by blast
83.216 - hence "f (Suc n) > f n" "\<forall>m \<ge> f (Suc n). s m \<le> s (f (Suc n))" by blast+}
83.217 - note fSuc = this
83.218 - {fix p q assume pq: "p \<ge> f q"
83.219 - have "s p \<le> s(f(q))" using f0(2)[rule_format, of p] pq fSuc
83.220 - by (cases q, simp_all) }
83.221 - note pqth = this
83.222 - {fix q
83.223 - have "f (Suc q) > f q" apply (induct q)
83.224 - using f0(1) fSuc(1)[of 0] apply simp by (rule fSuc(1))}
83.225 - note fss = this
83.226 - from fss have th1: "subseq f" unfolding subseq_Suc_iff ..
83.227 - {fix a b
83.228 - have "f a \<le> f (a + b)"
83.229 - proof(induct b)
83.230 - case 0 thus ?case by simp
83.231 - next
83.232 - case (Suc b)
83.233 - from fSuc(1)[of "a + b"] Suc.hyps show ?case by simp
83.234 - qed}
83.235 - note fmon0 = this
83.236 - have "monoseq (\<lambda>n. s (f n))"
83.237 - proof-
83.238 - {fix n
83.239 - have "s (f n) \<ge> s (f (Suc n))"
83.240 - proof(cases n)
83.241 - case 0
83.242 - assume n0: "n = 0"
83.243 - from fSuc(1)[of 0] have th0: "f 0 \<le> f (Suc 0)" by simp
83.244 - from f0(2)[rule_format, OF th0] show ?thesis using n0 by simp
83.245 - next
83.246 - case (Suc m)
83.247 - assume m: "n = Suc m"
83.248 - from fSuc(1)[of n] m have th0: "f (Suc m) \<le> f (Suc (Suc m))" by simp
83.249 - from m fSuc(2)[rule_format, OF th0] show ?thesis by simp
83.250 - qed}
83.251 - thus "monoseq (\<lambda>n. s (f n))" unfolding monoseq_Suc by blast
83.252 - qed
83.253 - with th1 have ?thesis by blast}
83.254 - moreover
83.255 - {fix N assume N: "\<forall>p >N. \<exists> m\<ge>p. s m > s p"
83.256 - {fix p assume p: "p \<ge> Suc N"
83.257 - hence pN: "p > N" by arith with N obtain m where m: "m \<ge> p" "s m > s p" by blast
83.258 - have "m \<noteq> p" using m(2) by auto
83.259 - with m have "\<exists>m>p. s p < s m" by - (rule exI[where x=m], auto)}
83.260 - note th0 = this
83.261 - let ?P = "\<lambda>m x. m > x \<and> s x < s m"
83.262 - from num_Axiom[of "SOME x. ?P x (Suc N)" "\<lambda>m x. SOME y. ?P y x"]
83.263 - obtain f where f: "f 0 = (SOME x. ?P x (Suc N))"
83.264 - "\<forall>n. f (Suc n) = (SOME m. ?P m (f n))" by blast
83.265 - have "?P (f 0) (Suc N)" unfolding f(1) some_eq_ex[of "\<lambda>p. ?P p (Suc N)"]
83.266 - using N apply -
83.267 - apply (erule allE[where x="Suc N"], clarsimp)
83.268 - apply (rule_tac x="m" in exI)
83.269 - apply auto
83.270 - apply (subgoal_tac "Suc N \<noteq> m")
83.271 - apply simp
83.272 - apply (rule ccontr, simp)
83.273 - done
83.274 - hence f0: "f 0 > Suc N" "s (Suc N) < s (f 0)" by blast+
83.275 - {fix n
83.276 - have "f n > N \<and> ?P (f (Suc n)) (f n)"
83.277 - unfolding f(2)[rule_format, of n] some_eq_ex[of "\<lambda>p. ?P p (f n)"]
83.278 - proof (induct n)
83.279 - case 0 thus ?case
83.280 - using f0 N apply auto
83.281 - apply (erule allE[where x="f 0"], clarsimp)
83.282 - apply (rule_tac x="m" in exI, simp)
83.283 - by (subgoal_tac "f 0 \<noteq> m", auto)
83.284 - next
83.285 - case (Suc n)
83.286 - from Suc.hyps have Nfn: "N < f n" by blast
83.287 - from Suc.hyps obtain m where m: "m > f n" "s (f n) < s m" by blast
83.288 - with Nfn have mN: "m > N" by arith
83.289 - note key = Suc.hyps[unfolded some_eq_ex[of "\<lambda>p. ?P p (f n)", symmetric] f(2)[rule_format, of n, symmetric]]
83.290 -
83.291 - from key have th0: "f (Suc n) > N" by simp
83.292 - from N[rule_format, OF th0]
83.293 - obtain m' where m': "m' \<ge> f (Suc n)" "s (f (Suc n)) < s m'" by blast
83.294 - have "m' \<noteq> f (Suc (n))" apply (rule ccontr) using m'(2) by auto
83.295 - hence "m' > f (Suc n)" using m'(1) by simp
83.296 - with key m'(2) show ?case by auto
83.297 - qed}
83.298 - note fSuc = this
83.299 - {fix n
83.300 - have "f n \<ge> Suc N \<and> f(Suc n) > f n \<and> s(f n) < s(f(Suc n))" using fSuc[of n] by auto
83.301 - hence "f n \<ge> Suc N" "f(Suc n) > f n" "s(f n) < s(f(Suc n))" by blast+}
83.302 - note thf = this
83.303 - have sqf: "subseq f" unfolding subseq_Suc_iff using thf by simp
83.304 - have "monoseq (\<lambda>n. s (f n))" unfolding monoseq_Suc using thf
83.305 - apply -
83.306 - apply (rule disjI1)
83.307 - apply auto
83.308 - apply (rule order_less_imp_le)
83.309 - apply blast
83.310 - done
83.311 - then have ?thesis using sqf by blast}
83.312 - ultimately show ?thesis unfolding linorder_not_less[symmetric] by blast
83.313 -qed
83.314 -
83.315 -lemma seq_suble: assumes sf: "subseq f" shows "n \<le> f n"
83.316 -proof(induct n)
83.317 - case 0 thus ?case by simp
83.318 -next
83.319 - case (Suc n)
83.320 - from sf[unfolded subseq_Suc_iff, rule_format, of n] Suc.hyps
83.321 - have "n < f (Suc n)" by arith
83.322 - thus ?case by arith
83.323 -qed
83.324 -
83.325 -subsection {* Fundamental theorem of algebra *}
83.326 -lemma unimodular_reduce_norm:
83.327 - assumes md: "cmod z = 1"
83.328 - shows "cmod (z + 1) < 1 \<or> cmod (z - 1) < 1 \<or> cmod (z + ii) < 1 \<or> cmod (z - ii) < 1"
83.329 -proof-
83.330 - obtain x y where z: "z = Complex x y " by (cases z, auto)
83.331 - from md z have xy: "x^2 + y^2 = 1" by (simp add: cmod_def)
83.332 - {assume C: "cmod (z + 1) \<ge> 1" "cmod (z - 1) \<ge> 1" "cmod (z + ii) \<ge> 1" "cmod (z - ii) \<ge> 1"
83.333 - from C z xy have "2*x \<le> 1" "2*x \<ge> -1" "2*y \<le> 1" "2*y \<ge> -1"
83.334 - by (simp_all add: cmod_def power2_eq_square ring_simps)
83.335 - hence "abs (2*x) \<le> 1" "abs (2*y) \<le> 1" by simp_all
83.336 - hence "(abs (2 * x))^2 <= 1^2" "(abs (2 * y)) ^2 <= 1^2"
83.337 - by - (rule power_mono, simp, simp)+
83.338 - hence th0: "4*x^2 \<le> 1" "4*y^2 \<le> 1"
83.339 - by (simp_all add: power2_abs power_mult_distrib)
83.340 - from add_mono[OF th0] xy have False by simp }
83.341 - thus ?thesis unfolding linorder_not_le[symmetric] by blast
83.342 -qed
83.343 -
83.344 -text{* Hence we can always reduce modulus of @{text "1 + b z^n"} if nonzero *}
83.345 -lemma reduce_poly_simple:
83.346 - assumes b: "b \<noteq> 0" and n: "n\<noteq>0"
83.347 - shows "\<exists>z. cmod (1 + b * z^n) < 1"
83.348 -using n
83.349 -proof(induct n rule: nat_less_induct)
83.350 - fix n
83.351 - assume IH: "\<forall>m<n. m \<noteq> 0 \<longrightarrow> (\<exists>z. cmod (1 + b * z ^ m) < 1)" and n: "n \<noteq> 0"
83.352 - let ?P = "\<lambda>z n. cmod (1 + b * z ^ n) < 1"
83.353 - {assume e: "even n"
83.354 - hence "\<exists>m. n = 2*m" by presburger
83.355 - then obtain m where m: "n = 2*m" by blast
83.356 - from n m have "m\<noteq>0" "m < n" by presburger+
83.357 - with IH[rule_format, of m] obtain z where z: "?P z m" by blast
83.358 - from z have "?P (csqrt z) n" by (simp add: m power_mult csqrt)
83.359 - hence "\<exists>z. ?P z n" ..}
83.360 - moreover
83.361 - {assume o: "odd n"
83.362 - from b have b': "b^2 \<noteq> 0" unfolding power2_eq_square by simp
83.363 - have "Im (inverse b) * (Im (inverse b) * \<bar>Im b * Im b + Re b * Re b\<bar>) +
83.364 - Re (inverse b) * (Re (inverse b) * \<bar>Im b * Im b + Re b * Re b\<bar>) =
83.365 - ((Re (inverse b))^2 + (Im (inverse b))^2) * \<bar>Im b * Im b + Re b * Re b\<bar>" by algebra
83.366 - also have "\<dots> = cmod (inverse b) ^2 * cmod b ^ 2"
83.367 - apply (simp add: cmod_def) using realpow_two_le_add_order[of "Re b" "Im b"]
83.368 - by (simp add: power2_eq_square)
83.369 - finally
83.370 - have th0: "Im (inverse b) * (Im (inverse b) * \<bar>Im b * Im b + Re b * Re b\<bar>) +
83.371 - Re (inverse b) * (Re (inverse b) * \<bar>Im b * Im b + Re b * Re b\<bar>) =
83.372 - 1"
83.373 - apply (simp add: power2_eq_square norm_mult[symmetric] norm_inverse[symmetric])
83.374 - using right_inverse[OF b']
83.375 - by (simp add: power2_eq_square[symmetric] power_inverse[symmetric] ring_simps)
83.376 - have th0: "cmod (complex_of_real (cmod b) / b) = 1"
83.377 - apply (simp add: complex_Re_mult cmod_def power2_eq_square Re_complex_of_real Im_complex_of_real divide_inverse ring_simps )
83.378 - by (simp add: real_sqrt_mult[symmetric] th0)
83.379 - from o have "\<exists>m. n = Suc (2*m)" by presburger+
83.380 - then obtain m where m: "n = Suc (2*m)" by blast
83.381 - from unimodular_reduce_norm[OF th0] o
83.382 - have "\<exists>v. cmod (complex_of_real (cmod b) / b + v^n) < 1"
83.383 - apply (cases "cmod (complex_of_real (cmod b) / b + 1) < 1", rule_tac x="1" in exI, simp)
83.384 - apply (cases "cmod (complex_of_real (cmod b) / b - 1) < 1", rule_tac x="-1" in exI, simp add: diff_def)
83.385 - apply (cases "cmod (complex_of_real (cmod b) / b + ii) < 1")
83.386 - apply (cases "even m", rule_tac x="ii" in exI, simp add: m power_mult)
83.387 - apply (rule_tac x="- ii" in exI, simp add: m power_mult)
83.388 - apply (cases "even m", rule_tac x="- ii" in exI, simp add: m power_mult diff_def)
83.389 - apply (rule_tac x="ii" in exI, simp add: m power_mult diff_def)
83.390 - done
83.391 - then obtain v where v: "cmod (complex_of_real (cmod b) / b + v^n) < 1" by blast
83.392 - let ?w = "v / complex_of_real (root n (cmod b))"
83.393 - from odd_real_root_pow[OF o, of "cmod b"]
83.394 - have th1: "?w ^ n = v^n / complex_of_real (cmod b)"
83.395 - by (simp add: power_divide complex_of_real_power)
83.396 - have th2:"cmod (complex_of_real (cmod b) / b) = 1" using b by (simp add: norm_divide)
83.397 - hence th3: "cmod (complex_of_real (cmod b) / b) \<ge> 0" by simp
83.398 - have th4: "cmod (complex_of_real (cmod b) / b) *
83.399 - cmod (1 + b * (v ^ n / complex_of_real (cmod b)))
83.400 - < cmod (complex_of_real (cmod b) / b) * 1"
83.401 - apply (simp only: norm_mult[symmetric] right_distrib)
83.402 - using b v by (simp add: th2)
83.403 -
83.404 - from mult_less_imp_less_left[OF th4 th3]
83.405 - have "?P ?w n" unfolding th1 .
83.406 - hence "\<exists>z. ?P z n" .. }
83.407 - ultimately show "\<exists>z. ?P z n" by blast
83.408 -qed
83.409 -
83.410 -
83.411 -text{* Bolzano-Weierstrass type property for closed disc in complex plane. *}
83.412 -
83.413 -lemma metric_bound_lemma: "cmod (x - y) <= \<bar>Re x - Re y\<bar> + \<bar>Im x - Im y\<bar>"
83.414 - using real_sqrt_sum_squares_triangle_ineq[of "Re x - Re y" 0 0 "Im x - Im y" ]
83.415 - unfolding cmod_def by simp
83.416 -
83.417 -lemma bolzano_weierstrass_complex_disc:
83.418 - assumes r: "\<forall>n. cmod (s n) \<le> r"
83.419 - shows "\<exists>f z. subseq f \<and> (\<forall>e >0. \<exists>N. \<forall>n \<ge> N. cmod (s (f n) - z) < e)"
83.420 -proof-
83.421 - from seq_monosub[of "Re o s"]
83.422 - obtain f g where f: "subseq f" "monoseq (\<lambda>n. Re (s (f n)))"
83.423 - unfolding o_def by blast
83.424 - from seq_monosub[of "Im o s o f"]
83.425 - obtain g where g: "subseq g" "monoseq (\<lambda>n. Im (s(f(g n))))" unfolding o_def by blast
83.426 - let ?h = "f o g"
83.427 - from r[rule_format, of 0] have rp: "r \<ge> 0" using norm_ge_zero[of "s 0"] by arith
83.428 - have th:"\<forall>n. r + 1 \<ge> \<bar> Re (s n)\<bar>"
83.429 - proof
83.430 - fix n
83.431 - from abs_Re_le_cmod[of "s n"] r[rule_format, of n] show "\<bar>Re (s n)\<bar> \<le> r + 1" by arith
83.432 - qed
83.433 - have conv1: "convergent (\<lambda>n. Re (s ( f n)))"
83.434 - apply (rule Bseq_monoseq_convergent)
83.435 - apply (simp add: Bseq_def)
83.436 - apply (rule exI[where x= "r + 1"])
83.437 - using th rp apply simp
83.438 - using f(2) .
83.439 - have th:"\<forall>n. r + 1 \<ge> \<bar> Im (s n)\<bar>"
83.440 - proof
83.441 - fix n
83.442 - from abs_Im_le_cmod[of "s n"] r[rule_format, of n] show "\<bar>Im (s n)\<bar> \<le> r + 1" by arith
83.443 - qed
83.444 -
83.445 - have conv2: "convergent (\<lambda>n. Im (s (f (g n))))"
83.446 - apply (rule Bseq_monoseq_convergent)
83.447 - apply (simp add: Bseq_def)
83.448 - apply (rule exI[where x= "r + 1"])
83.449 - using th rp apply simp
83.450 - using g(2) .
83.451 -
83.452 - from conv1[unfolded convergent_def] obtain x where "LIMSEQ (\<lambda>n. Re (s (f n))) x"
83.453 - by blast
83.454 - hence x: "\<forall>r>0. \<exists>n0. \<forall>n\<ge>n0. \<bar> Re (s (f n)) - x \<bar> < r"
83.455 - unfolding LIMSEQ_def real_norm_def .
83.456 -
83.457 - from conv2[unfolded convergent_def] obtain y where "LIMSEQ (\<lambda>n. Im (s (f (g n)))) y"
83.458 - by blast
83.459 - hence y: "\<forall>r>0. \<exists>n0. \<forall>n\<ge>n0. \<bar> Im (s (f (g n))) - y \<bar> < r"
83.460 - unfolding LIMSEQ_def real_norm_def .
83.461 - let ?w = "Complex x y"
83.462 - from f(1) g(1) have hs: "subseq ?h" unfolding subseq_def by auto
83.463 - {fix e assume ep: "e > (0::real)"
83.464 - hence e2: "e/2 > 0" by simp
83.465 - from x[rule_format, OF e2] y[rule_format, OF e2]
83.466 - obtain N1 N2 where N1: "\<forall>n\<ge>N1. \<bar>Re (s (f n)) - x\<bar> < e / 2" and N2: "\<forall>n\<ge>N2. \<bar>Im (s (f (g n))) - y\<bar> < e / 2" by blast
83.467 - {fix n assume nN12: "n \<ge> N1 + N2"
83.468 - hence nN1: "g n \<ge> N1" and nN2: "n \<ge> N2" using seq_suble[OF g(1), of n] by arith+
83.469 - from add_strict_mono[OF N1[rule_format, OF nN1] N2[rule_format, OF nN2]]
83.470 - have "cmod (s (?h n) - ?w) < e"
83.471 - using metric_bound_lemma[of "s (f (g n))" ?w] by simp }
83.472 - hence "\<exists>N. \<forall>n\<ge>N. cmod (s (?h n) - ?w) < e" by blast }
83.473 - with hs show ?thesis by blast
83.474 -qed
83.475 -
83.476 -text{* Polynomial is continuous. *}
83.477 -
83.478 -lemma poly_cont:
83.479 - assumes ep: "e > 0"
83.480 - shows "\<exists>d >0. \<forall>w. 0 < cmod (w - z) \<and> cmod (w - z) < d \<longrightarrow> cmod (poly p w - poly p z) < e"
83.481 -proof-
83.482 - from poly_offset[of p z] obtain q where q: "length q = length p" "\<And>x. poly q x = poly p (z + x)" by blast
83.483 - {fix w
83.484 - note q(2)[of "w - z", simplified]}
83.485 - note th = this
83.486 - show ?thesis unfolding th[symmetric]
83.487 - proof(induct q)
83.488 - case Nil thus ?case using ep by auto
83.489 - next
83.490 - case (Cons c cs)
83.491 - from poly_bound_exists[of 1 "cs"]
83.492 - obtain m where m: "m > 0" "\<And>z. cmod z \<le> 1 \<Longrightarrow> cmod (poly cs z) \<le> m" by blast
83.493 - from ep m(1) have em0: "e/m > 0" by (simp add: field_simps)
83.494 - have one0: "1 > (0::real)" by arith
83.495 - from real_lbound_gt_zero[OF one0 em0]
83.496 - obtain d where d: "d >0" "d < 1" "d < e / m" by blast
83.497 - from d(1,3) m(1) have dm: "d*m > 0" "d*m < e"
83.498 - by (simp_all add: field_simps real_mult_order)
83.499 - show ?case
83.500 - proof(rule ex_forward[OF real_lbound_gt_zero[OF one0 em0]], clarsimp simp add: norm_mult)
83.501 - fix d w
83.502 - assume H: "d > 0" "d < 1" "d < e/m" "w\<noteq>z" "cmod (w-z) < d"
83.503 - hence d1: "cmod (w-z) \<le> 1" "d \<ge> 0" by simp_all
83.504 - from H(3) m(1) have dme: "d*m < e" by (simp add: field_simps)
83.505 - from H have th: "cmod (w-z) \<le> d" by simp
83.506 - from mult_mono[OF th m(2)[OF d1(1)] d1(2) norm_ge_zero] dme
83.507 - show "cmod (w - z) * cmod (poly cs (w - z)) < e" by simp
83.508 - qed
83.509 - qed
83.510 -qed
83.511 -
83.512 -text{* Hence a polynomial attains minimum on a closed disc
83.513 - in the complex plane. *}
83.514 -lemma poly_minimum_modulus_disc:
83.515 - "\<exists>z. \<forall>w. cmod w \<le> r \<longrightarrow> cmod (poly p z) \<le> cmod (poly p w)"
83.516 -proof-
83.517 - {assume "\<not> r \<ge> 0" hence ?thesis unfolding linorder_not_le
83.518 - apply -
83.519 - apply (rule exI[where x=0])
83.520 - apply auto
83.521 - apply (subgoal_tac "cmod w < 0")
83.522 - apply simp
83.523 - apply arith
83.524 - done }
83.525 - moreover
83.526 - {assume rp: "r \<ge> 0"
83.527 - from rp have "cmod 0 \<le> r \<and> cmod (poly p 0) = - (- cmod (poly p 0))" by simp
83.528 - hence mth1: "\<exists>x z. cmod z \<le> r \<and> cmod (poly p z) = - x" by blast
83.529 - {fix x z
83.530 - assume H: "cmod z \<le> r" "cmod (poly p z) = - x" "\<not>x < 1"
83.531 - hence "- x < 0 " by arith
83.532 - with H(2) norm_ge_zero[of "poly p z"] have False by simp }
83.533 - then have mth2: "\<exists>z. \<forall>x. (\<exists>z. cmod z \<le> r \<and> cmod (poly p z) = - x) \<longrightarrow> x < z" by blast
83.534 - from real_sup_exists[OF mth1 mth2] obtain s where
83.535 - s: "\<forall>y. (\<exists>x. (\<exists>z. cmod z \<le> r \<and> cmod (poly p z) = - x) \<and> y < x) \<longleftrightarrow>(y < s)" by blast
83.536 - let ?m = "-s"
83.537 - {fix y
83.538 - from s[rule_format, of "-y"] have
83.539 - "(\<exists>z x. cmod z \<le> r \<and> -(- cmod (poly p z)) < y) \<longleftrightarrow> ?m < y"
83.540 - unfolding minus_less_iff[of y ] equation_minus_iff by blast }
83.541 - note s1 = this[unfolded minus_minus]
83.542 - from s1[of ?m] have s1m: "\<And>z x. cmod z \<le> r \<Longrightarrow> cmod (poly p z) \<ge> ?m"
83.543 - by auto
83.544 - {fix n::nat
83.545 - from s1[rule_format, of "?m + 1/real (Suc n)"]
83.546 - have "\<exists>z. cmod z \<le> r \<and> cmod (poly p z) < - s + 1 / real (Suc n)"
83.547 - by simp}
83.548 - hence th: "\<forall>n. \<exists>z. cmod z \<le> r \<and> cmod (poly p z) < - s + 1 / real (Suc n)" ..
83.549 - from choice[OF th] obtain g where
83.550 - g: "\<forall>n. cmod (g n) \<le> r" "\<forall>n. cmod (poly p (g n)) <?m+1 /real(Suc n)"
83.551 - by blast
83.552 - from bolzano_weierstrass_complex_disc[OF g(1)]
83.553 - obtain f z where fz: "subseq f" "\<forall>e>0. \<exists>N. \<forall>n\<ge>N. cmod (g (f n) - z) < e"
83.554 - by blast
83.555 - {fix w
83.556 - assume wr: "cmod w \<le> r"
83.557 - let ?e = "\<bar>cmod (poly p z) - ?m\<bar>"
83.558 - {assume e: "?e > 0"
83.559 - hence e2: "?e/2 > 0" by simp
83.560 - from poly_cont[OF e2, of z p] obtain d where
83.561 - d: "d>0" "\<forall>w. 0<cmod (w - z)\<and> cmod(w - z) < d \<longrightarrow> cmod(poly p w - poly p z) < ?e/2" by blast
83.562 - {fix w assume w: "cmod (w - z) < d"
83.563 - have "cmod(poly p w - poly p z) < ?e / 2"
83.564 - using d(2)[rule_format, of w] w e by (cases "w=z", simp_all)}
83.565 - note th1 = this
83.566 -
83.567 - from fz(2)[rule_format, OF d(1)] obtain N1 where
83.568 - N1: "\<forall>n\<ge>N1. cmod (g (f n) - z) < d" by blast
83.569 - from reals_Archimedean2[of "2/?e"] obtain N2::nat where
83.570 - N2: "2/?e < real N2" by blast
83.571 - have th2: "cmod(poly p (g(f(N1 + N2))) - poly p z) < ?e/2"
83.572 - using N1[rule_format, of "N1 + N2"] th1 by simp
83.573 - {fix a b e2 m :: real
83.574 - have "a < e2 \<Longrightarrow> abs(b - m) < e2 \<Longrightarrow> 2 * e2 <= abs(b - m) + a
83.575 - ==> False" by arith}
83.576 - note th0 = this
83.577 - have ath:
83.578 - "\<And>m x e. m <= x \<Longrightarrow> x < m + e ==> abs(x - m::real) < e" by arith
83.579 - from s1m[OF g(1)[rule_format]]
83.580 - have th31: "?m \<le> cmod(poly p (g (f (N1 + N2))))" .
83.581 - from seq_suble[OF fz(1), of "N1+N2"]
83.582 - have th00: "real (Suc (N1+N2)) \<le> real (Suc (f (N1+N2)))" by simp
83.583 - have th000: "0 \<le> (1::real)" "(1::real) \<le> 1" "real (Suc (N1+N2)) > 0"
83.584 - using N2 by auto
83.585 - from frac_le[OF th000 th00] have th00: "?m +1 / real (Suc (f (N1 + N2))) \<le> ?m + 1 / real (Suc (N1 + N2))" by simp
83.586 - from g(2)[rule_format, of "f (N1 + N2)"]
83.587 - have th01:"cmod (poly p (g (f (N1 + N2)))) < - s + 1 / real (Suc (f (N1 + N2)))" .
83.588 - from order_less_le_trans[OF th01 th00]
83.589 - have th32: "cmod(poly p (g (f (N1 + N2)))) < ?m + (1/ real(Suc (N1 + N2)))" .
83.590 - from N2 have "2/?e < real (Suc (N1 + N2))" by arith
83.591 - with e2 less_imp_inverse_less[of "2/?e" "real (Suc (N1 + N2))"]
83.592 - have "?e/2 > 1/ real (Suc (N1 + N2))" by (simp add: inverse_eq_divide)
83.593 - with ath[OF th31 th32]
83.594 - have thc1:"\<bar>cmod(poly p (g (f (N1 + N2)))) - ?m\<bar>< ?e/2" by arith
83.595 - have ath2: "\<And>(a::real) b c m. \<bar>a - b\<bar> <= c ==> \<bar>b - m\<bar> <= \<bar>a - m\<bar> + c"
83.596 - by arith
83.597 - have th22: "\<bar>cmod (poly p (g (f (N1 + N2)))) - cmod (poly p z)\<bar>
83.598 -\<le> cmod (poly p (g (f (N1 + N2))) - poly p z)"
83.599 - by (simp add: norm_triangle_ineq3)
83.600 - from ath2[OF th22, of ?m]
83.601 - have thc2: "2*(?e/2) \<le> \<bar>cmod(poly p (g (f (N1 + N2)))) - ?m\<bar> + cmod (poly p (g (f (N1 + N2))) - poly p z)" by simp
83.602 - from th0[OF th2 thc1 thc2] have False .}
83.603 - hence "?e = 0" by auto
83.604 - then have "cmod (poly p z) = ?m" by simp
83.605 - with s1m[OF wr]
83.606 - have "cmod (poly p z) \<le> cmod (poly p w)" by simp }
83.607 - hence ?thesis by blast}
83.608 - ultimately show ?thesis by blast
83.609 -qed
83.610 -
83.611 -lemma "(rcis (sqrt (abs r)) (a/2)) ^ 2 = rcis (abs r) a"
83.612 - unfolding power2_eq_square
83.613 - apply (simp add: rcis_mult)
83.614 - apply (simp add: power2_eq_square[symmetric])
83.615 - done
83.616 -
83.617 -lemma cispi: "cis pi = -1"
83.618 - unfolding cis_def
83.619 - by simp
83.620 -
83.621 -lemma "(rcis (sqrt (abs r)) ((pi + a)/2)) ^ 2 = rcis (- abs r) a"
83.622 - unfolding power2_eq_square
83.623 - apply (simp add: rcis_mult add_divide_distrib)
83.624 - apply (simp add: power2_eq_square[symmetric] rcis_def cispi cis_mult[symmetric])
83.625 - done
83.626 -
83.627 -text {* Nonzero polynomial in z goes to infinity as z does. *}
83.628 -
83.629 -instance complex::idom_char_0 by (intro_classes)
83.630 -instance complex :: recpower_idom_char_0 by intro_classes
83.631 -
83.632 -lemma poly_infinity:
83.633 - assumes ex: "list_ex (\<lambda>c. c \<noteq> 0) p"
83.634 - shows "\<exists>r. \<forall>z. r \<le> cmod z \<longrightarrow> d \<le> cmod (poly (a#p) z)"
83.635 -using ex
83.636 -proof(induct p arbitrary: a d)
83.637 - case (Cons c cs a d)
83.638 - {assume H: "list_ex (\<lambda>c. c\<noteq>0) cs"
83.639 - with Cons.hyps obtain r where r: "\<forall>z. r \<le> cmod z \<longrightarrow> d + cmod a \<le> cmod (poly (c # cs) z)" by blast
83.640 - let ?r = "1 + \<bar>r\<bar>"
83.641 - {fix z assume h: "1 + \<bar>r\<bar> \<le> cmod z"
83.642 - have r0: "r \<le> cmod z" using h by arith
83.643 - from r[rule_format, OF r0]
83.644 - have th0: "d + cmod a \<le> 1 * cmod(poly (c#cs) z)" by arith
83.645 - from h have z1: "cmod z \<ge> 1" by arith
83.646 - from order_trans[OF th0 mult_right_mono[OF z1 norm_ge_zero[of "poly (c#cs) z"]]]
83.647 - have th1: "d \<le> cmod(z * poly (c#cs) z) - cmod a"
83.648 - unfolding norm_mult by (simp add: ring_simps)
83.649 - from complex_mod_triangle_sub[of "z * poly (c#cs) z" a]
83.650 - have th2: "cmod(z * poly (c#cs) z) - cmod a \<le> cmod (poly (a#c#cs) z)"
83.651 - by (simp add: diff_le_eq ring_simps)
83.652 - from th1 th2 have "d \<le> cmod (poly (a#c#cs) z)" by arith}
83.653 - hence ?case by blast}
83.654 - moreover
83.655 - {assume cs0: "\<not> (list_ex (\<lambda>c. c \<noteq> 0) cs)"
83.656 - with Cons.prems have c0: "c \<noteq> 0" by simp
83.657 - from cs0 have cs0': "list_all (\<lambda>c. c = 0) cs"
83.658 - by (auto simp add: list_all_iff list_ex_iff)
83.659 - {fix z
83.660 - assume h: "(\<bar>d\<bar> + cmod a) / cmod c \<le> cmod z"
83.661 - from c0 have "cmod c > 0" by simp
83.662 - from h c0 have th0: "\<bar>d\<bar> + cmod a \<le> cmod (z*c)"
83.663 - by (simp add: field_simps norm_mult)
83.664 - have ath: "\<And>mzh mazh ma. mzh <= mazh + ma ==> abs(d) + ma <= mzh ==> d <= mazh" by arith
83.665 - from complex_mod_triangle_sub[of "z*c" a ]
83.666 - have th1: "cmod (z * c) \<le> cmod (a + z * c) + cmod a"
83.667 - by (simp add: ring_simps)
83.668 - from ath[OF th1 th0] have "d \<le> cmod (poly (a # c # cs) z)"
83.669 - using poly_0[OF cs0'] by simp}
83.670 - then have ?case by blast}
83.671 - ultimately show ?case by blast
83.672 -qed simp
83.673 -
83.674 -text {* Hence polynomial's modulus attains its minimum somewhere. *}
83.675 -lemma poly_minimum_modulus:
83.676 - "\<exists>z.\<forall>w. cmod (poly p z) \<le> cmod (poly p w)"
83.677 -proof(induct p)
83.678 - case (Cons c cs)
83.679 - {assume cs0: "list_ex (\<lambda>c. c \<noteq> 0) cs"
83.680 - from poly_infinity[OF cs0, of "cmod (poly (c#cs) 0)" c]
83.681 - obtain r where r: "\<And>z. r \<le> cmod z \<Longrightarrow> cmod (poly (c # cs) 0) \<le> cmod (poly (c # cs) z)" by blast
83.682 - have ath: "\<And>z r. r \<le> cmod z \<or> cmod z \<le> \<bar>r\<bar>" by arith
83.683 - from poly_minimum_modulus_disc[of "\<bar>r\<bar>" "c#cs"]
83.684 - obtain v where v: "\<And>w. cmod w \<le> \<bar>r\<bar> \<Longrightarrow> cmod (poly (c # cs) v) \<le> cmod (poly (c # cs) w)" by blast
83.685 - {fix z assume z: "r \<le> cmod z"
83.686 - from v[of 0] r[OF z]
83.687 - have "cmod (poly (c # cs) v) \<le> cmod (poly (c # cs) z)"
83.688 - by simp }
83.689 - note v0 = this
83.690 - from v0 v ath[of r] have ?case by blast}
83.691 - moreover
83.692 - {assume cs0: "\<not> (list_ex (\<lambda>c. c\<noteq>0) cs)"
83.693 - hence th:"list_all (\<lambda>c. c = 0) cs" by (simp add: list_all_iff list_ex_iff)
83.694 - from poly_0[OF th] Cons.hyps have ?case by simp}
83.695 - ultimately show ?case by blast
83.696 -qed simp
83.697 -
83.698 -text{* Constant function (non-syntactic characterization). *}
83.699 -definition "constant f = (\<forall>x y. f x = f y)"
83.700 -
83.701 -lemma nonconstant_length: "\<not> (constant (poly p)) \<Longrightarrow> length p \<ge> 2"
83.702 - unfolding constant_def
83.703 - apply (induct p, auto)
83.704 - apply (unfold not_less[symmetric])
83.705 - apply simp
83.706 - apply (rule ccontr)
83.707 - apply auto
83.708 - done
83.709 -
83.710 -lemma poly_replicate_append:
83.711 - "poly ((replicate n 0)@p) (x::'a::{recpower, comm_ring}) = x^n * poly p x"
83.712 - by(induct n, auto simp add: power_Suc ring_simps)
83.713 -
83.714 -text {* Decomposition of polynomial, skipping zero coefficients
83.715 - after the first. *}
83.716 -
83.717 -lemma poly_decompose_lemma:
83.718 - assumes nz: "\<not>(\<forall>z. z\<noteq>0 \<longrightarrow> poly p z = (0::'a::{recpower,idom}))"
83.719 - shows "\<exists>k a q. a\<noteq>0 \<and> Suc (length q + k) = length p \<and>
83.720 - (\<forall>z. poly p z = z^k * poly (a#q) z)"
83.721 -using nz
83.722 -proof(induct p)
83.723 - case Nil thus ?case by simp
83.724 -next
83.725 - case (Cons c cs)
83.726 - {assume c0: "c = 0"
83.727 -
83.728 - from Cons.hyps Cons.prems c0 have ?case apply auto
83.729 - apply (rule_tac x="k+1" in exI)
83.730 - apply (rule_tac x="a" in exI, clarsimp)
83.731 - apply (rule_tac x="q" in exI)
83.732 - by (auto simp add: power_Suc)}
83.733 - moreover
83.734 - {assume c0: "c\<noteq>0"
83.735 - hence ?case apply-
83.736 - apply (rule exI[where x=0])
83.737 - apply (rule exI[where x=c], clarsimp)
83.738 - apply (rule exI[where x=cs])
83.739 - apply auto
83.740 - done}
83.741 - ultimately show ?case by blast
83.742 -qed
83.743 -
83.744 -lemma poly_decompose:
83.745 - assumes nc: "~constant(poly p)"
83.746 - shows "\<exists>k a q. a\<noteq>(0::'a::{recpower,idom}) \<and> k\<noteq>0 \<and>
83.747 - length q + k + 1 = length p \<and>
83.748 - (\<forall>z. poly p z = poly p 0 + z^k * poly (a#q) z)"
83.749 -using nc
83.750 -proof(induct p)
83.751 - case Nil thus ?case by (simp add: constant_def)
83.752 -next
83.753 - case (Cons c cs)
83.754 - {assume C:"\<forall>z. z \<noteq> 0 \<longrightarrow> poly cs z = 0"
83.755 - {fix x y
83.756 - from C have "poly (c#cs) x = poly (c#cs) y" by (cases "x=0", auto)}
83.757 - with Cons.prems have False by (auto simp add: constant_def)}
83.758 - hence th: "\<not> (\<forall>z. z \<noteq> 0 \<longrightarrow> poly cs z = 0)" ..
83.759 - from poly_decompose_lemma[OF th]
83.760 - show ?case
83.761 - apply clarsimp
83.762 - apply (rule_tac x="k+1" in exI)
83.763 - apply (rule_tac x="a" in exI)
83.764 - apply simp
83.765 - apply (rule_tac x="q" in exI)
83.766 - apply (auto simp add: power_Suc)
83.767 - done
83.768 -qed
83.769 -
83.770 -text{* Fundamental theorem of algebral *}
83.771 -
83.772 -lemma fundamental_theorem_of_algebra:
83.773 - assumes nc: "~constant(poly p)"
83.774 - shows "\<exists>z::complex. poly p z = 0"
83.775 -using nc
83.776 -proof(induct n\<equiv> "length p" arbitrary: p rule: nat_less_induct)
83.777 - fix n fix p :: "complex list"
83.778 - let ?p = "poly p"
83.779 - assume H: "\<forall>m<n. \<forall>p. \<not> constant (poly p) \<longrightarrow> m = length p \<longrightarrow> (\<exists>(z::complex). poly p z = 0)" and nc: "\<not> constant ?p" and n: "n = length p"
83.780 - let ?ths = "\<exists>z. ?p z = 0"
83.781 -
83.782 - from nonconstant_length[OF nc] have n2: "n\<ge> 2" by (simp add: n)
83.783 - from poly_minimum_modulus obtain c where
83.784 - c: "\<forall>w. cmod (?p c) \<le> cmod (?p w)" by blast
83.785 - {assume pc: "?p c = 0" hence ?ths by blast}
83.786 - moreover
83.787 - {assume pc0: "?p c \<noteq> 0"
83.788 - from poly_offset[of p c] obtain q where
83.789 - q: "length q = length p" "\<forall>x. poly q x = ?p (c+x)" by blast
83.790 - {assume h: "constant (poly q)"
83.791 - from q(2) have th: "\<forall>x. poly q (x - c) = ?p x" by auto
83.792 - {fix x y
83.793 - from th have "?p x = poly q (x - c)" by auto
83.794 - also have "\<dots> = poly q (y - c)"
83.795 - using h unfolding constant_def by blast
83.796 - also have "\<dots> = ?p y" using th by auto
83.797 - finally have "?p x = ?p y" .}
83.798 - with nc have False unfolding constant_def by blast }
83.799 - hence qnc: "\<not> constant (poly q)" by blast
83.800 - from q(2) have pqc0: "?p c = poly q 0" by simp
83.801 - from c pqc0 have cq0: "\<forall>w. cmod (poly q 0) \<le> cmod (?p w)" by simp
83.802 - let ?a0 = "poly q 0"
83.803 - from pc0 pqc0 have a00: "?a0 \<noteq> 0" by simp
83.804 - from a00
83.805 - have qr: "\<forall>z. poly q z = poly (map (op * (inverse ?a0)) q) z * ?a0"
83.806 - by (simp add: poly_cmult_map)
83.807 - let ?r = "map (op * (inverse ?a0)) q"
83.808 - have lgqr: "length q = length ?r" by simp
83.809 - {assume h: "\<And>x y. poly ?r x = poly ?r y"
83.810 - {fix x y
83.811 - from qr[rule_format, of x]
83.812 - have "poly q x = poly ?r x * ?a0" by auto
83.813 - also have "\<dots> = poly ?r y * ?a0" using h by simp
83.814 - also have "\<dots> = poly q y" using qr[rule_format, of y] by simp
83.815 - finally have "poly q x = poly q y" .}
83.816 - with qnc have False unfolding constant_def by blast}
83.817 - hence rnc: "\<not> constant (poly ?r)" unfolding constant_def by blast
83.818 - from qr[rule_format, of 0] a00 have r01: "poly ?r 0 = 1" by auto
83.819 - {fix w
83.820 - have "cmod (poly ?r w) < 1 \<longleftrightarrow> cmod (poly q w / ?a0) < 1"
83.821 - using qr[rule_format, of w] a00 by simp
83.822 - also have "\<dots> \<longleftrightarrow> cmod (poly q w) < cmod ?a0"
83.823 - using a00 unfolding norm_divide by (simp add: field_simps)
83.824 - finally have "cmod (poly ?r w) < 1 \<longleftrightarrow> cmod (poly q w) < cmod ?a0" .}
83.825 - note mrmq_eq = this
83.826 - from poly_decompose[OF rnc] obtain k a s where
83.827 - kas: "a\<noteq>0" "k\<noteq>0" "length s + k + 1 = length ?r"
83.828 - "\<forall>z. poly ?r z = poly ?r 0 + z^k* poly (a#s) z" by blast
83.829 - {assume "k + 1 = n"
83.830 - with kas(3) lgqr[symmetric] q(1) n[symmetric] have s0:"s=[]" by auto
83.831 - {fix w
83.832 - have "cmod (poly ?r w) = cmod (1 + a * w ^ k)"
83.833 - using kas(4)[rule_format, of w] s0 r01 by (simp add: ring_simps)}
83.834 - note hth = this [symmetric]
83.835 - from reduce_poly_simple[OF kas(1,2)]
83.836 - have "\<exists>w. cmod (poly ?r w) < 1" unfolding hth by blast}
83.837 - moreover
83.838 - {assume kn: "k+1 \<noteq> n"
83.839 - from kn kas(3) q(1) n[symmetric] have k1n: "k + 1 < n" by simp
83.840 - have th01: "\<not> constant (poly (1#((replicate (k - 1) 0)@[a])))"
83.841 - unfolding constant_def poly_Nil poly_Cons poly_replicate_append
83.842 - using kas(1) apply simp
83.843 - by (rule exI[where x=0], rule exI[where x=1], simp)
83.844 - from kas(2) have th02: "k+1 = length (1#((replicate (k - 1) 0)@[a]))"
83.845 - by simp
83.846 - from H[rule_format, OF k1n th01 th02]
83.847 - obtain w where w: "1 + w^k * a = 0"
83.848 - unfolding poly_Nil poly_Cons poly_replicate_append
83.849 - using kas(2) by (auto simp add: power_Suc[symmetric, of _ "k - Suc 0"]
83.850 - mult_assoc[of _ _ a, symmetric])
83.851 - from poly_bound_exists[of "cmod w" s] obtain m where
83.852 - m: "m > 0" "\<forall>z. cmod z \<le> cmod w \<longrightarrow> cmod (poly s z) \<le> m" by blast
83.853 - have w0: "w\<noteq>0" using kas(2) w by (auto simp add: power_0_left)
83.854 - from w have "(1 + w ^ k * a) - 1 = 0 - 1" by simp
83.855 - then have wm1: "w^k * a = - 1" by simp
83.856 - have inv0: "0 < inverse (cmod w ^ (k + 1) * m)"
83.857 - using norm_ge_zero[of w] w0 m(1)
83.858 - by (simp add: inverse_eq_divide zero_less_mult_iff)
83.859 - with real_down2[OF zero_less_one] obtain t where
83.860 - t: "t > 0" "t < 1" "t < inverse (cmod w ^ (k + 1) * m)" by blast
83.861 - let ?ct = "complex_of_real t"
83.862 - let ?w = "?ct * w"
83.863 - have "1 + ?w^k * (a + ?w * poly s ?w) = 1 + ?ct^k * (w^k * a) + ?w^k * ?w * poly s ?w" using kas(1) by (simp add: ring_simps power_mult_distrib)
83.864 - also have "\<dots> = complex_of_real (1 - t^k) + ?w^k * ?w * poly s ?w"
83.865 - unfolding wm1 by (simp)
83.866 - finally have "cmod (1 + ?w^k * (a + ?w * poly s ?w)) = cmod (complex_of_real (1 - t^k) + ?w^k * ?w * poly s ?w)"
83.867 - apply -
83.868 - apply (rule cong[OF refl[of cmod]])
83.869 - apply assumption
83.870 - done
83.871 - with norm_triangle_ineq[of "complex_of_real (1 - t^k)" "?w^k * ?w * poly s ?w"]
83.872 - have th11: "cmod (1 + ?w^k * (a + ?w * poly s ?w)) \<le> \<bar>1 - t^k\<bar> + cmod (?w^k * ?w * poly s ?w)" unfolding norm_of_real by simp
83.873 - have ath: "\<And>x (t::real). 0\<le> x \<Longrightarrow> x < t \<Longrightarrow> t\<le>1 \<Longrightarrow> \<bar>1 - t\<bar> + x < 1" by arith
83.874 - have "t *cmod w \<le> 1 * cmod w" apply (rule mult_mono) using t(1,2) by auto
83.875 - then have tw: "cmod ?w \<le> cmod w" using t(1) by (simp add: norm_mult)
83.876 - from t inv0 have "t* (cmod w ^ (k + 1) * m) < 1"
83.877 - by (simp add: inverse_eq_divide field_simps)
83.878 - with zero_less_power[OF t(1), of k]
83.879 - have th30: "t^k * (t* (cmod w ^ (k + 1) * m)) < t^k * 1"
83.880 - apply - apply (rule mult_strict_left_mono) by simp_all
83.881 - have "cmod (?w^k * ?w * poly s ?w) = t^k * (t* (cmod w ^ (k+1) * cmod (poly s ?w)))" using w0 t(1)
83.882 - by (simp add: ring_simps power_mult_distrib norm_of_real norm_power norm_mult)
83.883 - then have "cmod (?w^k * ?w * poly s ?w) \<le> t^k * (t* (cmod w ^ (k + 1) * m))"
83.884 - using t(1,2) m(2)[rule_format, OF tw] w0
83.885 - apply (simp only: )
83.886 - apply auto
83.887 - apply (rule mult_mono, simp_all add: norm_ge_zero)+
83.888 - apply (simp add: zero_le_mult_iff zero_le_power)
83.889 - done
83.890 - with th30 have th120: "cmod (?w^k * ?w * poly s ?w) < t^k" by simp
83.891 - from power_strict_mono[OF t(2), of k] t(1) kas(2) have th121: "t^k \<le> 1"
83.892 - by auto
83.893 - from ath[OF norm_ge_zero[of "?w^k * ?w * poly s ?w"] th120 th121]
83.894 - have th12: "\<bar>1 - t^k\<bar> + cmod (?w^k * ?w * poly s ?w) < 1" .
83.895 - from th11 th12
83.896 - have "cmod (1 + ?w^k * (a + ?w * poly s ?w)) < 1" by arith
83.897 - then have "cmod (poly ?r ?w) < 1"
83.898 - unfolding kas(4)[rule_format, of ?w] r01 by simp
83.899 - then have "\<exists>w. cmod (poly ?r w) < 1" by blast}
83.900 - ultimately have cr0_contr: "\<exists>w. cmod (poly ?r w) < 1" by blast
83.901 - from cr0_contr cq0 q(2)
83.902 - have ?ths unfolding mrmq_eq not_less[symmetric] by auto}
83.903 - ultimately show ?ths by blast
83.904 -qed
83.905 -
83.906 -text {* Alternative version with a syntactic notion of constant polynomial. *}
83.907 -
83.908 -lemma fundamental_theorem_of_algebra_alt:
83.909 - assumes nc: "~(\<exists>a l. a\<noteq> 0 \<and> list_all(\<lambda>b. b = 0) l \<and> p = a#l)"
83.910 - shows "\<exists>z. poly p z = (0::complex)"
83.911 -using nc
83.912 -proof(induct p)
83.913 - case (Cons c cs)
83.914 - {assume "c=0" hence ?case by auto}
83.915 - moreover
83.916 - {assume c0: "c\<noteq>0"
83.917 - {assume nc: "constant (poly (c#cs))"
83.918 - from nc[unfolded constant_def, rule_format, of 0]
83.919 - have "\<forall>w. w \<noteq> 0 \<longrightarrow> poly cs w = 0" by auto
83.920 - hence "list_all (\<lambda>c. c=0) cs"
83.921 - proof(induct cs)
83.922 - case (Cons d ds)
83.923 - {assume "d=0" hence ?case using Cons.prems Cons.hyps by simp}
83.924 - moreover
83.925 - {assume d0: "d\<noteq>0"
83.926 - from poly_bound_exists[of 1 ds] obtain m where
83.927 - m: "m > 0" "\<forall>z. \<forall>z. cmod z \<le> 1 \<longrightarrow> cmod (poly ds z) \<le> m" by blast
83.928 - have dm: "cmod d / m > 0" using d0 m(1) by (simp add: field_simps)
83.929 - from real_down2[OF dm zero_less_one] obtain x where
83.930 - x: "x > 0" "x < cmod d / m" "x < 1" by blast
83.931 - let ?x = "complex_of_real x"
83.932 - from x have cx: "?x \<noteq> 0" "cmod ?x \<le> 1" by simp_all
83.933 - from Cons.prems[rule_format, OF cx(1)]
83.934 - have cth: "cmod (?x*poly ds ?x) = cmod d" by (simp add: eq_diff_eq[symmetric])
83.935 - from m(2)[rule_format, OF cx(2)] x(1)
83.936 - have th0: "cmod (?x*poly ds ?x) \<le> x*m"
83.937 - by (simp add: norm_mult)
83.938 - from x(2) m(1) have "x*m < cmod d" by (simp add: field_simps)
83.939 - with th0 have "cmod (?x*poly ds ?x) \<noteq> cmod d" by auto
83.940 - with cth have ?case by blast}
83.941 - ultimately show ?case by blast
83.942 - qed simp}
83.943 - then have nc: "\<not> constant (poly (c#cs))" using Cons.prems c0
83.944 - by blast
83.945 - from fundamental_theorem_of_algebra[OF nc] have ?case .}
83.946 - ultimately show ?case by blast
83.947 -qed simp
83.948 -
83.949 -subsection{* Nullstellenstatz, degrees and divisibility of polynomials *}
83.950 -
83.951 -lemma nullstellensatz_lemma:
83.952 - fixes p :: "complex list"
83.953 - assumes "\<forall>x. poly p x = 0 \<longrightarrow> poly q x = 0"
83.954 - and "degree p = n" and "n \<noteq> 0"
83.955 - shows "p divides (pexp q n)"
83.956 -using prems
83.957 -proof(induct n arbitrary: p q rule: nat_less_induct)
83.958 - fix n::nat fix p q :: "complex list"
83.959 - assume IH: "\<forall>m<n. \<forall>p q.
83.960 - (\<forall>x. poly p x = (0::complex) \<longrightarrow> poly q x = 0) \<longrightarrow>
83.961 - degree p = m \<longrightarrow> m \<noteq> 0 \<longrightarrow> p divides (q %^ m)"
83.962 - and pq0: "\<forall>x. poly p x = 0 \<longrightarrow> poly q x = 0"
83.963 - and dpn: "degree p = n" and n0: "n \<noteq> 0"
83.964 - let ?ths = "p divides (q %^ n)"
83.965 - {fix a assume a: "poly p a = 0"
83.966 - {assume p0: "poly p = poly []"
83.967 - hence ?ths unfolding divides_def using pq0 n0
83.968 - apply - apply (rule exI[where x="[]"], rule ext)
83.969 - by (auto simp add: poly_mult poly_exp)}
83.970 - moreover
83.971 - {assume p0: "poly p \<noteq> poly []"
83.972 - and oa: "order a p \<noteq> 0"
83.973 - from p0 have pne: "p \<noteq> []" by auto
83.974 - let ?op = "order a p"
83.975 - from p0 have ap: "([- a, 1] %^ ?op) divides p"
83.976 - "\<not> pexp [- a, 1] (Suc ?op) divides p" using order by blast+
83.977 - note oop = order_degree[OF p0, unfolded dpn]
83.978 - {assume q0: "q = []"
83.979 - hence ?ths using n0 unfolding divides_def
83.980 - apply simp
83.981 - apply (rule exI[where x="[]"], rule ext)
83.982 - by (simp add: divides_def poly_exp poly_mult)}
83.983 - moreover
83.984 - {assume q0: "q\<noteq>[]"
83.985 - from pq0[rule_format, OF a, unfolded poly_linear_divides] q0
83.986 - obtain r where r: "q = pmult [- a, 1] r" by blast
83.987 - from ap[unfolded divides_def] obtain s where
83.988 - s: "poly p = poly (pmult (pexp [- a, 1] ?op) s)" by blast
83.989 - have s0: "poly s \<noteq> poly []"
83.990 - using s p0 by (simp add: poly_entire)
83.991 - hence pns0: "poly (pnormalize s) \<noteq> poly []" and sne: "s\<noteq>[]" by auto
83.992 - {assume ds0: "degree s = 0"
83.993 - from ds0 pns0 have "\<exists>k. pnormalize s = [k]" unfolding degree_def
83.994 - by (cases "pnormalize s", auto)
83.995 - then obtain k where kpn: "pnormalize s = [k]" by blast
83.996 - from pns0[unfolded poly_zero] kpn have k: "k \<noteq>0" "poly s = poly [k]"
83.997 - using poly_normalize[of s] by simp_all
83.998 - let ?w = "pmult (pmult [1/k] (pexp [-a,1] (n - ?op))) (pexp r n)"
83.999 - from k r s oop have "poly (pexp q n) = poly (pmult p ?w)"
83.1000 - by - (rule ext, simp add: poly_mult poly_exp poly_cmult poly_add power_add[symmetric] ring_simps power_mult_distrib[symmetric])
83.1001 - hence ?ths unfolding divides_def by blast}
83.1002 - moreover
83.1003 - {assume ds0: "degree s \<noteq> 0"
83.1004 - from ds0 s0 dpn degree_unique[OF s, unfolded linear_pow_mul_degree] oa
83.1005 - have dsn: "degree s < n" by auto
83.1006 - {fix x assume h: "poly s x = 0"
83.1007 - {assume xa: "x = a"
83.1008 - from h[unfolded xa poly_linear_divides] sne obtain u where
83.1009 - u: "s = pmult [- a, 1] u" by blast
83.1010 - have "poly p = poly (pmult (pexp [- a, 1] (Suc ?op)) u)"
83.1011 - unfolding s u
83.1012 - apply (rule ext)
83.1013 - by (simp add: ring_simps power_mult_distrib[symmetric] poly_mult poly_cmult poly_add poly_exp)
83.1014 - with ap(2)[unfolded divides_def] have False by blast}
83.1015 - note xa = this
83.1016 - from h s have "poly p x = 0" by (simp add: poly_mult)
83.1017 - with pq0 have "poly q x = 0" by blast
83.1018 - with r xa have "poly r x = 0"
83.1019 - by (auto simp add: poly_mult poly_add poly_cmult eq_diff_eq[symmetric])}
83.1020 - note impth = this
83.1021 - from IH[rule_format, OF dsn, of s r] impth ds0
83.1022 - have "s divides (pexp r (degree s))" by blast
83.1023 - then obtain u where u: "poly (pexp r (degree s)) = poly (pmult s u)"
83.1024 - unfolding divides_def by blast
83.1025 - hence u': "\<And>x. poly s x * poly u x = poly r x ^ degree s"
83.1026 - by (simp add: poly_mult[symmetric] poly_exp[symmetric])
83.1027 - let ?w = "pmult (pmult u (pexp [-a,1] (n - ?op))) (pexp r (n - degree s))"
83.1028 - from u' s r oop[of a] dsn have "poly (pexp q n) = poly (pmult p ?w)"
83.1029 - apply - apply (rule ext)
83.1030 - apply (simp only: power_mult_distrib power_add[symmetric] poly_add poly_mult poly_exp poly_cmult ring_simps)
83.1031 -
83.1032 - apply (simp add: power_mult_distrib power_add[symmetric] poly_add poly_mult poly_exp poly_cmult mult_assoc[symmetric])
83.1033 - done
83.1034 - hence ?ths unfolding divides_def by blast}
83.1035 - ultimately have ?ths by blast }
83.1036 - ultimately have ?ths by blast}
83.1037 - ultimately have ?ths using a order_root by blast}
83.1038 - moreover
83.1039 - {assume exa: "\<not> (\<exists>a. poly p a = 0)"
83.1040 - from fundamental_theorem_of_algebra_alt[of p] exa obtain c cs where
83.1041 - ccs: "c\<noteq>0" "list_all (\<lambda>c. c = 0) cs" "p = c#cs" by blast
83.1042 -
83.1043 - from poly_0[OF ccs(2)] ccs(3)
83.1044 - have pp: "\<And>x. poly p x = c" by simp
83.1045 - let ?w = "pmult [1/c] (pexp q n)"
83.1046 - from pp ccs(1)
83.1047 - have "poly (pexp q n) = poly (pmult p ?w) "
83.1048 - apply - apply (rule ext)
83.1049 - unfolding poly_mult_assoc[symmetric] by (simp add: poly_mult)
83.1050 - hence ?ths unfolding divides_def by blast}
83.1051 - ultimately show ?ths by blast
83.1052 -qed
83.1053 -
83.1054 -lemma nullstellensatz_univariate:
83.1055 - "(\<forall>x. poly p x = (0::complex) \<longrightarrow> poly q x = 0) \<longleftrightarrow>
83.1056 - p divides (q %^ (degree p)) \<or> (poly p = poly [] \<and> poly q = poly [])"
83.1057 -proof-
83.1058 - {assume pe: "poly p = poly []"
83.1059 - hence eq: "(\<forall>x. poly p x = (0::complex) \<longrightarrow> poly q x = 0) \<longleftrightarrow> poly q = poly []"
83.1060 - apply auto
83.1061 - by (rule ext, simp)
83.1062 - {assume "p divides (pexp q (degree p))"
83.1063 - then obtain r where r: "poly (pexp q (degree p)) = poly (pmult p r)"
83.1064 - unfolding divides_def by blast
83.1065 - from cong[OF r refl] pe degree_unique[OF pe]
83.1066 - have False by (simp add: poly_mult degree_def)}
83.1067 - with eq pe have ?thesis by blast}
83.1068 - moreover
83.1069 - {assume pe: "poly p \<noteq> poly []"
83.1070 - have p0: "poly [0] = poly []" by (rule ext, simp)
83.1071 - {assume dp: "degree p = 0"
83.1072 - then obtain k where "pnormalize p = [k]" using pe poly_normalize[of p]
83.1073 - unfolding degree_def by (cases "pnormalize p", auto)
83.1074 - hence k: "pnormalize p = [k]" "poly p = poly [k]" "k\<noteq>0"
83.1075 - using pe poly_normalize[of p] by (auto simp add: p0)
83.1076 - hence th1: "\<forall>x. poly p x \<noteq> 0" by simp
83.1077 - from k(2,3) dp have "poly (pexp q (degree p)) = poly (pmult p [1/k]) "
83.1078 - by - (rule ext, simp add: poly_mult poly_exp)
83.1079 - hence th2: "p divides (pexp q (degree p))" unfolding divides_def by blast
83.1080 - from th1 th2 pe have ?thesis by blast}
83.1081 - moreover
83.1082 - {assume dp: "degree p \<noteq> 0"
83.1083 - then obtain n where n: "degree p = Suc n " by (cases "degree p", auto)
83.1084 - {assume "p divides (pexp q (Suc n))"
83.1085 - then obtain u where u: "poly (pexp q (Suc n)) = poly (pmult p u)"
83.1086 - unfolding divides_def by blast
83.1087 - hence u' :"\<And>x. poly (pexp q (Suc n)) x = poly (pmult p u) x" by simp_all
83.1088 - {fix x assume h: "poly p x = 0" "poly q x \<noteq> 0"
83.1089 - hence "poly (pexp q (Suc n)) x \<noteq> 0" by (simp only: poly_exp) simp
83.1090 - hence False using u' h(1) by (simp only: poly_mult poly_exp) simp}}
83.1091 - with n nullstellensatz_lemma[of p q "degree p"] dp
83.1092 - have ?thesis by auto}
83.1093 - ultimately have ?thesis by blast}
83.1094 - ultimately show ?thesis by blast
83.1095 -qed
83.1096 -
83.1097 -text{* Useful lemma *}
83.1098 -
83.1099 -lemma (in idom_char_0) constant_degree: "constant (poly p) \<longleftrightarrow> degree p = 0" (is "?lhs = ?rhs")
83.1100 -proof
83.1101 - assume l: ?lhs
83.1102 - from l[unfolded constant_def, rule_format, of _ "zero"]
83.1103 - have th: "poly p = poly [poly p 0]" apply - by (rule ext, simp)
83.1104 - from degree_unique[OF th] show ?rhs by (simp add: degree_def)
83.1105 -next
83.1106 - assume r: ?rhs
83.1107 - from r have "pnormalize p = [] \<or> (\<exists>k. pnormalize p = [k])"
83.1108 - unfolding degree_def by (cases "pnormalize p", auto)
83.1109 - then show ?lhs unfolding constant_def poly_normalize[of p, symmetric]
83.1110 - by (auto simp del: poly_normalize)
83.1111 -qed
83.1112 -
83.1113 -(* It would be nicer to prove this without using algebraic closure... *)
83.1114 -
83.1115 -lemma divides_degree_lemma: assumes dpn: "degree (p::complex list) = n"
83.1116 - shows "n \<le> degree (p *** q) \<or> poly (p *** q) = poly []"
83.1117 - using dpn
83.1118 -proof(induct n arbitrary: p q)
83.1119 - case 0 thus ?case by simp
83.1120 -next
83.1121 - case (Suc n p q)
83.1122 - from Suc.prems fundamental_theorem_of_algebra[of p] constant_degree[of p]
83.1123 - obtain a where a: "poly p a = 0" by auto
83.1124 - then obtain r where r: "p = pmult [-a, 1] r" unfolding poly_linear_divides
83.1125 - using Suc.prems by (auto simp add: degree_def)
83.1126 - {assume h: "poly (pmult r q) = poly []"
83.1127 - hence "poly (pmult p q) = poly []" using r
83.1128 - apply - apply (rule ext) by (auto simp add: poly_entire poly_mult poly_add poly_cmult) hence ?case by blast}
83.1129 - moreover
83.1130 - {assume h: "poly (pmult r q) \<noteq> poly []"
83.1131 - hence r0: "poly r \<noteq> poly []" and q0: "poly q \<noteq> poly []"
83.1132 - by (auto simp add: poly_entire)
83.1133 - have eq: "poly (pmult p q) = poly (pmult [-a, 1] (pmult r q))"
83.1134 - apply - apply (rule ext)
83.1135 - by (simp add: r poly_mult poly_add poly_cmult ring_simps)
83.1136 - from linear_mul_degree[OF h, of "- a"]
83.1137 - have dqe: "degree (pmult p q) = degree (pmult r q) + 1"
83.1138 - unfolding degree_unique[OF eq] .
83.1139 - from linear_mul_degree[OF r0, of "- a", unfolded r[symmetric]] r Suc.prems
83.1140 - have dr: "degree r = n" by auto
83.1141 - from Suc.hyps[OF dr, of q] have "Suc n \<le> degree (pmult p q)"
83.1142 - unfolding dqe using h by (auto simp del: poly.simps)
83.1143 - hence ?case by blast}
83.1144 - ultimately show ?case by blast
83.1145 -qed
83.1146 -
83.1147 -lemma divides_degree: assumes pq: "p divides (q:: complex list)"
83.1148 - shows "degree p \<le> degree q \<or> poly q = poly []"
83.1149 -using pq divides_degree_lemma[OF refl, of p]
83.1150 -apply (auto simp add: divides_def poly_entire)
83.1151 -apply atomize
83.1152 -apply (erule_tac x="qa" in allE, auto)
83.1153 -apply (subgoal_tac "degree q = degree (p *** qa)", simp)
83.1154 -apply (rule degree_unique, simp)
83.1155 -done
83.1156 -
83.1157 -(* Arithmetic operations on multivariate polynomials. *)
83.1158 -
83.1159 -lemma mpoly_base_conv:
83.1160 - "(0::complex) \<equiv> poly [] x" "c \<equiv> poly [c] x" "x \<equiv> poly [0,1] x" by simp_all
83.1161 -
83.1162 -lemma mpoly_norm_conv:
83.1163 - "poly [0] (x::complex) \<equiv> poly [] x" "poly [poly [] y] x \<equiv> poly [] x" by simp_all
83.1164 -
83.1165 -lemma mpoly_sub_conv:
83.1166 - "poly p (x::complex) - poly q x \<equiv> poly p x + -1 * poly q x"
83.1167 - by (simp add: diff_def)
83.1168 -
83.1169 -lemma poly_pad_rule: "poly p x = 0 ==> poly (0#p) x = (0::complex)" by simp
83.1170 -
83.1171 -lemma poly_cancel_eq_conv: "p = (0::complex) \<Longrightarrow> a \<noteq> 0 \<Longrightarrow> (q = 0) \<equiv> (a * q - b * p = 0)" apply (atomize (full)) by auto
83.1172 -
83.1173 -lemma resolve_eq_raw: "poly [] x \<equiv> 0" "poly [c] x \<equiv> (c::complex)" by auto
83.1174 -lemma resolve_eq_then: "(P \<Longrightarrow> (Q \<equiv> Q1)) \<Longrightarrow> (\<not>P \<Longrightarrow> (Q \<equiv> Q2))
83.1175 - \<Longrightarrow> Q \<equiv> P \<and> Q1 \<or> \<not>P\<and> Q2" apply (atomize (full)) by blast
83.1176 -lemma expand_ex_beta_conv: "list_ex P [c] \<equiv> P c" by simp
83.1177 -
83.1178 -lemma poly_divides_pad_rule:
83.1179 - fixes p q :: "complex list"
83.1180 - assumes pq: "p divides q"
83.1181 - shows "p divides ((0::complex)#q)"
83.1182 -proof-
83.1183 - from pq obtain r where r: "poly q = poly (p *** r)" unfolding divides_def by blast
83.1184 - hence "poly (0#q) = poly (p *** ([0,1] *** r))"
83.1185 - by - (rule ext, simp add: poly_mult poly_cmult poly_add)
83.1186 - thus ?thesis unfolding divides_def by blast
83.1187 -qed
83.1188 -
83.1189 -lemma poly_divides_pad_const_rule:
83.1190 - fixes p q :: "complex list"
83.1191 - assumes pq: "p divides q"
83.1192 - shows "p divides (a %* q)"
83.1193 -proof-
83.1194 - from pq obtain r where r: "poly q = poly (p *** r)" unfolding divides_def by blast
83.1195 - hence "poly (a %* q) = poly (p *** (a %* r))"
83.1196 - by - (rule ext, simp add: poly_mult poly_cmult poly_add)
83.1197 - thus ?thesis unfolding divides_def by blast
83.1198 -qed
83.1199 -
83.1200 -
83.1201 -lemma poly_divides_conv0:
83.1202 - fixes p :: "complex list"
83.1203 - assumes lgpq: "length q < length p" and lq:"last p \<noteq> 0"
83.1204 - shows "p divides q \<equiv> (\<not> (list_ex (\<lambda>c. c \<noteq> 0) q))" (is "?lhs \<equiv> ?rhs")
83.1205 -proof-
83.1206 - {assume r: ?rhs
83.1207 - hence eq: "poly q = poly []" unfolding poly_zero
83.1208 - by (simp add: list_all_iff list_ex_iff)
83.1209 - hence "poly q = poly (p *** [])" by - (rule ext, simp add: poly_mult)
83.1210 - hence ?lhs unfolding divides_def by blast}
83.1211 - moreover
83.1212 - {assume l: ?lhs
83.1213 - have ath: "\<And>lq lp dq::nat. lq < lp ==> lq \<noteq> 0 \<Longrightarrow> dq <= lq - 1 ==> dq < lp - 1"
83.1214 - by arith
83.1215 - {assume q0: "length q = 0"
83.1216 - hence "q = []" by simp
83.1217 - hence ?rhs by simp}
83.1218 - moreover
83.1219 - {assume lgq0: "length q \<noteq> 0"
83.1220 - from pnormalize_length[of q] have dql: "degree q \<le> length q - 1"
83.1221 - unfolding degree_def by simp
83.1222 - from ath[OF lgpq lgq0 dql, unfolded pnormal_degree[OF lq, symmetric]] divides_degree[OF l] have "poly q = poly []" by auto
83.1223 - hence ?rhs unfolding poly_zero by (simp add: list_all_iff list_ex_iff)}
83.1224 - ultimately have ?rhs by blast }
83.1225 - ultimately show "?lhs \<equiv> ?rhs" by - (atomize (full), blast)
83.1226 -qed
83.1227 -
83.1228 -lemma poly_divides_conv1:
83.1229 - assumes a0: "a\<noteq> (0::complex)" and pp': "(p::complex list) divides p'"
83.1230 - and qrp': "\<And>x. a * poly q x - poly p' x \<equiv> poly r x"
83.1231 - shows "p divides q \<equiv> p divides (r::complex list)" (is "?lhs \<equiv> ?rhs")
83.1232 -proof-
83.1233 - {
83.1234 - from pp' obtain t where t: "poly p' = poly (p *** t)"
83.1235 - unfolding divides_def by blast
83.1236 - {assume l: ?lhs
83.1237 - then obtain u where u: "poly q = poly (p *** u)" unfolding divides_def by blast
83.1238 - have "poly r = poly (p *** ((a %* u) +++ (-- t)))"
83.1239 - using u qrp' t
83.1240 - by - (rule ext,
83.1241 - simp add: poly_add poly_mult poly_cmult poly_minus ring_simps)
83.1242 - then have ?rhs unfolding divides_def by blast}
83.1243 - moreover
83.1244 - {assume r: ?rhs
83.1245 - then obtain u where u: "poly r = poly (p *** u)" unfolding divides_def by blast
83.1246 - from u t qrp' a0 have "poly q = poly (p *** ((1/a) %* (u +++ t)))"
83.1247 - by - (rule ext, atomize (full), simp add: poly_mult poly_add poly_cmult field_simps)
83.1248 - hence ?lhs unfolding divides_def by blast}
83.1249 - ultimately have "?lhs = ?rhs" by blast }
83.1250 -thus "?lhs \<equiv> ?rhs" by - (atomize(full), blast)
83.1251 -qed
83.1252 -
83.1253 -lemma basic_cqe_conv1:
83.1254 - "(\<exists>x. poly p x = 0 \<and> poly [] x \<noteq> 0) \<equiv> False"
83.1255 - "(\<exists>x. poly [] x \<noteq> 0) \<equiv> False"
83.1256 - "(\<exists>x. poly [c] x \<noteq> 0) \<equiv> c\<noteq>0"
83.1257 - "(\<exists>x. poly [] x = 0) \<equiv> True"
83.1258 - "(\<exists>x. poly [c] x = 0) \<equiv> c = 0" by simp_all
83.1259 -
83.1260 -lemma basic_cqe_conv2:
83.1261 - assumes l:"last (a#b#p) \<noteq> 0"
83.1262 - shows "(\<exists>x. poly (a#b#p) x = (0::complex)) \<equiv> True"
83.1263 -proof-
83.1264 - {fix h t
83.1265 - assume h: "h\<noteq>0" "list_all (\<lambda>c. c=(0::complex)) t" "a#b#p = h#t"
83.1266 - hence "list_all (\<lambda>c. c= 0) (b#p)" by simp
83.1267 - moreover have "last (b#p) \<in> set (b#p)" by simp
83.1268 - ultimately have "last (b#p) = 0" by (simp add: list_all_iff)
83.1269 - with l have False by simp}
83.1270 - hence th: "\<not> (\<exists> h t. h\<noteq>0 \<and> list_all (\<lambda>c. c=0) t \<and> a#b#p = h#t)"
83.1271 - by blast
83.1272 - from fundamental_theorem_of_algebra_alt[OF th]
83.1273 - show "(\<exists>x. poly (a#b#p) x = (0::complex)) \<equiv> True" by auto
83.1274 -qed
83.1275 -
83.1276 -lemma basic_cqe_conv_2b: "(\<exists>x. poly p x \<noteq> (0::complex)) \<equiv> (list_ex (\<lambda>c. c \<noteq> 0) p)"
83.1277 -proof-
83.1278 - have "\<not> (list_ex (\<lambda>c. c \<noteq> 0) p) \<longleftrightarrow> poly p = poly []"
83.1279 - by (simp add: poly_zero list_all_iff list_ex_iff)
83.1280 - also have "\<dots> \<longleftrightarrow> (\<not> (\<exists>x. poly p x \<noteq> 0))" by (auto intro: ext)
83.1281 - finally show "(\<exists>x. poly p x \<noteq> (0::complex)) \<equiv> (list_ex (\<lambda>c. c \<noteq> 0) p)"
83.1282 - by - (atomize (full), blast)
83.1283 -qed
83.1284 -
83.1285 -lemma basic_cqe_conv3:
83.1286 - fixes p q :: "complex list"
83.1287 - assumes l: "last (a#p) \<noteq> 0"
83.1288 - shows "(\<exists>x. poly (a#p) x =0 \<and> poly q x \<noteq> 0) \<equiv> \<not> ((a#p) divides (q %^ (length p)))"
83.1289 -proof-
83.1290 - note np = pnormalize_eq[OF l]
83.1291 - {assume "poly (a#p) = poly []" hence False using l
83.1292 - unfolding poly_zero apply (auto simp add: list_all_iff del: last.simps)
83.1293 - apply (cases p, simp_all) done}
83.1294 - then have p0: "poly (a#p) \<noteq> poly []" by blast
83.1295 - from np have dp:"degree (a#p) = length p" by (simp add: degree_def)
83.1296 - from nullstellensatz_univariate[of "a#p" q] p0 dp
83.1297 - show "(\<exists>x. poly (a#p) x =0 \<and> poly q x \<noteq> 0) \<equiv> \<not> ((a#p) divides (q %^ (length p)))"
83.1298 - by - (atomize (full), auto)
83.1299 -qed
83.1300 -
83.1301 -lemma basic_cqe_conv4:
83.1302 - fixes p q :: "complex list"
83.1303 - assumes h: "\<And>x. poly (q %^ n) x \<equiv> poly r x"
83.1304 - shows "p divides (q %^ n) \<equiv> p divides r"
83.1305 -proof-
83.1306 - from h have "poly (q %^ n) = poly r" by (auto intro: ext)
83.1307 - thus "p divides (q %^ n) \<equiv> p divides r" unfolding divides_def by simp
83.1308 -qed
83.1309 -
83.1310 -lemma pmult_Cons_Cons: "((a::complex)#b#p) *** q = (a %*q) +++ (0#((b#p) *** q))"
83.1311 - by simp
83.1312 -
83.1313 -lemma elim_neg_conv: "- z \<equiv> (-1) * (z::complex)" by simp
83.1314 -lemma eqT_intr: "PROP P \<Longrightarrow> (True \<Longrightarrow> PROP P )" "PROP P \<Longrightarrow> True" by blast+
83.1315 -lemma negate_negate_rule: "Trueprop P \<equiv> \<not> P \<equiv> False" by (atomize (full), auto)
83.1316 -lemma last_simps: "last [x] = x" "last (x#y#ys) = last (y#ys)" by simp_all
83.1317 -lemma length_simps: "length [] = 0" "length (x#y#xs) = length xs + 2" "length [x] = 1" by simp_all
83.1318 -
83.1319 -lemma complex_entire: "(z::complex) \<noteq> 0 \<and> w \<noteq> 0 \<equiv> z*w \<noteq> 0" by simp
83.1320 -lemma resolve_eq_ne: "(P \<equiv> True) \<equiv> (\<not>P \<equiv> False)" "(P \<equiv> False) \<equiv> (\<not>P \<equiv> True)"
83.1321 - by (atomize (full)) simp_all
83.1322 -lemma cqe_conv1: "poly [] x = 0 \<longleftrightarrow> True" by simp
83.1323 -lemma cqe_conv2: "(p \<Longrightarrow> (q \<equiv> r)) \<equiv> ((p \<and> q) \<equiv> (p \<and> r))" (is "?l \<equiv> ?r")
83.1324 -proof
83.1325 - assume "p \<Longrightarrow> q \<equiv> r" thus "p \<and> q \<equiv> p \<and> r" apply - apply (atomize (full)) by blast
83.1326 -next
83.1327 - assume "p \<and> q \<equiv> p \<and> r" "p"
83.1328 - thus "q \<equiv> r" apply - apply (atomize (full)) apply blast done
83.1329 -qed
83.1330 -lemma poly_const_conv: "poly [c] (x::complex) = y \<longleftrightarrow> c = y" by simp
83.1331 -
83.1332 -end
83.1333 \ No newline at end of file
84.1 --- a/src/HOL/Complex/README.html Tue Dec 30 08:18:54 2008 +0100
84.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
84.3 @@ -1,67 +0,0 @@
84.4 -<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
84.5 -
84.6 -<!-- $Id$ -->
84.7 -
84.8 -<HTML>
84.9 -
84.10 -<HEAD>
84.11 - <meta http-equiv="content-type" content="text/html;charset=iso-8859-1">
84.12 - <TITLE>HOL/Complex/README</TITLE>
84.13 -</HEAD>
84.14 -
84.15 -<BODY>
84.16 -
84.17 -<H1>Complex: The Complex Numbers</H1>
84.18 - <P>This directory defines the type <KBD>complex</KBD> of the complex numbers,
84.19 -with numeric constants and some complex analysis. The development includes
84.20 -nonstandard analysis for the complex numbers. Note that the image
84.21 -<KBD>HOL-Complex</KBD> includes theories from the directories
84.22 -<KBD><a href="#Anchor-Real">HOL/Real</a></KBD> and <KBD><a href="#Anchor-Hyperreal">HOL/Hyperreal</a></KBD>. They define other types including <kbd>real</kbd> (the real numbers) and <kbd>hypreal</kbd> (the hyperreal or non-standard reals).
84.23 -
84.24 -<ul>
84.25 -<li><a href="CLim.html">CLim</a> Limits, continuous functions, and derivatives for the complex numbers
84.26 -<li><a href="CSeries.html">CSeries</a> Finite summation and infinite series for the complex numbers
84.27 -<li><a href="CStar.html">CStar</a> Star-transforms for the complex numbers, to form non-standard extensions of sets and functions
84.28 -<li><a href="Complex.html">Complex</a> The complex numbers
84.29 -<li><a href="NSCA.html">NSCA</a> Nonstandard complex analysis
84.30 -<li><a href="NSComplex.html">NSComplex</a> Ultrapower construction of the nonstandard complex numbers
84.31 -</ul>
84.32 -
84.33 -<h2><a name="Anchor-Real" id="Anchor-Real"></a>Real: Dedekind Cut Construction of the Real Line</h2>
84.34 -
84.35 -<ul>
84.36 -<li><a href="Lubs.html">Lubs</a> Definition of upper bounds, lubs and so on, to support completeness proofs.
84.37 -<li><a href="PReal.html">PReal</a> The positive reals constructed using Dedekind cuts
84.38 -<li><a href="Rational.html">Rational</a> The rational numbers constructed as equivalence classes of integers
84.39 -<li><a href="RComplete.html">RComplete</a> The reals are complete: they satisfy the supremum property. They also have the Archimedean property.
84.40 -<li><a href="RealDef.html">RealDef</a> The real numbers, their ordering properties, and embedding of the integers and the natural numbers
84.41 -<li><a href="RealPow.html">RealPow</a> Real numbers raised to natural number powers
84.42 -</ul>
84.43 -<h2><a name="Anchor-Hyperreal" id="Anchor-Hyperreal"></a>Hyperreal: Ultrafilter Construction of the Non-Standard Reals</h2>
84.44 -See J. D. Fleuriot and L. C. Paulson. Mechanizing Nonstandard Real Analysis. LMS J. Computation and Mathematics 3 (2000), 140-190.
84.45 -<ul>
84.46 -<li><a href="Filter.html">Filter</a> Theory of Filters and Ultrafilters. Main result is a version of the Ultrafilter Theorem proved using Zorn's Lemma.
84.47 -<li><a href="HLog.html">HLog</a> Non-standard logarithms
84.48 -<li><a href="HSeries.html">HSeries</a> Non-standard theory of finite summation and infinite series
84.49 -<li><a href="HTranscendental.html">HTranscendental</a> Non-standard extensions of transcendental functions
84.50 -<li><a href="HyperDef.html">HyperDef</a> Ultrapower construction of the hyperreals
84.51 -<li><a href="HyperNat.html">HyperNat</a> Ultrapower construction of the hypernaturals
84.52 -<li><a href="HyperPow.html">HyperPow</a> Powers theory for the hyperreals
84.53 -<!-- <li><a href="IntFloor.html">IntFloor</a> Floor and Ceiling functions relating the reals and integers -->
84.54 -<li><a href="Integration.html">Integration</a> Gage integrals
84.55 -<li><a href="Lim.html">Lim</a> Theory of limits, continuous functions, and derivatives
84.56 -<li><a href="Log.html">Log</a> Logarithms for the reals
84.57 -<li><a href="MacLaurin.html">MacLaurin</a> MacLaurin series
84.58 -<li><a href="NatStar.html">NatStar</a> Star-transforms for the hypernaturals, to form non-standard extensions of sets and functions involving the naturals or reals
84.59 -<li><a href="NthRoot.html">NthRoot</a> Existence of n-th roots of real numbers
84.60 -<li><a href="NSA.html">NSA</a> Theory defining sets of infinite numbers, infinitesimals, the infinitely close relation, and their various algebraic properties.
84.61 -<li><a href="Poly.html">Poly</a> Univariate real polynomials
84.62 -<li><a href="SEQ.html">SEQ</a> Convergence of sequences and series using standard and nonstandard analysis
84.63 -<li><a href="Series.html">Series</a> Finite summation and infinite series for the reals
84.64 -<li><a href="Star.html">Star</a> Nonstandard extensions of real sets and real functions
84.65 -<li><a href="Transcendental.html">Transcendental</a> Power series and transcendental functions
84.66 -</ul>
84.67 -<HR>
84.68 -<P>Last modified $Date$
84.69 -</BODY>
84.70 -</HTML>
85.1 --- a/src/HOL/Complex/document/root.tex Tue Dec 30 08:18:54 2008 +0100
85.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
85.3 @@ -1,32 +0,0 @@
85.4 -
85.5 -% $Id$
85.6 -
85.7 -\documentclass[11pt,a4paper]{article}
85.8 -\usepackage{graphicx,isabelle,isabellesym,latexsym}
85.9 -\usepackage[latin1]{inputenc}
85.10 -\usepackage{pdfsetup}
85.11 -
85.12 -\urlstyle{rm}
85.13 -\isabellestyle{it}
85.14 -\pagestyle{myheadings}
85.15 -
85.16 -\begin{document}
85.17 -
85.18 -\title{Isabelle/HOL-Complex --- Higher-Order Logic with Complex Numbers}
85.19 -\maketitle
85.20 -
85.21 -\tableofcontents
85.22 -
85.23 -\begin{center}
85.24 - \includegraphics[width=\textwidth,height=\textheight,keepaspectratio]{session_graph}
85.25 -\end{center}
85.26 -
85.27 -\newpage
85.28 -
85.29 -\renewcommand{\isamarkupheader}[1]%
85.30 -{\section{\isabellecontext: #1}\markright{THEORY~``\isabellecontext''}}
85.31 -
85.32 -\parindent 0pt\parskip 0.5ex
85.33 -\input{session}
85.34 -
85.35 -\end{document}
86.1 --- a/src/HOL/Complex_Main.thy Tue Dec 30 08:18:54 2008 +0100
86.2 +++ b/src/HOL/Complex_Main.thy Tue Dec 30 11:10:01 2008 +0100
86.3 @@ -9,7 +9,7 @@
86.4 imports
86.5 Main
86.6 Real
86.7 - "~~/src/HOL/Complex/Fundamental_Theorem_Algebra"
86.8 + Fundamental_Theorem_Algebra
86.9 Log
86.10 Ln
86.11 Taylor
87.1 --- a/src/HOL/Datatype.thy Tue Dec 30 08:18:54 2008 +0100
87.2 +++ b/src/HOL/Datatype.thy Tue Dec 30 11:10:01 2008 +0100
87.3 @@ -578,7 +578,13 @@
87.4 lemma Sumr_inject: "Sumr f = Sumr g ==> f = g"
87.5 by (unfold Sumr_def) (erule sum_case_inject)
87.6
87.7 -hide (open) const Suml Sumr
87.8 +primrec Projl :: "'a + 'b => 'a"
87.9 +where Projl_Inl: "Projl (Inl x) = x"
87.10 +
87.11 +primrec Projr :: "'a + 'b => 'b"
87.12 +where Projr_Inr: "Projr (Inr x) = x"
87.13 +
87.14 +hide (open) const Suml Sumr Projl Projr
87.15
87.16
87.17 subsection {* The option datatype *}
88.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
88.2 +++ b/src/HOL/Dense_Linear_Order.thy Tue Dec 30 11:10:01 2008 +0100
88.3 @@ -0,0 +1,877 @@
88.4 +(* Author: Amine Chaieb, TU Muenchen *)
88.5 +
88.6 +header {* Dense linear order without endpoints
88.7 + and a quantifier elimination procedure in Ferrante and Rackoff style *}
88.8 +
88.9 +theory Dense_Linear_Order
88.10 +imports Plain Groebner_Basis
88.11 +uses
88.12 + "~~/src/HOL/Tools/Qelim/langford_data.ML"
88.13 + "~~/src/HOL/Tools/Qelim/ferrante_rackoff_data.ML"
88.14 + ("~~/src/HOL/Tools/Qelim/langford.ML")
88.15 + ("~~/src/HOL/Tools/Qelim/ferrante_rackoff.ML")
88.16 +begin
88.17 +
88.18 +setup {* Langford_Data.setup #> Ferrante_Rackoff_Data.setup *}
88.19 +
88.20 +context linorder
88.21 +begin
88.22 +
88.23 +lemma less_not_permute: "\<not> (x < y \<and> y < x)" by (simp add: not_less linear)
88.24 +
88.25 +lemma gather_simps:
88.26 + shows
88.27 + "(\<exists>x. (\<forall>y \<in> L. y < x) \<and> (\<forall>y \<in> U. x < y) \<and> x < u \<and> P x) \<longleftrightarrow> (\<exists>x. (\<forall>y \<in> L. y < x) \<and> (\<forall>y \<in> (insert u U). x < y) \<and> P x)"
88.28 + and "(\<exists>x. (\<forall>y \<in> L. y < x) \<and> (\<forall>y \<in> U. x < y) \<and> l < x \<and> P x) \<longleftrightarrow> (\<exists>x. (\<forall>y \<in> (insert l L). y < x) \<and> (\<forall>y \<in> U. x < y) \<and> P x)"
88.29 + "(\<exists>x. (\<forall>y \<in> L. y < x) \<and> (\<forall>y \<in> U. x < y) \<and> x < u) \<longleftrightarrow> (\<exists>x. (\<forall>y \<in> L. y < x) \<and> (\<forall>y \<in> (insert u U). x < y))"
88.30 + and "(\<exists>x. (\<forall>y \<in> L. y < x) \<and> (\<forall>y \<in> U. x < y) \<and> l < x) \<longleftrightarrow> (\<exists>x. (\<forall>y \<in> (insert l L). y < x) \<and> (\<forall>y \<in> U. x < y))" by auto
88.31 +
88.32 +lemma
88.33 + gather_start: "(\<exists>x. P x) \<equiv> (\<exists>x. (\<forall>y \<in> {}. y < x) \<and> (\<forall>y\<in> {}. x < y) \<and> P x)"
88.34 + by simp
88.35 +
88.36 +text{* Theorems for @{text "\<exists>z. \<forall>x. x < z \<longrightarrow> (P x \<longleftrightarrow> P\<^bsub>-\<infinity>\<^esub>)"}*}
88.37 +lemma minf_lt: "\<exists>z . \<forall>x. x < z \<longrightarrow> (x < t \<longleftrightarrow> True)" by auto
88.38 +lemma minf_gt: "\<exists>z . \<forall>x. x < z \<longrightarrow> (t < x \<longleftrightarrow> False)"
88.39 + by (simp add: not_less) (rule exI[where x="t"], auto simp add: less_le)
88.40 +
88.41 +lemma minf_le: "\<exists>z. \<forall>x. x < z \<longrightarrow> (x \<le> t \<longleftrightarrow> True)" by (auto simp add: less_le)
88.42 +lemma minf_ge: "\<exists>z. \<forall>x. x < z \<longrightarrow> (t \<le> x \<longleftrightarrow> False)"
88.43 + by (auto simp add: less_le not_less not_le)
88.44 +lemma minf_eq: "\<exists>z. \<forall>x. x < z \<longrightarrow> (x = t \<longleftrightarrow> False)" by auto
88.45 +lemma minf_neq: "\<exists>z. \<forall>x. x < z \<longrightarrow> (x \<noteq> t \<longleftrightarrow> True)" by auto
88.46 +lemma minf_P: "\<exists>z. \<forall>x. x < z \<longrightarrow> (P \<longleftrightarrow> P)" by blast
88.47 +
88.48 +text{* Theorems for @{text "\<exists>z. \<forall>x. x < z \<longrightarrow> (P x \<longleftrightarrow> P\<^bsub>+\<infinity>\<^esub>)"}*}
88.49 +lemma pinf_gt: "\<exists>z . \<forall>x. z < x \<longrightarrow> (t < x \<longleftrightarrow> True)" by auto
88.50 +lemma pinf_lt: "\<exists>z . \<forall>x. z < x \<longrightarrow> (x < t \<longleftrightarrow> False)"
88.51 + by (simp add: not_less) (rule exI[where x="t"], auto simp add: less_le)
88.52 +
88.53 +lemma pinf_ge: "\<exists>z. \<forall>x. z < x \<longrightarrow> (t \<le> x \<longleftrightarrow> True)" by (auto simp add: less_le)
88.54 +lemma pinf_le: "\<exists>z. \<forall>x. z < x \<longrightarrow> (x \<le> t \<longleftrightarrow> False)"
88.55 + by (auto simp add: less_le not_less not_le)
88.56 +lemma pinf_eq: "\<exists>z. \<forall>x. z < x \<longrightarrow> (x = t \<longleftrightarrow> False)" by auto
88.57 +lemma pinf_neq: "\<exists>z. \<forall>x. z < x \<longrightarrow> (x \<noteq> t \<longleftrightarrow> True)" by auto
88.58 +lemma pinf_P: "\<exists>z. \<forall>x. z < x \<longrightarrow> (P \<longleftrightarrow> P)" by blast
88.59 +
88.60 +lemma nmi_lt: "t \<in> U \<Longrightarrow> \<forall>x. \<not>True \<and> x < t \<longrightarrow> (\<exists> u\<in> U. u \<le> x)" by auto
88.61 +lemma nmi_gt: "t \<in> U \<Longrightarrow> \<forall>x. \<not>False \<and> t < x \<longrightarrow> (\<exists> u\<in> U. u \<le> x)"
88.62 + by (auto simp add: le_less)
88.63 +lemma nmi_le: "t \<in> U \<Longrightarrow> \<forall>x. \<not>True \<and> x\<le> t \<longrightarrow> (\<exists> u\<in> U. u \<le> x)" by auto
88.64 +lemma nmi_ge: "t \<in> U \<Longrightarrow> \<forall>x. \<not>False \<and> t\<le> x \<longrightarrow> (\<exists> u\<in> U. u \<le> x)" by auto
88.65 +lemma nmi_eq: "t \<in> U \<Longrightarrow> \<forall>x. \<not>False \<and> x = t \<longrightarrow> (\<exists> u\<in> U. u \<le> x)" by auto
88.66 +lemma nmi_neq: "t \<in> U \<Longrightarrow>\<forall>x. \<not>True \<and> x \<noteq> t \<longrightarrow> (\<exists> u\<in> U. u \<le> x)" by auto
88.67 +lemma nmi_P: "\<forall> x. ~P \<and> P \<longrightarrow> (\<exists> u\<in> U. u \<le> x)" by auto
88.68 +lemma nmi_conj: "\<lbrakk>\<forall>x. \<not>P1' \<and> P1 x \<longrightarrow> (\<exists> u\<in> U. u \<le> x) ;
88.69 + \<forall>x. \<not>P2' \<and> P2 x \<longrightarrow> (\<exists> u\<in> U. u \<le> x)\<rbrakk> \<Longrightarrow>
88.70 + \<forall>x. \<not>(P1' \<and> P2') \<and> (P1 x \<and> P2 x) \<longrightarrow> (\<exists> u\<in> U. u \<le> x)" by auto
88.71 +lemma nmi_disj: "\<lbrakk>\<forall>x. \<not>P1' \<and> P1 x \<longrightarrow> (\<exists> u\<in> U. u \<le> x) ;
88.72 + \<forall>x. \<not>P2' \<and> P2 x \<longrightarrow> (\<exists> u\<in> U. u \<le> x)\<rbrakk> \<Longrightarrow>
88.73 + \<forall>x. \<not>(P1' \<or> P2') \<and> (P1 x \<or> P2 x) \<longrightarrow> (\<exists> u\<in> U. u \<le> x)" by auto
88.74 +
88.75 +lemma npi_lt: "t \<in> U \<Longrightarrow> \<forall>x. \<not>False \<and> x < t \<longrightarrow> (\<exists> u\<in> U. x \<le> u)" by (auto simp add: le_less)
88.76 +lemma npi_gt: "t \<in> U \<Longrightarrow> \<forall>x. \<not>True \<and> t < x \<longrightarrow> (\<exists> u\<in> U. x \<le> u)" by auto
88.77 +lemma npi_le: "t \<in> U \<Longrightarrow> \<forall>x. \<not>False \<and> x \<le> t \<longrightarrow> (\<exists> u\<in> U. x \<le> u)" by auto
88.78 +lemma npi_ge: "t \<in> U \<Longrightarrow> \<forall>x. \<not>True \<and> t \<le> x \<longrightarrow> (\<exists> u\<in> U. x \<le> u)" by auto
88.79 +lemma npi_eq: "t \<in> U \<Longrightarrow> \<forall>x. \<not>False \<and> x = t \<longrightarrow> (\<exists> u\<in> U. x \<le> u)" by auto
88.80 +lemma npi_neq: "t \<in> U \<Longrightarrow> \<forall>x. \<not>True \<and> x \<noteq> t \<longrightarrow> (\<exists> u\<in> U. x \<le> u )" by auto
88.81 +lemma npi_P: "\<forall> x. ~P \<and> P \<longrightarrow> (\<exists> u\<in> U. x \<le> u)" by auto
88.82 +lemma npi_conj: "\<lbrakk>\<forall>x. \<not>P1' \<and> P1 x \<longrightarrow> (\<exists> u\<in> U. x \<le> u) ; \<forall>x. \<not>P2' \<and> P2 x \<longrightarrow> (\<exists> u\<in> U. x \<le> u)\<rbrakk>
88.83 + \<Longrightarrow> \<forall>x. \<not>(P1' \<and> P2') \<and> (P1 x \<and> P2 x) \<longrightarrow> (\<exists> u\<in> U. x \<le> u)" by auto
88.84 +lemma npi_disj: "\<lbrakk>\<forall>x. \<not>P1' \<and> P1 x \<longrightarrow> (\<exists> u\<in> U. x \<le> u) ; \<forall>x. \<not>P2' \<and> P2 x \<longrightarrow> (\<exists> u\<in> U. x \<le> u)\<rbrakk>
88.85 + \<Longrightarrow> \<forall>x. \<not>(P1' \<or> P2') \<and> (P1 x \<or> P2 x) \<longrightarrow> (\<exists> u\<in> U. x \<le> u)" by auto
88.86 +
88.87 +lemma lin_dense_lt: "t \<in> U \<Longrightarrow> \<forall>x l u. (\<forall> t. l < t \<and> t < u \<longrightarrow> t \<notin> U) \<and> l< x \<and> x < u \<and> x < t \<longrightarrow> (\<forall> y. l < y \<and> y < u \<longrightarrow> y < t)"
88.88 +proof(clarsimp)
88.89 + fix x l u y assume tU: "t \<in> U" and noU: "\<forall>t. l < t \<and> t < u \<longrightarrow> t \<notin> U" and lx: "l < x"
88.90 + and xu: "x<u" and px: "x < t" and ly: "l<y" and yu:"y < u"
88.91 + from tU noU ly yu have tny: "t\<noteq>y" by auto
88.92 + {assume H: "t < y"
88.93 + from less_trans[OF lx px] less_trans[OF H yu]
88.94 + have "l < t \<and> t < u" by simp
88.95 + with tU noU have "False" by auto}
88.96 + hence "\<not> t < y" by auto hence "y \<le> t" by (simp add: not_less)
88.97 + thus "y < t" using tny by (simp add: less_le)
88.98 +qed
88.99 +
88.100 +lemma lin_dense_gt: "t \<in> U \<Longrightarrow> \<forall>x l u. (\<forall> t. l < t \<and> t< u \<longrightarrow> t \<notin> U) \<and> l < x \<and> x < u \<and> t < x \<longrightarrow> (\<forall> y. l < y \<and> y < u \<longrightarrow> t < y)"
88.101 +proof(clarsimp)
88.102 + fix x l u y
88.103 + assume tU: "t \<in> U" and noU: "\<forall>t. l < t \<and> t < u \<longrightarrow> t \<notin> U" and lx: "l < x" and xu: "x<u"
88.104 + and px: "t < x" and ly: "l<y" and yu:"y < u"
88.105 + from tU noU ly yu have tny: "t\<noteq>y" by auto
88.106 + {assume H: "y< t"
88.107 + from less_trans[OF ly H] less_trans[OF px xu] have "l < t \<and> t < u" by simp
88.108 + with tU noU have "False" by auto}
88.109 + hence "\<not> y<t" by auto hence "t \<le> y" by (auto simp add: not_less)
88.110 + thus "t < y" using tny by (simp add:less_le)
88.111 +qed
88.112 +
88.113 +lemma lin_dense_le: "t \<in> U \<Longrightarrow> \<forall>x l u. (\<forall> t. l < t \<and> t< u \<longrightarrow> t \<notin> U) \<and> l< x \<and> x < u \<and> x \<le> t \<longrightarrow> (\<forall> y. l < y \<and> y < u \<longrightarrow> y\<le> t)"
88.114 +proof(clarsimp)
88.115 + fix x l u y
88.116 + assume tU: "t \<in> U" and noU: "\<forall>t. l < t \<and> t < u \<longrightarrow> t \<notin> U" and lx: "l < x" and xu: "x<u"
88.117 + and px: "x \<le> t" and ly: "l<y" and yu:"y < u"
88.118 + from tU noU ly yu have tny: "t\<noteq>y" by auto
88.119 + {assume H: "t < y"
88.120 + from less_le_trans[OF lx px] less_trans[OF H yu]
88.121 + have "l < t \<and> t < u" by simp
88.122 + with tU noU have "False" by auto}
88.123 + hence "\<not> t < y" by auto thus "y \<le> t" by (simp add: not_less)
88.124 +qed
88.125 +
88.126 +lemma lin_dense_ge: "t \<in> U \<Longrightarrow> \<forall>x l u. (\<forall> t. l < t \<and> t< u \<longrightarrow> t \<notin> U) \<and> l< x \<and> x < u \<and> t \<le> x \<longrightarrow> (\<forall> y. l < y \<and> y < u \<longrightarrow> t \<le> y)"
88.127 +proof(clarsimp)
88.128 + fix x l u y
88.129 + assume tU: "t \<in> U" and noU: "\<forall>t. l < t \<and> t < u \<longrightarrow> t \<notin> U" and lx: "l < x" and xu: "x<u"
88.130 + and px: "t \<le> x" and ly: "l<y" and yu:"y < u"
88.131 + from tU noU ly yu have tny: "t\<noteq>y" by auto
88.132 + {assume H: "y< t"
88.133 + from less_trans[OF ly H] le_less_trans[OF px xu]
88.134 + have "l < t \<and> t < u" by simp
88.135 + with tU noU have "False" by auto}
88.136 + hence "\<not> y<t" by auto thus "t \<le> y" by (simp add: not_less)
88.137 +qed
88.138 +lemma lin_dense_eq: "t \<in> U \<Longrightarrow> \<forall>x l u. (\<forall> t. l < t \<and> t< u \<longrightarrow> t \<notin> U) \<and> l< x \<and> x < u \<and> x = t \<longrightarrow> (\<forall> y. l < y \<and> y < u \<longrightarrow> y= t)" by auto
88.139 +lemma lin_dense_neq: "t \<in> U \<Longrightarrow> \<forall>x l u. (\<forall> t. l < t \<and> t< u \<longrightarrow> t \<notin> U) \<and> l< x \<and> x < u \<and> x \<noteq> t \<longrightarrow> (\<forall> y. l < y \<and> y < u \<longrightarrow> y\<noteq> t)" by auto
88.140 +lemma lin_dense_P: "\<forall>x l u. (\<forall> t. l < t \<and> t< u \<longrightarrow> t \<notin> U) \<and> l< x \<and> x < u \<and> P \<longrightarrow> (\<forall> y. l < y \<and> y < u \<longrightarrow> P)" by auto
88.141 +
88.142 +lemma lin_dense_conj:
88.143 + "\<lbrakk>\<forall>x l u. (\<forall> t. l < t \<and> t< u \<longrightarrow> t \<notin> U) \<and> l< x \<and> x < u \<and> P1 x
88.144 + \<longrightarrow> (\<forall> y. l < y \<and> y < u \<longrightarrow> P1 y) ;
88.145 + \<forall>x l u. (\<forall> t. l < t \<and> t< u \<longrightarrow> t \<notin> U) \<and> l< x \<and> x < u \<and> P2 x
88.146 + \<longrightarrow> (\<forall> y. l < y \<and> y < u \<longrightarrow> P2 y)\<rbrakk> \<Longrightarrow>
88.147 + \<forall>x l u. (\<forall> t. l < t \<and> t< u \<longrightarrow> t \<notin> U) \<and> l< x \<and> x < u \<and> (P1 x \<and> P2 x)
88.148 + \<longrightarrow> (\<forall> y. l < y \<and> y < u \<longrightarrow> (P1 y \<and> P2 y))"
88.149 + by blast
88.150 +lemma lin_dense_disj:
88.151 + "\<lbrakk>\<forall>x l u. (\<forall> t. l < t \<and> t< u \<longrightarrow> t \<notin> U) \<and> l< x \<and> x < u \<and> P1 x
88.152 + \<longrightarrow> (\<forall> y. l < y \<and> y < u \<longrightarrow> P1 y) ;
88.153 + \<forall>x l u. (\<forall> t. l < t \<and> t< u \<longrightarrow> t \<notin> U) \<and> l< x \<and> x < u \<and> P2 x
88.154 + \<longrightarrow> (\<forall> y. l < y \<and> y < u \<longrightarrow> P2 y)\<rbrakk> \<Longrightarrow>
88.155 + \<forall>x l u. (\<forall> t. l < t \<and> t< u \<longrightarrow> t \<notin> U) \<and> l< x \<and> x < u \<and> (P1 x \<or> P2 x)
88.156 + \<longrightarrow> (\<forall> y. l < y \<and> y < u \<longrightarrow> (P1 y \<or> P2 y))"
88.157 + by blast
88.158 +
88.159 +lemma npmibnd: "\<lbrakk>\<forall>x. \<not> MP \<and> P x \<longrightarrow> (\<exists> u\<in> U. u \<le> x); \<forall>x. \<not>PP \<and> P x \<longrightarrow> (\<exists> u\<in> U. x \<le> u)\<rbrakk>
88.160 + \<Longrightarrow> \<forall>x. \<not> MP \<and> \<not>PP \<and> P x \<longrightarrow> (\<exists> u\<in> U. \<exists> u' \<in> U. u \<le> x \<and> x \<le> u')"
88.161 +by auto
88.162 +
88.163 +lemma finite_set_intervals:
88.164 + assumes px: "P x" and lx: "l \<le> x" and xu: "x \<le> u" and linS: "l\<in> S"
88.165 + and uinS: "u \<in> S" and fS:"finite S" and lS: "\<forall> x\<in> S. l \<le> x" and Su: "\<forall> x\<in> S. x \<le> u"
88.166 + shows "\<exists> a \<in> S. \<exists> b \<in> S. (\<forall> y. a < y \<and> y < b \<longrightarrow> y \<notin> S) \<and> a \<le> x \<and> x \<le> b \<and> P x"
88.167 +proof-
88.168 + let ?Mx = "{y. y\<in> S \<and> y \<le> x}"
88.169 + let ?xM = "{y. y\<in> S \<and> x \<le> y}"
88.170 + let ?a = "Max ?Mx"
88.171 + let ?b = "Min ?xM"
88.172 + have MxS: "?Mx \<subseteq> S" by blast
88.173 + hence fMx: "finite ?Mx" using fS finite_subset by auto
88.174 + from lx linS have linMx: "l \<in> ?Mx" by blast
88.175 + hence Mxne: "?Mx \<noteq> {}" by blast
88.176 + have xMS: "?xM \<subseteq> S" by blast
88.177 + hence fxM: "finite ?xM" using fS finite_subset by auto
88.178 + from xu uinS have linxM: "u \<in> ?xM" by blast
88.179 + hence xMne: "?xM \<noteq> {}" by blast
88.180 + have ax:"?a \<le> x" using Mxne fMx by auto
88.181 + have xb:"x \<le> ?b" using xMne fxM by auto
88.182 + have "?a \<in> ?Mx" using Max_in[OF fMx Mxne] by simp hence ainS: "?a \<in> S" using MxS by blast
88.183 + have "?b \<in> ?xM" using Min_in[OF fxM xMne] by simp hence binS: "?b \<in> S" using xMS by blast
88.184 + have noy:"\<forall> y. ?a < y \<and> y < ?b \<longrightarrow> y \<notin> S"
88.185 + proof(clarsimp)
88.186 + fix y assume ay: "?a < y" and yb: "y < ?b" and yS: "y \<in> S"
88.187 + from yS have "y\<in> ?Mx \<or> y\<in> ?xM" by (auto simp add: linear)
88.188 + moreover {assume "y \<in> ?Mx" hence "y \<le> ?a" using Mxne fMx by auto with ay have "False" by (simp add: not_le[symmetric])}
88.189 + moreover {assume "y \<in> ?xM" hence "?b \<le> y" using xMne fxM by auto with yb have "False" by (simp add: not_le[symmetric])}
88.190 + ultimately show "False" by blast
88.191 + qed
88.192 + from ainS binS noy ax xb px show ?thesis by blast
88.193 +qed
88.194 +
88.195 +lemma finite_set_intervals2:
88.196 + assumes px: "P x" and lx: "l \<le> x" and xu: "x \<le> u" and linS: "l\<in> S"
88.197 + and uinS: "u \<in> S" and fS:"finite S" and lS: "\<forall> x\<in> S. l \<le> x" and Su: "\<forall> x\<in> S. x \<le> u"
88.198 + shows "(\<exists> s\<in> S. P s) \<or> (\<exists> a \<in> S. \<exists> b \<in> S. (\<forall> y. a < y \<and> y < b \<longrightarrow> y \<notin> S) \<and> a < x \<and> x < b \<and> P x)"
88.199 +proof-
88.200 + from finite_set_intervals[where P="P", OF px lx xu linS uinS fS lS Su]
88.201 + obtain a and b where
88.202 + as: "a\<in> S" and bs: "b\<in> S" and noS:"\<forall>y. a < y \<and> y < b \<longrightarrow> y \<notin> S"
88.203 + and axb: "a \<le> x \<and> x \<le> b \<and> P x" by auto
88.204 + from axb have "x= a \<or> x= b \<or> (a < x \<and> x < b)" by (auto simp add: le_less)
88.205 + thus ?thesis using px as bs noS by blast
88.206 +qed
88.207 +
88.208 +end
88.209 +
88.210 +section {* The classical QE after Langford for dense linear orders *}
88.211 +
88.212 +context dense_linear_order
88.213 +begin
88.214 +
88.215 +lemma interval_empty_iff:
88.216 + "{y. x < y \<and> y < z} = {} \<longleftrightarrow> \<not> x < z"
88.217 + by (auto dest: dense)
88.218 +
88.219 +lemma dlo_qe_bnds:
88.220 + assumes ne: "L \<noteq> {}" and neU: "U \<noteq> {}" and fL: "finite L" and fU: "finite U"
88.221 + shows "(\<exists>x. (\<forall>y \<in> L. y < x) \<and> (\<forall>y \<in> U. x < y)) \<equiv> (\<forall> l \<in> L. \<forall>u \<in> U. l < u)"
88.222 +proof (simp only: atomize_eq, rule iffI)
88.223 + assume H: "\<exists>x. (\<forall>y\<in>L. y < x) \<and> (\<forall>y\<in>U. x < y)"
88.224 + then obtain x where xL: "\<forall>y\<in>L. y < x" and xU: "\<forall>y\<in>U. x < y" by blast
88.225 + {fix l u assume l: "l \<in> L" and u: "u \<in> U"
88.226 + have "l < x" using xL l by blast
88.227 + also have "x < u" using xU u by blast
88.228 + finally (less_trans) have "l < u" .}
88.229 + thus "\<forall>l\<in>L. \<forall>u\<in>U. l < u" by blast
88.230 +next
88.231 + assume H: "\<forall>l\<in>L. \<forall>u\<in>U. l < u"
88.232 + let ?ML = "Max L"
88.233 + let ?MU = "Min U"
88.234 + from fL ne have th1: "?ML \<in> L" and th1': "\<forall>l\<in>L. l \<le> ?ML" by auto
88.235 + from fU neU have th2: "?MU \<in> U" and th2': "\<forall>u\<in>U. ?MU \<le> u" by auto
88.236 + from th1 th2 H have "?ML < ?MU" by auto
88.237 + with dense obtain w where th3: "?ML < w" and th4: "w < ?MU" by blast
88.238 + from th3 th1' have "\<forall>l \<in> L. l < w" by auto
88.239 + moreover from th4 th2' have "\<forall>u \<in> U. w < u" by auto
88.240 + ultimately show "\<exists>x. (\<forall>y\<in>L. y < x) \<and> (\<forall>y\<in>U. x < y)" by auto
88.241 +qed
88.242 +
88.243 +lemma dlo_qe_noub:
88.244 + assumes ne: "L \<noteq> {}" and fL: "finite L"
88.245 + shows "(\<exists>x. (\<forall>y \<in> L. y < x) \<and> (\<forall>y \<in> {}. x < y)) \<equiv> True"
88.246 +proof(simp add: atomize_eq)
88.247 + from gt_ex[of "Max L"] obtain M where M: "Max L < M" by blast
88.248 + from ne fL have "\<forall>x \<in> L. x \<le> Max L" by simp
88.249 + with M have "\<forall>x\<in>L. x < M" by (auto intro: le_less_trans)
88.250 + thus "\<exists>x. \<forall>y\<in>L. y < x" by blast
88.251 +qed
88.252 +
88.253 +lemma dlo_qe_nolb:
88.254 + assumes ne: "U \<noteq> {}" and fU: "finite U"
88.255 + shows "(\<exists>x. (\<forall>y \<in> {}. y < x) \<and> (\<forall>y \<in> U. x < y)) \<equiv> True"
88.256 +proof(simp add: atomize_eq)
88.257 + from lt_ex[of "Min U"] obtain M where M: "M < Min U" by blast
88.258 + from ne fU have "\<forall>x \<in> U. Min U \<le> x" by simp
88.259 + with M have "\<forall>x\<in>U. M < x" by (auto intro: less_le_trans)
88.260 + thus "\<exists>x. \<forall>y\<in>U. x < y" by blast
88.261 +qed
88.262 +
88.263 +lemma exists_neq: "\<exists>(x::'a). x \<noteq> t" "\<exists>(x::'a). t \<noteq> x"
88.264 + using gt_ex[of t] by auto
88.265 +
88.266 +lemmas dlo_simps = order_refl less_irrefl not_less not_le exists_neq
88.267 + le_less neq_iff linear less_not_permute
88.268 +
88.269 +lemma axiom: "dense_linear_order (op \<le>) (op <)" by (rule dense_linear_order_axioms)
88.270 +lemma atoms:
88.271 + shows "TERM (less :: 'a \<Rightarrow> _)"
88.272 + and "TERM (less_eq :: 'a \<Rightarrow> _)"
88.273 + and "TERM (op = :: 'a \<Rightarrow> _)" .
88.274 +
88.275 +declare axiom[langford qe: dlo_qe_bnds dlo_qe_nolb dlo_qe_noub gather: gather_start gather_simps atoms: atoms]
88.276 +declare dlo_simps[langfordsimp]
88.277 +
88.278 +end
88.279 +
88.280 +(* FIXME: Move to HOL -- together with the conj_aci_rule in langford.ML *)
88.281 +lemma dnf:
88.282 + "(P & (Q | R)) = ((P&Q) | (P&R))"
88.283 + "((Q | R) & P) = ((Q&P) | (R&P))"
88.284 + by blast+
88.285 +
88.286 +lemmas weak_dnf_simps = simp_thms dnf
88.287 +
88.288 +lemma nnf_simps:
88.289 + "(\<not>(P \<and> Q)) = (\<not>P \<or> \<not>Q)" "(\<not>(P \<or> Q)) = (\<not>P \<and> \<not>Q)" "(P \<longrightarrow> Q) = (\<not>P \<or> Q)"
88.290 + "(P = Q) = ((P \<and> Q) \<or> (\<not>P \<and> \<not> Q))" "(\<not> \<not>(P)) = P"
88.291 + by blast+
88.292 +
88.293 +lemma ex_distrib: "(\<exists>x. P x \<or> Q x) \<longleftrightarrow> ((\<exists>x. P x) \<or> (\<exists>x. Q x))" by blast
88.294 +
88.295 +lemmas dnf_simps = weak_dnf_simps nnf_simps ex_distrib
88.296 +
88.297 +use "~~/src/HOL/Tools/Qelim/langford.ML"
88.298 +method_setup dlo = {*
88.299 + Method.ctxt_args (Method.SIMPLE_METHOD' o LangfordQE.dlo_tac)
88.300 +*} "Langford's algorithm for quantifier elimination in dense linear orders"
88.301 +
88.302 +
88.303 +section {* Contructive dense linear orders yield QE for linear arithmetic over ordered Fields -- see @{text "Arith_Tools.thy"} *}
88.304 +
88.305 +text {* Linear order without upper bounds *}
88.306 +
88.307 +class_locale linorder_stupid_syntax = linorder
88.308 +begin
88.309 +notation
88.310 + less_eq ("op \<sqsubseteq>") and
88.311 + less_eq ("(_/ \<sqsubseteq> _)" [51, 51] 50) and
88.312 + less ("op \<sqsubset>") and
88.313 + less ("(_/ \<sqsubset> _)" [51, 51] 50)
88.314 +
88.315 +end
88.316 +
88.317 +class_locale linorder_no_ub = linorder_stupid_syntax +
88.318 + assumes gt_ex: "\<exists>y. less x y"
88.319 +begin
88.320 +lemma ge_ex: "\<exists>y. x \<sqsubseteq> y" using gt_ex by auto
88.321 +
88.322 +text {* Theorems for @{text "\<exists>z. \<forall>x. z \<sqsubset> x \<longrightarrow> (P x \<longleftrightarrow> P\<^bsub>+\<infinity>\<^esub>)"} *}
88.323 +lemma pinf_conj:
88.324 + assumes ex1: "\<exists>z1. \<forall>x. z1 \<sqsubset> x \<longrightarrow> (P1 x \<longleftrightarrow> P1')"
88.325 + and ex2: "\<exists>z2. \<forall>x. z2 \<sqsubset> x \<longrightarrow> (P2 x \<longleftrightarrow> P2')"
88.326 + shows "\<exists>z. \<forall>x. z \<sqsubset> x \<longrightarrow> ((P1 x \<and> P2 x) \<longleftrightarrow> (P1' \<and> P2'))"
88.327 +proof-
88.328 + from ex1 ex2 obtain z1 and z2 where z1: "\<forall>x. z1 \<sqsubset> x \<longrightarrow> (P1 x \<longleftrightarrow> P1')"
88.329 + and z2: "\<forall>x. z2 \<sqsubset> x \<longrightarrow> (P2 x \<longleftrightarrow> P2')" by blast
88.330 + from gt_ex obtain z where z:"ord.max less_eq z1 z2 \<sqsubset> z" by blast
88.331 + from z have zz1: "z1 \<sqsubset> z" and zz2: "z2 \<sqsubset> z" by simp_all
88.332 + {fix x assume H: "z \<sqsubset> x"
88.333 + from less_trans[OF zz1 H] less_trans[OF zz2 H]
88.334 + have "(P1 x \<and> P2 x) \<longleftrightarrow> (P1' \<and> P2')" using z1 zz1 z2 zz2 by auto
88.335 + }
88.336 + thus ?thesis by blast
88.337 +qed
88.338 +
88.339 +lemma pinf_disj:
88.340 + assumes ex1: "\<exists>z1. \<forall>x. z1 \<sqsubset> x \<longrightarrow> (P1 x \<longleftrightarrow> P1')"
88.341 + and ex2: "\<exists>z2. \<forall>x. z2 \<sqsubset> x \<longrightarrow> (P2 x \<longleftrightarrow> P2')"
88.342 + shows "\<exists>z. \<forall>x. z \<sqsubset> x \<longrightarrow> ((P1 x \<or> P2 x) \<longleftrightarrow> (P1' \<or> P2'))"
88.343 +proof-
88.344 + from ex1 ex2 obtain z1 and z2 where z1: "\<forall>x. z1 \<sqsubset> x \<longrightarrow> (P1 x \<longleftrightarrow> P1')"
88.345 + and z2: "\<forall>x. z2 \<sqsubset> x \<longrightarrow> (P2 x \<longleftrightarrow> P2')" by blast
88.346 + from gt_ex obtain z where z:"ord.max less_eq z1 z2 \<sqsubset> z" by blast
88.347 + from z have zz1: "z1 \<sqsubset> z" and zz2: "z2 \<sqsubset> z" by simp_all
88.348 + {fix x assume H: "z \<sqsubset> x"
88.349 + from less_trans[OF zz1 H] less_trans[OF zz2 H]
88.350 + have "(P1 x \<or> P2 x) \<longleftrightarrow> (P1' \<or> P2')" using z1 zz1 z2 zz2 by auto
88.351 + }
88.352 + thus ?thesis by blast
88.353 +qed
88.354 +
88.355 +lemma pinf_ex: assumes ex:"\<exists>z. \<forall>x. z \<sqsubset> x \<longrightarrow> (P x \<longleftrightarrow> P1)" and p1: P1 shows "\<exists> x. P x"
88.356 +proof-
88.357 + from ex obtain z where z: "\<forall>x. z \<sqsubset> x \<longrightarrow> (P x \<longleftrightarrow> P1)" by blast
88.358 + from gt_ex obtain x where x: "z \<sqsubset> x" by blast
88.359 + from z x p1 show ?thesis by blast
88.360 +qed
88.361 +
88.362 +end
88.363 +
88.364 +text {* Linear order without upper bounds *}
88.365 +
88.366 +class_locale linorder_no_lb = linorder_stupid_syntax +
88.367 + assumes lt_ex: "\<exists>y. less y x"
88.368 +begin
88.369 +lemma le_ex: "\<exists>y. y \<sqsubseteq> x" using lt_ex by auto
88.370 +
88.371 +
88.372 +text {* Theorems for @{text "\<exists>z. \<forall>x. x \<sqsubset> z \<longrightarrow> (P x \<longleftrightarrow> P\<^bsub>-\<infinity>\<^esub>)"} *}
88.373 +lemma minf_conj:
88.374 + assumes ex1: "\<exists>z1. \<forall>x. x \<sqsubset> z1 \<longrightarrow> (P1 x \<longleftrightarrow> P1')"
88.375 + and ex2: "\<exists>z2. \<forall>x. x \<sqsubset> z2 \<longrightarrow> (P2 x \<longleftrightarrow> P2')"
88.376 + shows "\<exists>z. \<forall>x. x \<sqsubset> z \<longrightarrow> ((P1 x \<and> P2 x) \<longleftrightarrow> (P1' \<and> P2'))"
88.377 +proof-
88.378 + from ex1 ex2 obtain z1 and z2 where z1: "\<forall>x. x \<sqsubset> z1 \<longrightarrow> (P1 x \<longleftrightarrow> P1')"and z2: "\<forall>x. x \<sqsubset> z2 \<longrightarrow> (P2 x \<longleftrightarrow> P2')" by blast
88.379 + from lt_ex obtain z where z:"z \<sqsubset> ord.min less_eq z1 z2" by blast
88.380 + from z have zz1: "z \<sqsubset> z1" and zz2: "z \<sqsubset> z2" by simp_all
88.381 + {fix x assume H: "x \<sqsubset> z"
88.382 + from less_trans[OF H zz1] less_trans[OF H zz2]
88.383 + have "(P1 x \<and> P2 x) \<longleftrightarrow> (P1' \<and> P2')" using z1 zz1 z2 zz2 by auto
88.384 + }
88.385 + thus ?thesis by blast
88.386 +qed
88.387 +
88.388 +lemma minf_disj:
88.389 + assumes ex1: "\<exists>z1. \<forall>x. x \<sqsubset> z1 \<longrightarrow> (P1 x \<longleftrightarrow> P1')"
88.390 + and ex2: "\<exists>z2. \<forall>x. x \<sqsubset> z2 \<longrightarrow> (P2 x \<longleftrightarrow> P2')"
88.391 + shows "\<exists>z. \<forall>x. x \<sqsubset> z \<longrightarrow> ((P1 x \<or> P2 x) \<longleftrightarrow> (P1' \<or> P2'))"
88.392 +proof-
88.393 + from ex1 ex2 obtain z1 and z2 where z1: "\<forall>x. x \<sqsubset> z1 \<longrightarrow> (P1 x \<longleftrightarrow> P1')"and z2: "\<forall>x. x \<sqsubset> z2 \<longrightarrow> (P2 x \<longleftrightarrow> P2')" by blast
88.394 + from lt_ex obtain z where z:"z \<sqsubset> ord.min less_eq z1 z2" by blast
88.395 + from z have zz1: "z \<sqsubset> z1" and zz2: "z \<sqsubset> z2" by simp_all
88.396 + {fix x assume H: "x \<sqsubset> z"
88.397 + from less_trans[OF H zz1] less_trans[OF H zz2]
88.398 + have "(P1 x \<or> P2 x) \<longleftrightarrow> (P1' \<or> P2')" using z1 zz1 z2 zz2 by auto
88.399 + }
88.400 + thus ?thesis by blast
88.401 +qed
88.402 +
88.403 +lemma minf_ex: assumes ex:"\<exists>z. \<forall>x. x \<sqsubset> z \<longrightarrow> (P x \<longleftrightarrow> P1)" and p1: P1 shows "\<exists> x. P x"
88.404 +proof-
88.405 + from ex obtain z where z: "\<forall>x. x \<sqsubset> z \<longrightarrow> (P x \<longleftrightarrow> P1)" by blast
88.406 + from lt_ex obtain x where x: "x \<sqsubset> z" by blast
88.407 + from z x p1 show ?thesis by blast
88.408 +qed
88.409 +
88.410 +end
88.411 +
88.412 +
88.413 +class_locale constr_dense_linear_order = linorder_no_lb + linorder_no_ub +
88.414 + fixes between
88.415 + assumes between_less: "less x y \<Longrightarrow> less x (between x y) \<and> less (between x y) y"
88.416 + and between_same: "between x x = x"
88.417 +
88.418 +class_interpretation constr_dense_linear_order < dense_linear_order
88.419 + apply unfold_locales
88.420 + using gt_ex lt_ex between_less
88.421 + by (auto, rule_tac x="between x y" in exI, simp)
88.422 +
88.423 +context constr_dense_linear_order
88.424 +begin
88.425 +
88.426 +lemma rinf_U:
88.427 + assumes fU: "finite U"
88.428 + and lin_dense: "\<forall>x l u. (\<forall> t. l \<sqsubset> t \<and> t\<sqsubset> u \<longrightarrow> t \<notin> U) \<and> l\<sqsubset> x \<and> x \<sqsubset> u \<and> P x
88.429 + \<longrightarrow> (\<forall> y. l \<sqsubset> y \<and> y \<sqsubset> u \<longrightarrow> P y )"
88.430 + and nmpiU: "\<forall>x. \<not> MP \<and> \<not>PP \<and> P x \<longrightarrow> (\<exists> u\<in> U. \<exists> u' \<in> U. u \<sqsubseteq> x \<and> x \<sqsubseteq> u')"
88.431 + and nmi: "\<not> MP" and npi: "\<not> PP" and ex: "\<exists> x. P x"
88.432 + shows "\<exists> u\<in> U. \<exists> u' \<in> U. P (between u u')"
88.433 +proof-
88.434 + from ex obtain x where px: "P x" by blast
88.435 + from px nmi npi nmpiU have "\<exists> u\<in> U. \<exists> u' \<in> U. u \<sqsubseteq> x \<and> x \<sqsubseteq> u'" by auto
88.436 + then obtain u and u' where uU:"u\<in> U" and uU': "u' \<in> U" and ux:"u \<sqsubseteq> x" and xu':"x \<sqsubseteq> u'" by auto
88.437 + from uU have Une: "U \<noteq> {}" by auto
88.438 + term "linorder.Min less_eq"
88.439 + let ?l = "linorder.Min less_eq U"
88.440 + let ?u = "linorder.Max less_eq U"
88.441 + have linM: "?l \<in> U" using fU Une by simp
88.442 + have uinM: "?u \<in> U" using fU Une by simp
88.443 + have lM: "\<forall> t\<in> U. ?l \<sqsubseteq> t" using Une fU by auto
88.444 + have Mu: "\<forall> t\<in> U. t \<sqsubseteq> ?u" using Une fU by auto
88.445 + have th:"?l \<sqsubseteq> u" using uU Une lM by auto
88.446 + from order_trans[OF th ux] have lx: "?l \<sqsubseteq> x" .
88.447 + have th: "u' \<sqsubseteq> ?u" using uU' Une Mu by simp
88.448 + from order_trans[OF xu' th] have xu: "x \<sqsubseteq> ?u" .
88.449 + from finite_set_intervals2[where P="P",OF px lx xu linM uinM fU lM Mu]
88.450 + have "(\<exists> s\<in> U. P s) \<or>
88.451 + (\<exists> t1\<in> U. \<exists> t2 \<in> U. (\<forall> y. t1 \<sqsubset> y \<and> y \<sqsubset> t2 \<longrightarrow> y \<notin> U) \<and> t1 \<sqsubset> x \<and> x \<sqsubset> t2 \<and> P x)" .
88.452 + moreover { fix u assume um: "u\<in>U" and pu: "P u"
88.453 + have "between u u = u" by (simp add: between_same)
88.454 + with um pu have "P (between u u)" by simp
88.455 + with um have ?thesis by blast}
88.456 + moreover{
88.457 + assume "\<exists> t1\<in> U. \<exists> t2 \<in> U. (\<forall> y. t1 \<sqsubset> y \<and> y \<sqsubset> t2 \<longrightarrow> y \<notin> U) \<and> t1 \<sqsubset> x \<and> x \<sqsubset> t2 \<and> P x"
88.458 + then obtain t1 and t2 where t1M: "t1 \<in> U" and t2M: "t2\<in> U"
88.459 + and noM: "\<forall> y. t1 \<sqsubset> y \<and> y \<sqsubset> t2 \<longrightarrow> y \<notin> U" and t1x: "t1 \<sqsubset> x" and xt2: "x \<sqsubset> t2" and px: "P x"
88.460 + by blast
88.461 + from less_trans[OF t1x xt2] have t1t2: "t1 \<sqsubset> t2" .
88.462 + let ?u = "between t1 t2"
88.463 + from between_less t1t2 have t1lu: "t1 \<sqsubset> ?u" and ut2: "?u \<sqsubset> t2" by auto
88.464 + from lin_dense noM t1x xt2 px t1lu ut2 have "P ?u" by blast
88.465 + with t1M t2M have ?thesis by blast}
88.466 + ultimately show ?thesis by blast
88.467 + qed
88.468 +
88.469 +theorem fr_eq:
88.470 + assumes fU: "finite U"
88.471 + and lin_dense: "\<forall>x l u. (\<forall> t. l \<sqsubset> t \<and> t\<sqsubset> u \<longrightarrow> t \<notin> U) \<and> l\<sqsubset> x \<and> x \<sqsubset> u \<and> P x
88.472 + \<longrightarrow> (\<forall> y. l \<sqsubset> y \<and> y \<sqsubset> u \<longrightarrow> P y )"
88.473 + and nmibnd: "\<forall>x. \<not> MP \<and> P x \<longrightarrow> (\<exists> u\<in> U. u \<sqsubseteq> x)"
88.474 + and npibnd: "\<forall>x. \<not>PP \<and> P x \<longrightarrow> (\<exists> u\<in> U. x \<sqsubseteq> u)"
88.475 + and mi: "\<exists>z. \<forall>x. x \<sqsubset> z \<longrightarrow> (P x = MP)" and pi: "\<exists>z. \<forall>x. z \<sqsubset> x \<longrightarrow> (P x = PP)"
88.476 + shows "(\<exists> x. P x) \<equiv> (MP \<or> PP \<or> (\<exists> u \<in> U. \<exists> u'\<in> U. P (between u u')))"
88.477 + (is "_ \<equiv> (_ \<or> _ \<or> ?F)" is "?E \<equiv> ?D")
88.478 +proof-
88.479 + {
88.480 + assume px: "\<exists> x. P x"
88.481 + have "MP \<or> PP \<or> (\<not> MP \<and> \<not> PP)" by blast
88.482 + moreover {assume "MP \<or> PP" hence "?D" by blast}
88.483 + moreover {assume nmi: "\<not> MP" and npi: "\<not> PP"
88.484 + from npmibnd[OF nmibnd npibnd]
88.485 + have nmpiU: "\<forall>x. \<not> MP \<and> \<not>PP \<and> P x \<longrightarrow> (\<exists> u\<in> U. \<exists> u' \<in> U. u \<sqsubseteq> x \<and> x \<sqsubseteq> u')" .
88.486 + from rinf_U[OF fU lin_dense nmpiU nmi npi px] have "?D" by blast}
88.487 + ultimately have "?D" by blast}
88.488 + moreover
88.489 + { assume "?D"
88.490 + moreover {assume m:"MP" from minf_ex[OF mi m] have "?E" .}
88.491 + moreover {assume p: "PP" from pinf_ex[OF pi p] have "?E" . }
88.492 + moreover {assume f:"?F" hence "?E" by blast}
88.493 + ultimately have "?E" by blast}
88.494 + ultimately have "?E = ?D" by blast thus "?E \<equiv> ?D" by simp
88.495 +qed
88.496 +
88.497 +lemmas minf_thms = minf_conj minf_disj minf_eq minf_neq minf_lt minf_le minf_gt minf_ge minf_P
88.498 +lemmas pinf_thms = pinf_conj pinf_disj pinf_eq pinf_neq pinf_lt pinf_le pinf_gt pinf_ge pinf_P
88.499 +
88.500 +lemmas nmi_thms = nmi_conj nmi_disj nmi_eq nmi_neq nmi_lt nmi_le nmi_gt nmi_ge nmi_P
88.501 +lemmas npi_thms = npi_conj npi_disj npi_eq npi_neq npi_lt npi_le npi_gt npi_ge npi_P
88.502 +lemmas lin_dense_thms = lin_dense_conj lin_dense_disj lin_dense_eq lin_dense_neq lin_dense_lt lin_dense_le lin_dense_gt lin_dense_ge lin_dense_P
88.503 +
88.504 +lemma ferrack_axiom: "constr_dense_linear_order less_eq less between"
88.505 + by (rule constr_dense_linear_order_axioms)
88.506 +lemma atoms:
88.507 + shows "TERM (less :: 'a \<Rightarrow> _)"
88.508 + and "TERM (less_eq :: 'a \<Rightarrow> _)"
88.509 + and "TERM (op = :: 'a \<Rightarrow> _)" .
88.510 +
88.511 +declare ferrack_axiom [ferrack minf: minf_thms pinf: pinf_thms
88.512 + nmi: nmi_thms npi: npi_thms lindense:
88.513 + lin_dense_thms qe: fr_eq atoms: atoms]
88.514 +
88.515 +declaration {*
88.516 +let
88.517 +fun simps phi = map (Morphism.thm phi) [@{thm "not_less"}, @{thm "not_le"}]
88.518 +fun generic_whatis phi =
88.519 + let
88.520 + val [lt, le] = map (Morphism.term phi) [@{term "op \<sqsubset>"}, @{term "op \<sqsubseteq>"}]
88.521 + fun h x t =
88.522 + case term_of t of
88.523 + Const("op =", _)$y$z => if term_of x aconv y then Ferrante_Rackoff_Data.Eq
88.524 + else Ferrante_Rackoff_Data.Nox
88.525 + | @{term "Not"}$(Const("op =", _)$y$z) => if term_of x aconv y then Ferrante_Rackoff_Data.NEq
88.526 + else Ferrante_Rackoff_Data.Nox
88.527 + | b$y$z => if Term.could_unify (b, lt) then
88.528 + if term_of x aconv y then Ferrante_Rackoff_Data.Lt
88.529 + else if term_of x aconv z then Ferrante_Rackoff_Data.Gt
88.530 + else Ferrante_Rackoff_Data.Nox
88.531 + else if Term.could_unify (b, le) then
88.532 + if term_of x aconv y then Ferrante_Rackoff_Data.Le
88.533 + else if term_of x aconv z then Ferrante_Rackoff_Data.Ge
88.534 + else Ferrante_Rackoff_Data.Nox
88.535 + else Ferrante_Rackoff_Data.Nox
88.536 + | _ => Ferrante_Rackoff_Data.Nox
88.537 + in h end
88.538 + fun ss phi = HOL_ss addsimps (simps phi)
88.539 +in
88.540 + Ferrante_Rackoff_Data.funs @{thm "ferrack_axiom"}
88.541 + {isolate_conv = K (K (K Thm.reflexive)), whatis = generic_whatis, simpset = ss}
88.542 +end
88.543 +*}
88.544 +
88.545 +end
88.546 +
88.547 +use "~~/src/HOL/Tools/Qelim/ferrante_rackoff.ML"
88.548 +
88.549 +method_setup ferrack = {*
88.550 + Method.ctxt_args (Method.SIMPLE_METHOD' o FerranteRackoff.dlo_tac)
88.551 +*} "Ferrante and Rackoff's algorithm for quantifier elimination in dense linear orders"
88.552 +
88.553 +subsection {* Ferrante and Rackoff algorithm over ordered fields *}
88.554 +
88.555 +lemma neg_prod_lt:"(c\<Colon>'a\<Colon>ordered_field) < 0 \<Longrightarrow> ((c*x < 0) == (x > 0))"
88.556 +proof-
88.557 + assume H: "c < 0"
88.558 + have "c*x < 0 = (0/c < x)" by (simp only: neg_divide_less_eq[OF H] ring_simps)
88.559 + also have "\<dots> = (0 < x)" by simp
88.560 + finally show "(c*x < 0) == (x > 0)" by simp
88.561 +qed
88.562 +
88.563 +lemma pos_prod_lt:"(c\<Colon>'a\<Colon>ordered_field) > 0 \<Longrightarrow> ((c*x < 0) == (x < 0))"
88.564 +proof-
88.565 + assume H: "c > 0"
88.566 + hence "c*x < 0 = (0/c > x)" by (simp only: pos_less_divide_eq[OF H] ring_simps)
88.567 + also have "\<dots> = (0 > x)" by simp
88.568 + finally show "(c*x < 0) == (x < 0)" by simp
88.569 +qed
88.570 +
88.571 +lemma neg_prod_sum_lt: "(c\<Colon>'a\<Colon>ordered_field) < 0 \<Longrightarrow> ((c*x + t< 0) == (x > (- 1/c)*t))"
88.572 +proof-
88.573 + assume H: "c < 0"
88.574 + have "c*x + t< 0 = (c*x < -t)" by (subst less_iff_diff_less_0 [of "c*x" "-t"], simp)
88.575 + also have "\<dots> = (-t/c < x)" by (simp only: neg_divide_less_eq[OF H] ring_simps)
88.576 + also have "\<dots> = ((- 1/c)*t < x)" by simp
88.577 + finally show "(c*x + t < 0) == (x > (- 1/c)*t)" by simp
88.578 +qed
88.579 +
88.580 +lemma pos_prod_sum_lt:"(c\<Colon>'a\<Colon>ordered_field) > 0 \<Longrightarrow> ((c*x + t < 0) == (x < (- 1/c)*t))"
88.581 +proof-
88.582 + assume H: "c > 0"
88.583 + have "c*x + t< 0 = (c*x < -t)" by (subst less_iff_diff_less_0 [of "c*x" "-t"], simp)
88.584 + also have "\<dots> = (-t/c > x)" by (simp only: pos_less_divide_eq[OF H] ring_simps)
88.585 + also have "\<dots> = ((- 1/c)*t > x)" by simp
88.586 + finally show "(c*x + t < 0) == (x < (- 1/c)*t)" by simp
88.587 +qed
88.588 +
88.589 +lemma sum_lt:"((x::'a::pordered_ab_group_add) + t < 0) == (x < - t)"
88.590 + using less_diff_eq[where a= x and b=t and c=0] by simp
88.591 +
88.592 +lemma neg_prod_le:"(c\<Colon>'a\<Colon>ordered_field) < 0 \<Longrightarrow> ((c*x <= 0) == (x >= 0))"
88.593 +proof-
88.594 + assume H: "c < 0"
88.595 + have "c*x <= 0 = (0/c <= x)" by (simp only: neg_divide_le_eq[OF H] ring_simps)
88.596 + also have "\<dots> = (0 <= x)" by simp
88.597 + finally show "(c*x <= 0) == (x >= 0)" by simp
88.598 +qed
88.599 +
88.600 +lemma pos_prod_le:"(c\<Colon>'a\<Colon>ordered_field) > 0 \<Longrightarrow> ((c*x <= 0) == (x <= 0))"
88.601 +proof-
88.602 + assume H: "c > 0"
88.603 + hence "c*x <= 0 = (0/c >= x)" by (simp only: pos_le_divide_eq[OF H] ring_simps)
88.604 + also have "\<dots> = (0 >= x)" by simp
88.605 + finally show "(c*x <= 0) == (x <= 0)" by simp
88.606 +qed
88.607 +
88.608 +lemma neg_prod_sum_le: "(c\<Colon>'a\<Colon>ordered_field) < 0 \<Longrightarrow> ((c*x + t <= 0) == (x >= (- 1/c)*t))"
88.609 +proof-
88.610 + assume H: "c < 0"
88.611 + have "c*x + t <= 0 = (c*x <= -t)" by (subst le_iff_diff_le_0 [of "c*x" "-t"], simp)
88.612 + also have "\<dots> = (-t/c <= x)" by (simp only: neg_divide_le_eq[OF H] ring_simps)
88.613 + also have "\<dots> = ((- 1/c)*t <= x)" by simp
88.614 + finally show "(c*x + t <= 0) == (x >= (- 1/c)*t)" by simp
88.615 +qed
88.616 +
88.617 +lemma pos_prod_sum_le:"(c\<Colon>'a\<Colon>ordered_field) > 0 \<Longrightarrow> ((c*x + t <= 0) == (x <= (- 1/c)*t))"
88.618 +proof-
88.619 + assume H: "c > 0"
88.620 + have "c*x + t <= 0 = (c*x <= -t)" by (subst le_iff_diff_le_0 [of "c*x" "-t"], simp)
88.621 + also have "\<dots> = (-t/c >= x)" by (simp only: pos_le_divide_eq[OF H] ring_simps)
88.622 + also have "\<dots> = ((- 1/c)*t >= x)" by simp
88.623 + finally show "(c*x + t <= 0) == (x <= (- 1/c)*t)" by simp
88.624 +qed
88.625 +
88.626 +lemma sum_le:"((x::'a::pordered_ab_group_add) + t <= 0) == (x <= - t)"
88.627 + using le_diff_eq[where a= x and b=t and c=0] by simp
88.628 +
88.629 +lemma nz_prod_eq:"(c\<Colon>'a\<Colon>ordered_field) \<noteq> 0 \<Longrightarrow> ((c*x = 0) == (x = 0))" by simp
88.630 +lemma nz_prod_sum_eq: "(c\<Colon>'a\<Colon>ordered_field) \<noteq> 0 \<Longrightarrow> ((c*x + t = 0) == (x = (- 1/c)*t))"
88.631 +proof-
88.632 + assume H: "c \<noteq> 0"
88.633 + have "c*x + t = 0 = (c*x = -t)" by (subst eq_iff_diff_eq_0 [of "c*x" "-t"], simp)
88.634 + also have "\<dots> = (x = -t/c)" by (simp only: nonzero_eq_divide_eq[OF H] ring_simps)
88.635 + finally show "(c*x + t = 0) == (x = (- 1/c)*t)" by simp
88.636 +qed
88.637 +lemma sum_eq:"((x::'a::pordered_ab_group_add) + t = 0) == (x = - t)"
88.638 + using eq_diff_eq[where a= x and b=t and c=0] by simp
88.639 +
88.640 +
88.641 +class_interpretation class_ordered_field_dense_linear_order: constr_dense_linear_order
88.642 + ["op <=" "op <"
88.643 + "\<lambda> x y. 1/2 * ((x::'a::{ordered_field,recpower,number_ring}) + y)"]
88.644 +proof (unfold_locales, dlo, dlo, auto)
88.645 + fix x y::'a assume lt: "x < y"
88.646 + from less_half_sum[OF lt] show "x < (x + y) /2" by simp
88.647 +next
88.648 + fix x y::'a assume lt: "x < y"
88.649 + from gt_half_sum[OF lt] show "(x + y) /2 < y" by simp
88.650 +qed
88.651 +
88.652 +declaration{*
88.653 +let
88.654 +fun earlier [] x y = false
88.655 + | earlier (h::t) x y =
88.656 + if h aconvc y then false else if h aconvc x then true else earlier t x y;
88.657 +
88.658 +fun dest_frac ct = case term_of ct of
88.659 + Const (@{const_name "HOL.divide"},_) $ a $ b=>
88.660 + Rat.rat_of_quotient (snd (HOLogic.dest_number a), snd (HOLogic.dest_number b))
88.661 + | t => Rat.rat_of_int (snd (HOLogic.dest_number t))
88.662 +
88.663 +fun mk_frac phi cT x =
88.664 + let val (a, b) = Rat.quotient_of_rat x
88.665 + in if b = 1 then Numeral.mk_cnumber cT a
88.666 + else Thm.capply
88.667 + (Thm.capply (Drule.cterm_rule (instantiate' [SOME cT] []) @{cpat "op /"})
88.668 + (Numeral.mk_cnumber cT a))
88.669 + (Numeral.mk_cnumber cT b)
88.670 + end
88.671 +
88.672 +fun whatis x ct = case term_of ct of
88.673 + Const(@{const_name "HOL.plus"}, _)$(Const(@{const_name "HOL.times"},_)$_$y)$_ =>
88.674 + if y aconv term_of x then ("c*x+t",[(funpow 2 Thm.dest_arg1) ct, Thm.dest_arg ct])
88.675 + else ("Nox",[])
88.676 +| Const(@{const_name "HOL.plus"}, _)$y$_ =>
88.677 + if y aconv term_of x then ("x+t",[Thm.dest_arg ct])
88.678 + else ("Nox",[])
88.679 +| Const(@{const_name "HOL.times"}, _)$_$y =>
88.680 + if y aconv term_of x then ("c*x",[Thm.dest_arg1 ct])
88.681 + else ("Nox",[])
88.682 +| t => if t aconv term_of x then ("x",[]) else ("Nox",[]);
88.683 +
88.684 +fun xnormalize_conv ctxt [] ct = reflexive ct
88.685 +| xnormalize_conv ctxt (vs as (x::_)) ct =
88.686 + case term_of ct of
88.687 + Const(@{const_name HOL.less},_)$_$Const(@{const_name "HOL.zero"},_) =>
88.688 + (case whatis x (Thm.dest_arg1 ct) of
88.689 + ("c*x+t",[c,t]) =>
88.690 + let
88.691 + val cr = dest_frac c
88.692 + val clt = Thm.dest_fun2 ct
88.693 + val cz = Thm.dest_arg ct
88.694 + val neg = cr </ Rat.zero
88.695 + val cthp = Simplifier.rewrite (local_simpset_of ctxt)
88.696 + (Thm.capply @{cterm "Trueprop"}
88.697 + (if neg then Thm.capply (Thm.capply clt c) cz
88.698 + else Thm.capply (Thm.capply clt cz) c))
88.699 + val cth = equal_elim (symmetric cthp) TrueI
88.700 + val th = implies_elim (instantiate' [SOME (ctyp_of_term x)] (map SOME [c,x,t])
88.701 + (if neg then @{thm neg_prod_sum_lt} else @{thm pos_prod_sum_lt})) cth
88.702 + val rth = Conv.fconv_rule (Conv.arg_conv (Conv.binop_conv
88.703 + (Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
88.704 + in rth end
88.705 + | ("x+t",[t]) =>
88.706 + let
88.707 + val T = ctyp_of_term x
88.708 + val th = instantiate' [SOME T] [SOME x, SOME t] @{thm "sum_lt"}
88.709 + val rth = Conv.fconv_rule (Conv.arg_conv (Conv.binop_conv
88.710 + (Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
88.711 + in rth end
88.712 + | ("c*x",[c]) =>
88.713 + let
88.714 + val cr = dest_frac c
88.715 + val clt = Thm.dest_fun2 ct
88.716 + val cz = Thm.dest_arg ct
88.717 + val neg = cr </ Rat.zero
88.718 + val cthp = Simplifier.rewrite (local_simpset_of ctxt)
88.719 + (Thm.capply @{cterm "Trueprop"}
88.720 + (if neg then Thm.capply (Thm.capply clt c) cz
88.721 + else Thm.capply (Thm.capply clt cz) c))
88.722 + val cth = equal_elim (symmetric cthp) TrueI
88.723 + val th = implies_elim (instantiate' [SOME (ctyp_of_term x)] (map SOME [c,x])
88.724 + (if neg then @{thm neg_prod_lt} else @{thm pos_prod_lt})) cth
88.725 + val rth = th
88.726 + in rth end
88.727 + | _ => reflexive ct)
88.728 +
88.729 +
88.730 +| Const(@{const_name HOL.less_eq},_)$_$Const(@{const_name "HOL.zero"},_) =>
88.731 + (case whatis x (Thm.dest_arg1 ct) of
88.732 + ("c*x+t",[c,t]) =>
88.733 + let
88.734 + val T = ctyp_of_term x
88.735 + val cr = dest_frac c
88.736 + val clt = Drule.cterm_rule (instantiate' [SOME T] []) @{cpat "op <"}
88.737 + val cz = Thm.dest_arg ct
88.738 + val neg = cr </ Rat.zero
88.739 + val cthp = Simplifier.rewrite (local_simpset_of ctxt)
88.740 + (Thm.capply @{cterm "Trueprop"}
88.741 + (if neg then Thm.capply (Thm.capply clt c) cz
88.742 + else Thm.capply (Thm.capply clt cz) c))
88.743 + val cth = equal_elim (symmetric cthp) TrueI
88.744 + val th = implies_elim (instantiate' [SOME T] (map SOME [c,x,t])
88.745 + (if neg then @{thm neg_prod_sum_le} else @{thm pos_prod_sum_le})) cth
88.746 + val rth = Conv.fconv_rule (Conv.arg_conv (Conv.binop_conv
88.747 + (Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
88.748 + in rth end
88.749 + | ("x+t",[t]) =>
88.750 + let
88.751 + val T = ctyp_of_term x
88.752 + val th = instantiate' [SOME T] [SOME x, SOME t] @{thm "sum_le"}
88.753 + val rth = Conv.fconv_rule (Conv.arg_conv (Conv.binop_conv
88.754 + (Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
88.755 + in rth end
88.756 + | ("c*x",[c]) =>
88.757 + let
88.758 + val T = ctyp_of_term x
88.759 + val cr = dest_frac c
88.760 + val clt = Drule.cterm_rule (instantiate' [SOME T] []) @{cpat "op <"}
88.761 + val cz = Thm.dest_arg ct
88.762 + val neg = cr </ Rat.zero
88.763 + val cthp = Simplifier.rewrite (local_simpset_of ctxt)
88.764 + (Thm.capply @{cterm "Trueprop"}
88.765 + (if neg then Thm.capply (Thm.capply clt c) cz
88.766 + else Thm.capply (Thm.capply clt cz) c))
88.767 + val cth = equal_elim (symmetric cthp) TrueI
88.768 + val th = implies_elim (instantiate' [SOME (ctyp_of_term x)] (map SOME [c,x])
88.769 + (if neg then @{thm neg_prod_le} else @{thm pos_prod_le})) cth
88.770 + val rth = th
88.771 + in rth end
88.772 + | _ => reflexive ct)
88.773 +
88.774 +| Const("op =",_)$_$Const(@{const_name "HOL.zero"},_) =>
88.775 + (case whatis x (Thm.dest_arg1 ct) of
88.776 + ("c*x+t",[c,t]) =>
88.777 + let
88.778 + val T = ctyp_of_term x
88.779 + val cr = dest_frac c
88.780 + val ceq = Thm.dest_fun2 ct
88.781 + val cz = Thm.dest_arg ct
88.782 + val cthp = Simplifier.rewrite (local_simpset_of ctxt)
88.783 + (Thm.capply @{cterm "Trueprop"}
88.784 + (Thm.capply @{cterm "Not"} (Thm.capply (Thm.capply ceq c) cz)))
88.785 + val cth = equal_elim (symmetric cthp) TrueI
88.786 + val th = implies_elim
88.787 + (instantiate' [SOME T] (map SOME [c,x,t]) @{thm nz_prod_sum_eq}) cth
88.788 + val rth = Conv.fconv_rule (Conv.arg_conv (Conv.binop_conv
88.789 + (Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
88.790 + in rth end
88.791 + | ("x+t",[t]) =>
88.792 + let
88.793 + val T = ctyp_of_term x
88.794 + val th = instantiate' [SOME T] [SOME x, SOME t] @{thm "sum_eq"}
88.795 + val rth = Conv.fconv_rule (Conv.arg_conv (Conv.binop_conv
88.796 + (Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
88.797 + in rth end
88.798 + | ("c*x",[c]) =>
88.799 + let
88.800 + val T = ctyp_of_term x
88.801 + val cr = dest_frac c
88.802 + val ceq = Thm.dest_fun2 ct
88.803 + val cz = Thm.dest_arg ct
88.804 + val cthp = Simplifier.rewrite (local_simpset_of ctxt)
88.805 + (Thm.capply @{cterm "Trueprop"}
88.806 + (Thm.capply @{cterm "Not"} (Thm.capply (Thm.capply ceq c) cz)))
88.807 + val cth = equal_elim (symmetric cthp) TrueI
88.808 + val rth = implies_elim
88.809 + (instantiate' [SOME T] (map SOME [c,x]) @{thm nz_prod_eq}) cth
88.810 + in rth end
88.811 + | _ => reflexive ct);
88.812 +
88.813 +local
88.814 + val less_iff_diff_less_0 = mk_meta_eq @{thm "less_iff_diff_less_0"}
88.815 + val le_iff_diff_le_0 = mk_meta_eq @{thm "le_iff_diff_le_0"}
88.816 + val eq_iff_diff_eq_0 = mk_meta_eq @{thm "eq_iff_diff_eq_0"}
88.817 +in
88.818 +fun field_isolate_conv phi ctxt vs ct = case term_of ct of
88.819 + Const(@{const_name HOL.less},_)$a$b =>
88.820 + let val (ca,cb) = Thm.dest_binop ct
88.821 + val T = ctyp_of_term ca
88.822 + val th = instantiate' [SOME T] [SOME ca, SOME cb] less_iff_diff_less_0
88.823 + val nth = Conv.fconv_rule
88.824 + (Conv.arg_conv (Conv.arg1_conv
88.825 + (Normalizer.semiring_normalize_ord_conv @{context} (earlier vs)))) th
88.826 + val rth = transitive nth (xnormalize_conv ctxt vs (Thm.rhs_of nth))
88.827 + in rth end
88.828 +| Const(@{const_name HOL.less_eq},_)$a$b =>
88.829 + let val (ca,cb) = Thm.dest_binop ct
88.830 + val T = ctyp_of_term ca
88.831 + val th = instantiate' [SOME T] [SOME ca, SOME cb] le_iff_diff_le_0
88.832 + val nth = Conv.fconv_rule
88.833 + (Conv.arg_conv (Conv.arg1_conv
88.834 + (Normalizer.semiring_normalize_ord_conv @{context} (earlier vs)))) th
88.835 + val rth = transitive nth (xnormalize_conv ctxt vs (Thm.rhs_of nth))
88.836 + in rth end
88.837 +
88.838 +| Const("op =",_)$a$b =>
88.839 + let val (ca,cb) = Thm.dest_binop ct
88.840 + val T = ctyp_of_term ca
88.841 + val th = instantiate' [SOME T] [SOME ca, SOME cb] eq_iff_diff_eq_0
88.842 + val nth = Conv.fconv_rule
88.843 + (Conv.arg_conv (Conv.arg1_conv
88.844 + (Normalizer.semiring_normalize_ord_conv @{context} (earlier vs)))) th
88.845 + val rth = transitive nth (xnormalize_conv ctxt vs (Thm.rhs_of nth))
88.846 + in rth end
88.847 +| @{term "Not"} $(Const("op =",_)$a$b) => Conv.arg_conv (field_isolate_conv phi ctxt vs) ct
88.848 +| _ => reflexive ct
88.849 +end;
88.850 +
88.851 +fun classfield_whatis phi =
88.852 + let
88.853 + fun h x t =
88.854 + case term_of t of
88.855 + Const("op =", _)$y$z => if term_of x aconv y then Ferrante_Rackoff_Data.Eq
88.856 + else Ferrante_Rackoff_Data.Nox
88.857 + | @{term "Not"}$(Const("op =", _)$y$z) => if term_of x aconv y then Ferrante_Rackoff_Data.NEq
88.858 + else Ferrante_Rackoff_Data.Nox
88.859 + | Const(@{const_name HOL.less},_)$y$z =>
88.860 + if term_of x aconv y then Ferrante_Rackoff_Data.Lt
88.861 + else if term_of x aconv z then Ferrante_Rackoff_Data.Gt
88.862 + else Ferrante_Rackoff_Data.Nox
88.863 + | Const (@{const_name HOL.less_eq},_)$y$z =>
88.864 + if term_of x aconv y then Ferrante_Rackoff_Data.Le
88.865 + else if term_of x aconv z then Ferrante_Rackoff_Data.Ge
88.866 + else Ferrante_Rackoff_Data.Nox
88.867 + | _ => Ferrante_Rackoff_Data.Nox
88.868 + in h end;
88.869 +fun class_field_ss phi =
88.870 + HOL_basic_ss addsimps ([@{thm "linorder_not_less"}, @{thm "linorder_not_le"}])
88.871 + addsplits [@{thm "abs_split"},@{thm "split_max"}, @{thm "split_min"}]
88.872 +
88.873 +in
88.874 +Ferrante_Rackoff_Data.funs @{thm "class_ordered_field_dense_linear_order.ferrack_axiom"}
88.875 + {isolate_conv = field_isolate_conv, whatis = classfield_whatis, simpset = class_field_ss}
88.876 +end
88.877 +*}
88.878 +
88.879 +
88.880 +end
89.1 --- a/src/HOL/Deriv.thy Tue Dec 30 08:18:54 2008 +0100
89.2 +++ b/src/HOL/Deriv.thy Tue Dec 30 11:10:01 2008 +0100
89.3 @@ -20,12 +20,6 @@
89.4 ("(DERIV (_)/ (_)/ :> (_))" [1000, 1000, 60] 60) where
89.5 "DERIV f x :> D = ((%h. (f(x + h) - f x) / h) -- 0 --> D)"
89.6
89.7 -definition
89.8 - differentiable :: "['a::real_normed_field \<Rightarrow> 'a, 'a] \<Rightarrow> bool"
89.9 - (infixl "differentiable" 60) where
89.10 - "f differentiable x = (\<exists>D. DERIV f x :> D)"
89.11 -
89.12 -
89.13 consts
89.14 Bolzano_bisect :: "[real*real=>bool, real, real, nat] => (real*real)"
89.15 primrec
89.16 @@ -316,63 +310,104 @@
89.17
89.18 subsection {* Differentiability predicate *}
89.19
89.20 +definition
89.21 + differentiable :: "['a::real_normed_field \<Rightarrow> 'a, 'a] \<Rightarrow> bool"
89.22 + (infixl "differentiable" 60) where
89.23 + "f differentiable x = (\<exists>D. DERIV f x :> D)"
89.24 +
89.25 +lemma differentiableE [elim?]:
89.26 + assumes "f differentiable x"
89.27 + obtains df where "DERIV f x :> df"
89.28 + using prems unfolding differentiable_def ..
89.29 +
89.30 lemma differentiableD: "f differentiable x ==> \<exists>D. DERIV f x :> D"
89.31 by (simp add: differentiable_def)
89.32
89.33 lemma differentiableI: "DERIV f x :> D ==> f differentiable x"
89.34 by (force simp add: differentiable_def)
89.35
89.36 -lemma differentiable_const: "(\<lambda>z. a) differentiable x"
89.37 - apply (unfold differentiable_def)
89.38 - apply (rule_tac x=0 in exI)
89.39 - apply simp
89.40 - done
89.41 +lemma differentiable_ident [simp]: "(\<lambda>x. x) differentiable x"
89.42 + by (rule DERIV_ident [THEN differentiableI])
89.43
89.44 -lemma differentiable_sum:
89.45 +lemma differentiable_const [simp]: "(\<lambda>z. a) differentiable x"
89.46 + by (rule DERIV_const [THEN differentiableI])
89.47 +
89.48 +lemma differentiable_compose:
89.49 + assumes f: "f differentiable (g x)"
89.50 + assumes g: "g differentiable x"
89.51 + shows "(\<lambda>x. f (g x)) differentiable x"
89.52 +proof -
89.53 + from `f differentiable (g x)` obtain df where "DERIV f (g x) :> df" ..
89.54 + moreover
89.55 + from `g differentiable x` obtain dg where "DERIV g x :> dg" ..
89.56 + ultimately
89.57 + have "DERIV (\<lambda>x. f (g x)) x :> df * dg" by (rule DERIV_chain2)
89.58 + thus ?thesis by (rule differentiableI)
89.59 +qed
89.60 +
89.61 +lemma differentiable_sum [simp]:
89.62 assumes "f differentiable x"
89.63 and "g differentiable x"
89.64 shows "(\<lambda>x. f x + g x) differentiable x"
89.65 proof -
89.66 - from prems have "\<exists>D. DERIV f x :> D" by (unfold differentiable_def)
89.67 - then obtain df where "DERIV f x :> df" ..
89.68 - moreover from prems have "\<exists>D. DERIV g x :> D" by (unfold differentiable_def)
89.69 - then obtain dg where "DERIV g x :> dg" ..
89.70 - ultimately have "DERIV (\<lambda>x. f x + g x) x :> df + dg" by (rule DERIV_add)
89.71 - hence "\<exists>D. DERIV (\<lambda>x. f x + g x) x :> D" by auto
89.72 - thus ?thesis by (fold differentiable_def)
89.73 + from `f differentiable x` obtain df where "DERIV f x :> df" ..
89.74 + moreover
89.75 + from `g differentiable x` obtain dg where "DERIV g x :> dg" ..
89.76 + ultimately
89.77 + have "DERIV (\<lambda>x. f x + g x) x :> df + dg" by (rule DERIV_add)
89.78 + thus ?thesis by (rule differentiableI)
89.79 qed
89.80
89.81 -lemma differentiable_diff:
89.82 +lemma differentiable_minus [simp]:
89.83 assumes "f differentiable x"
89.84 - and "g differentiable x"
89.85 - shows "(\<lambda>x. f x - g x) differentiable x"
89.86 + shows "(\<lambda>x. - f x) differentiable x"
89.87 proof -
89.88 - from prems have "f differentiable x" by simp
89.89 - moreover
89.90 - from prems have "\<exists>D. DERIV g x :> D" by (unfold differentiable_def)
89.91 - then obtain dg where "DERIV g x :> dg" ..
89.92 - then have "DERIV (\<lambda>x. - g x) x :> -dg" by (rule DERIV_minus)
89.93 - hence "\<exists>D. DERIV (\<lambda>x. - g x) x :> D" by auto
89.94 - hence "(\<lambda>x. - g x) differentiable x" by (fold differentiable_def)
89.95 - ultimately
89.96 - show ?thesis
89.97 - by (auto simp: diff_def dest: differentiable_sum)
89.98 + from `f differentiable x` obtain df where "DERIV f x :> df" ..
89.99 + hence "DERIV (\<lambda>x. - f x) x :> - df" by (rule DERIV_minus)
89.100 + thus ?thesis by (rule differentiableI)
89.101 qed
89.102
89.103 -lemma differentiable_mult:
89.104 +lemma differentiable_diff [simp]:
89.105 assumes "f differentiable x"
89.106 - and "g differentiable x"
89.107 + assumes "g differentiable x"
89.108 + shows "(\<lambda>x. f x - g x) differentiable x"
89.109 + unfolding diff_minus using prems by simp
89.110 +
89.111 +lemma differentiable_mult [simp]:
89.112 + assumes "f differentiable x"
89.113 + assumes "g differentiable x"
89.114 shows "(\<lambda>x. f x * g x) differentiable x"
89.115 proof -
89.116 - from prems have "\<exists>D. DERIV f x :> D" by (unfold differentiable_def)
89.117 - then obtain df where "DERIV f x :> df" ..
89.118 - moreover from prems have "\<exists>D. DERIV g x :> D" by (unfold differentiable_def)
89.119 - then obtain dg where "DERIV g x :> dg" ..
89.120 - ultimately have "DERIV (\<lambda>x. f x * g x) x :> df * g x + dg * f x" by (simp add: DERIV_mult)
89.121 - hence "\<exists>D. DERIV (\<lambda>x. f x * g x) x :> D" by auto
89.122 - thus ?thesis by (fold differentiable_def)
89.123 + from `f differentiable x` obtain df where "DERIV f x :> df" ..
89.124 + moreover
89.125 + from `g differentiable x` obtain dg where "DERIV g x :> dg" ..
89.126 + ultimately
89.127 + have "DERIV (\<lambda>x. f x * g x) x :> df * g x + dg * f x" by (rule DERIV_mult)
89.128 + thus ?thesis by (rule differentiableI)
89.129 qed
89.130
89.131 +lemma differentiable_inverse [simp]:
89.132 + assumes "f differentiable x" and "f x \<noteq> 0"
89.133 + shows "(\<lambda>x. inverse (f x)) differentiable x"
89.134 +proof -
89.135 + from `f differentiable x` obtain df where "DERIV f x :> df" ..
89.136 + hence "DERIV (\<lambda>x. inverse (f x)) x :> - (inverse (f x) * df * inverse (f x))"
89.137 + using `f x \<noteq> 0` by (rule DERIV_inverse')
89.138 + thus ?thesis by (rule differentiableI)
89.139 +qed
89.140 +
89.141 +lemma differentiable_divide [simp]:
89.142 + assumes "f differentiable x"
89.143 + assumes "g differentiable x" and "g x \<noteq> 0"
89.144 + shows "(\<lambda>x. f x / g x) differentiable x"
89.145 + unfolding divide_inverse using prems by simp
89.146 +
89.147 +lemma differentiable_power [simp]:
89.148 + fixes f :: "'a::{recpower,real_normed_field} \<Rightarrow> 'a"
89.149 + assumes "f differentiable x"
89.150 + shows "(\<lambda>x. f x ^ n) differentiable x"
89.151 + by (induct n, simp, simp add: power_Suc prems)
89.152 +
89.153
89.154 subsection {* Nested Intervals and Bisection *}
89.155
89.156 @@ -1722,4 +1757,60 @@
89.157 apply (simp add: poly_entire del: pmult_Cons)
89.158 done
89.159
89.160 +
89.161 +subsection {* Theorems about Limits *}
89.162 +
89.163 +(* need to rename second isCont_inverse *)
89.164 +
89.165 +lemma isCont_inv_fun:
89.166 + fixes f g :: "real \<Rightarrow> real"
89.167 + shows "[| 0 < d; \<forall>z. \<bar>z - x\<bar> \<le> d --> g(f(z)) = z;
89.168 + \<forall>z. \<bar>z - x\<bar> \<le> d --> isCont f z |]
89.169 + ==> isCont g (f x)"
89.170 +by (rule isCont_inverse_function)
89.171 +
89.172 +lemma isCont_inv_fun_inv:
89.173 + fixes f g :: "real \<Rightarrow> real"
89.174 + shows "[| 0 < d;
89.175 + \<forall>z. \<bar>z - x\<bar> \<le> d --> g(f(z)) = z;
89.176 + \<forall>z. \<bar>z - x\<bar> \<le> d --> isCont f z |]
89.177 + ==> \<exists>e. 0 < e &
89.178 + (\<forall>y. 0 < \<bar>y - f(x)\<bar> & \<bar>y - f(x)\<bar> < e --> f(g(y)) = y)"
89.179 +apply (drule isCont_inj_range)
89.180 +prefer 2 apply (assumption, assumption, auto)
89.181 +apply (rule_tac x = e in exI, auto)
89.182 +apply (rotate_tac 2)
89.183 +apply (drule_tac x = y in spec, auto)
89.184 +done
89.185 +
89.186 +
89.187 +text{*Bartle/Sherbert: Introduction to Real Analysis, Theorem 4.2.9, p. 110*}
89.188 +lemma LIM_fun_gt_zero:
89.189 + "[| f -- c --> (l::real); 0 < l |]
89.190 + ==> \<exists>r. 0 < r & (\<forall>x::real. x \<noteq> c & \<bar>c - x\<bar> < r --> 0 < f x)"
89.191 +apply (auto simp add: LIM_def)
89.192 +apply (drule_tac x = "l/2" in spec, safe, force)
89.193 +apply (rule_tac x = s in exI)
89.194 +apply (auto simp only: abs_less_iff)
89.195 +done
89.196 +
89.197 +lemma LIM_fun_less_zero:
89.198 + "[| f -- c --> (l::real); l < 0 |]
89.199 + ==> \<exists>r. 0 < r & (\<forall>x::real. x \<noteq> c & \<bar>c - x\<bar> < r --> f x < 0)"
89.200 +apply (auto simp add: LIM_def)
89.201 +apply (drule_tac x = "-l/2" in spec, safe, force)
89.202 +apply (rule_tac x = s in exI)
89.203 +apply (auto simp only: abs_less_iff)
89.204 +done
89.205 +
89.206 +
89.207 +lemma LIM_fun_not_zero:
89.208 + "[| f -- c --> (l::real); l \<noteq> 0 |]
89.209 + ==> \<exists>r. 0 < r & (\<forall>x::real. x \<noteq> c & \<bar>c - x\<bar> < r --> f x \<noteq> 0)"
89.210 +apply (cut_tac x = l and y = 0 in linorder_less_linear, auto)
89.211 +apply (drule LIM_fun_less_zero)
89.212 +apply (drule_tac [3] LIM_fun_gt_zero)
89.213 +apply force+
89.214 +done
89.215 +
89.216 end
90.1 --- a/src/HOL/Divides.thy Tue Dec 30 08:18:54 2008 +0100
90.2 +++ b/src/HOL/Divides.thy Tue Dec 30 11:10:01 2008 +0100
90.3 @@ -127,7 +127,7 @@
90.4 note that ultimately show thesis by blast
90.5 qed
90.6
90.7 -lemma dvd_eq_mod_eq_0 [code]: "a dvd b \<longleftrightarrow> b mod a = 0"
90.8 +lemma dvd_eq_mod_eq_0 [code unfold]: "a dvd b \<longleftrightarrow> b mod a = 0"
90.9 proof
90.10 assume "b mod a = 0"
90.11 with mod_div_equality [of b a] have "b div a * a = b" by simp
91.1 --- a/src/HOL/FunDef.thy Tue Dec 30 08:18:54 2008 +0100
91.2 +++ b/src/HOL/FunDef.thy Tue Dec 30 11:10:01 2008 +0100
91.3 @@ -3,11 +3,13 @@
91.4 Author: Alexander Krauss, TU Muenchen
91.5 *)
91.6
91.7 -header {* General recursive function definitions *}
91.8 +header {* Function Definitions and Termination Proofs *}
91.9
91.10 theory FunDef
91.11 imports Wellfounded
91.12 uses
91.13 + "Tools/prop_logic.ML"
91.14 + "Tools/sat_solver.ML"
91.15 ("Tools/function_package/fundef_lib.ML")
91.16 ("Tools/function_package/fundef_common.ML")
91.17 ("Tools/function_package/inductive_wrap.ML")
91.18 @@ -22,9 +24,14 @@
91.19 ("Tools/function_package/lexicographic_order.ML")
91.20 ("Tools/function_package/fundef_datatype.ML")
91.21 ("Tools/function_package/induction_scheme.ML")
91.22 + ("Tools/function_package/termination.ML")
91.23 + ("Tools/function_package/decompose.ML")
91.24 + ("Tools/function_package/descent.ML")
91.25 + ("Tools/function_package/scnp_solve.ML")
91.26 + ("Tools/function_package/scnp_reconstruct.ML")
91.27 begin
91.28
91.29 -text {* Definitions with default value. *}
91.30 +subsection {* Definitions with default value. *}
91.31
91.32 definition
91.33 THE_default :: "'a \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a" where
91.34 @@ -97,9 +104,6 @@
91.35 "wf R \<Longrightarrow> wfP (in_rel R)"
91.36 by (simp add: wfP_def)
91.37
91.38 -inductive is_measure :: "('a \<Rightarrow> nat) \<Rightarrow> bool"
91.39 -where is_measure_trivial: "is_measure f"
91.40 -
91.41 use "Tools/function_package/fundef_lib.ML"
91.42 use "Tools/function_package/fundef_common.ML"
91.43 use "Tools/function_package/inductive_wrap.ML"
91.44 @@ -110,19 +114,37 @@
91.45 use "Tools/function_package/pattern_split.ML"
91.46 use "Tools/function_package/auto_term.ML"
91.47 use "Tools/function_package/fundef_package.ML"
91.48 -use "Tools/function_package/measure_functions.ML"
91.49 -use "Tools/function_package/lexicographic_order.ML"
91.50 use "Tools/function_package/fundef_datatype.ML"
91.51 use "Tools/function_package/induction_scheme.ML"
91.52
91.53 setup {*
91.54 FundefPackage.setup
91.55 + #> FundefDatatype.setup
91.56 #> InductionScheme.setup
91.57 - #> MeasureFunctions.setup
91.58 - #> LexicographicOrder.setup
91.59 - #> FundefDatatype.setup
91.60 *}
91.61
91.62 +subsection {* Measure Functions *}
91.63 +
91.64 +inductive is_measure :: "('a \<Rightarrow> nat) \<Rightarrow> bool"
91.65 +where is_measure_trivial: "is_measure f"
91.66 +
91.67 +use "Tools/function_package/measure_functions.ML"
91.68 +setup MeasureFunctions.setup
91.69 +
91.70 +lemma measure_size[measure_function]: "is_measure size"
91.71 +by (rule is_measure_trivial)
91.72 +
91.73 +lemma measure_fst[measure_function]: "is_measure f \<Longrightarrow> is_measure (\<lambda>p. f (fst p))"
91.74 +by (rule is_measure_trivial)
91.75 +lemma measure_snd[measure_function]: "is_measure f \<Longrightarrow> is_measure (\<lambda>p. f (snd p))"
91.76 +by (rule is_measure_trivial)
91.77 +
91.78 +use "Tools/function_package/lexicographic_order.ML"
91.79 +setup LexicographicOrder.setup
91.80 +
91.81 +
91.82 +subsection {* Congruence Rules *}
91.83 +
91.84 lemma let_cong [fundef_cong]:
91.85 "M = N \<Longrightarrow> (\<And>x. x = N \<Longrightarrow> f x = g x) \<Longrightarrow> Let M f = Let N g"
91.86 unfolding Let_def by blast
91.87 @@ -140,17 +162,7 @@
91.88 "f (g x) = f' (g' x') \<Longrightarrow> (f o g) x = (f' o g') x'"
91.89 unfolding o_apply .
91.90
91.91 -subsection {* Setup for termination proofs *}
91.92 -
91.93 -text {* Rules for generating measure functions *}
91.94 -
91.95 -lemma [measure_function]: "is_measure size"
91.96 -by (rule is_measure_trivial)
91.97 -
91.98 -lemma [measure_function]: "is_measure f \<Longrightarrow> is_measure (\<lambda>p. f (fst p))"
91.99 -by (rule is_measure_trivial)
91.100 -lemma [measure_function]: "is_measure f \<Longrightarrow> is_measure (\<lambda>p. f (snd p))"
91.101 -by (rule is_measure_trivial)
91.102 +subsection {* Simp rules for termination proofs *}
91.103
91.104 lemma termination_basic_simps[termination_simp]:
91.105 "x < (y::nat) \<Longrightarrow> x < y + z"
91.106 @@ -166,5 +178,150 @@
91.107 "prod_size f g p = f (fst p) + g (snd p) + Suc 0"
91.108 by (induct p) auto
91.109
91.110 +subsection {* Decomposition *}
91.111 +
91.112 +lemma less_by_empty:
91.113 + "A = {} \<Longrightarrow> A \<subseteq> B"
91.114 +and union_comp_emptyL:
91.115 + "\<lbrakk> A O C = {}; B O C = {} \<rbrakk> \<Longrightarrow> (A \<union> B) O C = {}"
91.116 +and union_comp_emptyR:
91.117 + "\<lbrakk> A O B = {}; A O C = {} \<rbrakk> \<Longrightarrow> A O (B \<union> C) = {}"
91.118 +and wf_no_loop:
91.119 + "R O R = {} \<Longrightarrow> wf R"
91.120 +by (auto simp add: wf_comp_self[of R])
91.121 +
91.122 +
91.123 +subsection {* Reduction Pairs *}
91.124 +
91.125 +definition
91.126 + "reduction_pair P = (wf (fst P) \<and> snd P O fst P \<subseteq> fst P)"
91.127 +
91.128 +lemma reduction_pairI[intro]: "wf R \<Longrightarrow> S O R \<subseteq> R \<Longrightarrow> reduction_pair (R, S)"
91.129 +unfolding reduction_pair_def by auto
91.130 +
91.131 +lemma reduction_pair_lemma:
91.132 + assumes rp: "reduction_pair P"
91.133 + assumes "R \<subseteq> fst P"
91.134 + assumes "S \<subseteq> snd P"
91.135 + assumes "wf S"
91.136 + shows "wf (R \<union> S)"
91.137 +proof -
91.138 + from rp `S \<subseteq> snd P` have "wf (fst P)" "S O fst P \<subseteq> fst P"
91.139 + unfolding reduction_pair_def by auto
91.140 + with `wf S` have "wf (fst P \<union> S)"
91.141 + by (auto intro: wf_union_compatible)
91.142 + moreover from `R \<subseteq> fst P` have "R \<union> S \<subseteq> fst P \<union> S" by auto
91.143 + ultimately show ?thesis by (rule wf_subset)
91.144 +qed
91.145 +
91.146 +definition
91.147 + "rp_inv_image = (\<lambda>(R,S) f. (inv_image R f, inv_image S f))"
91.148 +
91.149 +lemma rp_inv_image_rp:
91.150 + "reduction_pair P \<Longrightarrow> reduction_pair (rp_inv_image P f)"
91.151 + unfolding reduction_pair_def rp_inv_image_def split_def
91.152 + by force
91.153 +
91.154 +
91.155 +subsection {* Concrete orders for SCNP termination proofs *}
91.156 +
91.157 +definition "pair_less = less_than <*lex*> less_than"
91.158 +definition "pair_leq = pair_less^="
91.159 +definition "max_strict = max_ext pair_less"
91.160 +definition "max_weak = max_ext pair_leq \<union> {({}, {})}"
91.161 +definition "min_strict = min_ext pair_less"
91.162 +definition "min_weak = min_ext pair_leq \<union> {({}, {})}"
91.163 +
91.164 +lemma wf_pair_less[simp]: "wf pair_less"
91.165 + by (auto simp: pair_less_def)
91.166 +
91.167 +text {* Introduction rules for @{text pair_less}/@{text pair_leq} *}
91.168 +lemma pair_leqI1: "a < b \<Longrightarrow> ((a, s), (b, t)) \<in> pair_leq"
91.169 + and pair_leqI2: "a \<le> b \<Longrightarrow> s \<le> t \<Longrightarrow> ((a, s), (b, t)) \<in> pair_leq"
91.170 + and pair_lessI1: "a < b \<Longrightarrow> ((a, s), (b, t)) \<in> pair_less"
91.171 + and pair_lessI2: "a \<le> b \<Longrightarrow> s < t \<Longrightarrow> ((a, s), (b, t)) \<in> pair_less"
91.172 + unfolding pair_leq_def pair_less_def by auto
91.173 +
91.174 +text {* Introduction rules for max *}
91.175 +lemma smax_emptyI:
91.176 + "finite Y \<Longrightarrow> Y \<noteq> {} \<Longrightarrow> ({}, Y) \<in> max_strict"
91.177 + and smax_insertI:
91.178 + "\<lbrakk>y \<in> Y; (x, y) \<in> pair_less; (X, Y) \<in> max_strict\<rbrakk> \<Longrightarrow> (insert x X, Y) \<in> max_strict"
91.179 + and wmax_emptyI:
91.180 + "finite X \<Longrightarrow> ({}, X) \<in> max_weak"
91.181 + and wmax_insertI:
91.182 + "\<lbrakk>y \<in> YS; (x, y) \<in> pair_leq; (XS, YS) \<in> max_weak\<rbrakk> \<Longrightarrow> (insert x XS, YS) \<in> max_weak"
91.183 +unfolding max_strict_def max_weak_def by (auto elim!: max_ext.cases)
91.184 +
91.185 +text {* Introduction rules for min *}
91.186 +lemma smin_emptyI:
91.187 + "X \<noteq> {} \<Longrightarrow> (X, {}) \<in> min_strict"
91.188 + and smin_insertI:
91.189 + "\<lbrakk>x \<in> XS; (x, y) \<in> pair_less; (XS, YS) \<in> min_strict\<rbrakk> \<Longrightarrow> (XS, insert y YS) \<in> min_strict"
91.190 + and wmin_emptyI:
91.191 + "(X, {}) \<in> min_weak"
91.192 + and wmin_insertI:
91.193 + "\<lbrakk>x \<in> XS; (x, y) \<in> pair_leq; (XS, YS) \<in> min_weak\<rbrakk> \<Longrightarrow> (XS, insert y YS) \<in> min_weak"
91.194 +by (auto simp: min_strict_def min_weak_def min_ext_def)
91.195 +
91.196 +text {* Reduction Pairs *}
91.197 +
91.198 +lemma max_ext_compat:
91.199 + assumes "S O R \<subseteq> R"
91.200 + shows "(max_ext S \<union> {({},{})}) O max_ext R \<subseteq> max_ext R"
91.201 +using assms
91.202 +apply auto
91.203 +apply (elim max_ext.cases)
91.204 +apply rule
91.205 +apply auto[3]
91.206 +apply (drule_tac x=xa in meta_spec)
91.207 +apply simp
91.208 +apply (erule bexE)
91.209 +apply (drule_tac x=xb in meta_spec)
91.210 +by auto
91.211 +
91.212 +lemma max_rpair_set: "reduction_pair (max_strict, max_weak)"
91.213 + unfolding max_strict_def max_weak_def
91.214 +apply (intro reduction_pairI max_ext_wf)
91.215 +apply simp
91.216 +apply (rule max_ext_compat)
91.217 +by (auto simp: pair_less_def pair_leq_def)
91.218 +
91.219 +lemma min_ext_compat:
91.220 + assumes "S O R \<subseteq> R"
91.221 + shows "(min_ext S \<union> {({},{})}) O min_ext R \<subseteq> min_ext R"
91.222 +using assms
91.223 +apply (auto simp: min_ext_def)
91.224 +apply (drule_tac x=ya in bspec, assumption)
91.225 +apply (erule bexE)
91.226 +apply (drule_tac x=xc in bspec)
91.227 +apply assumption
91.228 +by auto
91.229 +
91.230 +lemma min_rpair_set: "reduction_pair (min_strict, min_weak)"
91.231 + unfolding min_strict_def min_weak_def
91.232 +apply (intro reduction_pairI min_ext_wf)
91.233 +apply simp
91.234 +apply (rule min_ext_compat)
91.235 +by (auto simp: pair_less_def pair_leq_def)
91.236 +
91.237 +
91.238 +subsection {* Tool setup *}
91.239 +
91.240 +use "Tools/function_package/termination.ML"
91.241 +use "Tools/function_package/decompose.ML"
91.242 +use "Tools/function_package/descent.ML"
91.243 +use "Tools/function_package/scnp_solve.ML"
91.244 +use "Tools/function_package/scnp_reconstruct.ML"
91.245 +
91.246 +setup {* ScnpReconstruct.setup *}
91.247 +(*
91.248 +setup {*
91.249 + Context.theory_map (FundefCommon.set_termination_prover (ScnpReconstruct.decomp_scnp
91.250 + [ScnpSolve.MAX, ScnpSolve.MIN, ScnpSolve.MS]))
91.251 +*}
91.252 +*)
91.253 +
91.254 +
91.255
91.256 end
92.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
92.2 +++ b/src/HOL/Fundamental_Theorem_Algebra.thy Tue Dec 30 11:10:01 2008 +0100
92.3 @@ -0,0 +1,1327 @@
92.4 +(* Author: Amine Chaieb, TU Muenchen *)
92.5 +
92.6 +header{*Fundamental Theorem of Algebra*}
92.7 +
92.8 +theory Fundamental_Theorem_Algebra
92.9 +imports Univ_Poly Dense_Linear_Order Complex
92.10 +begin
92.11 +
92.12 +subsection {* Square root of complex numbers *}
92.13 +definition csqrt :: "complex \<Rightarrow> complex" where
92.14 +"csqrt z = (if Im z = 0 then
92.15 + if 0 \<le> Re z then Complex (sqrt(Re z)) 0
92.16 + else Complex 0 (sqrt(- Re z))
92.17 + else Complex (sqrt((cmod z + Re z) /2))
92.18 + ((Im z / abs(Im z)) * sqrt((cmod z - Re z) /2)))"
92.19 +
92.20 +lemma csqrt[algebra]: "csqrt z ^ 2 = z"
92.21 +proof-
92.22 + obtain x y where xy: "z = Complex x y" by (cases z, simp_all)
92.23 + {assume y0: "y = 0"
92.24 + {assume x0: "x \<ge> 0"
92.25 + then have ?thesis using y0 xy real_sqrt_pow2[OF x0]
92.26 + by (simp add: csqrt_def power2_eq_square)}
92.27 + moreover
92.28 + {assume "\<not> x \<ge> 0" hence x0: "- x \<ge> 0" by arith
92.29 + then have ?thesis using y0 xy real_sqrt_pow2[OF x0]
92.30 + by (simp add: csqrt_def power2_eq_square) }
92.31 + ultimately have ?thesis by blast}
92.32 + moreover
92.33 + {assume y0: "y\<noteq>0"
92.34 + {fix x y
92.35 + let ?z = "Complex x y"
92.36 + from abs_Re_le_cmod[of ?z] have tha: "abs x \<le> cmod ?z" by auto
92.37 + hence "cmod ?z - x \<ge> 0" "cmod ?z + x \<ge> 0" by arith+
92.38 + hence "(sqrt (x * x + y * y) + x) / 2 \<ge> 0" "(sqrt (x * x + y * y) - x) / 2 \<ge> 0" by (simp_all add: power2_eq_square) }
92.39 + note th = this
92.40 + have sq4: "\<And>x::real. x^2 / 4 = (x / 2) ^ 2"
92.41 + by (simp add: power2_eq_square)
92.42 + from th[of x y]
92.43 + have sq4': "sqrt (((sqrt (x * x + y * y) + x)^2 / 4)) = (sqrt (x * x + y * y) + x) / 2" "sqrt (((sqrt (x * x + y * y) - x)^2 / 4)) = (sqrt (x * x + y * y) - x) / 2" unfolding sq4 by simp_all
92.44 + then have th1: "sqrt ((sqrt (x * x + y * y) + x) * (sqrt (x * x + y * y) + x) / 4) - sqrt ((sqrt (x * x + y * y) - x) * (sqrt (x * x + y * y) - x) / 4) = x"
92.45 + unfolding power2_eq_square by simp
92.46 + have "sqrt 4 = sqrt (2^2)" by simp
92.47 + hence sqrt4: "sqrt 4 = 2" by (simp only: real_sqrt_abs)
92.48 + have th2: "2 *(y * sqrt ((sqrt (x * x + y * y) - x) * (sqrt (x * x + y * y) + x) / 4)) / \<bar>y\<bar> = y"
92.49 + using iffD2[OF real_sqrt_pow2_iff sum_power2_ge_zero[of x y]] y0
92.50 + unfolding power2_eq_square
92.51 + by (simp add: ring_simps real_sqrt_divide sqrt4)
92.52 + from y0 xy have ?thesis apply (simp add: csqrt_def power2_eq_square)
92.53 + apply (simp add: real_sqrt_sum_squares_mult_ge_zero[of x y] real_sqrt_pow2[OF th(1)[of x y], unfolded power2_eq_square] real_sqrt_pow2[OF th(2)[of x y], unfolded power2_eq_square] real_sqrt_mult[symmetric])
92.54 + using th1 th2 ..}
92.55 + ultimately show ?thesis by blast
92.56 +qed
92.57 +
92.58 +
92.59 +subsection{* More lemmas about module of complex numbers *}
92.60 +
92.61 +lemma complex_of_real_power: "complex_of_real x ^ n = complex_of_real (x^n)"
92.62 + by (rule of_real_power [symmetric])
92.63 +
92.64 +lemma real_down2: "(0::real) < d1 \<Longrightarrow> 0 < d2 ==> EX e. 0 < e & e < d1 & e < d2"
92.65 + apply ferrack apply arith done
92.66 +
92.67 +text{* The triangle inequality for cmod *}
92.68 +lemma complex_mod_triangle_sub: "cmod w \<le> cmod (w + z) + norm z"
92.69 + using complex_mod_triangle_ineq2[of "w + z" "-z"] by auto
92.70 +
92.71 +subsection{* Basic lemmas about complex polynomials *}
92.72 +
92.73 +lemma poly_bound_exists:
92.74 + shows "\<exists>m. m > 0 \<and> (\<forall>z. cmod z <= r \<longrightarrow> cmod (poly p z) \<le> m)"
92.75 +proof(induct p)
92.76 + case Nil thus ?case by (rule exI[where x=1], simp)
92.77 +next
92.78 + case (Cons c cs)
92.79 + from Cons.hyps obtain m where m: "\<forall>z. cmod z \<le> r \<longrightarrow> cmod (poly cs z) \<le> m"
92.80 + by blast
92.81 + let ?k = " 1 + cmod c + \<bar>r * m\<bar>"
92.82 + have kp: "?k > 0" using abs_ge_zero[of "r*m"] norm_ge_zero[of c] by arith
92.83 + {fix z
92.84 + assume H: "cmod z \<le> r"
92.85 + from m H have th: "cmod (poly cs z) \<le> m" by blast
92.86 + from H have rp: "r \<ge> 0" using norm_ge_zero[of z] by arith
92.87 + have "cmod (poly (c # cs) z) \<le> cmod c + cmod (z* poly cs z)"
92.88 + using norm_triangle_ineq[of c "z* poly cs z"] by simp
92.89 + also have "\<dots> \<le> cmod c + r*m" using mult_mono[OF H th rp norm_ge_zero[of "poly cs z"]] by (simp add: norm_mult)
92.90 + also have "\<dots> \<le> ?k" by simp
92.91 + finally have "cmod (poly (c # cs) z) \<le> ?k" .}
92.92 + with kp show ?case by blast
92.93 +qed
92.94 +
92.95 +
92.96 +text{* Offsetting the variable in a polynomial gives another of same degree *}
92.97 + (* FIXME : Lemma holds also in locale --- fix it later *)
92.98 +lemma poly_offset_lemma:
92.99 + shows "\<exists>b q. (length q = length p) \<and> (\<forall>x. poly (b#q) (x::complex) = (a + x) * poly p x)"
92.100 +proof(induct p)
92.101 + case Nil thus ?case by simp
92.102 +next
92.103 + case (Cons c cs)
92.104 + from Cons.hyps obtain b q where
92.105 + bq: "length q = length cs" "\<forall>x. poly (b # q) x = (a + x) * poly cs x"
92.106 + by blast
92.107 + let ?b = "a*c"
92.108 + let ?q = "(b+c)#q"
92.109 + have lg: "length ?q = length (c#cs)" using bq(1) by simp
92.110 + {fix x
92.111 + from bq(2)[rule_format, of x]
92.112 + have "x*poly (b # q) x = x*((a + x) * poly cs x)" by simp
92.113 + hence "poly (?b# ?q) x = (a + x) * poly (c # cs) x"
92.114 + by (simp add: ring_simps)}
92.115 + with lg show ?case by blast
92.116 +qed
92.117 +
92.118 + (* FIXME : This one too*)
92.119 +lemma poly_offset: "\<exists> q. length q = length p \<and> (\<forall>x. poly q (x::complex) = poly p (a + x))"
92.120 +proof (induct p)
92.121 + case Nil thus ?case by simp
92.122 +next
92.123 + case (Cons c cs)
92.124 + from Cons.hyps obtain q where q: "length q = length cs" "\<forall>x. poly q x = poly cs (a + x)" by blast
92.125 + from poly_offset_lemma[of q a] obtain b p where
92.126 + bp: "length p = length q" "\<forall>x. poly (b # p) x = (a + x) * poly q x"
92.127 + by blast
92.128 + thus ?case using q bp by - (rule exI[where x="(c + b)#p"], simp)
92.129 +qed
92.130 +
92.131 +text{* An alternative useful formulation of completeness of the reals *}
92.132 +lemma real_sup_exists: assumes ex: "\<exists>x. P x" and bz: "\<exists>z. \<forall>x. P x \<longrightarrow> x < z"
92.133 + shows "\<exists>(s::real). \<forall>y. (\<exists>x. P x \<and> y < x) \<longleftrightarrow> y < s"
92.134 +proof-
92.135 + from ex bz obtain x Y where x: "P x" and Y: "\<And>x. P x \<Longrightarrow> x < Y" by blast
92.136 + from ex have thx:"\<exists>x. x \<in> Collect P" by blast
92.137 + from bz have thY: "\<exists>Y. isUb UNIV (Collect P) Y"
92.138 + by(auto simp add: isUb_def isLub_def setge_def setle_def leastP_def Ball_def order_le_less)
92.139 + from reals_complete[OF thx thY] obtain L where L: "isLub UNIV (Collect P) L"
92.140 + by blast
92.141 + from Y[OF x] have xY: "x < Y" .
92.142 + from L have L': "\<forall>x. P x \<longrightarrow> x \<le> L" by (auto simp add: isUb_def isLub_def setge_def setle_def leastP_def Ball_def)
92.143 + from Y have Y': "\<forall>x. P x \<longrightarrow> x \<le> Y"
92.144 + apply (clarsimp, atomize (full)) by auto
92.145 + from L Y' have "L \<le> Y" by (auto simp add: isUb_def isLub_def setge_def setle_def leastP_def Ball_def)
92.146 + {fix y
92.147 + {fix z assume z: "P z" "y < z"
92.148 + from L' z have "y < L" by auto }
92.149 + moreover
92.150 + {assume yL: "y < L" "\<forall>z. P z \<longrightarrow> \<not> y < z"
92.151 + hence nox: "\<forall>z. P z \<longrightarrow> y \<ge> z" by auto
92.152 + from nox L have "y \<ge> L" by (auto simp add: isUb_def isLub_def setge_def setle_def leastP_def Ball_def)
92.153 + with yL(1) have False by arith}
92.154 + ultimately have "(\<exists>x. P x \<and> y < x) \<longleftrightarrow> y < L" by blast}
92.155 + thus ?thesis by blast
92.156 +qed
92.157 +
92.158 +
92.159 +subsection{* Some theorems about Sequences*}
92.160 +text{* Given a binary function @{text "f:: nat \<Rightarrow> 'a \<Rightarrow> 'a"}, its values are uniquely determined by a function g *}
92.161 +
92.162 +lemma num_Axiom: "EX! g. g 0 = e \<and> (\<forall>n. g (Suc n) = f n (g n))"
92.163 + unfolding Ex1_def
92.164 + apply (rule_tac x="nat_rec e f" in exI)
92.165 + apply (rule conjI)+
92.166 +apply (rule def_nat_rec_0, simp)
92.167 +apply (rule allI, rule def_nat_rec_Suc, simp)
92.168 +apply (rule allI, rule impI, rule ext)
92.169 +apply (erule conjE)
92.170 +apply (induct_tac x)
92.171 +apply (simp add: nat_rec_0)
92.172 +apply (erule_tac x="n" in allE)
92.173 +apply (simp)
92.174 +done
92.175 +
92.176 + text{* An equivalent formulation of monotony -- Not used here, but might be useful *}
92.177 +lemma mono_Suc: "mono f = (\<forall>n. (f n :: 'a :: order) \<le> f (Suc n))"
92.178 +unfolding mono_def
92.179 +proof auto
92.180 + fix A B :: nat
92.181 + assume H: "\<forall>n. f n \<le> f (Suc n)" "A \<le> B"
92.182 + hence "\<exists>k. B = A + k" apply - apply (thin_tac "\<forall>n. f n \<le> f (Suc n)")
92.183 + by presburger
92.184 + then obtain k where k: "B = A + k" by blast
92.185 + {fix a k
92.186 + have "f a \<le> f (a + k)"
92.187 + proof (induct k)
92.188 + case 0 thus ?case by simp
92.189 + next
92.190 + case (Suc k)
92.191 + from Suc.hyps H(1)[rule_format, of "a + k"] show ?case by simp
92.192 + qed}
92.193 + with k show "f A \<le> f B" by blast
92.194 +qed
92.195 +
92.196 +text{* for any sequence, there is a mootonic subsequence *}
92.197 +lemma seq_monosub: "\<exists>f. subseq f \<and> monoseq (\<lambda> n. (s (f n)))"
92.198 +proof-
92.199 + {assume H: "\<forall>n. \<exists>p >n. \<forall> m\<ge>p. s m \<le> s p"
92.200 + let ?P = "\<lambda> p n. p > n \<and> (\<forall>m \<ge> p. s m \<le> s p)"
92.201 + from num_Axiom[of "SOME p. ?P p 0" "\<lambda>p n. SOME p. ?P p n"]
92.202 + obtain f where f: "f 0 = (SOME p. ?P p 0)" "\<forall>n. f (Suc n) = (SOME p. ?P p (f n))" by blast
92.203 + have "?P (f 0) 0" unfolding f(1) some_eq_ex[of "\<lambda>p. ?P p 0"]
92.204 + using H apply -
92.205 + apply (erule allE[where x=0], erule exE, rule_tac x="p" in exI)
92.206 + unfolding order_le_less by blast
92.207 + hence f0: "f 0 > 0" "\<forall>m \<ge> f 0. s m \<le> s (f 0)" by blast+
92.208 + {fix n
92.209 + have "?P (f (Suc n)) (f n)"
92.210 + unfolding f(2)[rule_format, of n] some_eq_ex[of "\<lambda>p. ?P p (f n)"]
92.211 + using H apply -
92.212 + apply (erule allE[where x="f n"], erule exE, rule_tac x="p" in exI)
92.213 + unfolding order_le_less by blast
92.214 + hence "f (Suc n) > f n" "\<forall>m \<ge> f (Suc n). s m \<le> s (f (Suc n))" by blast+}
92.215 + note fSuc = this
92.216 + {fix p q assume pq: "p \<ge> f q"
92.217 + have "s p \<le> s(f(q))" using f0(2)[rule_format, of p] pq fSuc
92.218 + by (cases q, simp_all) }
92.219 + note pqth = this
92.220 + {fix q
92.221 + have "f (Suc q) > f q" apply (induct q)
92.222 + using f0(1) fSuc(1)[of 0] apply simp by (rule fSuc(1))}
92.223 + note fss = this
92.224 + from fss have th1: "subseq f" unfolding subseq_Suc_iff ..
92.225 + {fix a b
92.226 + have "f a \<le> f (a + b)"
92.227 + proof(induct b)
92.228 + case 0 thus ?case by simp
92.229 + next
92.230 + case (Suc b)
92.231 + from fSuc(1)[of "a + b"] Suc.hyps show ?case by simp
92.232 + qed}
92.233 + note fmon0 = this
92.234 + have "monoseq (\<lambda>n. s (f n))"
92.235 + proof-
92.236 + {fix n
92.237 + have "s (f n) \<ge> s (f (Suc n))"
92.238 + proof(cases n)
92.239 + case 0
92.240 + assume n0: "n = 0"
92.241 + from fSuc(1)[of 0] have th0: "f 0 \<le> f (Suc 0)" by simp
92.242 + from f0(2)[rule_format, OF th0] show ?thesis using n0 by simp
92.243 + next
92.244 + case (Suc m)
92.245 + assume m: "n = Suc m"
92.246 + from fSuc(1)[of n] m have th0: "f (Suc m) \<le> f (Suc (Suc m))" by simp
92.247 + from m fSuc(2)[rule_format, OF th0] show ?thesis by simp
92.248 + qed}
92.249 + thus "monoseq (\<lambda>n. s (f n))" unfolding monoseq_Suc by blast
92.250 + qed
92.251 + with th1 have ?thesis by blast}
92.252 + moreover
92.253 + {fix N assume N: "\<forall>p >N. \<exists> m\<ge>p. s m > s p"
92.254 + {fix p assume p: "p \<ge> Suc N"
92.255 + hence pN: "p > N" by arith with N obtain m where m: "m \<ge> p" "s m > s p" by blast
92.256 + have "m \<noteq> p" using m(2) by auto
92.257 + with m have "\<exists>m>p. s p < s m" by - (rule exI[where x=m], auto)}
92.258 + note th0 = this
92.259 + let ?P = "\<lambda>m x. m > x \<and> s x < s m"
92.260 + from num_Axiom[of "SOME x. ?P x (Suc N)" "\<lambda>m x. SOME y. ?P y x"]
92.261 + obtain f where f: "f 0 = (SOME x. ?P x (Suc N))"
92.262 + "\<forall>n. f (Suc n) = (SOME m. ?P m (f n))" by blast
92.263 + have "?P (f 0) (Suc N)" unfolding f(1) some_eq_ex[of "\<lambda>p. ?P p (Suc N)"]
92.264 + using N apply -
92.265 + apply (erule allE[where x="Suc N"], clarsimp)
92.266 + apply (rule_tac x="m" in exI)
92.267 + apply auto
92.268 + apply (subgoal_tac "Suc N \<noteq> m")
92.269 + apply simp
92.270 + apply (rule ccontr, simp)
92.271 + done
92.272 + hence f0: "f 0 > Suc N" "s (Suc N) < s (f 0)" by blast+
92.273 + {fix n
92.274 + have "f n > N \<and> ?P (f (Suc n)) (f n)"
92.275 + unfolding f(2)[rule_format, of n] some_eq_ex[of "\<lambda>p. ?P p (f n)"]
92.276 + proof (induct n)
92.277 + case 0 thus ?case
92.278 + using f0 N apply auto
92.279 + apply (erule allE[where x="f 0"], clarsimp)
92.280 + apply (rule_tac x="m" in exI, simp)
92.281 + by (subgoal_tac "f 0 \<noteq> m", auto)
92.282 + next
92.283 + case (Suc n)
92.284 + from Suc.hyps have Nfn: "N < f n" by blast
92.285 + from Suc.hyps obtain m where m: "m > f n" "s (f n) < s m" by blast
92.286 + with Nfn have mN: "m > N" by arith
92.287 + note key = Suc.hyps[unfolded some_eq_ex[of "\<lambda>p. ?P p (f n)", symmetric] f(2)[rule_format, of n, symmetric]]
92.288 +
92.289 + from key have th0: "f (Suc n) > N" by simp
92.290 + from N[rule_format, OF th0]
92.291 + obtain m' where m': "m' \<ge> f (Suc n)" "s (f (Suc n)) < s m'" by blast
92.292 + have "m' \<noteq> f (Suc (n))" apply (rule ccontr) using m'(2) by auto
92.293 + hence "m' > f (Suc n)" using m'(1) by simp
92.294 + with key m'(2) show ?case by auto
92.295 + qed}
92.296 + note fSuc = this
92.297 + {fix n
92.298 + have "f n \<ge> Suc N \<and> f(Suc n) > f n \<and> s(f n) < s(f(Suc n))" using fSuc[of n] by auto
92.299 + hence "f n \<ge> Suc N" "f(Suc n) > f n" "s(f n) < s(f(Suc n))" by blast+}
92.300 + note thf = this
92.301 + have sqf: "subseq f" unfolding subseq_Suc_iff using thf by simp
92.302 + have "monoseq (\<lambda>n. s (f n))" unfolding monoseq_Suc using thf
92.303 + apply -
92.304 + apply (rule disjI1)
92.305 + apply auto
92.306 + apply (rule order_less_imp_le)
92.307 + apply blast
92.308 + done
92.309 + then have ?thesis using sqf by blast}
92.310 + ultimately show ?thesis unfolding linorder_not_less[symmetric] by blast
92.311 +qed
92.312 +
92.313 +lemma seq_suble: assumes sf: "subseq f" shows "n \<le> f n"
92.314 +proof(induct n)
92.315 + case 0 thus ?case by simp
92.316 +next
92.317 + case (Suc n)
92.318 + from sf[unfolded subseq_Suc_iff, rule_format, of n] Suc.hyps
92.319 + have "n < f (Suc n)" by arith
92.320 + thus ?case by arith
92.321 +qed
92.322 +
92.323 +subsection {* Fundamental theorem of algebra *}
92.324 +lemma unimodular_reduce_norm:
92.325 + assumes md: "cmod z = 1"
92.326 + shows "cmod (z + 1) < 1 \<or> cmod (z - 1) < 1 \<or> cmod (z + ii) < 1 \<or> cmod (z - ii) < 1"
92.327 +proof-
92.328 + obtain x y where z: "z = Complex x y " by (cases z, auto)
92.329 + from md z have xy: "x^2 + y^2 = 1" by (simp add: cmod_def)
92.330 + {assume C: "cmod (z + 1) \<ge> 1" "cmod (z - 1) \<ge> 1" "cmod (z + ii) \<ge> 1" "cmod (z - ii) \<ge> 1"
92.331 + from C z xy have "2*x \<le> 1" "2*x \<ge> -1" "2*y \<le> 1" "2*y \<ge> -1"
92.332 + by (simp_all add: cmod_def power2_eq_square ring_simps)
92.333 + hence "abs (2*x) \<le> 1" "abs (2*y) \<le> 1" by simp_all
92.334 + hence "(abs (2 * x))^2 <= 1^2" "(abs (2 * y)) ^2 <= 1^2"
92.335 + by - (rule power_mono, simp, simp)+
92.336 + hence th0: "4*x^2 \<le> 1" "4*y^2 \<le> 1"
92.337 + by (simp_all add: power2_abs power_mult_distrib)
92.338 + from add_mono[OF th0] xy have False by simp }
92.339 + thus ?thesis unfolding linorder_not_le[symmetric] by blast
92.340 +qed
92.341 +
92.342 +text{* Hence we can always reduce modulus of @{text "1 + b z^n"} if nonzero *}
92.343 +lemma reduce_poly_simple:
92.344 + assumes b: "b \<noteq> 0" and n: "n\<noteq>0"
92.345 + shows "\<exists>z. cmod (1 + b * z^n) < 1"
92.346 +using n
92.347 +proof(induct n rule: nat_less_induct)
92.348 + fix n
92.349 + assume IH: "\<forall>m<n. m \<noteq> 0 \<longrightarrow> (\<exists>z. cmod (1 + b * z ^ m) < 1)" and n: "n \<noteq> 0"
92.350 + let ?P = "\<lambda>z n. cmod (1 + b * z ^ n) < 1"
92.351 + {assume e: "even n"
92.352 + hence "\<exists>m. n = 2*m" by presburger
92.353 + then obtain m where m: "n = 2*m" by blast
92.354 + from n m have "m\<noteq>0" "m < n" by presburger+
92.355 + with IH[rule_format, of m] obtain z where z: "?P z m" by blast
92.356 + from z have "?P (csqrt z) n" by (simp add: m power_mult csqrt)
92.357 + hence "\<exists>z. ?P z n" ..}
92.358 + moreover
92.359 + {assume o: "odd n"
92.360 + from b have b': "b^2 \<noteq> 0" unfolding power2_eq_square by simp
92.361 + have "Im (inverse b) * (Im (inverse b) * \<bar>Im b * Im b + Re b * Re b\<bar>) +
92.362 + Re (inverse b) * (Re (inverse b) * \<bar>Im b * Im b + Re b * Re b\<bar>) =
92.363 + ((Re (inverse b))^2 + (Im (inverse b))^2) * \<bar>Im b * Im b + Re b * Re b\<bar>" by algebra
92.364 + also have "\<dots> = cmod (inverse b) ^2 * cmod b ^ 2"
92.365 + apply (simp add: cmod_def) using realpow_two_le_add_order[of "Re b" "Im b"]
92.366 + by (simp add: power2_eq_square)
92.367 + finally
92.368 + have th0: "Im (inverse b) * (Im (inverse b) * \<bar>Im b * Im b + Re b * Re b\<bar>) +
92.369 + Re (inverse b) * (Re (inverse b) * \<bar>Im b * Im b + Re b * Re b\<bar>) =
92.370 + 1"
92.371 + apply (simp add: power2_eq_square norm_mult[symmetric] norm_inverse[symmetric])
92.372 + using right_inverse[OF b']
92.373 + by (simp add: power2_eq_square[symmetric] power_inverse[symmetric] ring_simps)
92.374 + have th0: "cmod (complex_of_real (cmod b) / b) = 1"
92.375 + apply (simp add: complex_Re_mult cmod_def power2_eq_square Re_complex_of_real Im_complex_of_real divide_inverse ring_simps )
92.376 + by (simp add: real_sqrt_mult[symmetric] th0)
92.377 + from o have "\<exists>m. n = Suc (2*m)" by presburger+
92.378 + then obtain m where m: "n = Suc (2*m)" by blast
92.379 + from unimodular_reduce_norm[OF th0] o
92.380 + have "\<exists>v. cmod (complex_of_real (cmod b) / b + v^n) < 1"
92.381 + apply (cases "cmod (complex_of_real (cmod b) / b + 1) < 1", rule_tac x="1" in exI, simp)
92.382 + apply (cases "cmod (complex_of_real (cmod b) / b - 1) < 1", rule_tac x="-1" in exI, simp add: diff_def)
92.383 + apply (cases "cmod (complex_of_real (cmod b) / b + ii) < 1")
92.384 + apply (cases "even m", rule_tac x="ii" in exI, simp add: m power_mult)
92.385 + apply (rule_tac x="- ii" in exI, simp add: m power_mult)
92.386 + apply (cases "even m", rule_tac x="- ii" in exI, simp add: m power_mult diff_def)
92.387 + apply (rule_tac x="ii" in exI, simp add: m power_mult diff_def)
92.388 + done
92.389 + then obtain v where v: "cmod (complex_of_real (cmod b) / b + v^n) < 1" by blast
92.390 + let ?w = "v / complex_of_real (root n (cmod b))"
92.391 + from odd_real_root_pow[OF o, of "cmod b"]
92.392 + have th1: "?w ^ n = v^n / complex_of_real (cmod b)"
92.393 + by (simp add: power_divide complex_of_real_power)
92.394 + have th2:"cmod (complex_of_real (cmod b) / b) = 1" using b by (simp add: norm_divide)
92.395 + hence th3: "cmod (complex_of_real (cmod b) / b) \<ge> 0" by simp
92.396 + have th4: "cmod (complex_of_real (cmod b) / b) *
92.397 + cmod (1 + b * (v ^ n / complex_of_real (cmod b)))
92.398 + < cmod (complex_of_real (cmod b) / b) * 1"
92.399 + apply (simp only: norm_mult[symmetric] right_distrib)
92.400 + using b v by (simp add: th2)
92.401 +
92.402 + from mult_less_imp_less_left[OF th4 th3]
92.403 + have "?P ?w n" unfolding th1 .
92.404 + hence "\<exists>z. ?P z n" .. }
92.405 + ultimately show "\<exists>z. ?P z n" by blast
92.406 +qed
92.407 +
92.408 +
92.409 +text{* Bolzano-Weierstrass type property for closed disc in complex plane. *}
92.410 +
92.411 +lemma metric_bound_lemma: "cmod (x - y) <= \<bar>Re x - Re y\<bar> + \<bar>Im x - Im y\<bar>"
92.412 + using real_sqrt_sum_squares_triangle_ineq[of "Re x - Re y" 0 0 "Im x - Im y" ]
92.413 + unfolding cmod_def by simp
92.414 +
92.415 +lemma bolzano_weierstrass_complex_disc:
92.416 + assumes r: "\<forall>n. cmod (s n) \<le> r"
92.417 + shows "\<exists>f z. subseq f \<and> (\<forall>e >0. \<exists>N. \<forall>n \<ge> N. cmod (s (f n) - z) < e)"
92.418 +proof-
92.419 + from seq_monosub[of "Re o s"]
92.420 + obtain f g where f: "subseq f" "monoseq (\<lambda>n. Re (s (f n)))"
92.421 + unfolding o_def by blast
92.422 + from seq_monosub[of "Im o s o f"]
92.423 + obtain g where g: "subseq g" "monoseq (\<lambda>n. Im (s(f(g n))))" unfolding o_def by blast
92.424 + let ?h = "f o g"
92.425 + from r[rule_format, of 0] have rp: "r \<ge> 0" using norm_ge_zero[of "s 0"] by arith
92.426 + have th:"\<forall>n. r + 1 \<ge> \<bar> Re (s n)\<bar>"
92.427 + proof
92.428 + fix n
92.429 + from abs_Re_le_cmod[of "s n"] r[rule_format, of n] show "\<bar>Re (s n)\<bar> \<le> r + 1" by arith
92.430 + qed
92.431 + have conv1: "convergent (\<lambda>n. Re (s ( f n)))"
92.432 + apply (rule Bseq_monoseq_convergent)
92.433 + apply (simp add: Bseq_def)
92.434 + apply (rule exI[where x= "r + 1"])
92.435 + using th rp apply simp
92.436 + using f(2) .
92.437 + have th:"\<forall>n. r + 1 \<ge> \<bar> Im (s n)\<bar>"
92.438 + proof
92.439 + fix n
92.440 + from abs_Im_le_cmod[of "s n"] r[rule_format, of n] show "\<bar>Im (s n)\<bar> \<le> r + 1" by arith
92.441 + qed
92.442 +
92.443 + have conv2: "convergent (\<lambda>n. Im (s (f (g n))))"
92.444 + apply (rule Bseq_monoseq_convergent)
92.445 + apply (simp add: Bseq_def)
92.446 + apply (rule exI[where x= "r + 1"])
92.447 + using th rp apply simp
92.448 + using g(2) .
92.449 +
92.450 + from conv1[unfolded convergent_def] obtain x where "LIMSEQ (\<lambda>n. Re (s (f n))) x"
92.451 + by blast
92.452 + hence x: "\<forall>r>0. \<exists>n0. \<forall>n\<ge>n0. \<bar> Re (s (f n)) - x \<bar> < r"
92.453 + unfolding LIMSEQ_def real_norm_def .
92.454 +
92.455 + from conv2[unfolded convergent_def] obtain y where "LIMSEQ (\<lambda>n. Im (s (f (g n)))) y"
92.456 + by blast
92.457 + hence y: "\<forall>r>0. \<exists>n0. \<forall>n\<ge>n0. \<bar> Im (s (f (g n))) - y \<bar> < r"
92.458 + unfolding LIMSEQ_def real_norm_def .
92.459 + let ?w = "Complex x y"
92.460 + from f(1) g(1) have hs: "subseq ?h" unfolding subseq_def by auto
92.461 + {fix e assume ep: "e > (0::real)"
92.462 + hence e2: "e/2 > 0" by simp
92.463 + from x[rule_format, OF e2] y[rule_format, OF e2]
92.464 + obtain N1 N2 where N1: "\<forall>n\<ge>N1. \<bar>Re (s (f n)) - x\<bar> < e / 2" and N2: "\<forall>n\<ge>N2. \<bar>Im (s (f (g n))) - y\<bar> < e / 2" by blast
92.465 + {fix n assume nN12: "n \<ge> N1 + N2"
92.466 + hence nN1: "g n \<ge> N1" and nN2: "n \<ge> N2" using seq_suble[OF g(1), of n] by arith+
92.467 + from add_strict_mono[OF N1[rule_format, OF nN1] N2[rule_format, OF nN2]]
92.468 + have "cmod (s (?h n) - ?w) < e"
92.469 + using metric_bound_lemma[of "s (f (g n))" ?w] by simp }
92.470 + hence "\<exists>N. \<forall>n\<ge>N. cmod (s (?h n) - ?w) < e" by blast }
92.471 + with hs show ?thesis by blast
92.472 +qed
92.473 +
92.474 +text{* Polynomial is continuous. *}
92.475 +
92.476 +lemma poly_cont:
92.477 + assumes ep: "e > 0"
92.478 + shows "\<exists>d >0. \<forall>w. 0 < cmod (w - z) \<and> cmod (w - z) < d \<longrightarrow> cmod (poly p w - poly p z) < e"
92.479 +proof-
92.480 + from poly_offset[of p z] obtain q where q: "length q = length p" "\<And>x. poly q x = poly p (z + x)" by blast
92.481 + {fix w
92.482 + note q(2)[of "w - z", simplified]}
92.483 + note th = this
92.484 + show ?thesis unfolding th[symmetric]
92.485 + proof(induct q)
92.486 + case Nil thus ?case using ep by auto
92.487 + next
92.488 + case (Cons c cs)
92.489 + from poly_bound_exists[of 1 "cs"]
92.490 + obtain m where m: "m > 0" "\<And>z. cmod z \<le> 1 \<Longrightarrow> cmod (poly cs z) \<le> m" by blast
92.491 + from ep m(1) have em0: "e/m > 0" by (simp add: field_simps)
92.492 + have one0: "1 > (0::real)" by arith
92.493 + from real_lbound_gt_zero[OF one0 em0]
92.494 + obtain d where d: "d >0" "d < 1" "d < e / m" by blast
92.495 + from d(1,3) m(1) have dm: "d*m > 0" "d*m < e"
92.496 + by (simp_all add: field_simps real_mult_order)
92.497 + show ?case
92.498 + proof(rule ex_forward[OF real_lbound_gt_zero[OF one0 em0]], clarsimp simp add: norm_mult)
92.499 + fix d w
92.500 + assume H: "d > 0" "d < 1" "d < e/m" "w\<noteq>z" "cmod (w-z) < d"
92.501 + hence d1: "cmod (w-z) \<le> 1" "d \<ge> 0" by simp_all
92.502 + from H(3) m(1) have dme: "d*m < e" by (simp add: field_simps)
92.503 + from H have th: "cmod (w-z) \<le> d" by simp
92.504 + from mult_mono[OF th m(2)[OF d1(1)] d1(2) norm_ge_zero] dme
92.505 + show "cmod (w - z) * cmod (poly cs (w - z)) < e" by simp
92.506 + qed
92.507 + qed
92.508 +qed
92.509 +
92.510 +text{* Hence a polynomial attains minimum on a closed disc
92.511 + in the complex plane. *}
92.512 +lemma poly_minimum_modulus_disc:
92.513 + "\<exists>z. \<forall>w. cmod w \<le> r \<longrightarrow> cmod (poly p z) \<le> cmod (poly p w)"
92.514 +proof-
92.515 + {assume "\<not> r \<ge> 0" hence ?thesis unfolding linorder_not_le
92.516 + apply -
92.517 + apply (rule exI[where x=0])
92.518 + apply auto
92.519 + apply (subgoal_tac "cmod w < 0")
92.520 + apply simp
92.521 + apply arith
92.522 + done }
92.523 + moreover
92.524 + {assume rp: "r \<ge> 0"
92.525 + from rp have "cmod 0 \<le> r \<and> cmod (poly p 0) = - (- cmod (poly p 0))" by simp
92.526 + hence mth1: "\<exists>x z. cmod z \<le> r \<and> cmod (poly p z) = - x" by blast
92.527 + {fix x z
92.528 + assume H: "cmod z \<le> r" "cmod (poly p z) = - x" "\<not>x < 1"
92.529 + hence "- x < 0 " by arith
92.530 + with H(2) norm_ge_zero[of "poly p z"] have False by simp }
92.531 + then have mth2: "\<exists>z. \<forall>x. (\<exists>z. cmod z \<le> r \<and> cmod (poly p z) = - x) \<longrightarrow> x < z" by blast
92.532 + from real_sup_exists[OF mth1 mth2] obtain s where
92.533 + s: "\<forall>y. (\<exists>x. (\<exists>z. cmod z \<le> r \<and> cmod (poly p z) = - x) \<and> y < x) \<longleftrightarrow>(y < s)" by blast
92.534 + let ?m = "-s"
92.535 + {fix y
92.536 + from s[rule_format, of "-y"] have
92.537 + "(\<exists>z x. cmod z \<le> r \<and> -(- cmod (poly p z)) < y) \<longleftrightarrow> ?m < y"
92.538 + unfolding minus_less_iff[of y ] equation_minus_iff by blast }
92.539 + note s1 = this[unfolded minus_minus]
92.540 + from s1[of ?m] have s1m: "\<And>z x. cmod z \<le> r \<Longrightarrow> cmod (poly p z) \<ge> ?m"
92.541 + by auto
92.542 + {fix n::nat
92.543 + from s1[rule_format, of "?m + 1/real (Suc n)"]
92.544 + have "\<exists>z. cmod z \<le> r \<and> cmod (poly p z) < - s + 1 / real (Suc n)"
92.545 + by simp}
92.546 + hence th: "\<forall>n. \<exists>z. cmod z \<le> r \<and> cmod (poly p z) < - s + 1 / real (Suc n)" ..
92.547 + from choice[OF th] obtain g where
92.548 + g: "\<forall>n. cmod (g n) \<le> r" "\<forall>n. cmod (poly p (g n)) <?m+1 /real(Suc n)"
92.549 + by blast
92.550 + from bolzano_weierstrass_complex_disc[OF g(1)]
92.551 + obtain f z where fz: "subseq f" "\<forall>e>0. \<exists>N. \<forall>n\<ge>N. cmod (g (f n) - z) < e"
92.552 + by blast
92.553 + {fix w
92.554 + assume wr: "cmod w \<le> r"
92.555 + let ?e = "\<bar>cmod (poly p z) - ?m\<bar>"
92.556 + {assume e: "?e > 0"
92.557 + hence e2: "?e/2 > 0" by simp
92.558 + from poly_cont[OF e2, of z p] obtain d where
92.559 + d: "d>0" "\<forall>w. 0<cmod (w - z)\<and> cmod(w - z) < d \<longrightarrow> cmod(poly p w - poly p z) < ?e/2" by blast
92.560 + {fix w assume w: "cmod (w - z) < d"
92.561 + have "cmod(poly p w - poly p z) < ?e / 2"
92.562 + using d(2)[rule_format, of w] w e by (cases "w=z", simp_all)}
92.563 + note th1 = this
92.564 +
92.565 + from fz(2)[rule_format, OF d(1)] obtain N1 where
92.566 + N1: "\<forall>n\<ge>N1. cmod (g (f n) - z) < d" by blast
92.567 + from reals_Archimedean2[of "2/?e"] obtain N2::nat where
92.568 + N2: "2/?e < real N2" by blast
92.569 + have th2: "cmod(poly p (g(f(N1 + N2))) - poly p z) < ?e/2"
92.570 + using N1[rule_format, of "N1 + N2"] th1 by simp
92.571 + {fix a b e2 m :: real
92.572 + have "a < e2 \<Longrightarrow> abs(b - m) < e2 \<Longrightarrow> 2 * e2 <= abs(b - m) + a
92.573 + ==> False" by arith}
92.574 + note th0 = this
92.575 + have ath:
92.576 + "\<And>m x e. m <= x \<Longrightarrow> x < m + e ==> abs(x - m::real) < e" by arith
92.577 + from s1m[OF g(1)[rule_format]]
92.578 + have th31: "?m \<le> cmod(poly p (g (f (N1 + N2))))" .
92.579 + from seq_suble[OF fz(1), of "N1+N2"]
92.580 + have th00: "real (Suc (N1+N2)) \<le> real (Suc (f (N1+N2)))" by simp
92.581 + have th000: "0 \<le> (1::real)" "(1::real) \<le> 1" "real (Suc (N1+N2)) > 0"
92.582 + using N2 by auto
92.583 + from frac_le[OF th000 th00] have th00: "?m +1 / real (Suc (f (N1 + N2))) \<le> ?m + 1 / real (Suc (N1 + N2))" by simp
92.584 + from g(2)[rule_format, of "f (N1 + N2)"]
92.585 + have th01:"cmod (poly p (g (f (N1 + N2)))) < - s + 1 / real (Suc (f (N1 + N2)))" .
92.586 + from order_less_le_trans[OF th01 th00]
92.587 + have th32: "cmod(poly p (g (f (N1 + N2)))) < ?m + (1/ real(Suc (N1 + N2)))" .
92.588 + from N2 have "2/?e < real (Suc (N1 + N2))" by arith
92.589 + with e2 less_imp_inverse_less[of "2/?e" "real (Suc (N1 + N2))"]
92.590 + have "?e/2 > 1/ real (Suc (N1 + N2))" by (simp add: inverse_eq_divide)
92.591 + with ath[OF th31 th32]
92.592 + have thc1:"\<bar>cmod(poly p (g (f (N1 + N2)))) - ?m\<bar>< ?e/2" by arith
92.593 + have ath2: "\<And>(a::real) b c m. \<bar>a - b\<bar> <= c ==> \<bar>b - m\<bar> <= \<bar>a - m\<bar> + c"
92.594 + by arith
92.595 + have th22: "\<bar>cmod (poly p (g (f (N1 + N2)))) - cmod (poly p z)\<bar>
92.596 +\<le> cmod (poly p (g (f (N1 + N2))) - poly p z)"
92.597 + by (simp add: norm_triangle_ineq3)
92.598 + from ath2[OF th22, of ?m]
92.599 + have thc2: "2*(?e/2) \<le> \<bar>cmod(poly p (g (f (N1 + N2)))) - ?m\<bar> + cmod (poly p (g (f (N1 + N2))) - poly p z)" by simp
92.600 + from th0[OF th2 thc1 thc2] have False .}
92.601 + hence "?e = 0" by auto
92.602 + then have "cmod (poly p z) = ?m" by simp
92.603 + with s1m[OF wr]
92.604 + have "cmod (poly p z) \<le> cmod (poly p w)" by simp }
92.605 + hence ?thesis by blast}
92.606 + ultimately show ?thesis by blast
92.607 +qed
92.608 +
92.609 +lemma "(rcis (sqrt (abs r)) (a/2)) ^ 2 = rcis (abs r) a"
92.610 + unfolding power2_eq_square
92.611 + apply (simp add: rcis_mult)
92.612 + apply (simp add: power2_eq_square[symmetric])
92.613 + done
92.614 +
92.615 +lemma cispi: "cis pi = -1"
92.616 + unfolding cis_def
92.617 + by simp
92.618 +
92.619 +lemma "(rcis (sqrt (abs r)) ((pi + a)/2)) ^ 2 = rcis (- abs r) a"
92.620 + unfolding power2_eq_square
92.621 + apply (simp add: rcis_mult add_divide_distrib)
92.622 + apply (simp add: power2_eq_square[symmetric] rcis_def cispi cis_mult[symmetric])
92.623 + done
92.624 +
92.625 +text {* Nonzero polynomial in z goes to infinity as z does. *}
92.626 +
92.627 +instance complex::idom_char_0 by (intro_classes)
92.628 +instance complex :: recpower_idom_char_0 by intro_classes
92.629 +
92.630 +lemma poly_infinity:
92.631 + assumes ex: "list_ex (\<lambda>c. c \<noteq> 0) p"
92.632 + shows "\<exists>r. \<forall>z. r \<le> cmod z \<longrightarrow> d \<le> cmod (poly (a#p) z)"
92.633 +using ex
92.634 +proof(induct p arbitrary: a d)
92.635 + case (Cons c cs a d)
92.636 + {assume H: "list_ex (\<lambda>c. c\<noteq>0) cs"
92.637 + with Cons.hyps obtain r where r: "\<forall>z. r \<le> cmod z \<longrightarrow> d + cmod a \<le> cmod (poly (c # cs) z)" by blast
92.638 + let ?r = "1 + \<bar>r\<bar>"
92.639 + {fix z assume h: "1 + \<bar>r\<bar> \<le> cmod z"
92.640 + have r0: "r \<le> cmod z" using h by arith
92.641 + from r[rule_format, OF r0]
92.642 + have th0: "d + cmod a \<le> 1 * cmod(poly (c#cs) z)" by arith
92.643 + from h have z1: "cmod z \<ge> 1" by arith
92.644 + from order_trans[OF th0 mult_right_mono[OF z1 norm_ge_zero[of "poly (c#cs) z"]]]
92.645 + have th1: "d \<le> cmod(z * poly (c#cs) z) - cmod a"
92.646 + unfolding norm_mult by (simp add: ring_simps)
92.647 + from complex_mod_triangle_sub[of "z * poly (c#cs) z" a]
92.648 + have th2: "cmod(z * poly (c#cs) z) - cmod a \<le> cmod (poly (a#c#cs) z)"
92.649 + by (simp add: diff_le_eq ring_simps)
92.650 + from th1 th2 have "d \<le> cmod (poly (a#c#cs) z)" by arith}
92.651 + hence ?case by blast}
92.652 + moreover
92.653 + {assume cs0: "\<not> (list_ex (\<lambda>c. c \<noteq> 0) cs)"
92.654 + with Cons.prems have c0: "c \<noteq> 0" by simp
92.655 + from cs0 have cs0': "list_all (\<lambda>c. c = 0) cs"
92.656 + by (auto simp add: list_all_iff list_ex_iff)
92.657 + {fix z
92.658 + assume h: "(\<bar>d\<bar> + cmod a) / cmod c \<le> cmod z"
92.659 + from c0 have "cmod c > 0" by simp
92.660 + from h c0 have th0: "\<bar>d\<bar> + cmod a \<le> cmod (z*c)"
92.661 + by (simp add: field_simps norm_mult)
92.662 + have ath: "\<And>mzh mazh ma. mzh <= mazh + ma ==> abs(d) + ma <= mzh ==> d <= mazh" by arith
92.663 + from complex_mod_triangle_sub[of "z*c" a ]
92.664 + have th1: "cmod (z * c) \<le> cmod (a + z * c) + cmod a"
92.665 + by (simp add: ring_simps)
92.666 + from ath[OF th1 th0] have "d \<le> cmod (poly (a # c # cs) z)"
92.667 + using poly_0[OF cs0'] by simp}
92.668 + then have ?case by blast}
92.669 + ultimately show ?case by blast
92.670 +qed simp
92.671 +
92.672 +text {* Hence polynomial's modulus attains its minimum somewhere. *}
92.673 +lemma poly_minimum_modulus:
92.674 + "\<exists>z.\<forall>w. cmod (poly p z) \<le> cmod (poly p w)"
92.675 +proof(induct p)
92.676 + case (Cons c cs)
92.677 + {assume cs0: "list_ex (\<lambda>c. c \<noteq> 0) cs"
92.678 + from poly_infinity[OF cs0, of "cmod (poly (c#cs) 0)" c]
92.679 + obtain r where r: "\<And>z. r \<le> cmod z \<Longrightarrow> cmod (poly (c # cs) 0) \<le> cmod (poly (c # cs) z)" by blast
92.680 + have ath: "\<And>z r. r \<le> cmod z \<or> cmod z \<le> \<bar>r\<bar>" by arith
92.681 + from poly_minimum_modulus_disc[of "\<bar>r\<bar>" "c#cs"]
92.682 + obtain v where v: "\<And>w. cmod w \<le> \<bar>r\<bar> \<Longrightarrow> cmod (poly (c # cs) v) \<le> cmod (poly (c # cs) w)" by blast
92.683 + {fix z assume z: "r \<le> cmod z"
92.684 + from v[of 0] r[OF z]
92.685 + have "cmod (poly (c # cs) v) \<le> cmod (poly (c # cs) z)"
92.686 + by simp }
92.687 + note v0 = this
92.688 + from v0 v ath[of r] have ?case by blast}
92.689 + moreover
92.690 + {assume cs0: "\<not> (list_ex (\<lambda>c. c\<noteq>0) cs)"
92.691 + hence th:"list_all (\<lambda>c. c = 0) cs" by (simp add: list_all_iff list_ex_iff)
92.692 + from poly_0[OF th] Cons.hyps have ?case by simp}
92.693 + ultimately show ?case by blast
92.694 +qed simp
92.695 +
92.696 +text{* Constant function (non-syntactic characterization). *}
92.697 +definition "constant f = (\<forall>x y. f x = f y)"
92.698 +
92.699 +lemma nonconstant_length: "\<not> (constant (poly p)) \<Longrightarrow> length p \<ge> 2"
92.700 + unfolding constant_def
92.701 + apply (induct p, auto)
92.702 + apply (unfold not_less[symmetric])
92.703 + apply simp
92.704 + apply (rule ccontr)
92.705 + apply auto
92.706 + done
92.707 +
92.708 +lemma poly_replicate_append:
92.709 + "poly ((replicate n 0)@p) (x::'a::{recpower, comm_ring}) = x^n * poly p x"
92.710 + by(induct n, auto simp add: power_Suc ring_simps)
92.711 +
92.712 +text {* Decomposition of polynomial, skipping zero coefficients
92.713 + after the first. *}
92.714 +
92.715 +lemma poly_decompose_lemma:
92.716 + assumes nz: "\<not>(\<forall>z. z\<noteq>0 \<longrightarrow> poly p z = (0::'a::{recpower,idom}))"
92.717 + shows "\<exists>k a q. a\<noteq>0 \<and> Suc (length q + k) = length p \<and>
92.718 + (\<forall>z. poly p z = z^k * poly (a#q) z)"
92.719 +using nz
92.720 +proof(induct p)
92.721 + case Nil thus ?case by simp
92.722 +next
92.723 + case (Cons c cs)
92.724 + {assume c0: "c = 0"
92.725 +
92.726 + from Cons.hyps Cons.prems c0 have ?case apply auto
92.727 + apply (rule_tac x="k+1" in exI)
92.728 + apply (rule_tac x="a" in exI, clarsimp)
92.729 + apply (rule_tac x="q" in exI)
92.730 + by (auto simp add: power_Suc)}
92.731 + moreover
92.732 + {assume c0: "c\<noteq>0"
92.733 + hence ?case apply-
92.734 + apply (rule exI[where x=0])
92.735 + apply (rule exI[where x=c], clarsimp)
92.736 + apply (rule exI[where x=cs])
92.737 + apply auto
92.738 + done}
92.739 + ultimately show ?case by blast
92.740 +qed
92.741 +
92.742 +lemma poly_decompose:
92.743 + assumes nc: "~constant(poly p)"
92.744 + shows "\<exists>k a q. a\<noteq>(0::'a::{recpower,idom}) \<and> k\<noteq>0 \<and>
92.745 + length q + k + 1 = length p \<and>
92.746 + (\<forall>z. poly p z = poly p 0 + z^k * poly (a#q) z)"
92.747 +using nc
92.748 +proof(induct p)
92.749 + case Nil thus ?case by (simp add: constant_def)
92.750 +next
92.751 + case (Cons c cs)
92.752 + {assume C:"\<forall>z. z \<noteq> 0 \<longrightarrow> poly cs z = 0"
92.753 + {fix x y
92.754 + from C have "poly (c#cs) x = poly (c#cs) y" by (cases "x=0", auto)}
92.755 + with Cons.prems have False by (auto simp add: constant_def)}
92.756 + hence th: "\<not> (\<forall>z. z \<noteq> 0 \<longrightarrow> poly cs z = 0)" ..
92.757 + from poly_decompose_lemma[OF th]
92.758 + show ?case
92.759 + apply clarsimp
92.760 + apply (rule_tac x="k+1" in exI)
92.761 + apply (rule_tac x="a" in exI)
92.762 + apply simp
92.763 + apply (rule_tac x="q" in exI)
92.764 + apply (auto simp add: power_Suc)
92.765 + done
92.766 +qed
92.767 +
92.768 +text{* Fundamental theorem of algebral *}
92.769 +
92.770 +lemma fundamental_theorem_of_algebra:
92.771 + assumes nc: "~constant(poly p)"
92.772 + shows "\<exists>z::complex. poly p z = 0"
92.773 +using nc
92.774 +proof(induct n\<equiv> "length p" arbitrary: p rule: nat_less_induct)
92.775 + fix n fix p :: "complex list"
92.776 + let ?p = "poly p"
92.777 + assume H: "\<forall>m<n. \<forall>p. \<not> constant (poly p) \<longrightarrow> m = length p \<longrightarrow> (\<exists>(z::complex). poly p z = 0)" and nc: "\<not> constant ?p" and n: "n = length p"
92.778 + let ?ths = "\<exists>z. ?p z = 0"
92.779 +
92.780 + from nonconstant_length[OF nc] have n2: "n\<ge> 2" by (simp add: n)
92.781 + from poly_minimum_modulus obtain c where
92.782 + c: "\<forall>w. cmod (?p c) \<le> cmod (?p w)" by blast
92.783 + {assume pc: "?p c = 0" hence ?ths by blast}
92.784 + moreover
92.785 + {assume pc0: "?p c \<noteq> 0"
92.786 + from poly_offset[of p c] obtain q where
92.787 + q: "length q = length p" "\<forall>x. poly q x = ?p (c+x)" by blast
92.788 + {assume h: "constant (poly q)"
92.789 + from q(2) have th: "\<forall>x. poly q (x - c) = ?p x" by auto
92.790 + {fix x y
92.791 + from th have "?p x = poly q (x - c)" by auto
92.792 + also have "\<dots> = poly q (y - c)"
92.793 + using h unfolding constant_def by blast
92.794 + also have "\<dots> = ?p y" using th by auto
92.795 + finally have "?p x = ?p y" .}
92.796 + with nc have False unfolding constant_def by blast }
92.797 + hence qnc: "\<not> constant (poly q)" by blast
92.798 + from q(2) have pqc0: "?p c = poly q 0" by simp
92.799 + from c pqc0 have cq0: "\<forall>w. cmod (poly q 0) \<le> cmod (?p w)" by simp
92.800 + let ?a0 = "poly q 0"
92.801 + from pc0 pqc0 have a00: "?a0 \<noteq> 0" by simp
92.802 + from a00
92.803 + have qr: "\<forall>z. poly q z = poly (map (op * (inverse ?a0)) q) z * ?a0"
92.804 + by (simp add: poly_cmult_map)
92.805 + let ?r = "map (op * (inverse ?a0)) q"
92.806 + have lgqr: "length q = length ?r" by simp
92.807 + {assume h: "\<And>x y. poly ?r x = poly ?r y"
92.808 + {fix x y
92.809 + from qr[rule_format, of x]
92.810 + have "poly q x = poly ?r x * ?a0" by auto
92.811 + also have "\<dots> = poly ?r y * ?a0" using h by simp
92.812 + also have "\<dots> = poly q y" using qr[rule_format, of y] by simp
92.813 + finally have "poly q x = poly q y" .}
92.814 + with qnc have False unfolding constant_def by blast}
92.815 + hence rnc: "\<not> constant (poly ?r)" unfolding constant_def by blast
92.816 + from qr[rule_format, of 0] a00 have r01: "poly ?r 0 = 1" by auto
92.817 + {fix w
92.818 + have "cmod (poly ?r w) < 1 \<longleftrightarrow> cmod (poly q w / ?a0) < 1"
92.819 + using qr[rule_format, of w] a00 by simp
92.820 + also have "\<dots> \<longleftrightarrow> cmod (poly q w) < cmod ?a0"
92.821 + using a00 unfolding norm_divide by (simp add: field_simps)
92.822 + finally have "cmod (poly ?r w) < 1 \<longleftrightarrow> cmod (poly q w) < cmod ?a0" .}
92.823 + note mrmq_eq = this
92.824 + from poly_decompose[OF rnc] obtain k a s where
92.825 + kas: "a\<noteq>0" "k\<noteq>0" "length s + k + 1 = length ?r"
92.826 + "\<forall>z. poly ?r z = poly ?r 0 + z^k* poly (a#s) z" by blast
92.827 + {assume "k + 1 = n"
92.828 + with kas(3) lgqr[symmetric] q(1) n[symmetric] have s0:"s=[]" by auto
92.829 + {fix w
92.830 + have "cmod (poly ?r w) = cmod (1 + a * w ^ k)"
92.831 + using kas(4)[rule_format, of w] s0 r01 by (simp add: ring_simps)}
92.832 + note hth = this [symmetric]
92.833 + from reduce_poly_simple[OF kas(1,2)]
92.834 + have "\<exists>w. cmod (poly ?r w) < 1" unfolding hth by blast}
92.835 + moreover
92.836 + {assume kn: "k+1 \<noteq> n"
92.837 + from kn kas(3) q(1) n[symmetric] have k1n: "k + 1 < n" by simp
92.838 + have th01: "\<not> constant (poly (1#((replicate (k - 1) 0)@[a])))"
92.839 + unfolding constant_def poly_Nil poly_Cons poly_replicate_append
92.840 + using kas(1) apply simp
92.841 + by (rule exI[where x=0], rule exI[where x=1], simp)
92.842 + from kas(2) have th02: "k+1 = length (1#((replicate (k - 1) 0)@[a]))"
92.843 + by simp
92.844 + from H[rule_format, OF k1n th01 th02]
92.845 + obtain w where w: "1 + w^k * a = 0"
92.846 + unfolding poly_Nil poly_Cons poly_replicate_append
92.847 + using kas(2) by (auto simp add: power_Suc[symmetric, of _ "k - Suc 0"]
92.848 + mult_assoc[of _ _ a, symmetric])
92.849 + from poly_bound_exists[of "cmod w" s] obtain m where
92.850 + m: "m > 0" "\<forall>z. cmod z \<le> cmod w \<longrightarrow> cmod (poly s z) \<le> m" by blast
92.851 + have w0: "w\<noteq>0" using kas(2) w by (auto simp add: power_0_left)
92.852 + from w have "(1 + w ^ k * a) - 1 = 0 - 1" by simp
92.853 + then have wm1: "w^k * a = - 1" by simp
92.854 + have inv0: "0 < inverse (cmod w ^ (k + 1) * m)"
92.855 + using norm_ge_zero[of w] w0 m(1)
92.856 + by (simp add: inverse_eq_divide zero_less_mult_iff)
92.857 + with real_down2[OF zero_less_one] obtain t where
92.858 + t: "t > 0" "t < 1" "t < inverse (cmod w ^ (k + 1) * m)" by blast
92.859 + let ?ct = "complex_of_real t"
92.860 + let ?w = "?ct * w"
92.861 + have "1 + ?w^k * (a + ?w * poly s ?w) = 1 + ?ct^k * (w^k * a) + ?w^k * ?w * poly s ?w" using kas(1) by (simp add: ring_simps power_mult_distrib)
92.862 + also have "\<dots> = complex_of_real (1 - t^k) + ?w^k * ?w * poly s ?w"
92.863 + unfolding wm1 by (simp)
92.864 + finally have "cmod (1 + ?w^k * (a + ?w * poly s ?w)) = cmod (complex_of_real (1 - t^k) + ?w^k * ?w * poly s ?w)"
92.865 + apply -
92.866 + apply (rule cong[OF refl[of cmod]])
92.867 + apply assumption
92.868 + done
92.869 + with norm_triangle_ineq[of "complex_of_real (1 - t^k)" "?w^k * ?w * poly s ?w"]
92.870 + have th11: "cmod (1 + ?w^k * (a + ?w * poly s ?w)) \<le> \<bar>1 - t^k\<bar> + cmod (?w^k * ?w * poly s ?w)" unfolding norm_of_real by simp
92.871 + have ath: "\<And>x (t::real). 0\<le> x \<Longrightarrow> x < t \<Longrightarrow> t\<le>1 \<Longrightarrow> \<bar>1 - t\<bar> + x < 1" by arith
92.872 + have "t *cmod w \<le> 1 * cmod w" apply (rule mult_mono) using t(1,2) by auto
92.873 + then have tw: "cmod ?w \<le> cmod w" using t(1) by (simp add: norm_mult)
92.874 + from t inv0 have "t* (cmod w ^ (k + 1) * m) < 1"
92.875 + by (simp add: inverse_eq_divide field_simps)
92.876 + with zero_less_power[OF t(1), of k]
92.877 + have th30: "t^k * (t* (cmod w ^ (k + 1) * m)) < t^k * 1"
92.878 + apply - apply (rule mult_strict_left_mono) by simp_all
92.879 + have "cmod (?w^k * ?w * poly s ?w) = t^k * (t* (cmod w ^ (k+1) * cmod (poly s ?w)))" using w0 t(1)
92.880 + by (simp add: ring_simps power_mult_distrib norm_of_real norm_power norm_mult)
92.881 + then have "cmod (?w^k * ?w * poly s ?w) \<le> t^k * (t* (cmod w ^ (k + 1) * m))"
92.882 + using t(1,2) m(2)[rule_format, OF tw] w0
92.883 + apply (simp only: )
92.884 + apply auto
92.885 + apply (rule mult_mono, simp_all add: norm_ge_zero)+
92.886 + apply (simp add: zero_le_mult_iff zero_le_power)
92.887 + done
92.888 + with th30 have th120: "cmod (?w^k * ?w * poly s ?w) < t^k" by simp
92.889 + from power_strict_mono[OF t(2), of k] t(1) kas(2) have th121: "t^k \<le> 1"
92.890 + by auto
92.891 + from ath[OF norm_ge_zero[of "?w^k * ?w * poly s ?w"] th120 th121]
92.892 + have th12: "\<bar>1 - t^k\<bar> + cmod (?w^k * ?w * poly s ?w) < 1" .
92.893 + from th11 th12
92.894 + have "cmod (1 + ?w^k * (a + ?w * poly s ?w)) < 1" by arith
92.895 + then have "cmod (poly ?r ?w) < 1"
92.896 + unfolding kas(4)[rule_format, of ?w] r01 by simp
92.897 + then have "\<exists>w. cmod (poly ?r w) < 1" by blast}
92.898 + ultimately have cr0_contr: "\<exists>w. cmod (poly ?r w) < 1" by blast
92.899 + from cr0_contr cq0 q(2)
92.900 + have ?ths unfolding mrmq_eq not_less[symmetric] by auto}
92.901 + ultimately show ?ths by blast
92.902 +qed
92.903 +
92.904 +text {* Alternative version with a syntactic notion of constant polynomial. *}
92.905 +
92.906 +lemma fundamental_theorem_of_algebra_alt:
92.907 + assumes nc: "~(\<exists>a l. a\<noteq> 0 \<and> list_all(\<lambda>b. b = 0) l \<and> p = a#l)"
92.908 + shows "\<exists>z. poly p z = (0::complex)"
92.909 +using nc
92.910 +proof(induct p)
92.911 + case (Cons c cs)
92.912 + {assume "c=0" hence ?case by auto}
92.913 + moreover
92.914 + {assume c0: "c\<noteq>0"
92.915 + {assume nc: "constant (poly (c#cs))"
92.916 + from nc[unfolded constant_def, rule_format, of 0]
92.917 + have "\<forall>w. w \<noteq> 0 \<longrightarrow> poly cs w = 0" by auto
92.918 + hence "list_all (\<lambda>c. c=0) cs"
92.919 + proof(induct cs)
92.920 + case (Cons d ds)
92.921 + {assume "d=0" hence ?case using Cons.prems Cons.hyps by simp}
92.922 + moreover
92.923 + {assume d0: "d\<noteq>0"
92.924 + from poly_bound_exists[of 1 ds] obtain m where
92.925 + m: "m > 0" "\<forall>z. \<forall>z. cmod z \<le> 1 \<longrightarrow> cmod (poly ds z) \<le> m" by blast
92.926 + have dm: "cmod d / m > 0" using d0 m(1) by (simp add: field_simps)
92.927 + from real_down2[OF dm zero_less_one] obtain x where
92.928 + x: "x > 0" "x < cmod d / m" "x < 1" by blast
92.929 + let ?x = "complex_of_real x"
92.930 + from x have cx: "?x \<noteq> 0" "cmod ?x \<le> 1" by simp_all
92.931 + from Cons.prems[rule_format, OF cx(1)]
92.932 + have cth: "cmod (?x*poly ds ?x) = cmod d" by (simp add: eq_diff_eq[symmetric])
92.933 + from m(2)[rule_format, OF cx(2)] x(1)
92.934 + have th0: "cmod (?x*poly ds ?x) \<le> x*m"
92.935 + by (simp add: norm_mult)
92.936 + from x(2) m(1) have "x*m < cmod d" by (simp add: field_simps)
92.937 + with th0 have "cmod (?x*poly ds ?x) \<noteq> cmod d" by auto
92.938 + with cth have ?case by blast}
92.939 + ultimately show ?case by blast
92.940 + qed simp}
92.941 + then have nc: "\<not> constant (poly (c#cs))" using Cons.prems c0
92.942 + by blast
92.943 + from fundamental_theorem_of_algebra[OF nc] have ?case .}
92.944 + ultimately show ?case by blast
92.945 +qed simp
92.946 +
92.947 +subsection{* Nullstellenstatz, degrees and divisibility of polynomials *}
92.948 +
92.949 +lemma nullstellensatz_lemma:
92.950 + fixes p :: "complex list"
92.951 + assumes "\<forall>x. poly p x = 0 \<longrightarrow> poly q x = 0"
92.952 + and "degree p = n" and "n \<noteq> 0"
92.953 + shows "p divides (pexp q n)"
92.954 +using prems
92.955 +proof(induct n arbitrary: p q rule: nat_less_induct)
92.956 + fix n::nat fix p q :: "complex list"
92.957 + assume IH: "\<forall>m<n. \<forall>p q.
92.958 + (\<forall>x. poly p x = (0::complex) \<longrightarrow> poly q x = 0) \<longrightarrow>
92.959 + degree p = m \<longrightarrow> m \<noteq> 0 \<longrightarrow> p divides (q %^ m)"
92.960 + and pq0: "\<forall>x. poly p x = 0 \<longrightarrow> poly q x = 0"
92.961 + and dpn: "degree p = n" and n0: "n \<noteq> 0"
92.962 + let ?ths = "p divides (q %^ n)"
92.963 + {fix a assume a: "poly p a = 0"
92.964 + {assume p0: "poly p = poly []"
92.965 + hence ?ths unfolding divides_def using pq0 n0
92.966 + apply - apply (rule exI[where x="[]"], rule ext)
92.967 + by (auto simp add: poly_mult poly_exp)}
92.968 + moreover
92.969 + {assume p0: "poly p \<noteq> poly []"
92.970 + and oa: "order a p \<noteq> 0"
92.971 + from p0 have pne: "p \<noteq> []" by auto
92.972 + let ?op = "order a p"
92.973 + from p0 have ap: "([- a, 1] %^ ?op) divides p"
92.974 + "\<not> pexp [- a, 1] (Suc ?op) divides p" using order by blast+
92.975 + note oop = order_degree[OF p0, unfolded dpn]
92.976 + {assume q0: "q = []"
92.977 + hence ?ths using n0 unfolding divides_def
92.978 + apply simp
92.979 + apply (rule exI[where x="[]"], rule ext)
92.980 + by (simp add: divides_def poly_exp poly_mult)}
92.981 + moreover
92.982 + {assume q0: "q\<noteq>[]"
92.983 + from pq0[rule_format, OF a, unfolded poly_linear_divides] q0
92.984 + obtain r where r: "q = pmult [- a, 1] r" by blast
92.985 + from ap[unfolded divides_def] obtain s where
92.986 + s: "poly p = poly (pmult (pexp [- a, 1] ?op) s)" by blast
92.987 + have s0: "poly s \<noteq> poly []"
92.988 + using s p0 by (simp add: poly_entire)
92.989 + hence pns0: "poly (pnormalize s) \<noteq> poly []" and sne: "s\<noteq>[]" by auto
92.990 + {assume ds0: "degree s = 0"
92.991 + from ds0 pns0 have "\<exists>k. pnormalize s = [k]" unfolding degree_def
92.992 + by (cases "pnormalize s", auto)
92.993 + then obtain k where kpn: "pnormalize s = [k]" by blast
92.994 + from pns0[unfolded poly_zero] kpn have k: "k \<noteq>0" "poly s = poly [k]"
92.995 + using poly_normalize[of s] by simp_all
92.996 + let ?w = "pmult (pmult [1/k] (pexp [-a,1] (n - ?op))) (pexp r n)"
92.997 + from k r s oop have "poly (pexp q n) = poly (pmult p ?w)"
92.998 + by - (rule ext, simp add: poly_mult poly_exp poly_cmult poly_add power_add[symmetric] ring_simps power_mult_distrib[symmetric])
92.999 + hence ?ths unfolding divides_def by blast}
92.1000 + moreover
92.1001 + {assume ds0: "degree s \<noteq> 0"
92.1002 + from ds0 s0 dpn degree_unique[OF s, unfolded linear_pow_mul_degree] oa
92.1003 + have dsn: "degree s < n" by auto
92.1004 + {fix x assume h: "poly s x = 0"
92.1005 + {assume xa: "x = a"
92.1006 + from h[unfolded xa poly_linear_divides] sne obtain u where
92.1007 + u: "s = pmult [- a, 1] u" by blast
92.1008 + have "poly p = poly (pmult (pexp [- a, 1] (Suc ?op)) u)"
92.1009 + unfolding s u
92.1010 + apply (rule ext)
92.1011 + by (simp add: ring_simps power_mult_distrib[symmetric] poly_mult poly_cmult poly_add poly_exp)
92.1012 + with ap(2)[unfolded divides_def] have False by blast}
92.1013 + note xa = this
92.1014 + from h s have "poly p x = 0" by (simp add: poly_mult)
92.1015 + with pq0 have "poly q x = 0" by blast
92.1016 + with r xa have "poly r x = 0"
92.1017 + by (auto simp add: poly_mult poly_add poly_cmult eq_diff_eq[symmetric])}
92.1018 + note impth = this
92.1019 + from IH[rule_format, OF dsn, of s r] impth ds0
92.1020 + have "s divides (pexp r (degree s))" by blast
92.1021 + then obtain u where u: "poly (pexp r (degree s)) = poly (pmult s u)"
92.1022 + unfolding divides_def by blast
92.1023 + hence u': "\<And>x. poly s x * poly u x = poly r x ^ degree s"
92.1024 + by (simp add: poly_mult[symmetric] poly_exp[symmetric])
92.1025 + let ?w = "pmult (pmult u (pexp [-a,1] (n - ?op))) (pexp r (n - degree s))"
92.1026 + from u' s r oop[of a] dsn have "poly (pexp q n) = poly (pmult p ?w)"
92.1027 + apply - apply (rule ext)
92.1028 + apply (simp only: power_mult_distrib power_add[symmetric] poly_add poly_mult poly_exp poly_cmult ring_simps)
92.1029 +
92.1030 + apply (simp add: power_mult_distrib power_add[symmetric] poly_add poly_mult poly_exp poly_cmult mult_assoc[symmetric])
92.1031 + done
92.1032 + hence ?ths unfolding divides_def by blast}
92.1033 + ultimately have ?ths by blast }
92.1034 + ultimately have ?ths by blast}
92.1035 + ultimately have ?ths using a order_root by blast}
92.1036 + moreover
92.1037 + {assume exa: "\<not> (\<exists>a. poly p a = 0)"
92.1038 + from fundamental_theorem_of_algebra_alt[of p] exa obtain c cs where
92.1039 + ccs: "c\<noteq>0" "list_all (\<lambda>c. c = 0) cs" "p = c#cs" by blast
92.1040 +
92.1041 + from poly_0[OF ccs(2)] ccs(3)
92.1042 + have pp: "\<And>x. poly p x = c" by simp
92.1043 + let ?w = "pmult [1/c] (pexp q n)"
92.1044 + from pp ccs(1)
92.1045 + have "poly (pexp q n) = poly (pmult p ?w) "
92.1046 + apply - apply (rule ext)
92.1047 + unfolding poly_mult_assoc[symmetric] by (simp add: poly_mult)
92.1048 + hence ?ths unfolding divides_def by blast}
92.1049 + ultimately show ?ths by blast
92.1050 +qed
92.1051 +
92.1052 +lemma nullstellensatz_univariate:
92.1053 + "(\<forall>x. poly p x = (0::complex) \<longrightarrow> poly q x = 0) \<longleftrightarrow>
92.1054 + p divides (q %^ (degree p)) \<or> (poly p = poly [] \<and> poly q = poly [])"
92.1055 +proof-
92.1056 + {assume pe: "poly p = poly []"
92.1057 + hence eq: "(\<forall>x. poly p x = (0::complex) \<longrightarrow> poly q x = 0) \<longleftrightarrow> poly q = poly []"
92.1058 + apply auto
92.1059 + by (rule ext, simp)
92.1060 + {assume "p divides (pexp q (degree p))"
92.1061 + then obtain r where r: "poly (pexp q (degree p)) = poly (pmult p r)"
92.1062 + unfolding divides_def by blast
92.1063 + from cong[OF r refl] pe degree_unique[OF pe]
92.1064 + have False by (simp add: poly_mult degree_def)}
92.1065 + with eq pe have ?thesis by blast}
92.1066 + moreover
92.1067 + {assume pe: "poly p \<noteq> poly []"
92.1068 + have p0: "poly [0] = poly []" by (rule ext, simp)
92.1069 + {assume dp: "degree p = 0"
92.1070 + then obtain k where "pnormalize p = [k]" using pe poly_normalize[of p]
92.1071 + unfolding degree_def by (cases "pnormalize p", auto)
92.1072 + hence k: "pnormalize p = [k]" "poly p = poly [k]" "k\<noteq>0"
92.1073 + using pe poly_normalize[of p] by (auto simp add: p0)
92.1074 + hence th1: "\<forall>x. poly p x \<noteq> 0" by simp
92.1075 + from k(2,3) dp have "poly (pexp q (degree p)) = poly (pmult p [1/k]) "
92.1076 + by - (rule ext, simp add: poly_mult poly_exp)
92.1077 + hence th2: "p divides (pexp q (degree p))" unfolding divides_def by blast
92.1078 + from th1 th2 pe have ?thesis by blast}
92.1079 + moreover
92.1080 + {assume dp: "degree p \<noteq> 0"
92.1081 + then obtain n where n: "degree p = Suc n " by (cases "degree p", auto)
92.1082 + {assume "p divides (pexp q (Suc n))"
92.1083 + then obtain u where u: "poly (pexp q (Suc n)) = poly (pmult p u)"
92.1084 + unfolding divides_def by blast
92.1085 + hence u' :"\<And>x. poly (pexp q (Suc n)) x = poly (pmult p u) x" by simp_all
92.1086 + {fix x assume h: "poly p x = 0" "poly q x \<noteq> 0"
92.1087 + hence "poly (pexp q (Suc n)) x \<noteq> 0" by (simp only: poly_exp) simp
92.1088 + hence False using u' h(1) by (simp only: poly_mult poly_exp) simp}}
92.1089 + with n nullstellensatz_lemma[of p q "degree p"] dp
92.1090 + have ?thesis by auto}
92.1091 + ultimately have ?thesis by blast}
92.1092 + ultimately show ?thesis by blast
92.1093 +qed
92.1094 +
92.1095 +text{* Useful lemma *}
92.1096 +
92.1097 +lemma (in idom_char_0) constant_degree: "constant (poly p) \<longleftrightarrow> degree p = 0" (is "?lhs = ?rhs")
92.1098 +proof
92.1099 + assume l: ?lhs
92.1100 + from l[unfolded constant_def, rule_format, of _ "zero"]
92.1101 + have th: "poly p = poly [poly p 0]" apply - by (rule ext, simp)
92.1102 + from degree_unique[OF th] show ?rhs by (simp add: degree_def)
92.1103 +next
92.1104 + assume r: ?rhs
92.1105 + from r have "pnormalize p = [] \<or> (\<exists>k. pnormalize p = [k])"
92.1106 + unfolding degree_def by (cases "pnormalize p", auto)
92.1107 + then show ?lhs unfolding constant_def poly_normalize[of p, symmetric]
92.1108 + by (auto simp del: poly_normalize)
92.1109 +qed
92.1110 +
92.1111 +(* It would be nicer to prove this without using algebraic closure... *)
92.1112 +
92.1113 +lemma divides_degree_lemma: assumes dpn: "degree (p::complex list) = n"
92.1114 + shows "n \<le> degree (p *** q) \<or> poly (p *** q) = poly []"
92.1115 + using dpn
92.1116 +proof(induct n arbitrary: p q)
92.1117 + case 0 thus ?case by simp
92.1118 +next
92.1119 + case (Suc n p q)
92.1120 + from Suc.prems fundamental_theorem_of_algebra[of p] constant_degree[of p]
92.1121 + obtain a where a: "poly p a = 0" by auto
92.1122 + then obtain r where r: "p = pmult [-a, 1] r" unfolding poly_linear_divides
92.1123 + using Suc.prems by (auto simp add: degree_def)
92.1124 + {assume h: "poly (pmult r q) = poly []"
92.1125 + hence "poly (pmult p q) = poly []" using r
92.1126 + apply - apply (rule ext) by (auto simp add: poly_entire poly_mult poly_add poly_cmult) hence ?case by blast}
92.1127 + moreover
92.1128 + {assume h: "poly (pmult r q) \<noteq> poly []"
92.1129 + hence r0: "poly r \<noteq> poly []" and q0: "poly q \<noteq> poly []"
92.1130 + by (auto simp add: poly_entire)
92.1131 + have eq: "poly (pmult p q) = poly (pmult [-a, 1] (pmult r q))"
92.1132 + apply - apply (rule ext)
92.1133 + by (simp add: r poly_mult poly_add poly_cmult ring_simps)
92.1134 + from linear_mul_degree[OF h, of "- a"]
92.1135 + have dqe: "degree (pmult p q) = degree (pmult r q) + 1"
92.1136 + unfolding degree_unique[OF eq] .
92.1137 + from linear_mul_degree[OF r0, of "- a", unfolded r[symmetric]] r Suc.prems
92.1138 + have dr: "degree r = n" by auto
92.1139 + from Suc.hyps[OF dr, of q] have "Suc n \<le> degree (pmult p q)"
92.1140 + unfolding dqe using h by (auto simp del: poly.simps)
92.1141 + hence ?case by blast}
92.1142 + ultimately show ?case by blast
92.1143 +qed
92.1144 +
92.1145 +lemma divides_degree: assumes pq: "p divides (q:: complex list)"
92.1146 + shows "degree p \<le> degree q \<or> poly q = poly []"
92.1147 +using pq divides_degree_lemma[OF refl, of p]
92.1148 +apply (auto simp add: divides_def poly_entire)
92.1149 +apply atomize
92.1150 +apply (erule_tac x="qa" in allE, auto)
92.1151 +apply (subgoal_tac "degree q = degree (p *** qa)", simp)
92.1152 +apply (rule degree_unique, simp)
92.1153 +done
92.1154 +
92.1155 +(* Arithmetic operations on multivariate polynomials. *)
92.1156 +
92.1157 +lemma mpoly_base_conv:
92.1158 + "(0::complex) \<equiv> poly [] x" "c \<equiv> poly [c] x" "x \<equiv> poly [0,1] x" by simp_all
92.1159 +
92.1160 +lemma mpoly_norm_conv:
92.1161 + "poly [0] (x::complex) \<equiv> poly [] x" "poly [poly [] y] x \<equiv> poly [] x" by simp_all
92.1162 +
92.1163 +lemma mpoly_sub_conv:
92.1164 + "poly p (x::complex) - poly q x \<equiv> poly p x + -1 * poly q x"
92.1165 + by (simp add: diff_def)
92.1166 +
92.1167 +lemma poly_pad_rule: "poly p x = 0 ==> poly (0#p) x = (0::complex)" by simp
92.1168 +
92.1169 +lemma poly_cancel_eq_conv: "p = (0::complex) \<Longrightarrow> a \<noteq> 0 \<Longrightarrow> (q = 0) \<equiv> (a * q - b * p = 0)" apply (atomize (full)) by auto
92.1170 +
92.1171 +lemma resolve_eq_raw: "poly [] x \<equiv> 0" "poly [c] x \<equiv> (c::complex)" by auto
92.1172 +lemma resolve_eq_then: "(P \<Longrightarrow> (Q \<equiv> Q1)) \<Longrightarrow> (\<not>P \<Longrightarrow> (Q \<equiv> Q2))
92.1173 + \<Longrightarrow> Q \<equiv> P \<and> Q1 \<or> \<not>P\<and> Q2" apply (atomize (full)) by blast
92.1174 +lemma expand_ex_beta_conv: "list_ex P [c] \<equiv> P c" by simp
92.1175 +
92.1176 +lemma poly_divides_pad_rule:
92.1177 + fixes p q :: "complex list"
92.1178 + assumes pq: "p divides q"
92.1179 + shows "p divides ((0::complex)#q)"
92.1180 +proof-
92.1181 + from pq obtain r where r: "poly q = poly (p *** r)" unfolding divides_def by blast
92.1182 + hence "poly (0#q) = poly (p *** ([0,1] *** r))"
92.1183 + by - (rule ext, simp add: poly_mult poly_cmult poly_add)
92.1184 + thus ?thesis unfolding divides_def by blast
92.1185 +qed
92.1186 +
92.1187 +lemma poly_divides_pad_const_rule:
92.1188 + fixes p q :: "complex list"
92.1189 + assumes pq: "p divides q"
92.1190 + shows "p divides (a %* q)"
92.1191 +proof-
92.1192 + from pq obtain r where r: "poly q = poly (p *** r)" unfolding divides_def by blast
92.1193 + hence "poly (a %* q) = poly (p *** (a %* r))"
92.1194 + by - (rule ext, simp add: poly_mult poly_cmult poly_add)
92.1195 + thus ?thesis unfolding divides_def by blast
92.1196 +qed
92.1197 +
92.1198 +
92.1199 +lemma poly_divides_conv0:
92.1200 + fixes p :: "complex list"
92.1201 + assumes lgpq: "length q < length p" and lq:"last p \<noteq> 0"
92.1202 + shows "p divides q \<equiv> (\<not> (list_ex (\<lambda>c. c \<noteq> 0) q))" (is "?lhs \<equiv> ?rhs")
92.1203 +proof-
92.1204 + {assume r: ?rhs
92.1205 + hence eq: "poly q = poly []" unfolding poly_zero
92.1206 + by (simp add: list_all_iff list_ex_iff)
92.1207 + hence "poly q = poly (p *** [])" by - (rule ext, simp add: poly_mult)
92.1208 + hence ?lhs unfolding divides_def by blast}
92.1209 + moreover
92.1210 + {assume l: ?lhs
92.1211 + have ath: "\<And>lq lp dq::nat. lq < lp ==> lq \<noteq> 0 \<Longrightarrow> dq <= lq - 1 ==> dq < lp - 1"
92.1212 + by arith
92.1213 + {assume q0: "length q = 0"
92.1214 + hence "q = []" by simp
92.1215 + hence ?rhs by simp}
92.1216 + moreover
92.1217 + {assume lgq0: "length q \<noteq> 0"
92.1218 + from pnormalize_length[of q] have dql: "degree q \<le> length q - 1"
92.1219 + unfolding degree_def by simp
92.1220 + from ath[OF lgpq lgq0 dql, unfolded pnormal_degree[OF lq, symmetric]] divides_degree[OF l] have "poly q = poly []" by auto
92.1221 + hence ?rhs unfolding poly_zero by (simp add: list_all_iff list_ex_iff)}
92.1222 + ultimately have ?rhs by blast }
92.1223 + ultimately show "?lhs \<equiv> ?rhs" by - (atomize (full), blast)
92.1224 +qed
92.1225 +
92.1226 +lemma poly_divides_conv1:
92.1227 + assumes a0: "a\<noteq> (0::complex)" and pp': "(p::complex list) divides p'"
92.1228 + and qrp': "\<And>x. a * poly q x - poly p' x \<equiv> poly r x"
92.1229 + shows "p divides q \<equiv> p divides (r::complex list)" (is "?lhs \<equiv> ?rhs")
92.1230 +proof-
92.1231 + {
92.1232 + from pp' obtain t where t: "poly p' = poly (p *** t)"
92.1233 + unfolding divides_def by blast
92.1234 + {assume l: ?lhs
92.1235 + then obtain u where u: "poly q = poly (p *** u)" unfolding divides_def by blast
92.1236 + have "poly r = poly (p *** ((a %* u) +++ (-- t)))"
92.1237 + using u qrp' t
92.1238 + by - (rule ext,
92.1239 + simp add: poly_add poly_mult poly_cmult poly_minus ring_simps)
92.1240 + then have ?rhs unfolding divides_def by blast}
92.1241 + moreover
92.1242 + {assume r: ?rhs
92.1243 + then obtain u where u: "poly r = poly (p *** u)" unfolding divides_def by blast
92.1244 + from u t qrp' a0 have "poly q = poly (p *** ((1/a) %* (u +++ t)))"
92.1245 + by - (rule ext, atomize (full), simp add: poly_mult poly_add poly_cmult field_simps)
92.1246 + hence ?lhs unfolding divides_def by blast}
92.1247 + ultimately have "?lhs = ?rhs" by blast }
92.1248 +thus "?lhs \<equiv> ?rhs" by - (atomize(full), blast)
92.1249 +qed
92.1250 +
92.1251 +lemma basic_cqe_conv1:
92.1252 + "(\<exists>x. poly p x = 0 \<and> poly [] x \<noteq> 0) \<equiv> False"
92.1253 + "(\<exists>x. poly [] x \<noteq> 0) \<equiv> False"
92.1254 + "(\<exists>x. poly [c] x \<noteq> 0) \<equiv> c\<noteq>0"
92.1255 + "(\<exists>x. poly [] x = 0) \<equiv> True"
92.1256 + "(\<exists>x. poly [c] x = 0) \<equiv> c = 0" by simp_all
92.1257 +
92.1258 +lemma basic_cqe_conv2:
92.1259 + assumes l:"last (a#b#p) \<noteq> 0"
92.1260 + shows "(\<exists>x. poly (a#b#p) x = (0::complex)) \<equiv> True"
92.1261 +proof-
92.1262 + {fix h t
92.1263 + assume h: "h\<noteq>0" "list_all (\<lambda>c. c=(0::complex)) t" "a#b#p = h#t"
92.1264 + hence "list_all (\<lambda>c. c= 0) (b#p)" by simp
92.1265 + moreover have "last (b#p) \<in> set (b#p)" by simp
92.1266 + ultimately have "last (b#p) = 0" by (simp add: list_all_iff)
92.1267 + with l have False by simp}
92.1268 + hence th: "\<not> (\<exists> h t. h\<noteq>0 \<and> list_all (\<lambda>c. c=0) t \<and> a#b#p = h#t)"
92.1269 + by blast
92.1270 + from fundamental_theorem_of_algebra_alt[OF th]
92.1271 + show "(\<exists>x. poly (a#b#p) x = (0::complex)) \<equiv> True" by auto
92.1272 +qed
92.1273 +
92.1274 +lemma basic_cqe_conv_2b: "(\<exists>x. poly p x \<noteq> (0::complex)) \<equiv> (list_ex (\<lambda>c. c \<noteq> 0) p)"
92.1275 +proof-
92.1276 + have "\<not> (list_ex (\<lambda>c. c \<noteq> 0) p) \<longleftrightarrow> poly p = poly []"
92.1277 + by (simp add: poly_zero list_all_iff list_ex_iff)
92.1278 + also have "\<dots> \<longleftrightarrow> (\<not> (\<exists>x. poly p x \<noteq> 0))" by (auto intro: ext)
92.1279 + finally show "(\<exists>x. poly p x \<noteq> (0::complex)) \<equiv> (list_ex (\<lambda>c. c \<noteq> 0) p)"
92.1280 + by - (atomize (full), blast)
92.1281 +qed
92.1282 +
92.1283 +lemma basic_cqe_conv3:
92.1284 + fixes p q :: "complex list"
92.1285 + assumes l: "last (a#p) \<noteq> 0"
92.1286 + shows "(\<exists>x. poly (a#p) x =0 \<and> poly q x \<noteq> 0) \<equiv> \<not> ((a#p) divides (q %^ (length p)))"
92.1287 +proof-
92.1288 + note np = pnormalize_eq[OF l]
92.1289 + {assume "poly (a#p) = poly []" hence False using l
92.1290 + unfolding poly_zero apply (auto simp add: list_all_iff del: last.simps)
92.1291 + apply (cases p, simp_all) done}
92.1292 + then have p0: "poly (a#p) \<noteq> poly []" by blast
92.1293 + from np have dp:"degree (a#p) = length p" by (simp add: degree_def)
92.1294 + from nullstellensatz_univariate[of "a#p" q] p0 dp
92.1295 + show "(\<exists>x. poly (a#p) x =0 \<and> poly q x \<noteq> 0) \<equiv> \<not> ((a#p) divides (q %^ (length p)))"
92.1296 + by - (atomize (full), auto)
92.1297 +qed
92.1298 +
92.1299 +lemma basic_cqe_conv4:
92.1300 + fixes p q :: "complex list"
92.1301 + assumes h: "\<And>x. poly (q %^ n) x \<equiv> poly r x"
92.1302 + shows "p divides (q %^ n) \<equiv> p divides r"
92.1303 +proof-
92.1304 + from h have "poly (q %^ n) = poly r" by (auto intro: ext)
92.1305 + thus "p divides (q %^ n) \<equiv> p divides r" unfolding divides_def by simp
92.1306 +qed
92.1307 +
92.1308 +lemma pmult_Cons_Cons: "((a::complex)#b#p) *** q = (a %*q) +++ (0#((b#p) *** q))"
92.1309 + by simp
92.1310 +
92.1311 +lemma elim_neg_conv: "- z \<equiv> (-1) * (z::complex)" by simp
92.1312 +lemma eqT_intr: "PROP P \<Longrightarrow> (True \<Longrightarrow> PROP P )" "PROP P \<Longrightarrow> True" by blast+
92.1313 +lemma negate_negate_rule: "Trueprop P \<equiv> \<not> P \<equiv> False" by (atomize (full), auto)
92.1314 +lemma last_simps: "last [x] = x" "last (x#y#ys) = last (y#ys)" by simp_all
92.1315 +lemma length_simps: "length [] = 0" "length (x#y#xs) = length xs + 2" "length [x] = 1" by simp_all
92.1316 +
92.1317 +lemma complex_entire: "(z::complex) \<noteq> 0 \<and> w \<noteq> 0 \<equiv> z*w \<noteq> 0" by simp
92.1318 +lemma resolve_eq_ne: "(P \<equiv> True) \<equiv> (\<not>P \<equiv> False)" "(P \<equiv> False) \<equiv> (\<not>P \<equiv> True)"
92.1319 + by (atomize (full)) simp_all
92.1320 +lemma cqe_conv1: "poly [] x = 0 \<longleftrightarrow> True" by simp
92.1321 +lemma cqe_conv2: "(p \<Longrightarrow> (q \<equiv> r)) \<equiv> ((p \<and> q) \<equiv> (p \<and> r))" (is "?l \<equiv> ?r")
92.1322 +proof
92.1323 + assume "p \<Longrightarrow> q \<equiv> r" thus "p \<and> q \<equiv> p \<and> r" apply - apply (atomize (full)) by blast
92.1324 +next
92.1325 + assume "p \<and> q \<equiv> p \<and> r" "p"
92.1326 + thus "q \<equiv> r" apply - apply (atomize (full)) apply blast done
92.1327 +qed
92.1328 +lemma poly_const_conv: "poly [c] (x::complex) = y \<longleftrightarrow> c = y" by simp
92.1329 +
92.1330 +end
92.1331 \ No newline at end of file
93.1 --- a/src/HOL/HOL.thy Tue Dec 30 08:18:54 2008 +0100
93.2 +++ b/src/HOL/HOL.thy Tue Dec 30 11:10:01 2008 +0100
93.3 @@ -26,6 +26,7 @@
93.4 "~~/src/Tools/atomize_elim.ML"
93.5 "~~/src/Tools/induct.ML"
93.6 ("~~/src/Tools/induct_tacs.ML")
93.7 + "~~/src/Tools/value.ML"
93.8 "~~/src/Tools/code/code_name.ML"
93.9 "~~/src/Tools/code/code_funcgr.ML"
93.10 "~~/src/Tools/code/code_thingol.ML"
94.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
94.2 +++ b/src/HOL/HahnBanach/Bounds.thy Tue Dec 30 11:10:01 2008 +0100
94.3 @@ -0,0 +1,82 @@
94.4 +(* Title: HOL/Real/HahnBanach/Bounds.thy
94.5 + Author: Gertrud Bauer, TU Munich
94.6 +*)
94.7 +
94.8 +header {* Bounds *}
94.9 +
94.10 +theory Bounds
94.11 +imports Main ContNotDenum
94.12 +begin
94.13 +
94.14 +locale lub =
94.15 + fixes A and x
94.16 + assumes least [intro?]: "(\<And>a. a \<in> A \<Longrightarrow> a \<le> b) \<Longrightarrow> x \<le> b"
94.17 + and upper [intro?]: "a \<in> A \<Longrightarrow> a \<le> x"
94.18 +
94.19 +lemmas [elim?] = lub.least lub.upper
94.20 +
94.21 +definition
94.22 + the_lub :: "'a::order set \<Rightarrow> 'a" where
94.23 + "the_lub A = The (lub A)"
94.24 +
94.25 +notation (xsymbols)
94.26 + the_lub ("\<Squnion>_" [90] 90)
94.27 +
94.28 +lemma the_lub_equality [elim?]:
94.29 + assumes "lub A x"
94.30 + shows "\<Squnion>A = (x::'a::order)"
94.31 +proof -
94.32 + interpret lub A x by fact
94.33 + show ?thesis
94.34 + proof (unfold the_lub_def)
94.35 + from `lub A x` show "The (lub A) = x"
94.36 + proof
94.37 + fix x' assume lub': "lub A x'"
94.38 + show "x' = x"
94.39 + proof (rule order_antisym)
94.40 + from lub' show "x' \<le> x"
94.41 + proof
94.42 + fix a assume "a \<in> A"
94.43 + then show "a \<le> x" ..
94.44 + qed
94.45 + show "x \<le> x'"
94.46 + proof
94.47 + fix a assume "a \<in> A"
94.48 + with lub' show "a \<le> x'" ..
94.49 + qed
94.50 + qed
94.51 + qed
94.52 + qed
94.53 +qed
94.54 +
94.55 +lemma the_lubI_ex:
94.56 + assumes ex: "\<exists>x. lub A x"
94.57 + shows "lub A (\<Squnion>A)"
94.58 +proof -
94.59 + from ex obtain x where x: "lub A x" ..
94.60 + also from x have [symmetric]: "\<Squnion>A = x" ..
94.61 + finally show ?thesis .
94.62 +qed
94.63 +
94.64 +lemma lub_compat: "lub A x = isLub UNIV A x"
94.65 +proof -
94.66 + have "isUb UNIV A = (\<lambda>x. A *<= x \<and> x \<in> UNIV)"
94.67 + by (rule ext) (simp only: isUb_def)
94.68 + then show ?thesis
94.69 + by (simp only: lub_def isLub_def leastP_def setge_def setle_def) blast
94.70 +qed
94.71 +
94.72 +lemma real_complete:
94.73 + fixes A :: "real set"
94.74 + assumes nonempty: "\<exists>a. a \<in> A"
94.75 + and ex_upper: "\<exists>y. \<forall>a \<in> A. a \<le> y"
94.76 + shows "\<exists>x. lub A x"
94.77 +proof -
94.78 + from ex_upper have "\<exists>y. isUb UNIV A y"
94.79 + unfolding isUb_def setle_def by blast
94.80 + with nonempty have "\<exists>x. isLub UNIV A x"
94.81 + by (rule reals_complete)
94.82 + then show ?thesis by (simp only: lub_compat)
94.83 +qed
94.84 +
94.85 +end
95.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
95.2 +++ b/src/HOL/HahnBanach/FunctionNorm.thy Tue Dec 30 11:10:01 2008 +0100
95.3 @@ -0,0 +1,278 @@
95.4 +(* Title: HOL/Real/HahnBanach/FunctionNorm.thy
95.5 + Author: Gertrud Bauer, TU Munich
95.6 +*)
95.7 +
95.8 +header {* The norm of a function *}
95.9 +
95.10 +theory FunctionNorm
95.11 +imports NormedSpace FunctionOrder
95.12 +begin
95.13 +
95.14 +subsection {* Continuous linear forms*}
95.15 +
95.16 +text {*
95.17 + A linear form @{text f} on a normed vector space @{text "(V, \<parallel>\<cdot>\<parallel>)"}
95.18 + is \emph{continuous}, iff it is bounded, i.e.
95.19 + \begin{center}
95.20 + @{text "\<exists>c \<in> R. \<forall>x \<in> V. \<bar>f x\<bar> \<le> c \<cdot> \<parallel>x\<parallel>"}
95.21 + \end{center}
95.22 + In our application no other functions than linear forms are
95.23 + considered, so we can define continuous linear forms as bounded
95.24 + linear forms:
95.25 +*}
95.26 +
95.27 +locale continuous = var_V + norm_syntax + linearform +
95.28 + assumes bounded: "\<exists>c. \<forall>x \<in> V. \<bar>f x\<bar> \<le> c * \<parallel>x\<parallel>"
95.29 +
95.30 +declare continuous.intro [intro?] continuous_axioms.intro [intro?]
95.31 +
95.32 +lemma continuousI [intro]:
95.33 + fixes norm :: "_ \<Rightarrow> real" ("\<parallel>_\<parallel>")
95.34 + assumes "linearform V f"
95.35 + assumes r: "\<And>x. x \<in> V \<Longrightarrow> \<bar>f x\<bar> \<le> c * \<parallel>x\<parallel>"
95.36 + shows "continuous V norm f"
95.37 +proof
95.38 + show "linearform V f" by fact
95.39 + from r have "\<exists>c. \<forall>x\<in>V. \<bar>f x\<bar> \<le> c * \<parallel>x\<parallel>" by blast
95.40 + then show "continuous_axioms V norm f" ..
95.41 +qed
95.42 +
95.43 +
95.44 +subsection {* The norm of a linear form *}
95.45 +
95.46 +text {*
95.47 + The least real number @{text c} for which holds
95.48 + \begin{center}
95.49 + @{text "\<forall>x \<in> V. \<bar>f x\<bar> \<le> c \<cdot> \<parallel>x\<parallel>"}
95.50 + \end{center}
95.51 + is called the \emph{norm} of @{text f}.
95.52 +
95.53 + For non-trivial vector spaces @{text "V \<noteq> {0}"} the norm can be
95.54 + defined as
95.55 + \begin{center}
95.56 + @{text "\<parallel>f\<parallel> = \<sup>x \<noteq> 0. \<bar>f x\<bar> / \<parallel>x\<parallel>"}
95.57 + \end{center}
95.58 +
95.59 + For the case @{text "V = {0}"} the supremum would be taken from an
95.60 + empty set. Since @{text \<real>} is unbounded, there would be no supremum.
95.61 + To avoid this situation it must be guaranteed that there is an
95.62 + element in this set. This element must be @{text "{} \<ge> 0"} so that
95.63 + @{text fn_norm} has the norm properties. Furthermore it does not
95.64 + have to change the norm in all other cases, so it must be @{text 0},
95.65 + as all other elements are @{text "{} \<ge> 0"}.
95.66 +
95.67 + Thus we define the set @{text B} where the supremum is taken from as
95.68 + follows:
95.69 + \begin{center}
95.70 + @{text "{0} \<union> {\<bar>f x\<bar> / \<parallel>x\<parallel>. x \<noteq> 0 \<and> x \<in> F}"}
95.71 + \end{center}
95.72 +
95.73 + @{text fn_norm} is equal to the supremum of @{text B}, if the
95.74 + supremum exists (otherwise it is undefined).
95.75 +*}
95.76 +
95.77 +locale fn_norm = norm_syntax +
95.78 + fixes B defines "B V f \<equiv> {0} \<union> {\<bar>f x\<bar> / \<parallel>x\<parallel> | x. x \<noteq> 0 \<and> x \<in> V}"
95.79 + fixes fn_norm ("\<parallel>_\<parallel>\<hyphen>_" [0, 1000] 999)
95.80 + defines "\<parallel>f\<parallel>\<hyphen>V \<equiv> \<Squnion>(B V f)"
95.81 +
95.82 +locale normed_vectorspace_with_fn_norm = normed_vectorspace + fn_norm
95.83 +
95.84 +lemma (in fn_norm) B_not_empty [intro]: "0 \<in> B V f"
95.85 + by (simp add: B_def)
95.86 +
95.87 +text {*
95.88 + The following lemma states that every continuous linear form on a
95.89 + normed space @{text "(V, \<parallel>\<cdot>\<parallel>)"} has a function norm.
95.90 +*}
95.91 +
95.92 +lemma (in normed_vectorspace_with_fn_norm) fn_norm_works:
95.93 + assumes "continuous V norm f"
95.94 + shows "lub (B V f) (\<parallel>f\<parallel>\<hyphen>V)"
95.95 +proof -
95.96 + interpret continuous V norm f by fact
95.97 + txt {* The existence of the supremum is shown using the
95.98 + completeness of the reals. Completeness means, that every
95.99 + non-empty bounded set of reals has a supremum. *}
95.100 + have "\<exists>a. lub (B V f) a"
95.101 + proof (rule real_complete)
95.102 + txt {* First we have to show that @{text B} is non-empty: *}
95.103 + have "0 \<in> B V f" ..
95.104 + then show "\<exists>x. x \<in> B V f" ..
95.105 +
95.106 + txt {* Then we have to show that @{text B} is bounded: *}
95.107 + show "\<exists>c. \<forall>y \<in> B V f. y \<le> c"
95.108 + proof -
95.109 + txt {* We know that @{text f} is bounded by some value @{text c}. *}
95.110 + from bounded obtain c where c: "\<forall>x \<in> V. \<bar>f x\<bar> \<le> c * \<parallel>x\<parallel>" ..
95.111 +
95.112 + txt {* To prove the thesis, we have to show that there is some
95.113 + @{text b}, such that @{text "y \<le> b"} for all @{text "y \<in>
95.114 + B"}. Due to the definition of @{text B} there are two cases. *}
95.115 +
95.116 + def b \<equiv> "max c 0"
95.117 + have "\<forall>y \<in> B V f. y \<le> b"
95.118 + proof
95.119 + fix y assume y: "y \<in> B V f"
95.120 + show "y \<le> b"
95.121 + proof cases
95.122 + assume "y = 0"
95.123 + then show ?thesis unfolding b_def by arith
95.124 + next
95.125 + txt {* The second case is @{text "y = \<bar>f x\<bar> / \<parallel>x\<parallel>"} for some
95.126 + @{text "x \<in> V"} with @{text "x \<noteq> 0"}. *}
95.127 + assume "y \<noteq> 0"
95.128 + with y obtain x where y_rep: "y = \<bar>f x\<bar> * inverse \<parallel>x\<parallel>"
95.129 + and x: "x \<in> V" and neq: "x \<noteq> 0"
95.130 + by (auto simp add: B_def real_divide_def)
95.131 + from x neq have gt: "0 < \<parallel>x\<parallel>" ..
95.132 +
95.133 + txt {* The thesis follows by a short calculation using the
95.134 + fact that @{text f} is bounded. *}
95.135 +
95.136 + note y_rep
95.137 + also have "\<bar>f x\<bar> * inverse \<parallel>x\<parallel> \<le> (c * \<parallel>x\<parallel>) * inverse \<parallel>x\<parallel>"
95.138 + proof (rule mult_right_mono)
95.139 + from c x show "\<bar>f x\<bar> \<le> c * \<parallel>x\<parallel>" ..
95.140 + from gt have "0 < inverse \<parallel>x\<parallel>"
95.141 + by (rule positive_imp_inverse_positive)
95.142 + then show "0 \<le> inverse \<parallel>x\<parallel>" by (rule order_less_imp_le)
95.143 + qed
95.144 + also have "\<dots> = c * (\<parallel>x\<parallel> * inverse \<parallel>x\<parallel>)"
95.145 + by (rule real_mult_assoc)
95.146 + also
95.147 + from gt have "\<parallel>x\<parallel> \<noteq> 0" by simp
95.148 + then have "\<parallel>x\<parallel> * inverse \<parallel>x\<parallel> = 1" by simp
95.149 + also have "c * 1 \<le> b" by (simp add: b_def le_maxI1)
95.150 + finally show "y \<le> b" .
95.151 + qed
95.152 + qed
95.153 + then show ?thesis ..
95.154 + qed
95.155 + qed
95.156 + then show ?thesis unfolding fn_norm_def by (rule the_lubI_ex)
95.157 +qed
95.158 +
95.159 +lemma (in normed_vectorspace_with_fn_norm) fn_norm_ub [iff?]:
95.160 + assumes "continuous V norm f"
95.161 + assumes b: "b \<in> B V f"
95.162 + shows "b \<le> \<parallel>f\<parallel>\<hyphen>V"
95.163 +proof -
95.164 + interpret continuous V norm f by fact
95.165 + have "lub (B V f) (\<parallel>f\<parallel>\<hyphen>V)"
95.166 + using `continuous V norm f` by (rule fn_norm_works)
95.167 + from this and b show ?thesis ..
95.168 +qed
95.169 +
95.170 +lemma (in normed_vectorspace_with_fn_norm) fn_norm_leastB:
95.171 + assumes "continuous V norm f"
95.172 + assumes b: "\<And>b. b \<in> B V f \<Longrightarrow> b \<le> y"
95.173 + shows "\<parallel>f\<parallel>\<hyphen>V \<le> y"
95.174 +proof -
95.175 + interpret continuous V norm f by fact
95.176 + have "lub (B V f) (\<parallel>f\<parallel>\<hyphen>V)"
95.177 + using `continuous V norm f` by (rule fn_norm_works)
95.178 + from this and b show ?thesis ..
95.179 +qed
95.180 +
95.181 +text {* The norm of a continuous function is always @{text "\<ge> 0"}. *}
95.182 +
95.183 +lemma (in normed_vectorspace_with_fn_norm) fn_norm_ge_zero [iff]:
95.184 + assumes "continuous V norm f"
95.185 + shows "0 \<le> \<parallel>f\<parallel>\<hyphen>V"
95.186 +proof -
95.187 + interpret continuous V norm f by fact
95.188 + txt {* The function norm is defined as the supremum of @{text B}.
95.189 + So it is @{text "\<ge> 0"} if all elements in @{text B} are @{text "\<ge>
95.190 + 0"}, provided the supremum exists and @{text B} is not empty. *}
95.191 + have "lub (B V f) (\<parallel>f\<parallel>\<hyphen>V)"
95.192 + using `continuous V norm f` by (rule fn_norm_works)
95.193 + moreover have "0 \<in> B V f" ..
95.194 + ultimately show ?thesis ..
95.195 +qed
95.196 +
95.197 +text {*
95.198 + \medskip The fundamental property of function norms is:
95.199 + \begin{center}
95.200 + @{text "\<bar>f x\<bar> \<le> \<parallel>f\<parallel> \<cdot> \<parallel>x\<parallel>"}
95.201 + \end{center}
95.202 +*}
95.203 +
95.204 +lemma (in normed_vectorspace_with_fn_norm) fn_norm_le_cong:
95.205 + assumes "continuous V norm f" "linearform V f"
95.206 + assumes x: "x \<in> V"
95.207 + shows "\<bar>f x\<bar> \<le> \<parallel>f\<parallel>\<hyphen>V * \<parallel>x\<parallel>"
95.208 +proof -
95.209 + interpret continuous V norm f by fact
95.210 + interpret linearform V f .
95.211 + show ?thesis
95.212 + proof cases
95.213 + assume "x = 0"
95.214 + then have "\<bar>f x\<bar> = \<bar>f 0\<bar>" by simp
95.215 + also have "f 0 = 0" by rule unfold_locales
95.216 + also have "\<bar>\<dots>\<bar> = 0" by simp
95.217 + also have a: "0 \<le> \<parallel>f\<parallel>\<hyphen>V"
95.218 + using `continuous V norm f` by (rule fn_norm_ge_zero)
95.219 + from x have "0 \<le> norm x" ..
95.220 + with a have "0 \<le> \<parallel>f\<parallel>\<hyphen>V * \<parallel>x\<parallel>" by (simp add: zero_le_mult_iff)
95.221 + finally show "\<bar>f x\<bar> \<le> \<parallel>f\<parallel>\<hyphen>V * \<parallel>x\<parallel>" .
95.222 + next
95.223 + assume "x \<noteq> 0"
95.224 + with x have neq: "\<parallel>x\<parallel> \<noteq> 0" by simp
95.225 + then have "\<bar>f x\<bar> = (\<bar>f x\<bar> * inverse \<parallel>x\<parallel>) * \<parallel>x\<parallel>" by simp
95.226 + also have "\<dots> \<le> \<parallel>f\<parallel>\<hyphen>V * \<parallel>x\<parallel>"
95.227 + proof (rule mult_right_mono)
95.228 + from x show "0 \<le> \<parallel>x\<parallel>" ..
95.229 + from x and neq have "\<bar>f x\<bar> * inverse \<parallel>x\<parallel> \<in> B V f"
95.230 + by (auto simp add: B_def real_divide_def)
95.231 + with `continuous V norm f` show "\<bar>f x\<bar> * inverse \<parallel>x\<parallel> \<le> \<parallel>f\<parallel>\<hyphen>V"
95.232 + by (rule fn_norm_ub)
95.233 + qed
95.234 + finally show ?thesis .
95.235 + qed
95.236 +qed
95.237 +
95.238 +text {*
95.239 + \medskip The function norm is the least positive real number for
95.240 + which the following inequation holds:
95.241 + \begin{center}
95.242 + @{text "\<bar>f x\<bar> \<le> c \<cdot> \<parallel>x\<parallel>"}
95.243 + \end{center}
95.244 +*}
95.245 +
95.246 +lemma (in normed_vectorspace_with_fn_norm) fn_norm_least [intro?]:
95.247 + assumes "continuous V norm f"
95.248 + assumes ineq: "\<forall>x \<in> V. \<bar>f x\<bar> \<le> c * \<parallel>x\<parallel>" and ge: "0 \<le> c"
95.249 + shows "\<parallel>f\<parallel>\<hyphen>V \<le> c"
95.250 +proof -
95.251 + interpret continuous V norm f by fact
95.252 + show ?thesis
95.253 + proof (rule fn_norm_leastB [folded B_def fn_norm_def])
95.254 + fix b assume b: "b \<in> B V f"
95.255 + show "b \<le> c"
95.256 + proof cases
95.257 + assume "b = 0"
95.258 + with ge show ?thesis by simp
95.259 + next
95.260 + assume "b \<noteq> 0"
95.261 + with b obtain x where b_rep: "b = \<bar>f x\<bar> * inverse \<parallel>x\<parallel>"
95.262 + and x_neq: "x \<noteq> 0" and x: "x \<in> V"
95.263 + by (auto simp add: B_def real_divide_def)
95.264 + note b_rep
95.265 + also have "\<bar>f x\<bar> * inverse \<parallel>x\<parallel> \<le> (c * \<parallel>x\<parallel>) * inverse \<parallel>x\<parallel>"
95.266 + proof (rule mult_right_mono)
95.267 + have "0 < \<parallel>x\<parallel>" using x x_neq ..
95.268 + then show "0 \<le> inverse \<parallel>x\<parallel>" by simp
95.269 + from ineq and x show "\<bar>f x\<bar> \<le> c * \<parallel>x\<parallel>" ..
95.270 + qed
95.271 + also have "\<dots> = c"
95.272 + proof -
95.273 + from x_neq and x have "\<parallel>x\<parallel> \<noteq> 0" by simp
95.274 + then show ?thesis by simp
95.275 + qed
95.276 + finally show ?thesis .
95.277 + qed
95.278 + qed (insert `continuous V norm f`, simp_all add: continuous_def)
95.279 +qed
95.280 +
95.281 +end
96.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
96.2 +++ b/src/HOL/HahnBanach/FunctionOrder.thy Tue Dec 30 11:10:01 2008 +0100
96.3 @@ -0,0 +1,142 @@
96.4 +(* Title: HOL/Real/HahnBanach/FunctionOrder.thy
96.5 + ID: $Id$
96.6 + Author: Gertrud Bauer, TU Munich
96.7 +*)
96.8 +
96.9 +header {* An order on functions *}
96.10 +
96.11 +theory FunctionOrder
96.12 +imports Subspace Linearform
96.13 +begin
96.14 +
96.15 +subsection {* The graph of a function *}
96.16 +
96.17 +text {*
96.18 + We define the \emph{graph} of a (real) function @{text f} with
96.19 + domain @{text F} as the set
96.20 + \begin{center}
96.21 + @{text "{(x, f x). x \<in> F}"}
96.22 + \end{center}
96.23 + So we are modeling partial functions by specifying the domain and
96.24 + the mapping function. We use the term ``function'' also for its
96.25 + graph.
96.26 +*}
96.27 +
96.28 +types 'a graph = "('a \<times> real) set"
96.29 +
96.30 +definition
96.31 + graph :: "'a set \<Rightarrow> ('a \<Rightarrow> real) \<Rightarrow> 'a graph" where
96.32 + "graph F f = {(x, f x) | x. x \<in> F}"
96.33 +
96.34 +lemma graphI [intro]: "x \<in> F \<Longrightarrow> (x, f x) \<in> graph F f"
96.35 + unfolding graph_def by blast
96.36 +
96.37 +lemma graphI2 [intro?]: "x \<in> F \<Longrightarrow> \<exists>t \<in> graph F f. t = (x, f x)"
96.38 + unfolding graph_def by blast
96.39 +
96.40 +lemma graphE [elim?]:
96.41 + "(x, y) \<in> graph F f \<Longrightarrow> (x \<in> F \<Longrightarrow> y = f x \<Longrightarrow> C) \<Longrightarrow> C"
96.42 + unfolding graph_def by blast
96.43 +
96.44 +
96.45 +subsection {* Functions ordered by domain extension *}
96.46 +
96.47 +text {*
96.48 + A function @{text h'} is an extension of @{text h}, iff the graph of
96.49 + @{text h} is a subset of the graph of @{text h'}.
96.50 +*}
96.51 +
96.52 +lemma graph_extI:
96.53 + "(\<And>x. x \<in> H \<Longrightarrow> h x = h' x) \<Longrightarrow> H \<subseteq> H'
96.54 + \<Longrightarrow> graph H h \<subseteq> graph H' h'"
96.55 + unfolding graph_def by blast
96.56 +
96.57 +lemma graph_extD1 [dest?]:
96.58 + "graph H h \<subseteq> graph H' h' \<Longrightarrow> x \<in> H \<Longrightarrow> h x = h' x"
96.59 + unfolding graph_def by blast
96.60 +
96.61 +lemma graph_extD2 [dest?]:
96.62 + "graph H h \<subseteq> graph H' h' \<Longrightarrow> H \<subseteq> H'"
96.63 + unfolding graph_def by blast
96.64 +
96.65 +
96.66 +subsection {* Domain and function of a graph *}
96.67 +
96.68 +text {*
96.69 + The inverse functions to @{text graph} are @{text domain} and @{text
96.70 + funct}.
96.71 +*}
96.72 +
96.73 +definition
96.74 + "domain" :: "'a graph \<Rightarrow> 'a set" where
96.75 + "domain g = {x. \<exists>y. (x, y) \<in> g}"
96.76 +
96.77 +definition
96.78 + funct :: "'a graph \<Rightarrow> ('a \<Rightarrow> real)" where
96.79 + "funct g = (\<lambda>x. (SOME y. (x, y) \<in> g))"
96.80 +
96.81 +text {*
96.82 + The following lemma states that @{text g} is the graph of a function
96.83 + if the relation induced by @{text g} is unique.
96.84 +*}
96.85 +
96.86 +lemma graph_domain_funct:
96.87 + assumes uniq: "\<And>x y z. (x, y) \<in> g \<Longrightarrow> (x, z) \<in> g \<Longrightarrow> z = y"
96.88 + shows "graph (domain g) (funct g) = g"
96.89 + unfolding domain_def funct_def graph_def
96.90 +proof auto (* FIXME !? *)
96.91 + fix a b assume g: "(a, b) \<in> g"
96.92 + from g show "(a, SOME y. (a, y) \<in> g) \<in> g" by (rule someI2)
96.93 + from g show "\<exists>y. (a, y) \<in> g" ..
96.94 + from g show "b = (SOME y. (a, y) \<in> g)"
96.95 + proof (rule some_equality [symmetric])
96.96 + fix y assume "(a, y) \<in> g"
96.97 + with g show "y = b" by (rule uniq)
96.98 + qed
96.99 +qed
96.100 +
96.101 +
96.102 +subsection {* Norm-preserving extensions of a function *}
96.103 +
96.104 +text {*
96.105 + Given a linear form @{text f} on the space @{text F} and a seminorm
96.106 + @{text p} on @{text E}. The set of all linear extensions of @{text
96.107 + f}, to superspaces @{text H} of @{text F}, which are bounded by
96.108 + @{text p}, is defined as follows.
96.109 +*}
96.110 +
96.111 +definition
96.112 + norm_pres_extensions ::
96.113 + "'a::{plus, minus, uminus, zero} set \<Rightarrow> ('a \<Rightarrow> real) \<Rightarrow> 'a set \<Rightarrow> ('a \<Rightarrow> real)
96.114 + \<Rightarrow> 'a graph set" where
96.115 + "norm_pres_extensions E p F f
96.116 + = {g. \<exists>H h. g = graph H h
96.117 + \<and> linearform H h
96.118 + \<and> H \<unlhd> E
96.119 + \<and> F \<unlhd> H
96.120 + \<and> graph F f \<subseteq> graph H h
96.121 + \<and> (\<forall>x \<in> H. h x \<le> p x)}"
96.122 +
96.123 +lemma norm_pres_extensionE [elim]:
96.124 + "g \<in> norm_pres_extensions E p F f
96.125 + \<Longrightarrow> (\<And>H h. g = graph H h \<Longrightarrow> linearform H h
96.126 + \<Longrightarrow> H \<unlhd> E \<Longrightarrow> F \<unlhd> H \<Longrightarrow> graph F f \<subseteq> graph H h
96.127 + \<Longrightarrow> \<forall>x \<in> H. h x \<le> p x \<Longrightarrow> C) \<Longrightarrow> C"
96.128 + unfolding norm_pres_extensions_def by blast
96.129 +
96.130 +lemma norm_pres_extensionI2 [intro]:
96.131 + "linearform H h \<Longrightarrow> H \<unlhd> E \<Longrightarrow> F \<unlhd> H
96.132 + \<Longrightarrow> graph F f \<subseteq> graph H h \<Longrightarrow> \<forall>x \<in> H. h x \<le> p x
96.133 + \<Longrightarrow> graph H h \<in> norm_pres_extensions E p F f"
96.134 + unfolding norm_pres_extensions_def by blast
96.135 +
96.136 +lemma norm_pres_extensionI: (* FIXME ? *)
96.137 + "\<exists>H h. g = graph H h
96.138 + \<and> linearform H h
96.139 + \<and> H \<unlhd> E
96.140 + \<and> F \<unlhd> H
96.141 + \<and> graph F f \<subseteq> graph H h
96.142 + \<and> (\<forall>x \<in> H. h x \<le> p x) \<Longrightarrow> g \<in> norm_pres_extensions E p F f"
96.143 + unfolding norm_pres_extensions_def by blast
96.144 +
96.145 +end
97.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
97.2 +++ b/src/HOL/HahnBanach/HahnBanach.thy Tue Dec 30 11:10:01 2008 +0100
97.3 @@ -0,0 +1,509 @@
97.4 +(* Title: HOL/Real/HahnBanach/HahnBanach.thy
97.5 + Author: Gertrud Bauer, TU Munich
97.6 +*)
97.7 +
97.8 +header {* The Hahn-Banach Theorem *}
97.9 +
97.10 +theory HahnBanach
97.11 +imports HahnBanachLemmas
97.12 +begin
97.13 +
97.14 +text {*
97.15 + We present the proof of two different versions of the Hahn-Banach
97.16 + Theorem, closely following \cite[\S36]{Heuser:1986}.
97.17 +*}
97.18 +
97.19 +subsection {* The Hahn-Banach Theorem for vector spaces *}
97.20 +
97.21 +text {*
97.22 + \textbf{Hahn-Banach Theorem.} Let @{text F} be a subspace of a real
97.23 + vector space @{text E}, let @{text p} be a semi-norm on @{text E},
97.24 + and @{text f} be a linear form defined on @{text F} such that @{text
97.25 + f} is bounded by @{text p}, i.e. @{text "\<forall>x \<in> F. f x \<le> p x"}. Then
97.26 + @{text f} can be extended to a linear form @{text h} on @{text E}
97.27 + such that @{text h} is norm-preserving, i.e. @{text h} is also
97.28 + bounded by @{text p}.
97.29 +
97.30 + \bigskip
97.31 + \textbf{Proof Sketch.}
97.32 + \begin{enumerate}
97.33 +
97.34 + \item Define @{text M} as the set of norm-preserving extensions of
97.35 + @{text f} to subspaces of @{text E}. The linear forms in @{text M}
97.36 + are ordered by domain extension.
97.37 +
97.38 + \item We show that every non-empty chain in @{text M} has an upper
97.39 + bound in @{text M}.
97.40 +
97.41 + \item With Zorn's Lemma we conclude that there is a maximal function
97.42 + @{text g} in @{text M}.
97.43 +
97.44 + \item The domain @{text H} of @{text g} is the whole space @{text
97.45 + E}, as shown by classical contradiction:
97.46 +
97.47 + \begin{itemize}
97.48 +
97.49 + \item Assuming @{text g} is not defined on whole @{text E}, it can
97.50 + still be extended in a norm-preserving way to a super-space @{text
97.51 + H'} of @{text H}.
97.52 +
97.53 + \item Thus @{text g} can not be maximal. Contradiction!
97.54 +
97.55 + \end{itemize}
97.56 + \end{enumerate}
97.57 +*}
97.58 +
97.59 +theorem HahnBanach:
97.60 + assumes E: "vectorspace E" and "subspace F E"
97.61 + and "seminorm E p" and "linearform F f"
97.62 + assumes fp: "\<forall>x \<in> F. f x \<le> p x"
97.63 + shows "\<exists>h. linearform E h \<and> (\<forall>x \<in> F. h x = f x) \<and> (\<forall>x \<in> E. h x \<le> p x)"
97.64 + -- {* Let @{text E} be a vector space, @{text F} a subspace of @{text E}, @{text p} a seminorm on @{text E}, *}
97.65 + -- {* and @{text f} a linear form on @{text F} such that @{text f} is bounded by @{text p}, *}
97.66 + -- {* then @{text f} can be extended to a linear form @{text h} on @{text E} in a norm-preserving way. \skp *}
97.67 +proof -
97.68 + interpret vectorspace E by fact
97.69 + interpret subspace F E by fact
97.70 + interpret seminorm E p by fact
97.71 + interpret linearform F f by fact
97.72 + def M \<equiv> "norm_pres_extensions E p F f"
97.73 + then have M: "M = \<dots>" by (simp only:)
97.74 + from E have F: "vectorspace F" ..
97.75 + note FE = `F \<unlhd> E`
97.76 + {
97.77 + fix c assume cM: "c \<in> chain M" and ex: "\<exists>x. x \<in> c"
97.78 + have "\<Union>c \<in> M"
97.79 + -- {* Show that every non-empty chain @{text c} of @{text M} has an upper bound in @{text M}: *}
97.80 + -- {* @{text "\<Union>c"} is greater than any element of the chain @{text c}, so it suffices to show @{text "\<Union>c \<in> M"}. *}
97.81 + unfolding M_def
97.82 + proof (rule norm_pres_extensionI)
97.83 + let ?H = "domain (\<Union>c)"
97.84 + let ?h = "funct (\<Union>c)"
97.85 +
97.86 + have a: "graph ?H ?h = \<Union>c"
97.87 + proof (rule graph_domain_funct)
97.88 + fix x y z assume "(x, y) \<in> \<Union>c" and "(x, z) \<in> \<Union>c"
97.89 + with M_def cM show "z = y" by (rule sup_definite)
97.90 + qed
97.91 + moreover from M cM a have "linearform ?H ?h"
97.92 + by (rule sup_lf)
97.93 + moreover from a M cM ex FE E have "?H \<unlhd> E"
97.94 + by (rule sup_subE)
97.95 + moreover from a M cM ex FE have "F \<unlhd> ?H"
97.96 + by (rule sup_supF)
97.97 + moreover from a M cM ex have "graph F f \<subseteq> graph ?H ?h"
97.98 + by (rule sup_ext)
97.99 + moreover from a M cM have "\<forall>x \<in> ?H. ?h x \<le> p x"
97.100 + by (rule sup_norm_pres)
97.101 + ultimately show "\<exists>H h. \<Union>c = graph H h
97.102 + \<and> linearform H h
97.103 + \<and> H \<unlhd> E
97.104 + \<and> F \<unlhd> H
97.105 + \<and> graph F f \<subseteq> graph H h
97.106 + \<and> (\<forall>x \<in> H. h x \<le> p x)" by blast
97.107 + qed
97.108 + }
97.109 + then have "\<exists>g \<in> M. \<forall>x \<in> M. g \<subseteq> x \<longrightarrow> g = x"
97.110 + -- {* With Zorn's Lemma we can conclude that there is a maximal element in @{text M}. \skp *}
97.111 + proof (rule Zorn's_Lemma)
97.112 + -- {* We show that @{text M} is non-empty: *}
97.113 + show "graph F f \<in> M"
97.114 + unfolding M_def
97.115 + proof (rule norm_pres_extensionI2)
97.116 + show "linearform F f" by fact
97.117 + show "F \<unlhd> E" by fact
97.118 + from F show "F \<unlhd> F" by (rule vectorspace.subspace_refl)
97.119 + show "graph F f \<subseteq> graph F f" ..
97.120 + show "\<forall>x\<in>F. f x \<le> p x" by fact
97.121 + qed
97.122 + qed
97.123 + then obtain g where gM: "g \<in> M" and gx: "\<forall>x \<in> M. g \<subseteq> x \<longrightarrow> g = x"
97.124 + by blast
97.125 + from gM obtain H h where
97.126 + g_rep: "g = graph H h"
97.127 + and linearform: "linearform H h"
97.128 + and HE: "H \<unlhd> E" and FH: "F \<unlhd> H"
97.129 + and graphs: "graph F f \<subseteq> graph H h"
97.130 + and hp: "\<forall>x \<in> H. h x \<le> p x" unfolding M_def ..
97.131 + -- {* @{text g} is a norm-preserving extension of @{text f}, in other words: *}
97.132 + -- {* @{text g} is the graph of some linear form @{text h} defined on a subspace @{text H} of @{text E}, *}
97.133 + -- {* and @{text h} is an extension of @{text f} that is again bounded by @{text p}. \skp *}
97.134 + from HE E have H: "vectorspace H"
97.135 + by (rule subspace.vectorspace)
97.136 +
97.137 + have HE_eq: "H = E"
97.138 + -- {* We show that @{text h} is defined on whole @{text E} by classical contradiction. \skp *}
97.139 + proof (rule classical)
97.140 + assume neq: "H \<noteq> E"
97.141 + -- {* Assume @{text h} is not defined on whole @{text E}. Then show that @{text h} can be extended *}
97.142 + -- {* in a norm-preserving way to a function @{text h'} with the graph @{text g'}. \skp *}
97.143 + have "\<exists>g' \<in> M. g \<subseteq> g' \<and> g \<noteq> g'"
97.144 + proof -
97.145 + from HE have "H \<subseteq> E" ..
97.146 + with neq obtain x' where x'E: "x' \<in> E" and "x' \<notin> H" by blast
97.147 + obtain x': "x' \<noteq> 0"
97.148 + proof
97.149 + show "x' \<noteq> 0"
97.150 + proof
97.151 + assume "x' = 0"
97.152 + with H have "x' \<in> H" by (simp only: vectorspace.zero)
97.153 + with `x' \<notin> H` show False by contradiction
97.154 + qed
97.155 + qed
97.156 +
97.157 + def H' \<equiv> "H + lin x'"
97.158 + -- {* Define @{text H'} as the direct sum of @{text H} and the linear closure of @{text x'}. \skp *}
97.159 + have HH': "H \<unlhd> H'"
97.160 + proof (unfold H'_def)
97.161 + from x'E have "vectorspace (lin x')" ..
97.162 + with H show "H \<unlhd> H + lin x'" ..
97.163 + qed
97.164 +
97.165 + obtain xi where
97.166 + xi: "\<forall>y \<in> H. - p (y + x') - h y \<le> xi
97.167 + \<and> xi \<le> p (y + x') - h y"
97.168 + -- {* Pick a real number @{text \<xi>} that fulfills certain inequations; this will *}
97.169 + -- {* be used to establish that @{text h'} is a norm-preserving extension of @{text h}.
97.170 + \label{ex-xi-use}\skp *}
97.171 + proof -
97.172 + from H have "\<exists>xi. \<forall>y \<in> H. - p (y + x') - h y \<le> xi
97.173 + \<and> xi \<le> p (y + x') - h y"
97.174 + proof (rule ex_xi)
97.175 + fix u v assume u: "u \<in> H" and v: "v \<in> H"
97.176 + with HE have uE: "u \<in> E" and vE: "v \<in> E" by auto
97.177 + from H u v linearform have "h v - h u = h (v - u)"
97.178 + by (simp add: linearform.diff)
97.179 + also from hp and H u v have "\<dots> \<le> p (v - u)"
97.180 + by (simp only: vectorspace.diff_closed)
97.181 + also from x'E uE vE have "v - u = x' + - x' + v + - u"
97.182 + by (simp add: diff_eq1)
97.183 + also from x'E uE vE have "\<dots> = v + x' + - (u + x')"
97.184 + by (simp add: add_ac)
97.185 + also from x'E uE vE have "\<dots> = (v + x') - (u + x')"
97.186 + by (simp add: diff_eq1)
97.187 + also from x'E uE vE E have "p \<dots> \<le> p (v + x') + p (u + x')"
97.188 + by (simp add: diff_subadditive)
97.189 + finally have "h v - h u \<le> p (v + x') + p (u + x')" .
97.190 + then show "- p (u + x') - h u \<le> p (v + x') - h v" by simp
97.191 + qed
97.192 + then show thesis by (blast intro: that)
97.193 + qed
97.194 +
97.195 + def h' \<equiv> "\<lambda>x. let (y, a) =
97.196 + SOME (y, a). x = y + a \<cdot> x' \<and> y \<in> H in h y + a * xi"
97.197 + -- {* Define the extension @{text h'} of @{text h} to @{text H'} using @{text \<xi>}. \skp *}
97.198 +
97.199 + have "g \<subseteq> graph H' h' \<and> g \<noteq> graph H' h'"
97.200 + -- {* @{text h'} is an extension of @{text h} \dots \skp *}
97.201 + proof
97.202 + show "g \<subseteq> graph H' h'"
97.203 + proof -
97.204 + have "graph H h \<subseteq> graph H' h'"
97.205 + proof (rule graph_extI)
97.206 + fix t assume t: "t \<in> H"
97.207 + from E HE t have "(SOME (y, a). t = y + a \<cdot> x' \<and> y \<in> H) = (t, 0)"
97.208 + using `x' \<notin> H` `x' \<in> E` `x' \<noteq> 0` by (rule decomp_H'_H)
97.209 + with h'_def show "h t = h' t" by (simp add: Let_def)
97.210 + next
97.211 + from HH' show "H \<subseteq> H'" ..
97.212 + qed
97.213 + with g_rep show ?thesis by (simp only:)
97.214 + qed
97.215 +
97.216 + show "g \<noteq> graph H' h'"
97.217 + proof -
97.218 + have "graph H h \<noteq> graph H' h'"
97.219 + proof
97.220 + assume eq: "graph H h = graph H' h'"
97.221 + have "x' \<in> H'"
97.222 + unfolding H'_def
97.223 + proof
97.224 + from H show "0 \<in> H" by (rule vectorspace.zero)
97.225 + from x'E show "x' \<in> lin x'" by (rule x_lin_x)
97.226 + from x'E show "x' = 0 + x'" by simp
97.227 + qed
97.228 + then have "(x', h' x') \<in> graph H' h'" ..
97.229 + with eq have "(x', h' x') \<in> graph H h" by (simp only:)
97.230 + then have "x' \<in> H" ..
97.231 + with `x' \<notin> H` show False by contradiction
97.232 + qed
97.233 + with g_rep show ?thesis by simp
97.234 + qed
97.235 + qed
97.236 + moreover have "graph H' h' \<in> M"
97.237 + -- {* and @{text h'} is norm-preserving. \skp *}
97.238 + proof (unfold M_def)
97.239 + show "graph H' h' \<in> norm_pres_extensions E p F f"
97.240 + proof (rule norm_pres_extensionI2)
97.241 + show "linearform H' h'"
97.242 + using h'_def H'_def HE linearform `x' \<notin> H` `x' \<in> E` `x' \<noteq> 0` E
97.243 + by (rule h'_lf)
97.244 + show "H' \<unlhd> E"
97.245 + unfolding H'_def
97.246 + proof
97.247 + show "H \<unlhd> E" by fact
97.248 + show "vectorspace E" by fact
97.249 + from x'E show "lin x' \<unlhd> E" ..
97.250 + qed
97.251 + from H `F \<unlhd> H` HH' show FH': "F \<unlhd> H'"
97.252 + by (rule vectorspace.subspace_trans)
97.253 + show "graph F f \<subseteq> graph H' h'"
97.254 + proof (rule graph_extI)
97.255 + fix x assume x: "x \<in> F"
97.256 + with graphs have "f x = h x" ..
97.257 + also have "\<dots> = h x + 0 * xi" by simp
97.258 + also have "\<dots> = (let (y, a) = (x, 0) in h y + a * xi)"
97.259 + by (simp add: Let_def)
97.260 + also have "(x, 0) =
97.261 + (SOME (y, a). x = y + a \<cdot> x' \<and> y \<in> H)"
97.262 + using E HE
97.263 + proof (rule decomp_H'_H [symmetric])
97.264 + from FH x show "x \<in> H" ..
97.265 + from x' show "x' \<noteq> 0" .
97.266 + show "x' \<notin> H" by fact
97.267 + show "x' \<in> E" by fact
97.268 + qed
97.269 + also have
97.270 + "(let (y, a) = (SOME (y, a). x = y + a \<cdot> x' \<and> y \<in> H)
97.271 + in h y + a * xi) = h' x" by (simp only: h'_def)
97.272 + finally show "f x = h' x" .
97.273 + next
97.274 + from FH' show "F \<subseteq> H'" ..
97.275 + qed
97.276 + show "\<forall>x \<in> H'. h' x \<le> p x"
97.277 + using h'_def H'_def `x' \<notin> H` `x' \<in> E` `x' \<noteq> 0` E HE
97.278 + `seminorm E p` linearform and hp xi
97.279 + by (rule h'_norm_pres)
97.280 + qed
97.281 + qed
97.282 + ultimately show ?thesis ..
97.283 + qed
97.284 + then have "\<not> (\<forall>x \<in> M. g \<subseteq> x \<longrightarrow> g = x)" by simp
97.285 + -- {* So the graph @{text g} of @{text h} cannot be maximal. Contradiction! \skp *}
97.286 + with gx show "H = E" by contradiction
97.287 + qed
97.288 +
97.289 + from HE_eq and linearform have "linearform E h"
97.290 + by (simp only:)
97.291 + moreover have "\<forall>x \<in> F. h x = f x"
97.292 + proof
97.293 + fix x assume "x \<in> F"
97.294 + with graphs have "f x = h x" ..
97.295 + then show "h x = f x" ..
97.296 + qed
97.297 + moreover from HE_eq and hp have "\<forall>x \<in> E. h x \<le> p x"
97.298 + by (simp only:)
97.299 + ultimately show ?thesis by blast
97.300 +qed
97.301 +
97.302 +
97.303 +subsection {* Alternative formulation *}
97.304 +
97.305 +text {*
97.306 + The following alternative formulation of the Hahn-Banach
97.307 + Theorem\label{abs-HahnBanach} uses the fact that for a real linear
97.308 + form @{text f} and a seminorm @{text p} the following inequations
97.309 + are equivalent:\footnote{This was shown in lemma @{thm [source]
97.310 + abs_ineq_iff} (see page \pageref{abs-ineq-iff}).}
97.311 + \begin{center}
97.312 + \begin{tabular}{lll}
97.313 + @{text "\<forall>x \<in> H. \<bar>h x\<bar> \<le> p x"} & and &
97.314 + @{text "\<forall>x \<in> H. h x \<le> p x"} \\
97.315 + \end{tabular}
97.316 + \end{center}
97.317 +*}
97.318 +
97.319 +theorem abs_HahnBanach:
97.320 + assumes E: "vectorspace E" and FE: "subspace F E"
97.321 + and lf: "linearform F f" and sn: "seminorm E p"
97.322 + assumes fp: "\<forall>x \<in> F. \<bar>f x\<bar> \<le> p x"
97.323 + shows "\<exists>g. linearform E g
97.324 + \<and> (\<forall>x \<in> F. g x = f x)
97.325 + \<and> (\<forall>x \<in> E. \<bar>g x\<bar> \<le> p x)"
97.326 +proof -
97.327 + interpret vectorspace E by fact
97.328 + interpret subspace F E by fact
97.329 + interpret linearform F f by fact
97.330 + interpret seminorm E p by fact
97.331 + have "\<exists>g. linearform E g \<and> (\<forall>x \<in> F. g x = f x) \<and> (\<forall>x \<in> E. g x \<le> p x)"
97.332 + using E FE sn lf
97.333 + proof (rule HahnBanach)
97.334 + show "\<forall>x \<in> F. f x \<le> p x"
97.335 + using FE E sn lf and fp by (rule abs_ineq_iff [THEN iffD1])
97.336 + qed
97.337 + then obtain g where lg: "linearform E g" and *: "\<forall>x \<in> F. g x = f x"
97.338 + and **: "\<forall>x \<in> E. g x \<le> p x" by blast
97.339 + have "\<forall>x \<in> E. \<bar>g x\<bar> \<le> p x"
97.340 + using _ E sn lg **
97.341 + proof (rule abs_ineq_iff [THEN iffD2])
97.342 + show "E \<unlhd> E" ..
97.343 + qed
97.344 + with lg * show ?thesis by blast
97.345 +qed
97.346 +
97.347 +
97.348 +subsection {* The Hahn-Banach Theorem for normed spaces *}
97.349 +
97.350 +text {*
97.351 + Every continuous linear form @{text f} on a subspace @{text F} of a
97.352 + norm space @{text E}, can be extended to a continuous linear form
97.353 + @{text g} on @{text E} such that @{text "\<parallel>f\<parallel> = \<parallel>g\<parallel>"}.
97.354 +*}
97.355 +
97.356 +theorem norm_HahnBanach:
97.357 + fixes V and norm ("\<parallel>_\<parallel>")
97.358 + fixes B defines "\<And>V f. B V f \<equiv> {0} \<union> {\<bar>f x\<bar> / \<parallel>x\<parallel> | x. x \<noteq> 0 \<and> x \<in> V}"
97.359 + fixes fn_norm ("\<parallel>_\<parallel>\<hyphen>_" [0, 1000] 999)
97.360 + defines "\<And>V f. \<parallel>f\<parallel>\<hyphen>V \<equiv> \<Squnion>(B V f)"
97.361 + assumes E_norm: "normed_vectorspace E norm" and FE: "subspace F E"
97.362 + and linearform: "linearform F f" and "continuous F norm f"
97.363 + shows "\<exists>g. linearform E g
97.364 + \<and> continuous E norm g
97.365 + \<and> (\<forall>x \<in> F. g x = f x)
97.366 + \<and> \<parallel>g\<parallel>\<hyphen>E = \<parallel>f\<parallel>\<hyphen>F"
97.367 +proof -
97.368 + interpret normed_vectorspace E norm by fact
97.369 + interpret normed_vectorspace_with_fn_norm E norm B fn_norm
97.370 + by (auto simp: B_def fn_norm_def) intro_locales
97.371 + interpret subspace F E by fact
97.372 + interpret linearform F f by fact
97.373 + interpret continuous F norm f by fact
97.374 + have E: "vectorspace E" by intro_locales
97.375 + have F: "vectorspace F" by rule intro_locales
97.376 + have F_norm: "normed_vectorspace F norm"
97.377 + using FE E_norm by (rule subspace_normed_vs)
97.378 + have ge_zero: "0 \<le> \<parallel>f\<parallel>\<hyphen>F"
97.379 + by (rule normed_vectorspace_with_fn_norm.fn_norm_ge_zero
97.380 + [OF normed_vectorspace_with_fn_norm.intro,
97.381 + OF F_norm `continuous F norm f` , folded B_def fn_norm_def])
97.382 + txt {* We define a function @{text p} on @{text E} as follows:
97.383 + @{text "p x = \<parallel>f\<parallel> \<cdot> \<parallel>x\<parallel>"} *}
97.384 + def p \<equiv> "\<lambda>x. \<parallel>f\<parallel>\<hyphen>F * \<parallel>x\<parallel>"
97.385 +
97.386 + txt {* @{text p} is a seminorm on @{text E}: *}
97.387 + have q: "seminorm E p"
97.388 + proof
97.389 + fix x y a assume x: "x \<in> E" and y: "y \<in> E"
97.390 +
97.391 + txt {* @{text p} is positive definite: *}
97.392 + have "0 \<le> \<parallel>f\<parallel>\<hyphen>F" by (rule ge_zero)
97.393 + moreover from x have "0 \<le> \<parallel>x\<parallel>" ..
97.394 + ultimately show "0 \<le> p x"
97.395 + by (simp add: p_def zero_le_mult_iff)
97.396 +
97.397 + txt {* @{text p} is absolutely homogenous: *}
97.398 +
97.399 + show "p (a \<cdot> x) = \<bar>a\<bar> * p x"
97.400 + proof -
97.401 + have "p (a \<cdot> x) = \<parallel>f\<parallel>\<hyphen>F * \<parallel>a \<cdot> x\<parallel>" by (simp only: p_def)
97.402 + also from x have "\<parallel>a \<cdot> x\<parallel> = \<bar>a\<bar> * \<parallel>x\<parallel>" by (rule abs_homogenous)
97.403 + also have "\<parallel>f\<parallel>\<hyphen>F * (\<bar>a\<bar> * \<parallel>x\<parallel>) = \<bar>a\<bar> * (\<parallel>f\<parallel>\<hyphen>F * \<parallel>x\<parallel>)" by simp
97.404 + also have "\<dots> = \<bar>a\<bar> * p x" by (simp only: p_def)
97.405 + finally show ?thesis .
97.406 + qed
97.407 +
97.408 + txt {* Furthermore, @{text p} is subadditive: *}
97.409 +
97.410 + show "p (x + y) \<le> p x + p y"
97.411 + proof -
97.412 + have "p (x + y) = \<parallel>f\<parallel>\<hyphen>F * \<parallel>x + y\<parallel>" by (simp only: p_def)
97.413 + also have a: "0 \<le> \<parallel>f\<parallel>\<hyphen>F" by (rule ge_zero)
97.414 + from x y have "\<parallel>x + y\<parallel> \<le> \<parallel>x\<parallel> + \<parallel>y\<parallel>" ..
97.415 + with a have " \<parallel>f\<parallel>\<hyphen>F * \<parallel>x + y\<parallel> \<le> \<parallel>f\<parallel>\<hyphen>F * (\<parallel>x\<parallel> + \<parallel>y\<parallel>)"
97.416 + by (simp add: mult_left_mono)
97.417 + also have "\<dots> = \<parallel>f\<parallel>\<hyphen>F * \<parallel>x\<parallel> + \<parallel>f\<parallel>\<hyphen>F * \<parallel>y\<parallel>" by (simp only: right_distrib)
97.418 + also have "\<dots> = p x + p y" by (simp only: p_def)
97.419 + finally show ?thesis .
97.420 + qed
97.421 + qed
97.422 +
97.423 + txt {* @{text f} is bounded by @{text p}. *}
97.424 +
97.425 + have "\<forall>x \<in> F. \<bar>f x\<bar> \<le> p x"
97.426 + proof
97.427 + fix x assume "x \<in> F"
97.428 + with `continuous F norm f` and linearform
97.429 + show "\<bar>f x\<bar> \<le> p x"
97.430 + unfolding p_def by (rule normed_vectorspace_with_fn_norm.fn_norm_le_cong
97.431 + [OF normed_vectorspace_with_fn_norm.intro,
97.432 + OF F_norm, folded B_def fn_norm_def])
97.433 + qed
97.434 +
97.435 + txt {* Using the fact that @{text p} is a seminorm and @{text f} is bounded
97.436 + by @{text p} we can apply the Hahn-Banach Theorem for real vector
97.437 + spaces. So @{text f} can be extended in a norm-preserving way to
97.438 + some function @{text g} on the whole vector space @{text E}. *}
97.439 +
97.440 + with E FE linearform q obtain g where
97.441 + linearformE: "linearform E g"
97.442 + and a: "\<forall>x \<in> F. g x = f x"
97.443 + and b: "\<forall>x \<in> E. \<bar>g x\<bar> \<le> p x"
97.444 + by (rule abs_HahnBanach [elim_format]) iprover
97.445 +
97.446 + txt {* We furthermore have to show that @{text g} is also continuous: *}
97.447 +
97.448 + have g_cont: "continuous E norm g" using linearformE
97.449 + proof
97.450 + fix x assume "x \<in> E"
97.451 + with b show "\<bar>g x\<bar> \<le> \<parallel>f\<parallel>\<hyphen>F * \<parallel>x\<parallel>"
97.452 + by (simp only: p_def)
97.453 + qed
97.454 +
97.455 + txt {* To complete the proof, we show that @{text "\<parallel>g\<parallel> = \<parallel>f\<parallel>"}. *}
97.456 +
97.457 + have "\<parallel>g\<parallel>\<hyphen>E = \<parallel>f\<parallel>\<hyphen>F"
97.458 + proof (rule order_antisym)
97.459 + txt {*
97.460 + First we show @{text "\<parallel>g\<parallel> \<le> \<parallel>f\<parallel>"}. The function norm @{text
97.461 + "\<parallel>g\<parallel>"} is defined as the smallest @{text "c \<in> \<real>"} such that
97.462 + \begin{center}
97.463 + \begin{tabular}{l}
97.464 + @{text "\<forall>x \<in> E. \<bar>g x\<bar> \<le> c \<cdot> \<parallel>x\<parallel>"}
97.465 + \end{tabular}
97.466 + \end{center}
97.467 + \noindent Furthermore holds
97.468 + \begin{center}
97.469 + \begin{tabular}{l}
97.470 + @{text "\<forall>x \<in> E. \<bar>g x\<bar> \<le> \<parallel>f\<parallel> \<cdot> \<parallel>x\<parallel>"}
97.471 + \end{tabular}
97.472 + \end{center}
97.473 + *}
97.474 +
97.475 + have "\<forall>x \<in> E. \<bar>g x\<bar> \<le> \<parallel>f\<parallel>\<hyphen>F * \<parallel>x\<parallel>"
97.476 + proof
97.477 + fix x assume "x \<in> E"
97.478 + with b show "\<bar>g x\<bar> \<le> \<parallel>f\<parallel>\<hyphen>F * \<parallel>x\<parallel>"
97.479 + by (simp only: p_def)
97.480 + qed
97.481 + from g_cont this ge_zero
97.482 + show "\<parallel>g\<parallel>\<hyphen>E \<le> \<parallel>f\<parallel>\<hyphen>F"
97.483 + by (rule fn_norm_least [of g, folded B_def fn_norm_def])
97.484 +
97.485 + txt {* The other direction is achieved by a similar argument. *}
97.486 +
97.487 + show "\<parallel>f\<parallel>\<hyphen>F \<le> \<parallel>g\<parallel>\<hyphen>E"
97.488 + proof (rule normed_vectorspace_with_fn_norm.fn_norm_least
97.489 + [OF normed_vectorspace_with_fn_norm.intro,
97.490 + OF F_norm, folded B_def fn_norm_def])
97.491 + show "\<forall>x \<in> F. \<bar>f x\<bar> \<le> \<parallel>g\<parallel>\<hyphen>E * \<parallel>x\<parallel>"
97.492 + proof
97.493 + fix x assume x: "x \<in> F"
97.494 + from a x have "g x = f x" ..
97.495 + then have "\<bar>f x\<bar> = \<bar>g x\<bar>" by (simp only:)
97.496 + also from g_cont
97.497 + have "\<dots> \<le> \<parallel>g\<parallel>\<hyphen>E * \<parallel>x\<parallel>"
97.498 + proof (rule fn_norm_le_cong [of g, folded B_def fn_norm_def])
97.499 + from FE x show "x \<in> E" ..
97.500 + qed
97.501 + finally show "\<bar>f x\<bar> \<le> \<parallel>g\<parallel>\<hyphen>E * \<parallel>x\<parallel>" .
97.502 + qed
97.503 + show "0 \<le> \<parallel>g\<parallel>\<hyphen>E"
97.504 + using g_cont
97.505 + by (rule fn_norm_ge_zero [of g, folded B_def fn_norm_def])
97.506 + show "continuous F norm f" by fact
97.507 + qed
97.508 + qed
97.509 + with linearformE a g_cont show ?thesis by blast
97.510 +qed
97.511 +
97.512 +end
98.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
98.2 +++ b/src/HOL/HahnBanach/HahnBanachExtLemmas.thy Tue Dec 30 11:10:01 2008 +0100
98.3 @@ -0,0 +1,280 @@
98.4 +(* Title: HOL/Real/HahnBanach/HahnBanachExtLemmas.thy
98.5 + Author: Gertrud Bauer, TU Munich
98.6 +*)
98.7 +
98.8 +header {* Extending non-maximal functions *}
98.9 +
98.10 +theory HahnBanachExtLemmas
98.11 +imports FunctionNorm
98.12 +begin
98.13 +
98.14 +text {*
98.15 + In this section the following context is presumed. Let @{text E} be
98.16 + a real vector space with a seminorm @{text q} on @{text E}. @{text
98.17 + F} is a subspace of @{text E} and @{text f} a linear function on
98.18 + @{text F}. We consider a subspace @{text H} of @{text E} that is a
98.19 + superspace of @{text F} and a linear form @{text h} on @{text
98.20 + H}. @{text H} is a not equal to @{text E} and @{text "x\<^sub>0"} is
98.21 + an element in @{text "E - H"}. @{text H} is extended to the direct
98.22 + sum @{text "H' = H + lin x\<^sub>0"}, so for any @{text "x \<in> H'"}
98.23 + the decomposition of @{text "x = y + a \<cdot> x"} with @{text "y \<in> H"} is
98.24 + unique. @{text h'} is defined on @{text H'} by @{text "h' x = h y +
98.25 + a \<cdot> \<xi>"} for a certain @{text \<xi>}.
98.26 +
98.27 + Subsequently we show some properties of this extension @{text h'} of
98.28 + @{text h}.
98.29 +
98.30 + \medskip This lemma will be used to show the existence of a linear
98.31 + extension of @{text f} (see page \pageref{ex-xi-use}). It is a
98.32 + consequence of the completeness of @{text \<real>}. To show
98.33 + \begin{center}
98.34 + \begin{tabular}{l}
98.35 + @{text "\<exists>\<xi>. \<forall>y \<in> F. a y \<le> \<xi> \<and> \<xi> \<le> b y"}
98.36 + \end{tabular}
98.37 + \end{center}
98.38 + \noindent it suffices to show that
98.39 + \begin{center}
98.40 + \begin{tabular}{l}
98.41 + @{text "\<forall>u \<in> F. \<forall>v \<in> F. a u \<le> b v"}
98.42 + \end{tabular}
98.43 + \end{center}
98.44 +*}
98.45 +
98.46 +lemma ex_xi:
98.47 + assumes "vectorspace F"
98.48 + assumes r: "\<And>u v. u \<in> F \<Longrightarrow> v \<in> F \<Longrightarrow> a u \<le> b v"
98.49 + shows "\<exists>xi::real. \<forall>y \<in> F. a y \<le> xi \<and> xi \<le> b y"
98.50 +proof -
98.51 + interpret vectorspace F by fact
98.52 + txt {* From the completeness of the reals follows:
98.53 + The set @{text "S = {a u. u \<in> F}"} has a supremum, if it is
98.54 + non-empty and has an upper bound. *}
98.55 +
98.56 + let ?S = "{a u | u. u \<in> F}"
98.57 + have "\<exists>xi. lub ?S xi"
98.58 + proof (rule real_complete)
98.59 + have "a 0 \<in> ?S" by blast
98.60 + then show "\<exists>X. X \<in> ?S" ..
98.61 + have "\<forall>y \<in> ?S. y \<le> b 0"
98.62 + proof
98.63 + fix y assume y: "y \<in> ?S"
98.64 + then obtain u where u: "u \<in> F" and y: "y = a u" by blast
98.65 + from u and zero have "a u \<le> b 0" by (rule r)
98.66 + with y show "y \<le> b 0" by (simp only:)
98.67 + qed
98.68 + then show "\<exists>u. \<forall>y \<in> ?S. y \<le> u" ..
98.69 + qed
98.70 + then obtain xi where xi: "lub ?S xi" ..
98.71 + {
98.72 + fix y assume "y \<in> F"
98.73 + then have "a y \<in> ?S" by blast
98.74 + with xi have "a y \<le> xi" by (rule lub.upper)
98.75 + } moreover {
98.76 + fix y assume y: "y \<in> F"
98.77 + from xi have "xi \<le> b y"
98.78 + proof (rule lub.least)
98.79 + fix au assume "au \<in> ?S"
98.80 + then obtain u where u: "u \<in> F" and au: "au = a u" by blast
98.81 + from u y have "a u \<le> b y" by (rule r)
98.82 + with au show "au \<le> b y" by (simp only:)
98.83 + qed
98.84 + } ultimately show "\<exists>xi. \<forall>y \<in> F. a y \<le> xi \<and> xi \<le> b y" by blast
98.85 +qed
98.86 +
98.87 +text {*
98.88 + \medskip The function @{text h'} is defined as a @{text "h' x = h y
98.89 + + a \<cdot> \<xi>"} where @{text "x = y + a \<cdot> \<xi>"} is a linear extension of
98.90 + @{text h} to @{text H'}.
98.91 +*}
98.92 +
98.93 +lemma h'_lf:
98.94 + assumes h'_def: "h' \<equiv> \<lambda>x. let (y, a) =
98.95 + SOME (y, a). x = y + a \<cdot> x0 \<and> y \<in> H in h y + a * xi"
98.96 + and H'_def: "H' \<equiv> H + lin x0"
98.97 + and HE: "H \<unlhd> E"
98.98 + assumes "linearform H h"
98.99 + assumes x0: "x0 \<notin> H" "x0 \<in> E" "x0 \<noteq> 0"
98.100 + assumes E: "vectorspace E"
98.101 + shows "linearform H' h'"
98.102 +proof -
98.103 + interpret linearform H h by fact
98.104 + interpret vectorspace E by fact
98.105 + show ?thesis
98.106 + proof
98.107 + note E = `vectorspace E`
98.108 + have H': "vectorspace H'"
98.109 + proof (unfold H'_def)
98.110 + from `x0 \<in> E`
98.111 + have "lin x0 \<unlhd> E" ..
98.112 + with HE show "vectorspace (H + lin x0)" using E ..
98.113 + qed
98.114 + {
98.115 + fix x1 x2 assume x1: "x1 \<in> H'" and x2: "x2 \<in> H'"
98.116 + show "h' (x1 + x2) = h' x1 + h' x2"
98.117 + proof -
98.118 + from H' x1 x2 have "x1 + x2 \<in> H'"
98.119 + by (rule vectorspace.add_closed)
98.120 + with x1 x2 obtain y y1 y2 a a1 a2 where
98.121 + x1x2: "x1 + x2 = y + a \<cdot> x0" and y: "y \<in> H"
98.122 + and x1_rep: "x1 = y1 + a1 \<cdot> x0" and y1: "y1 \<in> H"
98.123 + and x2_rep: "x2 = y2 + a2 \<cdot> x0" and y2: "y2 \<in> H"
98.124 + unfolding H'_def sum_def lin_def by blast
98.125 +
98.126 + have ya: "y1 + y2 = y \<and> a1 + a2 = a" using E HE _ y x0
98.127 + proof (rule decomp_H') txt_raw {* \label{decomp-H-use} *}
98.128 + from HE y1 y2 show "y1 + y2 \<in> H"
98.129 + by (rule subspace.add_closed)
98.130 + from x0 and HE y y1 y2
98.131 + have "x0 \<in> E" "y \<in> E" "y1 \<in> E" "y2 \<in> E" by auto
98.132 + with x1_rep x2_rep have "(y1 + y2) + (a1 + a2) \<cdot> x0 = x1 + x2"
98.133 + by (simp add: add_ac add_mult_distrib2)
98.134 + also note x1x2
98.135 + finally show "(y1 + y2) + (a1 + a2) \<cdot> x0 = y + a \<cdot> x0" .
98.136 + qed
98.137 +
98.138 + from h'_def x1x2 E HE y x0
98.139 + have "h' (x1 + x2) = h y + a * xi"
98.140 + by (rule h'_definite)
98.141 + also have "\<dots> = h (y1 + y2) + (a1 + a2) * xi"
98.142 + by (simp only: ya)
98.143 + also from y1 y2 have "h (y1 + y2) = h y1 + h y2"
98.144 + by simp
98.145 + also have "\<dots> + (a1 + a2) * xi = (h y1 + a1 * xi) + (h y2 + a2 * xi)"
98.146 + by (simp add: left_distrib)
98.147 + also from h'_def x1_rep E HE y1 x0
98.148 + have "h y1 + a1 * xi = h' x1"
98.149 + by (rule h'_definite [symmetric])
98.150 + also from h'_def x2_rep E HE y2 x0
98.151 + have "h y2 + a2 * xi = h' x2"
98.152 + by (rule h'_definite [symmetric])
98.153 + finally show ?thesis .
98.154 + qed
98.155 + next
98.156 + fix x1 c assume x1: "x1 \<in> H'"
98.157 + show "h' (c \<cdot> x1) = c * (h' x1)"
98.158 + proof -
98.159 + from H' x1 have ax1: "c \<cdot> x1 \<in> H'"
98.160 + by (rule vectorspace.mult_closed)
98.161 + with x1 obtain y a y1 a1 where
98.162 + cx1_rep: "c \<cdot> x1 = y + a \<cdot> x0" and y: "y \<in> H"
98.163 + and x1_rep: "x1 = y1 + a1 \<cdot> x0" and y1: "y1 \<in> H"
98.164 + unfolding H'_def sum_def lin_def by blast
98.165 +
98.166 + have ya: "c \<cdot> y1 = y \<and> c * a1 = a" using E HE _ y x0
98.167 + proof (rule decomp_H')
98.168 + from HE y1 show "c \<cdot> y1 \<in> H"
98.169 + by (rule subspace.mult_closed)
98.170 + from x0 and HE y y1
98.171 + have "x0 \<in> E" "y \<in> E" "y1 \<in> E" by auto
98.172 + with x1_rep have "c \<cdot> y1 + (c * a1) \<cdot> x0 = c \<cdot> x1"
98.173 + by (simp add: mult_assoc add_mult_distrib1)
98.174 + also note cx1_rep
98.175 + finally show "c \<cdot> y1 + (c * a1) \<cdot> x0 = y + a \<cdot> x0" .
98.176 + qed
98.177 +
98.178 + from h'_def cx1_rep E HE y x0 have "h' (c \<cdot> x1) = h y + a * xi"
98.179 + by (rule h'_definite)
98.180 + also have "\<dots> = h (c \<cdot> y1) + (c * a1) * xi"
98.181 + by (simp only: ya)
98.182 + also from y1 have "h (c \<cdot> y1) = c * h y1"
98.183 + by simp
98.184 + also have "\<dots> + (c * a1) * xi = c * (h y1 + a1 * xi)"
98.185 + by (simp only: right_distrib)
98.186 + also from h'_def x1_rep E HE y1 x0 have "h y1 + a1 * xi = h' x1"
98.187 + by (rule h'_definite [symmetric])
98.188 + finally show ?thesis .
98.189 + qed
98.190 + }
98.191 + qed
98.192 +qed
98.193 +
98.194 +text {* \medskip The linear extension @{text h'} of @{text h}
98.195 + is bounded by the seminorm @{text p}. *}
98.196 +
98.197 +lemma h'_norm_pres:
98.198 + assumes h'_def: "h' \<equiv> \<lambda>x. let (y, a) =
98.199 + SOME (y, a). x = y + a \<cdot> x0 \<and> y \<in> H in h y + a * xi"
98.200 + and H'_def: "H' \<equiv> H + lin x0"
98.201 + and x0: "x0 \<notin> H" "x0 \<in> E" "x0 \<noteq> 0"
98.202 + assumes E: "vectorspace E" and HE: "subspace H E"
98.203 + and "seminorm E p" and "linearform H h"
98.204 + assumes a: "\<forall>y \<in> H. h y \<le> p y"
98.205 + and a': "\<forall>y \<in> H. - p (y + x0) - h y \<le> xi \<and> xi \<le> p (y + x0) - h y"
98.206 + shows "\<forall>x \<in> H'. h' x \<le> p x"
98.207 +proof -
98.208 + interpret vectorspace E by fact
98.209 + interpret subspace H E by fact
98.210 + interpret seminorm E p by fact
98.211 + interpret linearform H h by fact
98.212 + show ?thesis
98.213 + proof
98.214 + fix x assume x': "x \<in> H'"
98.215 + show "h' x \<le> p x"
98.216 + proof -
98.217 + from a' have a1: "\<forall>ya \<in> H. - p (ya + x0) - h ya \<le> xi"
98.218 + and a2: "\<forall>ya \<in> H. xi \<le> p (ya + x0) - h ya" by auto
98.219 + from x' obtain y a where
98.220 + x_rep: "x = y + a \<cdot> x0" and y: "y \<in> H"
98.221 + unfolding H'_def sum_def lin_def by blast
98.222 + from y have y': "y \<in> E" ..
98.223 + from y have ay: "inverse a \<cdot> y \<in> H" by simp
98.224 +
98.225 + from h'_def x_rep E HE y x0 have "h' x = h y + a * xi"
98.226 + by (rule h'_definite)
98.227 + also have "\<dots> \<le> p (y + a \<cdot> x0)"
98.228 + proof (rule linorder_cases)
98.229 + assume z: "a = 0"
98.230 + then have "h y + a * xi = h y" by simp
98.231 + also from a y have "\<dots> \<le> p y" ..
98.232 + also from x0 y' z have "p y = p (y + a \<cdot> x0)" by simp
98.233 + finally show ?thesis .
98.234 + next
98.235 + txt {* In the case @{text "a < 0"}, we use @{text "a\<^sub>1"}
98.236 + with @{text ya} taken as @{text "y / a"}: *}
98.237 + assume lz: "a < 0" then have nz: "a \<noteq> 0" by simp
98.238 + from a1 ay
98.239 + have "- p (inverse a \<cdot> y + x0) - h (inverse a \<cdot> y) \<le> xi" ..
98.240 + with lz have "a * xi \<le>
98.241 + a * (- p (inverse a \<cdot> y + x0) - h (inverse a \<cdot> y))"
98.242 + by (simp add: mult_left_mono_neg order_less_imp_le)
98.243 +
98.244 + also have "\<dots> =
98.245 + - a * (p (inverse a \<cdot> y + x0)) - a * (h (inverse a \<cdot> y))"
98.246 + by (simp add: right_diff_distrib)
98.247 + also from lz x0 y' have "- a * (p (inverse a \<cdot> y + x0)) =
98.248 + p (a \<cdot> (inverse a \<cdot> y + x0))"
98.249 + by (simp add: abs_homogenous)
98.250 + also from nz x0 y' have "\<dots> = p (y + a \<cdot> x0)"
98.251 + by (simp add: add_mult_distrib1 mult_assoc [symmetric])
98.252 + also from nz y have "a * (h (inverse a \<cdot> y)) = h y"
98.253 + by simp
98.254 + finally have "a * xi \<le> p (y + a \<cdot> x0) - h y" .
98.255 + then show ?thesis by simp
98.256 + next
98.257 + txt {* In the case @{text "a > 0"}, we use @{text "a\<^sub>2"}
98.258 + with @{text ya} taken as @{text "y / a"}: *}
98.259 + assume gz: "0 < a" then have nz: "a \<noteq> 0" by simp
98.260 + from a2 ay
98.261 + have "xi \<le> p (inverse a \<cdot> y + x0) - h (inverse a \<cdot> y)" ..
98.262 + with gz have "a * xi \<le>
98.263 + a * (p (inverse a \<cdot> y + x0) - h (inverse a \<cdot> y))"
98.264 + by simp
98.265 + also have "\<dots> = a * p (inverse a \<cdot> y + x0) - a * h (inverse a \<cdot> y)"
98.266 + by (simp add: right_diff_distrib)
98.267 + also from gz x0 y'
98.268 + have "a * p (inverse a \<cdot> y + x0) = p (a \<cdot> (inverse a \<cdot> y + x0))"
98.269 + by (simp add: abs_homogenous)
98.270 + also from nz x0 y' have "\<dots> = p (y + a \<cdot> x0)"
98.271 + by (simp add: add_mult_distrib1 mult_assoc [symmetric])
98.272 + also from nz y have "a * h (inverse a \<cdot> y) = h y"
98.273 + by simp
98.274 + finally have "a * xi \<le> p (y + a \<cdot> x0) - h y" .
98.275 + then show ?thesis by simp
98.276 + qed
98.277 + also from x_rep have "\<dots> = p x" by (simp only:)
98.278 + finally show ?thesis .
98.279 + qed
98.280 + qed
98.281 +qed
98.282 +
98.283 +end
99.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
99.2 +++ b/src/HOL/HahnBanach/HahnBanachLemmas.thy Tue Dec 30 11:10:01 2008 +0100
99.3 @@ -0,0 +1,4 @@
99.4 +(*<*)
99.5 +theory HahnBanachLemmas imports HahnBanachSupLemmas HahnBanachExtLemmas begin
99.6 +end
99.7 +(*>*)
99.8 \ No newline at end of file
100.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
100.2 +++ b/src/HOL/HahnBanach/HahnBanachSupLemmas.thy Tue Dec 30 11:10:01 2008 +0100
100.3 @@ -0,0 +1,446 @@
100.4 +(* Title: HOL/Real/HahnBanach/HahnBanachSupLemmas.thy
100.5 + ID: $Id$
100.6 + Author: Gertrud Bauer, TU Munich
100.7 +*)
100.8 +
100.9 +header {* The supremum w.r.t.~the function order *}
100.10 +
100.11 +theory HahnBanachSupLemmas
100.12 +imports FunctionNorm ZornLemma
100.13 +begin
100.14 +
100.15 +text {*
100.16 + This section contains some lemmas that will be used in the proof of
100.17 + the Hahn-Banach Theorem. In this section the following context is
100.18 + presumed. Let @{text E} be a real vector space with a seminorm
100.19 + @{text p} on @{text E}. @{text F} is a subspace of @{text E} and
100.20 + @{text f} a linear form on @{text F}. We consider a chain @{text c}
100.21 + of norm-preserving extensions of @{text f}, such that @{text "\<Union>c =
100.22 + graph H h"}. We will show some properties about the limit function
100.23 + @{text h}, i.e.\ the supremum of the chain @{text c}.
100.24 +
100.25 + \medskip Let @{text c} be a chain of norm-preserving extensions of
100.26 + the function @{text f} and let @{text "graph H h"} be the supremum
100.27 + of @{text c}. Every element in @{text H} is member of one of the
100.28 + elements of the chain.
100.29 +*}
100.30 +lemmas [dest?] = chainD
100.31 +lemmas chainE2 [elim?] = chainD2 [elim_format, standard]
100.32 +
100.33 +lemma some_H'h't:
100.34 + assumes M: "M = norm_pres_extensions E p F f"
100.35 + and cM: "c \<in> chain M"
100.36 + and u: "graph H h = \<Union>c"
100.37 + and x: "x \<in> H"
100.38 + shows "\<exists>H' h'. graph H' h' \<in> c
100.39 + \<and> (x, h x) \<in> graph H' h'
100.40 + \<and> linearform H' h' \<and> H' \<unlhd> E
100.41 + \<and> F \<unlhd> H' \<and> graph F f \<subseteq> graph H' h'
100.42 + \<and> (\<forall>x \<in> H'. h' x \<le> p x)"
100.43 +proof -
100.44 + from x have "(x, h x) \<in> graph H h" ..
100.45 + also from u have "\<dots> = \<Union>c" .
100.46 + finally obtain g where gc: "g \<in> c" and gh: "(x, h x) \<in> g" by blast
100.47 +
100.48 + from cM have "c \<subseteq> M" ..
100.49 + with gc have "g \<in> M" ..
100.50 + also from M have "\<dots> = norm_pres_extensions E p F f" .
100.51 + finally obtain H' and h' where g: "g = graph H' h'"
100.52 + and * : "linearform H' h'" "H' \<unlhd> E" "F \<unlhd> H'"
100.53 + "graph F f \<subseteq> graph H' h'" "\<forall>x \<in> H'. h' x \<le> p x" ..
100.54 +
100.55 + from gc and g have "graph H' h' \<in> c" by (simp only:)
100.56 + moreover from gh and g have "(x, h x) \<in> graph H' h'" by (simp only:)
100.57 + ultimately show ?thesis using * by blast
100.58 +qed
100.59 +
100.60 +text {*
100.61 + \medskip Let @{text c} be a chain of norm-preserving extensions of
100.62 + the function @{text f} and let @{text "graph H h"} be the supremum
100.63 + of @{text c}. Every element in the domain @{text H} of the supremum
100.64 + function is member of the domain @{text H'} of some function @{text
100.65 + h'}, such that @{text h} extends @{text h'}.
100.66 +*}
100.67 +
100.68 +lemma some_H'h':
100.69 + assumes M: "M = norm_pres_extensions E p F f"
100.70 + and cM: "c \<in> chain M"
100.71 + and u: "graph H h = \<Union>c"
100.72 + and x: "x \<in> H"
100.73 + shows "\<exists>H' h'. x \<in> H' \<and> graph H' h' \<subseteq> graph H h
100.74 + \<and> linearform H' h' \<and> H' \<unlhd> E \<and> F \<unlhd> H'
100.75 + \<and> graph F f \<subseteq> graph H' h' \<and> (\<forall>x \<in> H'. h' x \<le> p x)"
100.76 +proof -
100.77 + from M cM u x obtain H' h' where
100.78 + x_hx: "(x, h x) \<in> graph H' h'"
100.79 + and c: "graph H' h' \<in> c"
100.80 + and * : "linearform H' h'" "H' \<unlhd> E" "F \<unlhd> H'"
100.81 + "graph F f \<subseteq> graph H' h'" "\<forall>x \<in> H'. h' x \<le> p x"
100.82 + by (rule some_H'h't [elim_format]) blast
100.83 + from x_hx have "x \<in> H'" ..
100.84 + moreover from cM u c have "graph H' h' \<subseteq> graph H h"
100.85 + by (simp only: chain_ball_Union_upper)
100.86 + ultimately show ?thesis using * by blast
100.87 +qed
100.88 +
100.89 +text {*
100.90 + \medskip Any two elements @{text x} and @{text y} in the domain
100.91 + @{text H} of the supremum function @{text h} are both in the domain
100.92 + @{text H'} of some function @{text h'}, such that @{text h} extends
100.93 + @{text h'}.
100.94 +*}
100.95 +
100.96 +lemma some_H'h'2:
100.97 + assumes M: "M = norm_pres_extensions E p F f"
100.98 + and cM: "c \<in> chain M"
100.99 + and u: "graph H h = \<Union>c"
100.100 + and x: "x \<in> H"
100.101 + and y: "y \<in> H"
100.102 + shows "\<exists>H' h'. x \<in> H' \<and> y \<in> H'
100.103 + \<and> graph H' h' \<subseteq> graph H h
100.104 + \<and> linearform H' h' \<and> H' \<unlhd> E \<and> F \<unlhd> H'
100.105 + \<and> graph F f \<subseteq> graph H' h' \<and> (\<forall>x \<in> H'. h' x \<le> p x)"
100.106 +proof -
100.107 + txt {* @{text y} is in the domain @{text H''} of some function @{text h''},
100.108 + such that @{text h} extends @{text h''}. *}
100.109 +
100.110 + from M cM u and y obtain H' h' where
100.111 + y_hy: "(y, h y) \<in> graph H' h'"
100.112 + and c': "graph H' h' \<in> c"
100.113 + and * :
100.114 + "linearform H' h'" "H' \<unlhd> E" "F \<unlhd> H'"
100.115 + "graph F f \<subseteq> graph H' h'" "\<forall>x \<in> H'. h' x \<le> p x"
100.116 + by (rule some_H'h't [elim_format]) blast
100.117 +
100.118 + txt {* @{text x} is in the domain @{text H'} of some function @{text h'},
100.119 + such that @{text h} extends @{text h'}. *}
100.120 +
100.121 + from M cM u and x obtain H'' h'' where
100.122 + x_hx: "(x, h x) \<in> graph H'' h''"
100.123 + and c'': "graph H'' h'' \<in> c"
100.124 + and ** :
100.125 + "linearform H'' h''" "H'' \<unlhd> E" "F \<unlhd> H''"
100.126 + "graph F f \<subseteq> graph H'' h''" "\<forall>x \<in> H''. h'' x \<le> p x"
100.127 + by (rule some_H'h't [elim_format]) blast
100.128 +
100.129 + txt {* Since both @{text h'} and @{text h''} are elements of the chain,
100.130 + @{text h''} is an extension of @{text h'} or vice versa. Thus both
100.131 + @{text x} and @{text y} are contained in the greater
100.132 + one. \label{cases1}*}
100.133 +
100.134 + from cM c'' c' have "graph H'' h'' \<subseteq> graph H' h' \<or> graph H' h' \<subseteq> graph H'' h''"
100.135 + (is "?case1 \<or> ?case2") ..
100.136 + then show ?thesis
100.137 + proof
100.138 + assume ?case1
100.139 + have "(x, h x) \<in> graph H'' h''" by fact
100.140 + also have "\<dots> \<subseteq> graph H' h'" by fact
100.141 + finally have xh:"(x, h x) \<in> graph H' h'" .
100.142 + then have "x \<in> H'" ..
100.143 + moreover from y_hy have "y \<in> H'" ..
100.144 + moreover from cM u and c' have "graph H' h' \<subseteq> graph H h"
100.145 + by (simp only: chain_ball_Union_upper)
100.146 + ultimately show ?thesis using * by blast
100.147 + next
100.148 + assume ?case2
100.149 + from x_hx have "x \<in> H''" ..
100.150 + moreover {
100.151 + have "(y, h y) \<in> graph H' h'" by (rule y_hy)
100.152 + also have "\<dots> \<subseteq> graph H'' h''" by fact
100.153 + finally have "(y, h y) \<in> graph H'' h''" .
100.154 + } then have "y \<in> H''" ..
100.155 + moreover from cM u and c'' have "graph H'' h'' \<subseteq> graph H h"
100.156 + by (simp only: chain_ball_Union_upper)
100.157 + ultimately show ?thesis using ** by blast
100.158 + qed
100.159 +qed
100.160 +
100.161 +text {*
100.162 + \medskip The relation induced by the graph of the supremum of a
100.163 + chain @{text c} is definite, i.~e.~t is the graph of a function.
100.164 +*}
100.165 +
100.166 +lemma sup_definite:
100.167 + assumes M_def: "M \<equiv> norm_pres_extensions E p F f"
100.168 + and cM: "c \<in> chain M"
100.169 + and xy: "(x, y) \<in> \<Union>c"
100.170 + and xz: "(x, z) \<in> \<Union>c"
100.171 + shows "z = y"
100.172 +proof -
100.173 + from cM have c: "c \<subseteq> M" ..
100.174 + from xy obtain G1 where xy': "(x, y) \<in> G1" and G1: "G1 \<in> c" ..
100.175 + from xz obtain G2 where xz': "(x, z) \<in> G2" and G2: "G2 \<in> c" ..
100.176 +
100.177 + from G1 c have "G1 \<in> M" ..
100.178 + then obtain H1 h1 where G1_rep: "G1 = graph H1 h1"
100.179 + unfolding M_def by blast
100.180 +
100.181 + from G2 c have "G2 \<in> M" ..
100.182 + then obtain H2 h2 where G2_rep: "G2 = graph H2 h2"
100.183 + unfolding M_def by blast
100.184 +
100.185 + txt {* @{text "G\<^sub>1"} is contained in @{text "G\<^sub>2"}
100.186 + or vice versa, since both @{text "G\<^sub>1"} and @{text
100.187 + "G\<^sub>2"} are members of @{text c}. \label{cases2}*}
100.188 +
100.189 + from cM G1 G2 have "G1 \<subseteq> G2 \<or> G2 \<subseteq> G1" (is "?case1 \<or> ?case2") ..
100.190 + then show ?thesis
100.191 + proof
100.192 + assume ?case1
100.193 + with xy' G2_rep have "(x, y) \<in> graph H2 h2" by blast
100.194 + then have "y = h2 x" ..
100.195 + also
100.196 + from xz' G2_rep have "(x, z) \<in> graph H2 h2" by (simp only:)
100.197 + then have "z = h2 x" ..
100.198 + finally show ?thesis .
100.199 + next
100.200 + assume ?case2
100.201 + with xz' G1_rep have "(x, z) \<in> graph H1 h1" by blast
100.202 + then have "z = h1 x" ..
100.203 + also
100.204 + from xy' G1_rep have "(x, y) \<in> graph H1 h1" by (simp only:)
100.205 + then have "y = h1 x" ..
100.206 + finally show ?thesis ..
100.207 + qed
100.208 +qed
100.209 +
100.210 +text {*
100.211 + \medskip The limit function @{text h} is linear. Every element
100.212 + @{text x} in the domain of @{text h} is in the domain of a function
100.213 + @{text h'} in the chain of norm preserving extensions. Furthermore,
100.214 + @{text h} is an extension of @{text h'} so the function values of
100.215 + @{text x} are identical for @{text h'} and @{text h}. Finally, the
100.216 + function @{text h'} is linear by construction of @{text M}.
100.217 +*}
100.218 +
100.219 +lemma sup_lf:
100.220 + assumes M: "M = norm_pres_extensions E p F f"
100.221 + and cM: "c \<in> chain M"
100.222 + and u: "graph H h = \<Union>c"
100.223 + shows "linearform H h"
100.224 +proof
100.225 + fix x y assume x: "x \<in> H" and y: "y \<in> H"
100.226 + with M cM u obtain H' h' where
100.227 + x': "x \<in> H'" and y': "y \<in> H'"
100.228 + and b: "graph H' h' \<subseteq> graph H h"
100.229 + and linearform: "linearform H' h'"
100.230 + and subspace: "H' \<unlhd> E"
100.231 + by (rule some_H'h'2 [elim_format]) blast
100.232 +
100.233 + show "h (x + y) = h x + h y"
100.234 + proof -
100.235 + from linearform x' y' have "h' (x + y) = h' x + h' y"
100.236 + by (rule linearform.add)
100.237 + also from b x' have "h' x = h x" ..
100.238 + also from b y' have "h' y = h y" ..
100.239 + also from subspace x' y' have "x + y \<in> H'"
100.240 + by (rule subspace.add_closed)
100.241 + with b have "h' (x + y) = h (x + y)" ..
100.242 + finally show ?thesis .
100.243 + qed
100.244 +next
100.245 + fix x a assume x: "x \<in> H"
100.246 + with M cM u obtain H' h' where
100.247 + x': "x \<in> H'"
100.248 + and b: "graph H' h' \<subseteq> graph H h"
100.249 + and linearform: "linearform H' h'"
100.250 + and subspace: "H' \<unlhd> E"
100.251 + by (rule some_H'h' [elim_format]) blast
100.252 +
100.253 + show "h (a \<cdot> x) = a * h x"
100.254 + proof -
100.255 + from linearform x' have "h' (a \<cdot> x) = a * h' x"
100.256 + by (rule linearform.mult)
100.257 + also from b x' have "h' x = h x" ..
100.258 + also from subspace x' have "a \<cdot> x \<in> H'"
100.259 + by (rule subspace.mult_closed)
100.260 + with b have "h' (a \<cdot> x) = h (a \<cdot> x)" ..
100.261 + finally show ?thesis .
100.262 + qed
100.263 +qed
100.264 +
100.265 +text {*
100.266 + \medskip The limit of a non-empty chain of norm preserving
100.267 + extensions of @{text f} is an extension of @{text f}, since every
100.268 + element of the chain is an extension of @{text f} and the supremum
100.269 + is an extension for every element of the chain.
100.270 +*}
100.271 +
100.272 +lemma sup_ext:
100.273 + assumes graph: "graph H h = \<Union>c"
100.274 + and M: "M = norm_pres_extensions E p F f"
100.275 + and cM: "c \<in> chain M"
100.276 + and ex: "\<exists>x. x \<in> c"
100.277 + shows "graph F f \<subseteq> graph H h"
100.278 +proof -
100.279 + from ex obtain x where xc: "x \<in> c" ..
100.280 + from cM have "c \<subseteq> M" ..
100.281 + with xc have "x \<in> M" ..
100.282 + with M have "x \<in> norm_pres_extensions E p F f"
100.283 + by (simp only:)
100.284 + then obtain G g where "x = graph G g" and "graph F f \<subseteq> graph G g" ..
100.285 + then have "graph F f \<subseteq> x" by (simp only:)
100.286 + also from xc have "\<dots> \<subseteq> \<Union>c" by blast
100.287 + also from graph have "\<dots> = graph H h" ..
100.288 + finally show ?thesis .
100.289 +qed
100.290 +
100.291 +text {*
100.292 + \medskip The domain @{text H} of the limit function is a superspace
100.293 + of @{text F}, since @{text F} is a subset of @{text H}. The
100.294 + existence of the @{text 0} element in @{text F} and the closure
100.295 + properties follow from the fact that @{text F} is a vector space.
100.296 +*}
100.297 +
100.298 +lemma sup_supF:
100.299 + assumes graph: "graph H h = \<Union>c"
100.300 + and M: "M = norm_pres_extensions E p F f"
100.301 + and cM: "c \<in> chain M"
100.302 + and ex: "\<exists>x. x \<in> c"
100.303 + and FE: "F \<unlhd> E"
100.304 + shows "F \<unlhd> H"
100.305 +proof
100.306 + from FE show "F \<noteq> {}" by (rule subspace.non_empty)
100.307 + from graph M cM ex have "graph F f \<subseteq> graph H h" by (rule sup_ext)
100.308 + then show "F \<subseteq> H" ..
100.309 + fix x y assume "x \<in> F" and "y \<in> F"
100.310 + with FE show "x + y \<in> F" by (rule subspace.add_closed)
100.311 +next
100.312 + fix x a assume "x \<in> F"
100.313 + with FE show "a \<cdot> x \<in> F" by (rule subspace.mult_closed)
100.314 +qed
100.315 +
100.316 +text {*
100.317 + \medskip The domain @{text H} of the limit function is a subspace of
100.318 + @{text E}.
100.319 +*}
100.320 +
100.321 +lemma sup_subE:
100.322 + assumes graph: "graph H h = \<Union>c"
100.323 + and M: "M = norm_pres_extensions E p F f"
100.324 + and cM: "c \<in> chain M"
100.325 + and ex: "\<exists>x. x \<in> c"
100.326 + and FE: "F \<unlhd> E"
100.327 + and E: "vectorspace E"
100.328 + shows "H \<unlhd> E"
100.329 +proof
100.330 + show "H \<noteq> {}"
100.331 + proof -
100.332 + from FE E have "0 \<in> F" by (rule subspace.zero)
100.333 + also from graph M cM ex FE have "F \<unlhd> H" by (rule sup_supF)
100.334 + then have "F \<subseteq> H" ..
100.335 + finally show ?thesis by blast
100.336 + qed
100.337 + show "H \<subseteq> E"
100.338 + proof
100.339 + fix x assume "x \<in> H"
100.340 + with M cM graph
100.341 + obtain H' h' where x: "x \<in> H'" and H'E: "H' \<unlhd> E"
100.342 + by (rule some_H'h' [elim_format]) blast
100.343 + from H'E have "H' \<subseteq> E" ..
100.344 + with x show "x \<in> E" ..
100.345 + qed
100.346 + fix x y assume x: "x \<in> H" and y: "y \<in> H"
100.347 + show "x + y \<in> H"
100.348 + proof -
100.349 + from M cM graph x y obtain H' h' where
100.350 + x': "x \<in> H'" and y': "y \<in> H'" and H'E: "H' \<unlhd> E"
100.351 + and graphs: "graph H' h' \<subseteq> graph H h"
100.352 + by (rule some_H'h'2 [elim_format]) blast
100.353 + from H'E x' y' have "x + y \<in> H'"
100.354 + by (rule subspace.add_closed)
100.355 + also from graphs have "H' \<subseteq> H" ..
100.356 + finally show ?thesis .
100.357 + qed
100.358 +next
100.359 + fix x a assume x: "x \<in> H"
100.360 + show "a \<cdot> x \<in> H"
100.361 + proof -
100.362 + from M cM graph x
100.363 + obtain H' h' where x': "x \<in> H'" and H'E: "H' \<unlhd> E"
100.364 + and graphs: "graph H' h' \<subseteq> graph H h"
100.365 + by (rule some_H'h' [elim_format]) blast
100.366 + from H'E x' have "a \<cdot> x \<in> H'" by (rule subspace.mult_closed)
100.367 + also from graphs have "H' \<subseteq> H" ..
100.368 + finally show ?thesis .
100.369 + qed
100.370 +qed
100.371 +
100.372 +text {*
100.373 + \medskip The limit function is bounded by the norm @{text p} as
100.374 + well, since all elements in the chain are bounded by @{text p}.
100.375 +*}
100.376 +
100.377 +lemma sup_norm_pres:
100.378 + assumes graph: "graph H h = \<Union>c"
100.379 + and M: "M = norm_pres_extensions E p F f"
100.380 + and cM: "c \<in> chain M"
100.381 + shows "\<forall>x \<in> H. h x \<le> p x"
100.382 +proof
100.383 + fix x assume "x \<in> H"
100.384 + with M cM graph obtain H' h' where x': "x \<in> H'"
100.385 + and graphs: "graph H' h' \<subseteq> graph H h"
100.386 + and a: "\<forall>x \<in> H'. h' x \<le> p x"
100.387 + by (rule some_H'h' [elim_format]) blast
100.388 + from graphs x' have [symmetric]: "h' x = h x" ..
100.389 + also from a x' have "h' x \<le> p x " ..
100.390 + finally show "h x \<le> p x" .
100.391 +qed
100.392 +
100.393 +text {*
100.394 + \medskip The following lemma is a property of linear forms on real
100.395 + vector spaces. It will be used for the lemma @{text abs_HahnBanach}
100.396 + (see page \pageref{abs-HahnBanach}). \label{abs-ineq-iff} For real
100.397 + vector spaces the following inequations are equivalent:
100.398 + \begin{center}
100.399 + \begin{tabular}{lll}
100.400 + @{text "\<forall>x \<in> H. \<bar>h x\<bar> \<le> p x"} & and &
100.401 + @{text "\<forall>x \<in> H. h x \<le> p x"} \\
100.402 + \end{tabular}
100.403 + \end{center}
100.404 +*}
100.405 +
100.406 +lemma abs_ineq_iff:
100.407 + assumes "subspace H E" and "vectorspace E" and "seminorm E p"
100.408 + and "linearform H h"
100.409 + shows "(\<forall>x \<in> H. \<bar>h x\<bar> \<le> p x) = (\<forall>x \<in> H. h x \<le> p x)" (is "?L = ?R")
100.410 +proof
100.411 + interpret subspace H E by fact
100.412 + interpret vectorspace E by fact
100.413 + interpret seminorm E p by fact
100.414 + interpret linearform H h by fact
100.415 + have H: "vectorspace H" using `vectorspace E` ..
100.416 + {
100.417 + assume l: ?L
100.418 + show ?R
100.419 + proof
100.420 + fix x assume x: "x \<in> H"
100.421 + have "h x \<le> \<bar>h x\<bar>" by arith
100.422 + also from l x have "\<dots> \<le> p x" ..
100.423 + finally show "h x \<le> p x" .
100.424 + qed
100.425 + next
100.426 + assume r: ?R
100.427 + show ?L
100.428 + proof
100.429 + fix x assume x: "x \<in> H"
100.430 + show "\<And>a b :: real. - a \<le> b \<Longrightarrow> b \<le> a \<Longrightarrow> \<bar>b\<bar> \<le> a"
100.431 + by arith
100.432 + from `linearform H h` and H x
100.433 + have "- h x = h (- x)" by (rule linearform.neg [symmetric])
100.434 + also
100.435 + from H x have "- x \<in> H" by (rule vectorspace.neg_closed)
100.436 + with r have "h (- x) \<le> p (- x)" ..
100.437 + also have "\<dots> = p x"
100.438 + using `seminorm E p` `vectorspace E`
100.439 + proof (rule seminorm.minus)
100.440 + from x show "x \<in> E" ..
100.441 + qed
100.442 + finally have "- h x \<le> p x" .
100.443 + then show "- p x \<le> h x" by simp
100.444 + from r x show "h x \<le> p x" ..
100.445 + qed
100.446 + }
100.447 +qed
100.448 +
100.449 +end
101.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
101.2 +++ b/src/HOL/HahnBanach/Linearform.thy Tue Dec 30 11:10:01 2008 +0100
101.3 @@ -0,0 +1,60 @@
101.4 +(* Title: HOL/Real/HahnBanach/Linearform.thy
101.5 + Author: Gertrud Bauer, TU Munich
101.6 +*)
101.7 +
101.8 +header {* Linearforms *}
101.9 +
101.10 +theory Linearform
101.11 +imports VectorSpace
101.12 +begin
101.13 +
101.14 +text {*
101.15 + A \emph{linear form} is a function on a vector space into the reals
101.16 + that is additive and multiplicative.
101.17 +*}
101.18 +
101.19 +locale linearform =
101.20 + fixes V :: "'a\<Colon>{minus, plus, zero, uminus} set" and f
101.21 + assumes add [iff]: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> f (x + y) = f x + f y"
101.22 + and mult [iff]: "x \<in> V \<Longrightarrow> f (a \<cdot> x) = a * f x"
101.23 +
101.24 +declare linearform.intro [intro?]
101.25 +
101.26 +lemma (in linearform) neg [iff]:
101.27 + assumes "vectorspace V"
101.28 + shows "x \<in> V \<Longrightarrow> f (- x) = - f x"
101.29 +proof -
101.30 + interpret vectorspace V by fact
101.31 + assume x: "x \<in> V"
101.32 + then have "f (- x) = f ((- 1) \<cdot> x)" by (simp add: negate_eq1)
101.33 + also from x have "\<dots> = (- 1) * (f x)" by (rule mult)
101.34 + also from x have "\<dots> = - (f x)" by simp
101.35 + finally show ?thesis .
101.36 +qed
101.37 +
101.38 +lemma (in linearform) diff [iff]:
101.39 + assumes "vectorspace V"
101.40 + shows "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> f (x - y) = f x - f y"
101.41 +proof -
101.42 + interpret vectorspace V by fact
101.43 + assume x: "x \<in> V" and y: "y \<in> V"
101.44 + then have "x - y = x + - y" by (rule diff_eq1)
101.45 + also have "f \<dots> = f x + f (- y)" by (rule add) (simp_all add: x y)
101.46 + also have "f (- y) = - f y" using `vectorspace V` y by (rule neg)
101.47 + finally show ?thesis by simp
101.48 +qed
101.49 +
101.50 +text {* Every linear form yields @{text 0} for the @{text 0} vector. *}
101.51 +
101.52 +lemma (in linearform) zero [iff]:
101.53 + assumes "vectorspace V"
101.54 + shows "f 0 = 0"
101.55 +proof -
101.56 + interpret vectorspace V by fact
101.57 + have "f 0 = f (0 - 0)" by simp
101.58 + also have "\<dots> = f 0 - f 0" using `vectorspace V` by (rule diff) simp_all
101.59 + also have "\<dots> = 0" by simp
101.60 + finally show ?thesis .
101.61 +qed
101.62 +
101.63 +end
102.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
102.2 +++ b/src/HOL/HahnBanach/NormedSpace.thy Tue Dec 30 11:10:01 2008 +0100
102.3 @@ -0,0 +1,117 @@
102.4 +(* Title: HOL/Real/HahnBanach/NormedSpace.thy
102.5 + Author: Gertrud Bauer, TU Munich
102.6 +*)
102.7 +
102.8 +header {* Normed vector spaces *}
102.9 +
102.10 +theory NormedSpace
102.11 +imports Subspace
102.12 +begin
102.13 +
102.14 +subsection {* Quasinorms *}
102.15 +
102.16 +text {*
102.17 + A \emph{seminorm} @{text "\<parallel>\<cdot>\<parallel>"} is a function on a real vector space
102.18 + into the reals that has the following properties: it is positive
102.19 + definite, absolute homogenous and subadditive.
102.20 +*}
102.21 +
102.22 +locale norm_syntax =
102.23 + fixes norm :: "'a \<Rightarrow> real" ("\<parallel>_\<parallel>")
102.24 +
102.25 +locale seminorm = var_V + norm_syntax +
102.26 + constrains V :: "'a\<Colon>{minus, plus, zero, uminus} set"
102.27 + assumes ge_zero [iff?]: "x \<in> V \<Longrightarrow> 0 \<le> \<parallel>x\<parallel>"
102.28 + and abs_homogenous [iff?]: "x \<in> V \<Longrightarrow> \<parallel>a \<cdot> x\<parallel> = \<bar>a\<bar> * \<parallel>x\<parallel>"
102.29 + and subadditive [iff?]: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> \<parallel>x + y\<parallel> \<le> \<parallel>x\<parallel> + \<parallel>y\<parallel>"
102.30 +
102.31 +declare seminorm.intro [intro?]
102.32 +
102.33 +lemma (in seminorm) diff_subadditive:
102.34 + assumes "vectorspace V"
102.35 + shows "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> \<parallel>x - y\<parallel> \<le> \<parallel>x\<parallel> + \<parallel>y\<parallel>"
102.36 +proof -
102.37 + interpret vectorspace V by fact
102.38 + assume x: "x \<in> V" and y: "y \<in> V"
102.39 + then have "x - y = x + - 1 \<cdot> y"
102.40 + by (simp add: diff_eq2 negate_eq2a)
102.41 + also from x y have "\<parallel>\<dots>\<parallel> \<le> \<parallel>x\<parallel> + \<parallel>- 1 \<cdot> y\<parallel>"
102.42 + by (simp add: subadditive)
102.43 + also from y have "\<parallel>- 1 \<cdot> y\<parallel> = \<bar>- 1\<bar> * \<parallel>y\<parallel>"
102.44 + by (rule abs_homogenous)
102.45 + also have "\<dots> = \<parallel>y\<parallel>" by simp
102.46 + finally show ?thesis .
102.47 +qed
102.48 +
102.49 +lemma (in seminorm) minus:
102.50 + assumes "vectorspace V"
102.51 + shows "x \<in> V \<Longrightarrow> \<parallel>- x\<parallel> = \<parallel>x\<parallel>"
102.52 +proof -
102.53 + interpret vectorspace V by fact
102.54 + assume x: "x \<in> V"
102.55 + then have "- x = - 1 \<cdot> x" by (simp only: negate_eq1)
102.56 + also from x have "\<parallel>\<dots>\<parallel> = \<bar>- 1\<bar> * \<parallel>x\<parallel>"
102.57 + by (rule abs_homogenous)
102.58 + also have "\<dots> = \<parallel>x\<parallel>" by simp
102.59 + finally show ?thesis .
102.60 +qed
102.61 +
102.62 +
102.63 +subsection {* Norms *}
102.64 +
102.65 +text {*
102.66 + A \emph{norm} @{text "\<parallel>\<cdot>\<parallel>"} is a seminorm that maps only the
102.67 + @{text 0} vector to @{text 0}.
102.68 +*}
102.69 +
102.70 +locale norm = seminorm +
102.71 + assumes zero_iff [iff]: "x \<in> V \<Longrightarrow> (\<parallel>x\<parallel> = 0) = (x = 0)"
102.72 +
102.73 +
102.74 +subsection {* Normed vector spaces *}
102.75 +
102.76 +text {*
102.77 + A vector space together with a norm is called a \emph{normed
102.78 + space}.
102.79 +*}
102.80 +
102.81 +locale normed_vectorspace = vectorspace + norm
102.82 +
102.83 +declare normed_vectorspace.intro [intro?]
102.84 +
102.85 +lemma (in normed_vectorspace) gt_zero [intro?]:
102.86 + "x \<in> V \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> 0 < \<parallel>x\<parallel>"
102.87 +proof -
102.88 + assume x: "x \<in> V" and neq: "x \<noteq> 0"
102.89 + from x have "0 \<le> \<parallel>x\<parallel>" ..
102.90 + also have [symmetric]: "\<dots> \<noteq> 0"
102.91 + proof
102.92 + assume "\<parallel>x\<parallel> = 0"
102.93 + with x have "x = 0" by simp
102.94 + with neq show False by contradiction
102.95 + qed
102.96 + finally show ?thesis .
102.97 +qed
102.98 +
102.99 +text {*
102.100 + Any subspace of a normed vector space is again a normed vectorspace.
102.101 +*}
102.102 +
102.103 +lemma subspace_normed_vs [intro?]:
102.104 + fixes F E norm
102.105 + assumes "subspace F E" "normed_vectorspace E norm"
102.106 + shows "normed_vectorspace F norm"
102.107 +proof -
102.108 + interpret subspace F E by fact
102.109 + interpret normed_vectorspace E norm by fact
102.110 + show ?thesis
102.111 + proof
102.112 + show "vectorspace F" by (rule vectorspace) unfold_locales
102.113 + next
102.114 + have "NormedSpace.norm E norm" ..
102.115 + with subset show "NormedSpace.norm F norm"
102.116 + by (simp add: norm_def seminorm_def norm_axioms_def)
102.117 + qed
102.118 +qed
102.119 +
102.120 +end
103.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
103.2 +++ b/src/HOL/HahnBanach/README.html Tue Dec 30 11:10:01 2008 +0100
103.3 @@ -0,0 +1,38 @@
103.4 +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
103.5 +
103.6 +<!-- $Id$ -->
103.7 +
103.8 +<HTML>
103.9 +
103.10 +<HEAD>
103.11 + <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
103.12 + <TITLE>HOL/Real/HahnBanach/README</TITLE>
103.13 +</HEAD>
103.14 +
103.15 +<BODY>
103.16 +
103.17 +<H3>The Hahn-Banach Theorem for Real Vector Spaces (Isabelle/Isar)</H3>
103.18 +
103.19 +Author: Gertrud Bauer, Technische Universität München<P>
103.20 +
103.21 +This directory contains the proof of the Hahn-Banach theorem for real vectorspaces,
103.22 +following H. Heuser, Funktionalanalysis, p. 228 -232.
103.23 +The Hahn-Banach theorem is one of the fundamental theorems of functioal analysis.
103.24 +It is a conclusion of Zorn's lemma.<P>
103.25 +
103.26 +Two different formaulations of the theorem are presented, one for general real vectorspaces
103.27 +and its application to normed vectorspaces. <P>
103.28 +
103.29 +The theorem says, that every continous linearform, defined on arbitrary subspaces
103.30 +(not only one-dimensional subspaces), can be extended to a continous linearform on
103.31 +the whole vectorspace.
103.32 +
103.33 +
103.34 +<HR>
103.35 +
103.36 +<ADDRESS>
103.37 +<A NAME="bauerg@in.tum.de" HREF="mailto:bauerg@in.tum.de">bauerg@in.tum.de</A>
103.38 +</ADDRESS>
103.39 +
103.40 +</BODY>
103.41 +</HTML>
104.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
104.2 +++ b/src/HOL/HahnBanach/ROOT.ML Tue Dec 30 11:10:01 2008 +0100
104.3 @@ -0,0 +1,8 @@
104.4 +(* Title: HOL/Real/HahnBanach/ROOT.ML
104.5 + ID: $Id$
104.6 + Author: Gertrud Bauer, TU Munich
104.7 +
104.8 +The Hahn-Banach theorem for real vector spaces (Isabelle/Isar).
104.9 +*)
104.10 +
104.11 +time_use_thy "HahnBanach";
105.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
105.2 +++ b/src/HOL/HahnBanach/Subspace.thy Tue Dec 30 11:10:01 2008 +0100
105.3 @@ -0,0 +1,513 @@
105.4 +(* Title: HOL/Real/HahnBanach/Subspace.thy
105.5 + Author: Gertrud Bauer, TU Munich
105.6 +*)
105.7 +
105.8 +header {* Subspaces *}
105.9 +
105.10 +theory Subspace
105.11 +imports VectorSpace
105.12 +begin
105.13 +
105.14 +subsection {* Definition *}
105.15 +
105.16 +text {*
105.17 + A non-empty subset @{text U} of a vector space @{text V} is a
105.18 + \emph{subspace} of @{text V}, iff @{text U} is closed under addition
105.19 + and scalar multiplication.
105.20 +*}
105.21 +
105.22 +locale subspace =
105.23 + fixes U :: "'a\<Colon>{minus, plus, zero, uminus} set" and V
105.24 + assumes non_empty [iff, intro]: "U \<noteq> {}"
105.25 + and subset [iff]: "U \<subseteq> V"
105.26 + and add_closed [iff]: "x \<in> U \<Longrightarrow> y \<in> U \<Longrightarrow> x + y \<in> U"
105.27 + and mult_closed [iff]: "x \<in> U \<Longrightarrow> a \<cdot> x \<in> U"
105.28 +
105.29 +notation (symbols)
105.30 + subspace (infix "\<unlhd>" 50)
105.31 +
105.32 +declare vectorspace.intro [intro?] subspace.intro [intro?]
105.33 +
105.34 +lemma subspace_subset [elim]: "U \<unlhd> V \<Longrightarrow> U \<subseteq> V"
105.35 + by (rule subspace.subset)
105.36 +
105.37 +lemma (in subspace) subsetD [iff]: "x \<in> U \<Longrightarrow> x \<in> V"
105.38 + using subset by blast
105.39 +
105.40 +lemma subspaceD [elim]: "U \<unlhd> V \<Longrightarrow> x \<in> U \<Longrightarrow> x \<in> V"
105.41 + by (rule subspace.subsetD)
105.42 +
105.43 +lemma rev_subspaceD [elim?]: "x \<in> U \<Longrightarrow> U \<unlhd> V \<Longrightarrow> x \<in> V"
105.44 + by (rule subspace.subsetD)
105.45 +
105.46 +lemma (in subspace) diff_closed [iff]:
105.47 + assumes "vectorspace V"
105.48 + assumes x: "x \<in> U" and y: "y \<in> U"
105.49 + shows "x - y \<in> U"
105.50 +proof -
105.51 + interpret vectorspace V by fact
105.52 + from x y show ?thesis by (simp add: diff_eq1 negate_eq1)
105.53 +qed
105.54 +
105.55 +text {*
105.56 + \medskip Similar as for linear spaces, the existence of the zero
105.57 + element in every subspace follows from the non-emptiness of the
105.58 + carrier set and by vector space laws.
105.59 +*}
105.60 +
105.61 +lemma (in subspace) zero [intro]:
105.62 + assumes "vectorspace V"
105.63 + shows "0 \<in> U"
105.64 +proof -
105.65 + interpret V!: vectorspace V by fact
105.66 + have "U \<noteq> {}" by (rule non_empty)
105.67 + then obtain x where x: "x \<in> U" by blast
105.68 + then have "x \<in> V" .. then have "0 = x - x" by simp
105.69 + also from `vectorspace V` x x have "\<dots> \<in> U" by (rule diff_closed)
105.70 + finally show ?thesis .
105.71 +qed
105.72 +
105.73 +lemma (in subspace) neg_closed [iff]:
105.74 + assumes "vectorspace V"
105.75 + assumes x: "x \<in> U"
105.76 + shows "- x \<in> U"
105.77 +proof -
105.78 + interpret vectorspace V by fact
105.79 + from x show ?thesis by (simp add: negate_eq1)
105.80 +qed
105.81 +
105.82 +text {* \medskip Further derived laws: every subspace is a vector space. *}
105.83 +
105.84 +lemma (in subspace) vectorspace [iff]:
105.85 + assumes "vectorspace V"
105.86 + shows "vectorspace U"
105.87 +proof -
105.88 + interpret vectorspace V by fact
105.89 + show ?thesis
105.90 + proof
105.91 + show "U \<noteq> {}" ..
105.92 + fix x y z assume x: "x \<in> U" and y: "y \<in> U" and z: "z \<in> U"
105.93 + fix a b :: real
105.94 + from x y show "x + y \<in> U" by simp
105.95 + from x show "a \<cdot> x \<in> U" by simp
105.96 + from x y z show "(x + y) + z = x + (y + z)" by (simp add: add_ac)
105.97 + from x y show "x + y = y + x" by (simp add: add_ac)
105.98 + from x show "x - x = 0" by simp
105.99 + from x show "0 + x = x" by simp
105.100 + from x y show "a \<cdot> (x + y) = a \<cdot> x + a \<cdot> y" by (simp add: distrib)
105.101 + from x show "(a + b) \<cdot> x = a \<cdot> x + b \<cdot> x" by (simp add: distrib)
105.102 + from x show "(a * b) \<cdot> x = a \<cdot> b \<cdot> x" by (simp add: mult_assoc)
105.103 + from x show "1 \<cdot> x = x" by simp
105.104 + from x show "- x = - 1 \<cdot> x" by (simp add: negate_eq1)
105.105 + from x y show "x - y = x + - y" by (simp add: diff_eq1)
105.106 + qed
105.107 +qed
105.108 +
105.109 +
105.110 +text {* The subspace relation is reflexive. *}
105.111 +
105.112 +lemma (in vectorspace) subspace_refl [intro]: "V \<unlhd> V"
105.113 +proof
105.114 + show "V \<noteq> {}" ..
105.115 + show "V \<subseteq> V" ..
105.116 + fix x y assume x: "x \<in> V" and y: "y \<in> V"
105.117 + fix a :: real
105.118 + from x y show "x + y \<in> V" by simp
105.119 + from x show "a \<cdot> x \<in> V" by simp
105.120 +qed
105.121 +
105.122 +text {* The subspace relation is transitive. *}
105.123 +
105.124 +lemma (in vectorspace) subspace_trans [trans]:
105.125 + "U \<unlhd> V \<Longrightarrow> V \<unlhd> W \<Longrightarrow> U \<unlhd> W"
105.126 +proof
105.127 + assume uv: "U \<unlhd> V" and vw: "V \<unlhd> W"
105.128 + from uv show "U \<noteq> {}" by (rule subspace.non_empty)
105.129 + show "U \<subseteq> W"
105.130 + proof -
105.131 + from uv have "U \<subseteq> V" by (rule subspace.subset)
105.132 + also from vw have "V \<subseteq> W" by (rule subspace.subset)
105.133 + finally show ?thesis .
105.134 + qed
105.135 + fix x y assume x: "x \<in> U" and y: "y \<in> U"
105.136 + from uv and x y show "x + y \<in> U" by (rule subspace.add_closed)
105.137 + from uv and x show "\<And>a. a \<cdot> x \<in> U" by (rule subspace.mult_closed)
105.138 +qed
105.139 +
105.140 +
105.141 +subsection {* Linear closure *}
105.142 +
105.143 +text {*
105.144 + The \emph{linear closure} of a vector @{text x} is the set of all
105.145 + scalar multiples of @{text x}.
105.146 +*}
105.147 +
105.148 +definition
105.149 + lin :: "('a::{minus, plus, zero}) \<Rightarrow> 'a set" where
105.150 + "lin x = {a \<cdot> x | a. True}"
105.151 +
105.152 +lemma linI [intro]: "y = a \<cdot> x \<Longrightarrow> y \<in> lin x"
105.153 + unfolding lin_def by blast
105.154 +
105.155 +lemma linI' [iff]: "a \<cdot> x \<in> lin x"
105.156 + unfolding lin_def by blast
105.157 +
105.158 +lemma linE [elim]: "x \<in> lin v \<Longrightarrow> (\<And>a::real. x = a \<cdot> v \<Longrightarrow> C) \<Longrightarrow> C"
105.159 + unfolding lin_def by blast
105.160 +
105.161 +
105.162 +text {* Every vector is contained in its linear closure. *}
105.163 +
105.164 +lemma (in vectorspace) x_lin_x [iff]: "x \<in> V \<Longrightarrow> x \<in> lin x"
105.165 +proof -
105.166 + assume "x \<in> V"
105.167 + then have "x = 1 \<cdot> x" by simp
105.168 + also have "\<dots> \<in> lin x" ..
105.169 + finally show ?thesis .
105.170 +qed
105.171 +
105.172 +lemma (in vectorspace) "0_lin_x" [iff]: "x \<in> V \<Longrightarrow> 0 \<in> lin x"
105.173 +proof
105.174 + assume "x \<in> V"
105.175 + then show "0 = 0 \<cdot> x" by simp
105.176 +qed
105.177 +
105.178 +text {* Any linear closure is a subspace. *}
105.179 +
105.180 +lemma (in vectorspace) lin_subspace [intro]:
105.181 + "x \<in> V \<Longrightarrow> lin x \<unlhd> V"
105.182 +proof
105.183 + assume x: "x \<in> V"
105.184 + then show "lin x \<noteq> {}" by (auto simp add: x_lin_x)
105.185 + show "lin x \<subseteq> V"
105.186 + proof
105.187 + fix x' assume "x' \<in> lin x"
105.188 + then obtain a where "x' = a \<cdot> x" ..
105.189 + with x show "x' \<in> V" by simp
105.190 + qed
105.191 + fix x' x'' assume x': "x' \<in> lin x" and x'': "x'' \<in> lin x"
105.192 + show "x' + x'' \<in> lin x"
105.193 + proof -
105.194 + from x' obtain a' where "x' = a' \<cdot> x" ..
105.195 + moreover from x'' obtain a'' where "x'' = a'' \<cdot> x" ..
105.196 + ultimately have "x' + x'' = (a' + a'') \<cdot> x"
105.197 + using x by (simp add: distrib)
105.198 + also have "\<dots> \<in> lin x" ..
105.199 + finally show ?thesis .
105.200 + qed
105.201 + fix a :: real
105.202 + show "a \<cdot> x' \<in> lin x"
105.203 + proof -
105.204 + from x' obtain a' where "x' = a' \<cdot> x" ..
105.205 + with x have "a \<cdot> x' = (a * a') \<cdot> x" by (simp add: mult_assoc)
105.206 + also have "\<dots> \<in> lin x" ..
105.207 + finally show ?thesis .
105.208 + qed
105.209 +qed
105.210 +
105.211 +
105.212 +text {* Any linear closure is a vector space. *}
105.213 +
105.214 +lemma (in vectorspace) lin_vectorspace [intro]:
105.215 + assumes "x \<in> V"
105.216 + shows "vectorspace (lin x)"
105.217 +proof -
105.218 + from `x \<in> V` have "subspace (lin x) V"
105.219 + by (rule lin_subspace)
105.220 + from this and vectorspace_axioms show ?thesis
105.221 + by (rule subspace.vectorspace)
105.222 +qed
105.223 +
105.224 +
105.225 +subsection {* Sum of two vectorspaces *}
105.226 +
105.227 +text {*
105.228 + The \emph{sum} of two vectorspaces @{text U} and @{text V} is the
105.229 + set of all sums of elements from @{text U} and @{text V}.
105.230 +*}
105.231 +
105.232 +instantiation "fun" :: (type, type) plus
105.233 +begin
105.234 +
105.235 +definition
105.236 + sum_def: "plus_fun U V = {u + v | u v. u \<in> U \<and> v \<in> V}" (* FIXME not fully general!? *)
105.237 +
105.238 +instance ..
105.239 +
105.240 +end
105.241 +
105.242 +lemma sumE [elim]:
105.243 + "x \<in> U + V \<Longrightarrow> (\<And>u v. x = u + v \<Longrightarrow> u \<in> U \<Longrightarrow> v \<in> V \<Longrightarrow> C) \<Longrightarrow> C"
105.244 + unfolding sum_def by blast
105.245 +
105.246 +lemma sumI [intro]:
105.247 + "u \<in> U \<Longrightarrow> v \<in> V \<Longrightarrow> x = u + v \<Longrightarrow> x \<in> U + V"
105.248 + unfolding sum_def by blast
105.249 +
105.250 +lemma sumI' [intro]:
105.251 + "u \<in> U \<Longrightarrow> v \<in> V \<Longrightarrow> u + v \<in> U + V"
105.252 + unfolding sum_def by blast
105.253 +
105.254 +text {* @{text U} is a subspace of @{text "U + V"}. *}
105.255 +
105.256 +lemma subspace_sum1 [iff]:
105.257 + assumes "vectorspace U" "vectorspace V"
105.258 + shows "U \<unlhd> U + V"
105.259 +proof -
105.260 + interpret vectorspace U by fact
105.261 + interpret vectorspace V by fact
105.262 + show ?thesis
105.263 + proof
105.264 + show "U \<noteq> {}" ..
105.265 + show "U \<subseteq> U + V"
105.266 + proof
105.267 + fix x assume x: "x \<in> U"
105.268 + moreover have "0 \<in> V" ..
105.269 + ultimately have "x + 0 \<in> U + V" ..
105.270 + with x show "x \<in> U + V" by simp
105.271 + qed
105.272 + fix x y assume x: "x \<in> U" and "y \<in> U"
105.273 + then show "x + y \<in> U" by simp
105.274 + from x show "\<And>a. a \<cdot> x \<in> U" by simp
105.275 + qed
105.276 +qed
105.277 +
105.278 +text {* The sum of two subspaces is again a subspace. *}
105.279 +
105.280 +lemma sum_subspace [intro?]:
105.281 + assumes "subspace U E" "vectorspace E" "subspace V E"
105.282 + shows "U + V \<unlhd> E"
105.283 +proof -
105.284 + interpret subspace U E by fact
105.285 + interpret vectorspace E by fact
105.286 + interpret subspace V E by fact
105.287 + show ?thesis
105.288 + proof
105.289 + have "0 \<in> U + V"
105.290 + proof
105.291 + show "0 \<in> U" using `vectorspace E` ..
105.292 + show "0 \<in> V" using `vectorspace E` ..
105.293 + show "(0::'a) = 0 + 0" by simp
105.294 + qed
105.295 + then show "U + V \<noteq> {}" by blast
105.296 + show "U + V \<subseteq> E"
105.297 + proof
105.298 + fix x assume "x \<in> U + V"
105.299 + then obtain u v where "x = u + v" and
105.300 + "u \<in> U" and "v \<in> V" ..
105.301 + then show "x \<in> E" by simp
105.302 + qed
105.303 + fix x y assume x: "x \<in> U + V" and y: "y \<in> U + V"
105.304 + show "x + y \<in> U + V"
105.305 + proof -
105.306 + from x obtain ux vx where "x = ux + vx" and "ux \<in> U" and "vx \<in> V" ..
105.307 + moreover
105.308 + from y obtain uy vy where "y = uy + vy" and "uy \<in> U" and "vy \<in> V" ..
105.309 + ultimately
105.310 + have "ux + uy \<in> U"
105.311 + and "vx + vy \<in> V"
105.312 + and "x + y = (ux + uy) + (vx + vy)"
105.313 + using x y by (simp_all add: add_ac)
105.314 + then show ?thesis ..
105.315 + qed
105.316 + fix a show "a \<cdot> x \<in> U + V"
105.317 + proof -
105.318 + from x obtain u v where "x = u + v" and "u \<in> U" and "v \<in> V" ..
105.319 + then have "a \<cdot> u \<in> U" and "a \<cdot> v \<in> V"
105.320 + and "a \<cdot> x = (a \<cdot> u) + (a \<cdot> v)" by (simp_all add: distrib)
105.321 + then show ?thesis ..
105.322 + qed
105.323 + qed
105.324 +qed
105.325 +
105.326 +text{* The sum of two subspaces is a vectorspace. *}
105.327 +
105.328 +lemma sum_vs [intro?]:
105.329 + "U \<unlhd> E \<Longrightarrow> V \<unlhd> E \<Longrightarrow> vectorspace E \<Longrightarrow> vectorspace (U + V)"
105.330 + by (rule subspace.vectorspace) (rule sum_subspace)
105.331 +
105.332 +
105.333 +subsection {* Direct sums *}
105.334 +
105.335 +text {*
105.336 + The sum of @{text U} and @{text V} is called \emph{direct}, iff the
105.337 + zero element is the only common element of @{text U} and @{text
105.338 + V}. For every element @{text x} of the direct sum of @{text U} and
105.339 + @{text V} the decomposition in @{text "x = u + v"} with
105.340 + @{text "u \<in> U"} and @{text "v \<in> V"} is unique.
105.341 +*}
105.342 +
105.343 +lemma decomp:
105.344 + assumes "vectorspace E" "subspace U E" "subspace V E"
105.345 + assumes direct: "U \<inter> V = {0}"
105.346 + and u1: "u1 \<in> U" and u2: "u2 \<in> U"
105.347 + and v1: "v1 \<in> V" and v2: "v2 \<in> V"
105.348 + and sum: "u1 + v1 = u2 + v2"
105.349 + shows "u1 = u2 \<and> v1 = v2"
105.350 +proof -
105.351 + interpret vectorspace E by fact
105.352 + interpret subspace U E by fact
105.353 + interpret subspace V E by fact
105.354 + show ?thesis
105.355 + proof
105.356 + have U: "vectorspace U" (* FIXME: use interpret *)
105.357 + using `subspace U E` `vectorspace E` by (rule subspace.vectorspace)
105.358 + have V: "vectorspace V"
105.359 + using `subspace V E` `vectorspace E` by (rule subspace.vectorspace)
105.360 + from u1 u2 v1 v2 and sum have eq: "u1 - u2 = v2 - v1"
105.361 + by (simp add: add_diff_swap)
105.362 + from u1 u2 have u: "u1 - u2 \<in> U"
105.363 + by (rule vectorspace.diff_closed [OF U])
105.364 + with eq have v': "v2 - v1 \<in> U" by (simp only:)
105.365 + from v2 v1 have v: "v2 - v1 \<in> V"
105.366 + by (rule vectorspace.diff_closed [OF V])
105.367 + with eq have u': " u1 - u2 \<in> V" by (simp only:)
105.368 +
105.369 + show "u1 = u2"
105.370 + proof (rule add_minus_eq)
105.371 + from u1 show "u1 \<in> E" ..
105.372 + from u2 show "u2 \<in> E" ..
105.373 + from u u' and direct show "u1 - u2 = 0" by blast
105.374 + qed
105.375 + show "v1 = v2"
105.376 + proof (rule add_minus_eq [symmetric])
105.377 + from v1 show "v1 \<in> E" ..
105.378 + from v2 show "v2 \<in> E" ..
105.379 + from v v' and direct show "v2 - v1 = 0" by blast
105.380 + qed
105.381 + qed
105.382 +qed
105.383 +
105.384 +text {*
105.385 + An application of the previous lemma will be used in the proof of
105.386 + the Hahn-Banach Theorem (see page \pageref{decomp-H-use}): for any
105.387 + element @{text "y + a \<cdot> x\<^sub>0"} of the direct sum of a
105.388 + vectorspace @{text H} and the linear closure of @{text "x\<^sub>0"}
105.389 + the components @{text "y \<in> H"} and @{text a} are uniquely
105.390 + determined.
105.391 +*}
105.392 +
105.393 +lemma decomp_H':
105.394 + assumes "vectorspace E" "subspace H E"
105.395 + assumes y1: "y1 \<in> H" and y2: "y2 \<in> H"
105.396 + and x': "x' \<notin> H" "x' \<in> E" "x' \<noteq> 0"
105.397 + and eq: "y1 + a1 \<cdot> x' = y2 + a2 \<cdot> x'"
105.398 + shows "y1 = y2 \<and> a1 = a2"
105.399 +proof -
105.400 + interpret vectorspace E by fact
105.401 + interpret subspace H E by fact
105.402 + show ?thesis
105.403 + proof
105.404 + have c: "y1 = y2 \<and> a1 \<cdot> x' = a2 \<cdot> x'"
105.405 + proof (rule decomp)
105.406 + show "a1 \<cdot> x' \<in> lin x'" ..
105.407 + show "a2 \<cdot> x' \<in> lin x'" ..
105.408 + show "H \<inter> lin x' = {0}"
105.409 + proof
105.410 + show "H \<inter> lin x' \<subseteq> {0}"
105.411 + proof
105.412 + fix x assume x: "x \<in> H \<inter> lin x'"
105.413 + then obtain a where xx': "x = a \<cdot> x'"
105.414 + by blast
105.415 + have "x = 0"
105.416 + proof cases
105.417 + assume "a = 0"
105.418 + with xx' and x' show ?thesis by simp
105.419 + next
105.420 + assume a: "a \<noteq> 0"
105.421 + from x have "x \<in> H" ..
105.422 + with xx' have "inverse a \<cdot> a \<cdot> x' \<in> H" by simp
105.423 + with a and x' have "x' \<in> H" by (simp add: mult_assoc2)
105.424 + with `x' \<notin> H` show ?thesis by contradiction
105.425 + qed
105.426 + then show "x \<in> {0}" ..
105.427 + qed
105.428 + show "{0} \<subseteq> H \<inter> lin x'"
105.429 + proof -
105.430 + have "0 \<in> H" using `vectorspace E` ..
105.431 + moreover have "0 \<in> lin x'" using `x' \<in> E` ..
105.432 + ultimately show ?thesis by blast
105.433 + qed
105.434 + qed
105.435 + show "lin x' \<unlhd> E" using `x' \<in> E` ..
105.436 + qed (rule `vectorspace E`, rule `subspace H E`, rule y1, rule y2, rule eq)
105.437 + then show "y1 = y2" ..
105.438 + from c have "a1 \<cdot> x' = a2 \<cdot> x'" ..
105.439 + with x' show "a1 = a2" by (simp add: mult_right_cancel)
105.440 + qed
105.441 +qed
105.442 +
105.443 +text {*
105.444 + Since for any element @{text "y + a \<cdot> x'"} of the direct sum of a
105.445 + vectorspace @{text H} and the linear closure of @{text x'} the
105.446 + components @{text "y \<in> H"} and @{text a} are unique, it follows from
105.447 + @{text "y \<in> H"} that @{text "a = 0"}.
105.448 +*}
105.449 +
105.450 +lemma decomp_H'_H:
105.451 + assumes "vectorspace E" "subspace H E"
105.452 + assumes t: "t \<in> H"
105.453 + and x': "x' \<notin> H" "x' \<in> E" "x' \<noteq> 0"
105.454 + shows "(SOME (y, a). t = y + a \<cdot> x' \<and> y \<in> H) = (t, 0)"
105.455 +proof -
105.456 + interpret vectorspace E by fact
105.457 + interpret subspace H E by fact
105.458 + show ?thesis
105.459 + proof (rule, simp_all only: split_paired_all split_conv)
105.460 + from t x' show "t = t + 0 \<cdot> x' \<and> t \<in> H" by simp
105.461 + fix y and a assume ya: "t = y + a \<cdot> x' \<and> y \<in> H"
105.462 + have "y = t \<and> a = 0"
105.463 + proof (rule decomp_H')
105.464 + from ya x' show "y + a \<cdot> x' = t + 0 \<cdot> x'" by simp
105.465 + from ya show "y \<in> H" ..
105.466 + qed (rule `vectorspace E`, rule `subspace H E`, rule t, (rule x')+)
105.467 + with t x' show "(y, a) = (y + a \<cdot> x', 0)" by simp
105.468 + qed
105.469 +qed
105.470 +
105.471 +text {*
105.472 + The components @{text "y \<in> H"} and @{text a} in @{text "y + a \<cdot> x'"}
105.473 + are unique, so the function @{text h'} defined by
105.474 + @{text "h' (y + a \<cdot> x') = h y + a \<cdot> \<xi>"} is definite.
105.475 +*}
105.476 +
105.477 +lemma h'_definite:
105.478 + fixes H
105.479 + assumes h'_def:
105.480 + "h' \<equiv> (\<lambda>x. let (y, a) = SOME (y, a). (x = y + a \<cdot> x' \<and> y \<in> H)
105.481 + in (h y) + a * xi)"
105.482 + and x: "x = y + a \<cdot> x'"
105.483 + assumes "vectorspace E" "subspace H E"
105.484 + assumes y: "y \<in> H"
105.485 + and x': "x' \<notin> H" "x' \<in> E" "x' \<noteq> 0"
105.486 + shows "h' x = h y + a * xi"
105.487 +proof -
105.488 + interpret vectorspace E by fact
105.489 + interpret subspace H E by fact
105.490 + from x y x' have "x \<in> H + lin x'" by auto
105.491 + have "\<exists>!p. (\<lambda>(y, a). x = y + a \<cdot> x' \<and> y \<in> H) p" (is "\<exists>!p. ?P p")
105.492 + proof (rule ex_ex1I)
105.493 + from x y show "\<exists>p. ?P p" by blast
105.494 + fix p q assume p: "?P p" and q: "?P q"
105.495 + show "p = q"
105.496 + proof -
105.497 + from p have xp: "x = fst p + snd p \<cdot> x' \<and> fst p \<in> H"
105.498 + by (cases p) simp
105.499 + from q have xq: "x = fst q + snd q \<cdot> x' \<and> fst q \<in> H"
105.500 + by (cases q) simp
105.501 + have "fst p = fst q \<and> snd p = snd q"
105.502 + proof (rule decomp_H')
105.503 + from xp show "fst p \<in> H" ..
105.504 + from xq show "fst q \<in> H" ..
105.505 + from xp and xq show "fst p + snd p \<cdot> x' = fst q + snd q \<cdot> x'"
105.506 + by simp
105.507 + qed (rule `vectorspace E`, rule `subspace H E`, (rule x')+)
105.508 + then show ?thesis by (cases p, cases q) simp
105.509 + qed
105.510 + qed
105.511 + then have eq: "(SOME (y, a). x = y + a \<cdot> x' \<and> y \<in> H) = (y, a)"
105.512 + by (rule some1_equality) (simp add: x y)
105.513 + with h'_def show "h' x = h y + a * xi" by (simp add: Let_def)
105.514 +qed
105.515 +
105.516 +end
106.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
106.2 +++ b/src/HOL/HahnBanach/VectorSpace.thy Tue Dec 30 11:10:01 2008 +0100
106.3 @@ -0,0 +1,419 @@
106.4 +(* Title: HOL/Real/HahnBanach/VectorSpace.thy
106.5 + ID: $Id$
106.6 + Author: Gertrud Bauer, TU Munich
106.7 +*)
106.8 +
106.9 +header {* Vector spaces *}
106.10 +
106.11 +theory VectorSpace
106.12 +imports Real Bounds Zorn
106.13 +begin
106.14 +
106.15 +subsection {* Signature *}
106.16 +
106.17 +text {*
106.18 + For the definition of real vector spaces a type @{typ 'a} of the
106.19 + sort @{text "{plus, minus, zero}"} is considered, on which a real
106.20 + scalar multiplication @{text \<cdot>} is declared.
106.21 +*}
106.22 +
106.23 +consts
106.24 + prod :: "real \<Rightarrow> 'a::{plus, minus, zero} \<Rightarrow> 'a" (infixr "'(*')" 70)
106.25 +
106.26 +notation (xsymbols)
106.27 + prod (infixr "\<cdot>" 70)
106.28 +notation (HTML output)
106.29 + prod (infixr "\<cdot>" 70)
106.30 +
106.31 +
106.32 +subsection {* Vector space laws *}
106.33 +
106.34 +text {*
106.35 + A \emph{vector space} is a non-empty set @{text V} of elements from
106.36 + @{typ 'a} with the following vector space laws: The set @{text V} is
106.37 + closed under addition and scalar multiplication, addition is
106.38 + associative and commutative; @{text "- x"} is the inverse of @{text
106.39 + x} w.~r.~t.~addition and @{text 0} is the neutral element of
106.40 + addition. Addition and multiplication are distributive; scalar
106.41 + multiplication is associative and the real number @{text "1"} is
106.42 + the neutral element of scalar multiplication.
106.43 +*}
106.44 +
106.45 +locale var_V = fixes V
106.46 +
106.47 +locale vectorspace = var_V +
106.48 + assumes non_empty [iff, intro?]: "V \<noteq> {}"
106.49 + and add_closed [iff]: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x + y \<in> V"
106.50 + and mult_closed [iff]: "x \<in> V \<Longrightarrow> a \<cdot> x \<in> V"
106.51 + and add_assoc: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> z \<in> V \<Longrightarrow> (x + y) + z = x + (y + z)"
106.52 + and add_commute: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x + y = y + x"
106.53 + and diff_self [simp]: "x \<in> V \<Longrightarrow> x - x = 0"
106.54 + and add_zero_left [simp]: "x \<in> V \<Longrightarrow> 0 + x = x"
106.55 + and add_mult_distrib1: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> a \<cdot> (x + y) = a \<cdot> x + a \<cdot> y"
106.56 + and add_mult_distrib2: "x \<in> V \<Longrightarrow> (a + b) \<cdot> x = a \<cdot> x + b \<cdot> x"
106.57 + and mult_assoc: "x \<in> V \<Longrightarrow> (a * b) \<cdot> x = a \<cdot> (b \<cdot> x)"
106.58 + and mult_1 [simp]: "x \<in> V \<Longrightarrow> 1 \<cdot> x = x"
106.59 + and negate_eq1: "x \<in> V \<Longrightarrow> - x = (- 1) \<cdot> x"
106.60 + and diff_eq1: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x - y = x + - y"
106.61 +
106.62 +lemma (in vectorspace) negate_eq2: "x \<in> V \<Longrightarrow> (- 1) \<cdot> x = - x"
106.63 + by (rule negate_eq1 [symmetric])
106.64 +
106.65 +lemma (in vectorspace) negate_eq2a: "x \<in> V \<Longrightarrow> -1 \<cdot> x = - x"
106.66 + by (simp add: negate_eq1)
106.67 +
106.68 +lemma (in vectorspace) diff_eq2: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x + - y = x - y"
106.69 + by (rule diff_eq1 [symmetric])
106.70 +
106.71 +lemma (in vectorspace) diff_closed [iff]: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x - y \<in> V"
106.72 + by (simp add: diff_eq1 negate_eq1)
106.73 +
106.74 +lemma (in vectorspace) neg_closed [iff]: "x \<in> V \<Longrightarrow> - x \<in> V"
106.75 + by (simp add: negate_eq1)
106.76 +
106.77 +lemma (in vectorspace) add_left_commute:
106.78 + "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> z \<in> V \<Longrightarrow> x + (y + z) = y + (x + z)"
106.79 +proof -
106.80 + assume xyz: "x \<in> V" "y \<in> V" "z \<in> V"
106.81 + then have "x + (y + z) = (x + y) + z"
106.82 + by (simp only: add_assoc)
106.83 + also from xyz have "\<dots> = (y + x) + z" by (simp only: add_commute)
106.84 + also from xyz have "\<dots> = y + (x + z)" by (simp only: add_assoc)
106.85 + finally show ?thesis .
106.86 +qed
106.87 +
106.88 +theorems (in vectorspace) add_ac =
106.89 + add_assoc add_commute add_left_commute
106.90 +
106.91 +
106.92 +text {* The existence of the zero element of a vector space
106.93 + follows from the non-emptiness of carrier set. *}
106.94 +
106.95 +lemma (in vectorspace) zero [iff]: "0 \<in> V"
106.96 +proof -
106.97 + from non_empty obtain x where x: "x \<in> V" by blast
106.98 + then have "0 = x - x" by (rule diff_self [symmetric])
106.99 + also from x x have "\<dots> \<in> V" by (rule diff_closed)
106.100 + finally show ?thesis .
106.101 +qed
106.102 +
106.103 +lemma (in vectorspace) add_zero_right [simp]:
106.104 + "x \<in> V \<Longrightarrow> x + 0 = x"
106.105 +proof -
106.106 + assume x: "x \<in> V"
106.107 + from this and zero have "x + 0 = 0 + x" by (rule add_commute)
106.108 + also from x have "\<dots> = x" by (rule add_zero_left)
106.109 + finally show ?thesis .
106.110 +qed
106.111 +
106.112 +lemma (in vectorspace) mult_assoc2:
106.113 + "x \<in> V \<Longrightarrow> a \<cdot> b \<cdot> x = (a * b) \<cdot> x"
106.114 + by (simp only: mult_assoc)
106.115 +
106.116 +lemma (in vectorspace) diff_mult_distrib1:
106.117 + "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> a \<cdot> (x - y) = a \<cdot> x - a \<cdot> y"
106.118 + by (simp add: diff_eq1 negate_eq1 add_mult_distrib1 mult_assoc2)
106.119 +
106.120 +lemma (in vectorspace) diff_mult_distrib2:
106.121 + "x \<in> V \<Longrightarrow> (a - b) \<cdot> x = a \<cdot> x - (b \<cdot> x)"
106.122 +proof -
106.123 + assume x: "x \<in> V"
106.124 + have " (a - b) \<cdot> x = (a + - b) \<cdot> x"
106.125 + by (simp add: real_diff_def)
106.126 + also from x have "\<dots> = a \<cdot> x + (- b) \<cdot> x"
106.127 + by (rule add_mult_distrib2)
106.128 + also from x have "\<dots> = a \<cdot> x + - (b \<cdot> x)"
106.129 + by (simp add: negate_eq1 mult_assoc2)
106.130 + also from x have "\<dots> = a \<cdot> x - (b \<cdot> x)"
106.131 + by (simp add: diff_eq1)
106.132 + finally show ?thesis .
106.133 +qed
106.134 +
106.135 +lemmas (in vectorspace) distrib =
106.136 + add_mult_distrib1 add_mult_distrib2
106.137 + diff_mult_distrib1 diff_mult_distrib2
106.138 +
106.139 +
106.140 +text {* \medskip Further derived laws: *}
106.141 +
106.142 +lemma (in vectorspace) mult_zero_left [simp]:
106.143 + "x \<in> V \<Longrightarrow> 0 \<cdot> x = 0"
106.144 +proof -
106.145 + assume x: "x \<in> V"
106.146 + have "0 \<cdot> x = (1 - 1) \<cdot> x" by simp
106.147 + also have "\<dots> = (1 + - 1) \<cdot> x" by simp
106.148 + also from x have "\<dots> = 1 \<cdot> x + (- 1) \<cdot> x"
106.149 + by (rule add_mult_distrib2)
106.150 + also from x have "\<dots> = x + (- 1) \<cdot> x" by simp
106.151 + also from x have "\<dots> = x + - x" by (simp add: negate_eq2a)
106.152 + also from x have "\<dots> = x - x" by (simp add: diff_eq2)
106.153 + also from x have "\<dots> = 0" by simp
106.154 + finally show ?thesis .
106.155 +qed
106.156 +
106.157 +lemma (in vectorspace) mult_zero_right [simp]:
106.158 + "a \<cdot> 0 = (0::'a)"
106.159 +proof -
106.160 + have "a \<cdot> 0 = a \<cdot> (0 - (0::'a))" by simp
106.161 + also have "\<dots> = a \<cdot> 0 - a \<cdot> 0"
106.162 + by (rule diff_mult_distrib1) simp_all
106.163 + also have "\<dots> = 0" by simp
106.164 + finally show ?thesis .
106.165 +qed
106.166 +
106.167 +lemma (in vectorspace) minus_mult_cancel [simp]:
106.168 + "x \<in> V \<Longrightarrow> (- a) \<cdot> - x = a \<cdot> x"
106.169 + by (simp add: negate_eq1 mult_assoc2)
106.170 +
106.171 +lemma (in vectorspace) add_minus_left_eq_diff:
106.172 + "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> - x + y = y - x"
106.173 +proof -
106.174 + assume xy: "x \<in> V" "y \<in> V"
106.175 + then have "- x + y = y + - x" by (simp add: add_commute)
106.176 + also from xy have "\<dots> = y - x" by (simp add: diff_eq1)
106.177 + finally show ?thesis .
106.178 +qed
106.179 +
106.180 +lemma (in vectorspace) add_minus [simp]:
106.181 + "x \<in> V \<Longrightarrow> x + - x = 0"
106.182 + by (simp add: diff_eq2)
106.183 +
106.184 +lemma (in vectorspace) add_minus_left [simp]:
106.185 + "x \<in> V \<Longrightarrow> - x + x = 0"
106.186 + by (simp add: diff_eq2 add_commute)
106.187 +
106.188 +lemma (in vectorspace) minus_minus [simp]:
106.189 + "x \<in> V \<Longrightarrow> - (- x) = x"
106.190 + by (simp add: negate_eq1 mult_assoc2)
106.191 +
106.192 +lemma (in vectorspace) minus_zero [simp]:
106.193 + "- (0::'a) = 0"
106.194 + by (simp add: negate_eq1)
106.195 +
106.196 +lemma (in vectorspace) minus_zero_iff [simp]:
106.197 + "x \<in> V \<Longrightarrow> (- x = 0) = (x = 0)"
106.198 +proof
106.199 + assume x: "x \<in> V"
106.200 + {
106.201 + from x have "x = - (- x)" by (simp add: minus_minus)
106.202 + also assume "- x = 0"
106.203 + also have "- \<dots> = 0" by (rule minus_zero)
106.204 + finally show "x = 0" .
106.205 + next
106.206 + assume "x = 0"
106.207 + then show "- x = 0" by simp
106.208 + }
106.209 +qed
106.210 +
106.211 +lemma (in vectorspace) add_minus_cancel [simp]:
106.212 + "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x + (- x + y) = y"
106.213 + by (simp add: add_assoc [symmetric] del: add_commute)
106.214 +
106.215 +lemma (in vectorspace) minus_add_cancel [simp]:
106.216 + "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> - x + (x + y) = y"
106.217 + by (simp add: add_assoc [symmetric] del: add_commute)
106.218 +
106.219 +lemma (in vectorspace) minus_add_distrib [simp]:
106.220 + "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> - (x + y) = - x + - y"
106.221 + by (simp add: negate_eq1 add_mult_distrib1)
106.222 +
106.223 +lemma (in vectorspace) diff_zero [simp]:
106.224 + "x \<in> V \<Longrightarrow> x - 0 = x"
106.225 + by (simp add: diff_eq1)
106.226 +
106.227 +lemma (in vectorspace) diff_zero_right [simp]:
106.228 + "x \<in> V \<Longrightarrow> 0 - x = - x"
106.229 + by (simp add: diff_eq1)
106.230 +
106.231 +lemma (in vectorspace) add_left_cancel:
106.232 + "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> z \<in> V \<Longrightarrow> (x + y = x + z) = (y = z)"
106.233 +proof
106.234 + assume x: "x \<in> V" and y: "y \<in> V" and z: "z \<in> V"
106.235 + {
106.236 + from y have "y = 0 + y" by simp
106.237 + also from x y have "\<dots> = (- x + x) + y" by simp
106.238 + also from x y have "\<dots> = - x + (x + y)"
106.239 + by (simp add: add_assoc neg_closed)
106.240 + also assume "x + y = x + z"
106.241 + also from x z have "- x + (x + z) = - x + x + z"
106.242 + by (simp add: add_assoc [symmetric] neg_closed)
106.243 + also from x z have "\<dots> = z" by simp
106.244 + finally show "y = z" .
106.245 + next
106.246 + assume "y = z"
106.247 + then show "x + y = x + z" by (simp only:)
106.248 + }
106.249 +qed
106.250 +
106.251 +lemma (in vectorspace) add_right_cancel:
106.252 + "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> z \<in> V \<Longrightarrow> (y + x = z + x) = (y = z)"
106.253 + by (simp only: add_commute add_left_cancel)
106.254 +
106.255 +lemma (in vectorspace) add_assoc_cong:
106.256 + "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x' \<in> V \<Longrightarrow> y' \<in> V \<Longrightarrow> z \<in> V
106.257 + \<Longrightarrow> x + y = x' + y' \<Longrightarrow> x + (y + z) = x' + (y' + z)"
106.258 + by (simp only: add_assoc [symmetric])
106.259 +
106.260 +lemma (in vectorspace) mult_left_commute:
106.261 + "x \<in> V \<Longrightarrow> a \<cdot> b \<cdot> x = b \<cdot> a \<cdot> x"
106.262 + by (simp add: real_mult_commute mult_assoc2)
106.263 +
106.264 +lemma (in vectorspace) mult_zero_uniq:
106.265 + "x \<in> V \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> a \<cdot> x = 0 \<Longrightarrow> a = 0"
106.266 +proof (rule classical)
106.267 + assume a: "a \<noteq> 0"
106.268 + assume x: "x \<in> V" "x \<noteq> 0" and ax: "a \<cdot> x = 0"
106.269 + from x a have "x = (inverse a * a) \<cdot> x" by simp
106.270 + also from `x \<in> V` have "\<dots> = inverse a \<cdot> (a \<cdot> x)" by (rule mult_assoc)
106.271 + also from ax have "\<dots> = inverse a \<cdot> 0" by simp
106.272 + also have "\<dots> = 0" by simp
106.273 + finally have "x = 0" .
106.274 + with `x \<noteq> 0` show "a = 0" by contradiction
106.275 +qed
106.276 +
106.277 +lemma (in vectorspace) mult_left_cancel:
106.278 + "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> a \<noteq> 0 \<Longrightarrow> (a \<cdot> x = a \<cdot> y) = (x = y)"
106.279 +proof
106.280 + assume x: "x \<in> V" and y: "y \<in> V" and a: "a \<noteq> 0"
106.281 + from x have "x = 1 \<cdot> x" by simp
106.282 + also from a have "\<dots> = (inverse a * a) \<cdot> x" by simp
106.283 + also from x have "\<dots> = inverse a \<cdot> (a \<cdot> x)"
106.284 + by (simp only: mult_assoc)
106.285 + also assume "a \<cdot> x = a \<cdot> y"
106.286 + also from a y have "inverse a \<cdot> \<dots> = y"
106.287 + by (simp add: mult_assoc2)
106.288 + finally show "x = y" .
106.289 +next
106.290 + assume "x = y"
106.291 + then show "a \<cdot> x = a \<cdot> y" by (simp only:)
106.292 +qed
106.293 +
106.294 +lemma (in vectorspace) mult_right_cancel:
106.295 + "x \<in> V \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> (a \<cdot> x = b \<cdot> x) = (a = b)"
106.296 +proof
106.297 + assume x: "x \<in> V" and neq: "x \<noteq> 0"
106.298 + {
106.299 + from x have "(a - b) \<cdot> x = a \<cdot> x - b \<cdot> x"
106.300 + by (simp add: diff_mult_distrib2)
106.301 + also assume "a \<cdot> x = b \<cdot> x"
106.302 + with x have "a \<cdot> x - b \<cdot> x = 0" by simp
106.303 + finally have "(a - b) \<cdot> x = 0" .
106.304 + with x neq have "a - b = 0" by (rule mult_zero_uniq)
106.305 + then show "a = b" by simp
106.306 + next
106.307 + assume "a = b"
106.308 + then show "a \<cdot> x = b \<cdot> x" by (simp only:)
106.309 + }
106.310 +qed
106.311 +
106.312 +lemma (in vectorspace) eq_diff_eq:
106.313 + "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> z \<in> V \<Longrightarrow> (x = z - y) = (x + y = z)"
106.314 +proof
106.315 + assume x: "x \<in> V" and y: "y \<in> V" and z: "z \<in> V"
106.316 + {
106.317 + assume "x = z - y"
106.318 + then have "x + y = z - y + y" by simp
106.319 + also from y z have "\<dots> = z + - y + y"
106.320 + by (simp add: diff_eq1)
106.321 + also have "\<dots> = z + (- y + y)"
106.322 + by (rule add_assoc) (simp_all add: y z)
106.323 + also from y z have "\<dots> = z + 0"
106.324 + by (simp only: add_minus_left)
106.325 + also from z have "\<dots> = z"
106.326 + by (simp only: add_zero_right)
106.327 + finally show "x + y = z" .
106.328 + next
106.329 + assume "x + y = z"
106.330 + then have "z - y = (x + y) - y" by simp
106.331 + also from x y have "\<dots> = x + y + - y"
106.332 + by (simp add: diff_eq1)
106.333 + also have "\<dots> = x + (y + - y)"
106.334 + by (rule add_assoc) (simp_all add: x y)
106.335 + also from x y have "\<dots> = x" by simp
106.336 + finally show "x = z - y" ..
106.337 + }
106.338 +qed
106.339 +
106.340 +lemma (in vectorspace) add_minus_eq_minus:
106.341 + "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x + y = 0 \<Longrightarrow> x = - y"
106.342 +proof -
106.343 + assume x: "x \<in> V" and y: "y \<in> V"
106.344 + from x y have "x = (- y + y) + x" by simp
106.345 + also from x y have "\<dots> = - y + (x + y)" by (simp add: add_ac)
106.346 + also assume "x + y = 0"
106.347 + also from y have "- y + 0 = - y" by simp
106.348 + finally show "x = - y" .
106.349 +qed
106.350 +
106.351 +lemma (in vectorspace) add_minus_eq:
106.352 + "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x - y = 0 \<Longrightarrow> x = y"
106.353 +proof -
106.354 + assume x: "x \<in> V" and y: "y \<in> V"
106.355 + assume "x - y = 0"
106.356 + with x y have eq: "x + - y = 0" by (simp add: diff_eq1)
106.357 + with _ _ have "x = - (- y)"
106.358 + by (rule add_minus_eq_minus) (simp_all add: x y)
106.359 + with x y show "x = y" by simp
106.360 +qed
106.361 +
106.362 +lemma (in vectorspace) add_diff_swap:
106.363 + "a \<in> V \<Longrightarrow> b \<in> V \<Longrightarrow> c \<in> V \<Longrightarrow> d \<in> V \<Longrightarrow> a + b = c + d
106.364 + \<Longrightarrow> a - c = d - b"
106.365 +proof -
106.366 + assume vs: "a \<in> V" "b \<in> V" "c \<in> V" "d \<in> V"
106.367 + and eq: "a + b = c + d"
106.368 + then have "- c + (a + b) = - c + (c + d)"
106.369 + by (simp add: add_left_cancel)
106.370 + also have "\<dots> = d" using `c \<in> V` `d \<in> V` by (rule minus_add_cancel)
106.371 + finally have eq: "- c + (a + b) = d" .
106.372 + from vs have "a - c = (- c + (a + b)) + - b"
106.373 + by (simp add: add_ac diff_eq1)
106.374 + also from vs eq have "\<dots> = d + - b"
106.375 + by (simp add: add_right_cancel)
106.376 + also from vs have "\<dots> = d - b" by (simp add: diff_eq2)
106.377 + finally show "a - c = d - b" .
106.378 +qed
106.379 +
106.380 +lemma (in vectorspace) vs_add_cancel_21:
106.381 + "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> z \<in> V \<Longrightarrow> u \<in> V
106.382 + \<Longrightarrow> (x + (y + z) = y + u) = (x + z = u)"
106.383 +proof
106.384 + assume vs: "x \<in> V" "y \<in> V" "z \<in> V" "u \<in> V"
106.385 + {
106.386 + from vs have "x + z = - y + y + (x + z)" by simp
106.387 + also have "\<dots> = - y + (y + (x + z))"
106.388 + by (rule add_assoc) (simp_all add: vs)
106.389 + also from vs have "y + (x + z) = x + (y + z)"
106.390 + by (simp add: add_ac)
106.391 + also assume "x + (y + z) = y + u"
106.392 + also from vs have "- y + (y + u) = u" by simp
106.393 + finally show "x + z = u" .
106.394 + next
106.395 + assume "x + z = u"
106.396 + with vs show "x + (y + z) = y + u"
106.397 + by (simp only: add_left_commute [of x])
106.398 + }
106.399 +qed
106.400 +
106.401 +lemma (in vectorspace) add_cancel_end:
106.402 + "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> z \<in> V \<Longrightarrow> (x + (y + z) = y) = (x = - z)"
106.403 +proof
106.404 + assume vs: "x \<in> V" "y \<in> V" "z \<in> V"
106.405 + {
106.406 + assume "x + (y + z) = y"
106.407 + with vs have "(x + z) + y = 0 + y"
106.408 + by (simp add: add_ac)
106.409 + with vs have "x + z = 0"
106.410 + by (simp only: add_right_cancel add_closed zero)
106.411 + with vs show "x = - z" by (simp add: add_minus_eq_minus)
106.412 + next
106.413 + assume eq: "x = - z"
106.414 + then have "x + (y + z) = - z + (y + z)" by simp
106.415 + also have "\<dots> = y + (- z + z)"
106.416 + by (rule add_left_commute) (simp_all add: vs)
106.417 + also from vs have "\<dots> = y" by simp
106.418 + finally show "x + (y + z) = y" .
106.419 + }
106.420 +qed
106.421 +
106.422 +end
107.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
107.2 +++ b/src/HOL/HahnBanach/ZornLemma.thy Tue Dec 30 11:10:01 2008 +0100
107.3 @@ -0,0 +1,57 @@
107.4 +(* Title: HOL/Real/HahnBanach/ZornLemma.thy
107.5 + Author: Gertrud Bauer, TU Munich
107.6 +*)
107.7 +
107.8 +header {* Zorn's Lemma *}
107.9 +
107.10 +theory ZornLemma
107.11 +imports Zorn
107.12 +begin
107.13 +
107.14 +text {*
107.15 + Zorn's Lemmas states: if every linear ordered subset of an ordered
107.16 + set @{text S} has an upper bound in @{text S}, then there exists a
107.17 + maximal element in @{text S}. In our application, @{text S} is a
107.18 + set of sets ordered by set inclusion. Since the union of a chain of
107.19 + sets is an upper bound for all elements of the chain, the conditions
107.20 + of Zorn's lemma can be modified: if @{text S} is non-empty, it
107.21 + suffices to show that for every non-empty chain @{text c} in @{text
107.22 + S} the union of @{text c} also lies in @{text S}.
107.23 +*}
107.24 +
107.25 +theorem Zorn's_Lemma:
107.26 + assumes r: "\<And>c. c \<in> chain S \<Longrightarrow> \<exists>x. x \<in> c \<Longrightarrow> \<Union>c \<in> S"
107.27 + and aS: "a \<in> S"
107.28 + shows "\<exists>y \<in> S. \<forall>z \<in> S. y \<subseteq> z \<longrightarrow> y = z"
107.29 +proof (rule Zorn_Lemma2)
107.30 + show "\<forall>c \<in> chain S. \<exists>y \<in> S. \<forall>z \<in> c. z \<subseteq> y"
107.31 + proof
107.32 + fix c assume "c \<in> chain S"
107.33 + show "\<exists>y \<in> S. \<forall>z \<in> c. z \<subseteq> y"
107.34 + proof cases
107.35 +
107.36 + txt {* If @{text c} is an empty chain, then every element in
107.37 + @{text S} is an upper bound of @{text c}. *}
107.38 +
107.39 + assume "c = {}"
107.40 + with aS show ?thesis by fast
107.41 +
107.42 + txt {* If @{text c} is non-empty, then @{text "\<Union>c"} is an upper
107.43 + bound of @{text c}, lying in @{text S}. *}
107.44 +
107.45 + next
107.46 + assume "c \<noteq> {}"
107.47 + show ?thesis
107.48 + proof
107.49 + show "\<forall>z \<in> c. z \<subseteq> \<Union>c" by fast
107.50 + show "\<Union>c \<in> S"
107.51 + proof (rule r)
107.52 + from `c \<noteq> {}` show "\<exists>x. x \<in> c" by fast
107.53 + show "c \<in> chain S" by fact
107.54 + qed
107.55 + qed
107.56 + qed
107.57 + qed
107.58 +qed
107.59 +
107.60 +end
108.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
108.2 +++ b/src/HOL/HahnBanach/document/root.bib Tue Dec 30 11:10:01 2008 +0100
108.3 @@ -0,0 +1,27 @@
108.4 +
108.5 +@Book{Heuser:1986,
108.6 + author = {H. Heuser},
108.7 + title = {Funktionalanalysis: Theorie und Anwendung},
108.8 + publisher = {Teubner},
108.9 + year = 1986
108.10 +}
108.11 +
108.12 +@InCollection{Narici:1996,
108.13 + author = {L. Narici and E. Beckenstein},
108.14 + title = {The {Hahn-Banach Theorem}: The Life and Times},
108.15 + booktitle = {Topology Atlas},
108.16 + publisher = {York University, Toronto, Ontario, Canada},
108.17 + year = 1996,
108.18 + note = {\url{http://at.yorku.ca/topology/preprint.htm} and
108.19 + \url{http://at.yorku.ca/p/a/a/a/16.htm}}
108.20 +}
108.21 +
108.22 +@Article{Nowak:1993,
108.23 + author = {B. Nowak and A. Trybulec},
108.24 + title = {{Hahn-Banach} Theorem},
108.25 + journal = {Journal of Formalized Mathematics},
108.26 + year = {1993},
108.27 + volume = {5},
108.28 + institution = {University of Bialystok},
108.29 + note = {\url{http://mizar.uwb.edu.pl/JFM/Vol5/hahnban.html}}
108.30 +}
109.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
109.2 +++ b/src/HOL/HahnBanach/document/root.tex Tue Dec 30 11:10:01 2008 +0100
109.3 @@ -0,0 +1,83 @@
109.4 +\documentclass[10pt,a4paper,twoside]{article}
109.5 +\usepackage{graphicx}
109.6 +\usepackage{latexsym,theorem}
109.7 +\usepackage{isabelle,isabellesym}
109.8 +\usepackage{pdfsetup} %last one!
109.9 +
109.10 +\isabellestyle{it}
109.11 +\urlstyle{rm}
109.12 +
109.13 +\newcommand{\isasymsup}{\isamath{\sup\,}}
109.14 +\newcommand{\skp}{\smallskip}
109.15 +
109.16 +
109.17 +\begin{document}
109.18 +
109.19 +\pagestyle{headings}
109.20 +\pagenumbering{arabic}
109.21 +
109.22 +\title{The Hahn-Banach Theorem \\ for Real Vector Spaces}
109.23 +\author{Gertrud Bauer \\ \url{http://www.in.tum.de/~bauerg/}}
109.24 +\maketitle
109.25 +
109.26 +\begin{abstract}
109.27 + The Hahn-Banach Theorem is one of the most fundamental results in functional
109.28 + analysis. We present a fully formal proof of two versions of the theorem,
109.29 + one for general linear spaces and another for normed spaces. This
109.30 + development is based on simply-typed classical set-theory, as provided by
109.31 + Isabelle/HOL.
109.32 +\end{abstract}
109.33 +
109.34 +
109.35 +\tableofcontents
109.36 +\parindent 0pt \parskip 0.5ex
109.37 +
109.38 +\clearpage
109.39 +\section{Preface}
109.40 +
109.41 +This is a fully formal proof of the Hahn-Banach Theorem. It closely follows
109.42 +the informal presentation given in Heuser's textbook \cite[{\S} 36]{Heuser:1986}.
109.43 +Another formal proof of the same theorem has been done in Mizar
109.44 +\cite{Nowak:1993}. A general overview of the relevance and history of the
109.45 +Hahn-Banach Theorem is given by Narici and Beckenstein \cite{Narici:1996}.
109.46 +
109.47 +\medskip The document is structured as follows. The first part contains
109.48 +definitions of basic notions of linear algebra: vector spaces, subspaces,
109.49 +normed spaces, continuous linear-forms, norm of functions and an order on
109.50 +functions by domain extension. The second part contains some lemmas about the
109.51 +supremum (w.r.t.\ the function order) and extension of non-maximal functions.
109.52 +With these preliminaries, the main proof of the theorem (in its two versions)
109.53 +is conducted in the third part. The dependencies of individual theories are
109.54 +as follows.
109.55 +
109.56 +\begin{center}
109.57 + \includegraphics[scale=0.5]{session_graph}
109.58 +\end{center}
109.59 +
109.60 +\clearpage
109.61 +\part {Basic Notions}
109.62 +
109.63 +\input{Bounds}
109.64 +\input{VectorSpace}
109.65 +\input{Subspace}
109.66 +\input{NormedSpace}
109.67 +\input{Linearform}
109.68 +\input{FunctionOrder}
109.69 +\input{FunctionNorm}
109.70 +\input{ZornLemma}
109.71 +
109.72 +\clearpage
109.73 +\part {Lemmas for the Proof}
109.74 +
109.75 +\input{HahnBanachSupLemmas}
109.76 +\input{HahnBanachExtLemmas}
109.77 +\input{HahnBanachLemmas}
109.78 +
109.79 +\clearpage
109.80 +\part {The Main Proof}
109.81 +
109.82 +\input{HahnBanach}
109.83 +\bibliographystyle{abbrv}
109.84 +\bibliography{root}
109.85 +
109.86 +\end{document}
110.1 --- a/src/HOL/Hyperreal/SEQ.thy Tue Dec 30 08:18:54 2008 +0100
110.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
110.3 @@ -1,1136 +0,0 @@
110.4 -(* Title : SEQ.thy
110.5 - Author : Jacques D. Fleuriot
110.6 - Copyright : 1998 University of Cambridge
110.7 - Description : Convergence of sequences and series
110.8 - Conversion to Isar and new proofs by Lawrence C Paulson, 2004
110.9 - Additional contributions by Jeremy Avigad and Brian Huffman
110.10 -*)
110.11 -
110.12 -header {* Sequences and Convergence *}
110.13 -
110.14 -theory SEQ
110.15 -imports "../Real/RealVector" "../RComplete"
110.16 -begin
110.17 -
110.18 -definition
110.19 - Zseq :: "[nat \<Rightarrow> 'a::real_normed_vector] \<Rightarrow> bool" where
110.20 - --{*Standard definition of sequence converging to zero*}
110.21 - [code del]: "Zseq X = (\<forall>r>0. \<exists>no. \<forall>n\<ge>no. norm (X n) < r)"
110.22 -
110.23 -definition
110.24 - LIMSEQ :: "[nat => 'a::real_normed_vector, 'a] => bool"
110.25 - ("((_)/ ----> (_))" [60, 60] 60) where
110.26 - --{*Standard definition of convergence of sequence*}
110.27 - [code del]: "X ----> L = (\<forall>r. 0 < r --> (\<exists>no. \<forall>n. no \<le> n --> norm (X n - L) < r))"
110.28 -
110.29 -definition
110.30 - lim :: "(nat => 'a::real_normed_vector) => 'a" where
110.31 - --{*Standard definition of limit using choice operator*}
110.32 - "lim X = (THE L. X ----> L)"
110.33 -
110.34 -definition
110.35 - convergent :: "(nat => 'a::real_normed_vector) => bool" where
110.36 - --{*Standard definition of convergence*}
110.37 - "convergent X = (\<exists>L. X ----> L)"
110.38 -
110.39 -definition
110.40 - Bseq :: "(nat => 'a::real_normed_vector) => bool" where
110.41 - --{*Standard definition for bounded sequence*}
110.42 - [code del]: "Bseq X = (\<exists>K>0.\<forall>n. norm (X n) \<le> K)"
110.43 -
110.44 -definition
110.45 - monoseq :: "(nat=>real)=>bool" where
110.46 - --{*Definition for monotonicity*}
110.47 - [code del]: "monoseq X = ((\<forall>m. \<forall>n\<ge>m. X m \<le> X n) | (\<forall>m. \<forall>n\<ge>m. X n \<le> X m))"
110.48 -
110.49 -definition
110.50 - subseq :: "(nat => nat) => bool" where
110.51 - --{*Definition of subsequence*}
110.52 - [code del]: "subseq f = (\<forall>m. \<forall>n>m. (f m) < (f n))"
110.53 -
110.54 -definition
110.55 - Cauchy :: "(nat => 'a::real_normed_vector) => bool" where
110.56 - --{*Standard definition of the Cauchy condition*}
110.57 - [code del]: "Cauchy X = (\<forall>e>0. \<exists>M. \<forall>m \<ge> M. \<forall>n \<ge> M. norm (X m - X n) < e)"
110.58 -
110.59 -
110.60 -subsection {* Bounded Sequences *}
110.61 -
110.62 -lemma BseqI': assumes K: "\<And>n. norm (X n) \<le> K" shows "Bseq X"
110.63 -unfolding Bseq_def
110.64 -proof (intro exI conjI allI)
110.65 - show "0 < max K 1" by simp
110.66 -next
110.67 - fix n::nat
110.68 - have "norm (X n) \<le> K" by (rule K)
110.69 - thus "norm (X n) \<le> max K 1" by simp
110.70 -qed
110.71 -
110.72 -lemma BseqE: "\<lbrakk>Bseq X; \<And>K. \<lbrakk>0 < K; \<forall>n. norm (X n) \<le> K\<rbrakk> \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
110.73 -unfolding Bseq_def by auto
110.74 -
110.75 -lemma BseqI2': assumes K: "\<forall>n\<ge>N. norm (X n) \<le> K" shows "Bseq X"
110.76 -proof (rule BseqI')
110.77 - let ?A = "norm ` X ` {..N}"
110.78 - have 1: "finite ?A" by simp
110.79 - fix n::nat
110.80 - show "norm (X n) \<le> max K (Max ?A)"
110.81 - proof (cases rule: linorder_le_cases)
110.82 - assume "n \<ge> N"
110.83 - hence "norm (X n) \<le> K" using K by simp
110.84 - thus "norm (X n) \<le> max K (Max ?A)" by simp
110.85 - next
110.86 - assume "n \<le> N"
110.87 - hence "norm (X n) \<in> ?A" by simp
110.88 - with 1 have "norm (X n) \<le> Max ?A" by (rule Max_ge)
110.89 - thus "norm (X n) \<le> max K (Max ?A)" by simp
110.90 - qed
110.91 -qed
110.92 -
110.93 -lemma Bseq_ignore_initial_segment: "Bseq X \<Longrightarrow> Bseq (\<lambda>n. X (n + k))"
110.94 -unfolding Bseq_def by auto
110.95 -
110.96 -lemma Bseq_offset: "Bseq (\<lambda>n. X (n + k)) \<Longrightarrow> Bseq X"
110.97 -apply (erule BseqE)
110.98 -apply (rule_tac N="k" and K="K" in BseqI2')
110.99 -apply clarify
110.100 -apply (drule_tac x="n - k" in spec, simp)
110.101 -done
110.102 -
110.103 -
110.104 -subsection {* Sequences That Converge to Zero *}
110.105 -
110.106 -lemma ZseqI:
110.107 - "(\<And>r. 0 < r \<Longrightarrow> \<exists>no. \<forall>n\<ge>no. norm (X n) < r) \<Longrightarrow> Zseq X"
110.108 -unfolding Zseq_def by simp
110.109 -
110.110 -lemma ZseqD:
110.111 - "\<lbrakk>Zseq X; 0 < r\<rbrakk> \<Longrightarrow> \<exists>no. \<forall>n\<ge>no. norm (X n) < r"
110.112 -unfolding Zseq_def by simp
110.113 -
110.114 -lemma Zseq_zero: "Zseq (\<lambda>n. 0)"
110.115 -unfolding Zseq_def by simp
110.116 -
110.117 -lemma Zseq_const_iff: "Zseq (\<lambda>n. k) = (k = 0)"
110.118 -unfolding Zseq_def by force
110.119 -
110.120 -lemma Zseq_norm_iff: "Zseq (\<lambda>n. norm (X n)) = Zseq (\<lambda>n. X n)"
110.121 -unfolding Zseq_def by simp
110.122 -
110.123 -lemma Zseq_imp_Zseq:
110.124 - assumes X: "Zseq X"
110.125 - assumes Y: "\<And>n. norm (Y n) \<le> norm (X n) * K"
110.126 - shows "Zseq (\<lambda>n. Y n)"
110.127 -proof (cases)
110.128 - assume K: "0 < K"
110.129 - show ?thesis
110.130 - proof (rule ZseqI)
110.131 - fix r::real assume "0 < r"
110.132 - hence "0 < r / K"
110.133 - using K by (rule divide_pos_pos)
110.134 - then obtain N where "\<forall>n\<ge>N. norm (X n) < r / K"
110.135 - using ZseqD [OF X] by fast
110.136 - hence "\<forall>n\<ge>N. norm (X n) * K < r"
110.137 - by (simp add: pos_less_divide_eq K)
110.138 - hence "\<forall>n\<ge>N. norm (Y n) < r"
110.139 - by (simp add: order_le_less_trans [OF Y])
110.140 - thus "\<exists>N. \<forall>n\<ge>N. norm (Y n) < r" ..
110.141 - qed
110.142 -next
110.143 - assume "\<not> 0 < K"
110.144 - hence K: "K \<le> 0" by (simp only: linorder_not_less)
110.145 - {
110.146 - fix n::nat
110.147 - have "norm (Y n) \<le> norm (X n) * K" by (rule Y)
110.148 - also have "\<dots> \<le> norm (X n) * 0"
110.149 - using K norm_ge_zero by (rule mult_left_mono)
110.150 - finally have "norm (Y n) = 0" by simp
110.151 - }
110.152 - thus ?thesis by (simp add: Zseq_zero)
110.153 -qed
110.154 -
110.155 -lemma Zseq_le: "\<lbrakk>Zseq Y; \<forall>n. norm (X n) \<le> norm (Y n)\<rbrakk> \<Longrightarrow> Zseq X"
110.156 -by (erule_tac K="1" in Zseq_imp_Zseq, simp)
110.157 -
110.158 -lemma Zseq_add:
110.159 - assumes X: "Zseq X"
110.160 - assumes Y: "Zseq Y"
110.161 - shows "Zseq (\<lambda>n. X n + Y n)"
110.162 -proof (rule ZseqI)
110.163 - fix r::real assume "0 < r"
110.164 - hence r: "0 < r / 2" by simp
110.165 - obtain M where M: "\<forall>n\<ge>M. norm (X n) < r/2"
110.166 - using ZseqD [OF X r] by fast
110.167 - obtain N where N: "\<forall>n\<ge>N. norm (Y n) < r/2"
110.168 - using ZseqD [OF Y r] by fast
110.169 - show "\<exists>N. \<forall>n\<ge>N. norm (X n + Y n) < r"
110.170 - proof (intro exI allI impI)
110.171 - fix n assume n: "max M N \<le> n"
110.172 - have "norm (X n + Y n) \<le> norm (X n) + norm (Y n)"
110.173 - by (rule norm_triangle_ineq)
110.174 - also have "\<dots> < r/2 + r/2"
110.175 - proof (rule add_strict_mono)
110.176 - from M n show "norm (X n) < r/2" by simp
110.177 - from N n show "norm (Y n) < r/2" by simp
110.178 - qed
110.179 - finally show "norm (X n + Y n) < r" by simp
110.180 - qed
110.181 -qed
110.182 -
110.183 -lemma Zseq_minus: "Zseq X \<Longrightarrow> Zseq (\<lambda>n. - X n)"
110.184 -unfolding Zseq_def by simp
110.185 -
110.186 -lemma Zseq_diff: "\<lbrakk>Zseq X; Zseq Y\<rbrakk> \<Longrightarrow> Zseq (\<lambda>n. X n - Y n)"
110.187 -by (simp only: diff_minus Zseq_add Zseq_minus)
110.188 -
110.189 -lemma (in bounded_linear) Zseq:
110.190 - assumes X: "Zseq X"
110.191 - shows "Zseq (\<lambda>n. f (X n))"
110.192 -proof -
110.193 - obtain K where "\<And>x. norm (f x) \<le> norm x * K"
110.194 - using bounded by fast
110.195 - with X show ?thesis
110.196 - by (rule Zseq_imp_Zseq)
110.197 -qed
110.198 -
110.199 -lemma (in bounded_bilinear) Zseq:
110.200 - assumes X: "Zseq X"
110.201 - assumes Y: "Zseq Y"
110.202 - shows "Zseq (\<lambda>n. X n ** Y n)"
110.203 -proof (rule ZseqI)
110.204 - fix r::real assume r: "0 < r"
110.205 - obtain K where K: "0 < K"
110.206 - and norm_le: "\<And>x y. norm (x ** y) \<le> norm x * norm y * K"
110.207 - using pos_bounded by fast
110.208 - from K have K': "0 < inverse K"
110.209 - by (rule positive_imp_inverse_positive)
110.210 - obtain M where M: "\<forall>n\<ge>M. norm (X n) < r"
110.211 - using ZseqD [OF X r] by fast
110.212 - obtain N where N: "\<forall>n\<ge>N. norm (Y n) < inverse K"
110.213 - using ZseqD [OF Y K'] by fast
110.214 - show "\<exists>N. \<forall>n\<ge>N. norm (X n ** Y n) < r"
110.215 - proof (intro exI allI impI)
110.216 - fix n assume n: "max M N \<le> n"
110.217 - have "norm (X n ** Y n) \<le> norm (X n) * norm (Y n) * K"
110.218 - by (rule norm_le)
110.219 - also have "norm (X n) * norm (Y n) * K < r * inverse K * K"
110.220 - proof (intro mult_strict_right_mono mult_strict_mono' norm_ge_zero K)
110.221 - from M n show Xn: "norm (X n) < r" by simp
110.222 - from N n show Yn: "norm (Y n) < inverse K" by simp
110.223 - qed
110.224 - also from K have "r * inverse K * K = r" by simp
110.225 - finally show "norm (X n ** Y n) < r" .
110.226 - qed
110.227 -qed
110.228 -
110.229 -lemma (in bounded_bilinear) Zseq_prod_Bseq:
110.230 - assumes X: "Zseq X"
110.231 - assumes Y: "Bseq Y"
110.232 - shows "Zseq (\<lambda>n. X n ** Y n)"
110.233 -proof -
110.234 - obtain K where K: "0 \<le> K"
110.235 - and norm_le: "\<And>x y. norm (x ** y) \<le> norm x * norm y * K"
110.236 - using nonneg_bounded by fast
110.237 - obtain B where B: "0 < B"
110.238 - and norm_Y: "\<And>n. norm (Y n) \<le> B"
110.239 - using Y [unfolded Bseq_def] by fast
110.240 - from X show ?thesis
110.241 - proof (rule Zseq_imp_Zseq)
110.242 - fix n::nat
110.243 - have "norm (X n ** Y n) \<le> norm (X n) * norm (Y n) * K"
110.244 - by (rule norm_le)
110.245 - also have "\<dots> \<le> norm (X n) * B * K"
110.246 - by (intro mult_mono' order_refl norm_Y norm_ge_zero
110.247 - mult_nonneg_nonneg K)
110.248 - also have "\<dots> = norm (X n) * (B * K)"
110.249 - by (rule mult_assoc)
110.250 - finally show "norm (X n ** Y n) \<le> norm (X n) * (B * K)" .
110.251 - qed
110.252 -qed
110.253 -
110.254 -lemma (in bounded_bilinear) Bseq_prod_Zseq:
110.255 - assumes X: "Bseq X"
110.256 - assumes Y: "Zseq Y"
110.257 - shows "Zseq (\<lambda>n. X n ** Y n)"
110.258 -proof -
110.259 - obtain K where K: "0 \<le> K"
110.260 - and norm_le: "\<And>x y. norm (x ** y) \<le> norm x * norm y * K"
110.261 - using nonneg_bounded by fast
110.262 - obtain B where B: "0 < B"
110.263 - and norm_X: "\<And>n. norm (X n) \<le> B"
110.264 - using X [unfolded Bseq_def] by fast
110.265 - from Y show ?thesis
110.266 - proof (rule Zseq_imp_Zseq)
110.267 - fix n::nat
110.268 - have "norm (X n ** Y n) \<le> norm (X n) * norm (Y n) * K"
110.269 - by (rule norm_le)
110.270 - also have "\<dots> \<le> B * norm (Y n) * K"
110.271 - by (intro mult_mono' order_refl norm_X norm_ge_zero
110.272 - mult_nonneg_nonneg K)
110.273 - also have "\<dots> = norm (Y n) * (B * K)"
110.274 - by (simp only: mult_ac)
110.275 - finally show "norm (X n ** Y n) \<le> norm (Y n) * (B * K)" .
110.276 - qed
110.277 -qed
110.278 -
110.279 -lemma (in bounded_bilinear) Zseq_left:
110.280 - "Zseq X \<Longrightarrow> Zseq (\<lambda>n. X n ** a)"
110.281 -by (rule bounded_linear_left [THEN bounded_linear.Zseq])
110.282 -
110.283 -lemma (in bounded_bilinear) Zseq_right:
110.284 - "Zseq X \<Longrightarrow> Zseq (\<lambda>n. a ** X n)"
110.285 -by (rule bounded_linear_right [THEN bounded_linear.Zseq])
110.286 -
110.287 -lemmas Zseq_mult = mult.Zseq
110.288 -lemmas Zseq_mult_right = mult.Zseq_right
110.289 -lemmas Zseq_mult_left = mult.Zseq_left
110.290 -
110.291 -
110.292 -subsection {* Limits of Sequences *}
110.293 -
110.294 -lemma LIMSEQ_iff:
110.295 - "(X ----> L) = (\<forall>r>0. \<exists>no. \<forall>n \<ge> no. norm (X n - L) < r)"
110.296 -by (rule LIMSEQ_def)
110.297 -
110.298 -lemma LIMSEQ_Zseq_iff: "((\<lambda>n. X n) ----> L) = Zseq (\<lambda>n. X n - L)"
110.299 -by (simp only: LIMSEQ_def Zseq_def)
110.300 -
110.301 -lemma LIMSEQ_I:
110.302 - "(\<And>r. 0 < r \<Longrightarrow> \<exists>no. \<forall>n\<ge>no. norm (X n - L) < r) \<Longrightarrow> X ----> L"
110.303 -by (simp add: LIMSEQ_def)
110.304 -
110.305 -lemma LIMSEQ_D:
110.306 - "\<lbrakk>X ----> L; 0 < r\<rbrakk> \<Longrightarrow> \<exists>no. \<forall>n\<ge>no. norm (X n - L) < r"
110.307 -by (simp add: LIMSEQ_def)
110.308 -
110.309 -lemma LIMSEQ_const: "(\<lambda>n. k) ----> k"
110.310 -by (simp add: LIMSEQ_def)
110.311 -
110.312 -lemma LIMSEQ_const_iff: "(\<lambda>n. k) ----> l = (k = l)"
110.313 -by (simp add: LIMSEQ_Zseq_iff Zseq_const_iff)
110.314 -
110.315 -lemma LIMSEQ_norm: "X ----> a \<Longrightarrow> (\<lambda>n. norm (X n)) ----> norm a"
110.316 -apply (simp add: LIMSEQ_def, safe)
110.317 -apply (drule_tac x="r" in spec, safe)
110.318 -apply (rule_tac x="no" in exI, safe)
110.319 -apply (drule_tac x="n" in spec, safe)
110.320 -apply (erule order_le_less_trans [OF norm_triangle_ineq3])
110.321 -done
110.322 -
110.323 -lemma LIMSEQ_ignore_initial_segment:
110.324 - "f ----> a \<Longrightarrow> (\<lambda>n. f (n + k)) ----> a"
110.325 -apply (rule LIMSEQ_I)
110.326 -apply (drule (1) LIMSEQ_D)
110.327 -apply (erule exE, rename_tac N)
110.328 -apply (rule_tac x=N in exI)
110.329 -apply simp
110.330 -done
110.331 -
110.332 -lemma LIMSEQ_offset:
110.333 - "(\<lambda>n. f (n + k)) ----> a \<Longrightarrow> f ----> a"
110.334 -apply (rule LIMSEQ_I)
110.335 -apply (drule (1) LIMSEQ_D)
110.336 -apply (erule exE, rename_tac N)
110.337 -apply (rule_tac x="N + k" in exI)
110.338 -apply clarify
110.339 -apply (drule_tac x="n - k" in spec)
110.340 -apply (simp add: le_diff_conv2)
110.341 -done
110.342 -
110.343 -lemma LIMSEQ_Suc: "f ----> l \<Longrightarrow> (\<lambda>n. f (Suc n)) ----> l"
110.344 -by (drule_tac k="1" in LIMSEQ_ignore_initial_segment, simp)
110.345 -
110.346 -lemma LIMSEQ_imp_Suc: "(\<lambda>n. f (Suc n)) ----> l \<Longrightarrow> f ----> l"
110.347 -by (rule_tac k="1" in LIMSEQ_offset, simp)
110.348 -
110.349 -lemma LIMSEQ_Suc_iff: "(\<lambda>n. f (Suc n)) ----> l = f ----> l"
110.350 -by (blast intro: LIMSEQ_imp_Suc LIMSEQ_Suc)
110.351 -
110.352 -lemma add_diff_add:
110.353 - fixes a b c d :: "'a::ab_group_add"
110.354 - shows "(a + c) - (b + d) = (a - b) + (c - d)"
110.355 -by simp
110.356 -
110.357 -lemma minus_diff_minus:
110.358 - fixes a b :: "'a::ab_group_add"
110.359 - shows "(- a) - (- b) = - (a - b)"
110.360 -by simp
110.361 -
110.362 -lemma LIMSEQ_add: "\<lbrakk>X ----> a; Y ----> b\<rbrakk> \<Longrightarrow> (\<lambda>n. X n + Y n) ----> a + b"
110.363 -by (simp only: LIMSEQ_Zseq_iff add_diff_add Zseq_add)
110.364 -
110.365 -lemma LIMSEQ_minus: "X ----> a \<Longrightarrow> (\<lambda>n. - X n) ----> - a"
110.366 -by (simp only: LIMSEQ_Zseq_iff minus_diff_minus Zseq_minus)
110.367 -
110.368 -lemma LIMSEQ_minus_cancel: "(\<lambda>n. - X n) ----> - a \<Longrightarrow> X ----> a"
110.369 -by (drule LIMSEQ_minus, simp)
110.370 -
110.371 -lemma LIMSEQ_diff: "\<lbrakk>X ----> a; Y ----> b\<rbrakk> \<Longrightarrow> (\<lambda>n. X n - Y n) ----> a - b"
110.372 -by (simp add: diff_minus LIMSEQ_add LIMSEQ_minus)
110.373 -
110.374 -lemma LIMSEQ_unique: "\<lbrakk>X ----> a; X ----> b\<rbrakk> \<Longrightarrow> a = b"
110.375 -by (drule (1) LIMSEQ_diff, simp add: LIMSEQ_const_iff)
110.376 -
110.377 -lemma (in bounded_linear) LIMSEQ:
110.378 - "X ----> a \<Longrightarrow> (\<lambda>n. f (X n)) ----> f a"
110.379 -by (simp only: LIMSEQ_Zseq_iff diff [symmetric] Zseq)
110.380 -
110.381 -lemma (in bounded_bilinear) LIMSEQ:
110.382 - "\<lbrakk>X ----> a; Y ----> b\<rbrakk> \<Longrightarrow> (\<lambda>n. X n ** Y n) ----> a ** b"
110.383 -by (simp only: LIMSEQ_Zseq_iff prod_diff_prod
110.384 - Zseq_add Zseq Zseq_left Zseq_right)
110.385 -
110.386 -lemma LIMSEQ_mult:
110.387 - fixes a b :: "'a::real_normed_algebra"
110.388 - shows "[| X ----> a; Y ----> b |] ==> (%n. X n * Y n) ----> a * b"
110.389 -by (rule mult.LIMSEQ)
110.390 -
110.391 -lemma inverse_diff_inverse:
110.392 - "\<lbrakk>(a::'a::division_ring) \<noteq> 0; b \<noteq> 0\<rbrakk>
110.393 - \<Longrightarrow> inverse a - inverse b = - (inverse a * (a - b) * inverse b)"
110.394 -by (simp add: ring_simps)
110.395 -
110.396 -lemma Bseq_inverse_lemma:
110.397 - fixes x :: "'a::real_normed_div_algebra"
110.398 - shows "\<lbrakk>r \<le> norm x; 0 < r\<rbrakk> \<Longrightarrow> norm (inverse x) \<le> inverse r"
110.399 -apply (subst nonzero_norm_inverse, clarsimp)
110.400 -apply (erule (1) le_imp_inverse_le)
110.401 -done
110.402 -
110.403 -lemma Bseq_inverse:
110.404 - fixes a :: "'a::real_normed_div_algebra"
110.405 - assumes X: "X ----> a"
110.406 - assumes a: "a \<noteq> 0"
110.407 - shows "Bseq (\<lambda>n. inverse (X n))"
110.408 -proof -
110.409 - from a have "0 < norm a" by simp
110.410 - hence "\<exists>r>0. r < norm a" by (rule dense)
110.411 - then obtain r where r1: "0 < r" and r2: "r < norm a" by fast
110.412 - obtain N where N: "\<And>n. N \<le> n \<Longrightarrow> norm (X n - a) < r"
110.413 - using LIMSEQ_D [OF X r1] by fast
110.414 - show ?thesis
110.415 - proof (rule BseqI2' [rule_format])
110.416 - fix n assume n: "N \<le> n"
110.417 - hence 1: "norm (X n - a) < r" by (rule N)
110.418 - hence 2: "X n \<noteq> 0" using r2 by auto
110.419 - hence "norm (inverse (X n)) = inverse (norm (X n))"
110.420 - by (rule nonzero_norm_inverse)
110.421 - also have "\<dots> \<le> inverse (norm a - r)"
110.422 - proof (rule le_imp_inverse_le)
110.423 - show "0 < norm a - r" using r2 by simp
110.424 - next
110.425 - have "norm a - norm (X n) \<le> norm (a - X n)"
110.426 - by (rule norm_triangle_ineq2)
110.427 - also have "\<dots> = norm (X n - a)"
110.428 - by (rule norm_minus_commute)
110.429 - also have "\<dots> < r" using 1 .
110.430 - finally show "norm a - r \<le> norm (X n)" by simp
110.431 - qed
110.432 - finally show "norm (inverse (X n)) \<le> inverse (norm a - r)" .
110.433 - qed
110.434 -qed
110.435 -
110.436 -lemma LIMSEQ_inverse_lemma:
110.437 - fixes a :: "'a::real_normed_div_algebra"
110.438 - shows "\<lbrakk>X ----> a; a \<noteq> 0; \<forall>n. X n \<noteq> 0\<rbrakk>
110.439 - \<Longrightarrow> (\<lambda>n. inverse (X n)) ----> inverse a"
110.440 -apply (subst LIMSEQ_Zseq_iff)
110.441 -apply (simp add: inverse_diff_inverse nonzero_imp_inverse_nonzero)
110.442 -apply (rule Zseq_minus)
110.443 -apply (rule Zseq_mult_left)
110.444 -apply (rule mult.Bseq_prod_Zseq)
110.445 -apply (erule (1) Bseq_inverse)
110.446 -apply (simp add: LIMSEQ_Zseq_iff)
110.447 -done
110.448 -
110.449 -lemma LIMSEQ_inverse:
110.450 - fixes a :: "'a::real_normed_div_algebra"
110.451 - assumes X: "X ----> a"
110.452 - assumes a: "a \<noteq> 0"
110.453 - shows "(\<lambda>n. inverse (X n)) ----> inverse a"
110.454 -proof -
110.455 - from a have "0 < norm a" by simp
110.456 - then obtain k where "\<forall>n\<ge>k. norm (X n - a) < norm a"
110.457 - using LIMSEQ_D [OF X] by fast
110.458 - hence "\<forall>n\<ge>k. X n \<noteq> 0" by auto
110.459 - hence k: "\<forall>n. X (n + k) \<noteq> 0" by simp
110.460 -
110.461 - from X have "(\<lambda>n. X (n + k)) ----> a"
110.462 - by (rule LIMSEQ_ignore_initial_segment)
110.463 - hence "(\<lambda>n. inverse (X (n + k))) ----> inverse a"
110.464 - using a k by (rule LIMSEQ_inverse_lemma)
110.465 - thus "(\<lambda>n. inverse (X n)) ----> inverse a"
110.466 - by (rule LIMSEQ_offset)
110.467 -qed
110.468 -
110.469 -lemma LIMSEQ_divide:
110.470 - fixes a b :: "'a::real_normed_field"
110.471 - shows "\<lbrakk>X ----> a; Y ----> b; b \<noteq> 0\<rbrakk> \<Longrightarrow> (\<lambda>n. X n / Y n) ----> a / b"
110.472 -by (simp add: LIMSEQ_mult LIMSEQ_inverse divide_inverse)
110.473 -
110.474 -lemma LIMSEQ_pow:
110.475 - fixes a :: "'a::{real_normed_algebra,recpower}"
110.476 - shows "X ----> a \<Longrightarrow> (\<lambda>n. (X n) ^ m) ----> a ^ m"
110.477 -by (induct m) (simp_all add: power_Suc LIMSEQ_const LIMSEQ_mult)
110.478 -
110.479 -lemma LIMSEQ_setsum:
110.480 - assumes n: "\<And>n. n \<in> S \<Longrightarrow> X n ----> L n"
110.481 - shows "(\<lambda>m. \<Sum>n\<in>S. X n m) ----> (\<Sum>n\<in>S. L n)"
110.482 -proof (cases "finite S")
110.483 - case True
110.484 - thus ?thesis using n
110.485 - proof (induct)
110.486 - case empty
110.487 - show ?case
110.488 - by (simp add: LIMSEQ_const)
110.489 - next
110.490 - case insert
110.491 - thus ?case
110.492 - by (simp add: LIMSEQ_add)
110.493 - qed
110.494 -next
110.495 - case False
110.496 - thus ?thesis
110.497 - by (simp add: LIMSEQ_const)
110.498 -qed
110.499 -
110.500 -lemma LIMSEQ_setprod:
110.501 - fixes L :: "'a \<Rightarrow> 'b::{real_normed_algebra,comm_ring_1}"
110.502 - assumes n: "\<And>n. n \<in> S \<Longrightarrow> X n ----> L n"
110.503 - shows "(\<lambda>m. \<Prod>n\<in>S. X n m) ----> (\<Prod>n\<in>S. L n)"
110.504 -proof (cases "finite S")
110.505 - case True
110.506 - thus ?thesis using n
110.507 - proof (induct)
110.508 - case empty
110.509 - show ?case
110.510 - by (simp add: LIMSEQ_const)
110.511 - next
110.512 - case insert
110.513 - thus ?case
110.514 - by (simp add: LIMSEQ_mult)
110.515 - qed
110.516 -next
110.517 - case False
110.518 - thus ?thesis
110.519 - by (simp add: setprod_def LIMSEQ_const)
110.520 -qed
110.521 -
110.522 -lemma LIMSEQ_add_const: "f ----> a ==> (%n.(f n + b)) ----> a + b"
110.523 -by (simp add: LIMSEQ_add LIMSEQ_const)
110.524 -
110.525 -(* FIXME: delete *)
110.526 -lemma LIMSEQ_add_minus:
110.527 - "[| X ----> a; Y ----> b |] ==> (%n. X n + -Y n) ----> a + -b"
110.528 -by (simp only: LIMSEQ_add LIMSEQ_minus)
110.529 -
110.530 -lemma LIMSEQ_diff_const: "f ----> a ==> (%n.(f n - b)) ----> a - b"
110.531 -by (simp add: LIMSEQ_diff LIMSEQ_const)
110.532 -
110.533 -lemma LIMSEQ_diff_approach_zero:
110.534 - "g ----> L ==> (%x. f x - g x) ----> 0 ==>
110.535 - f ----> L"
110.536 - apply (drule LIMSEQ_add)
110.537 - apply assumption
110.538 - apply simp
110.539 -done
110.540 -
110.541 -lemma LIMSEQ_diff_approach_zero2:
110.542 - "f ----> L ==> (%x. f x - g x) ----> 0 ==>
110.543 - g ----> L";
110.544 - apply (drule LIMSEQ_diff)
110.545 - apply assumption
110.546 - apply simp
110.547 -done
110.548 -
110.549 -text{*A sequence tends to zero iff its abs does*}
110.550 -lemma LIMSEQ_norm_zero: "((\<lambda>n. norm (X n)) ----> 0) = (X ----> 0)"
110.551 -by (simp add: LIMSEQ_def)
110.552 -
110.553 -lemma LIMSEQ_rabs_zero: "((%n. \<bar>f n\<bar>) ----> 0) = (f ----> (0::real))"
110.554 -by (simp add: LIMSEQ_def)
110.555 -
110.556 -lemma LIMSEQ_imp_rabs: "f ----> (l::real) ==> (%n. \<bar>f n\<bar>) ----> \<bar>l\<bar>"
110.557 -by (drule LIMSEQ_norm, simp)
110.558 -
110.559 -text{*An unbounded sequence's inverse tends to 0*}
110.560 -
110.561 -lemma LIMSEQ_inverse_zero:
110.562 - "\<forall>r::real. \<exists>N. \<forall>n\<ge>N. r < X n \<Longrightarrow> (\<lambda>n. inverse (X n)) ----> 0"
110.563 -apply (rule LIMSEQ_I)
110.564 -apply (drule_tac x="inverse r" in spec, safe)
110.565 -apply (rule_tac x="N" in exI, safe)
110.566 -apply (drule_tac x="n" in spec, safe)
110.567 -apply (frule positive_imp_inverse_positive)
110.568 -apply (frule (1) less_imp_inverse_less)
110.569 -apply (subgoal_tac "0 < X n", simp)
110.570 -apply (erule (1) order_less_trans)
110.571 -done
110.572 -
110.573 -text{*The sequence @{term "1/n"} tends to 0 as @{term n} tends to infinity*}
110.574 -
110.575 -lemma LIMSEQ_inverse_real_of_nat: "(%n. inverse(real(Suc n))) ----> 0"
110.576 -apply (rule LIMSEQ_inverse_zero, safe)
110.577 -apply (cut_tac x = r in reals_Archimedean2)
110.578 -apply (safe, rule_tac x = n in exI)
110.579 -apply (auto simp add: real_of_nat_Suc)
110.580 -done
110.581 -
110.582 -text{*The sequence @{term "r + 1/n"} tends to @{term r} as @{term n} tends to
110.583 -infinity is now easily proved*}
110.584 -
110.585 -lemma LIMSEQ_inverse_real_of_nat_add:
110.586 - "(%n. r + inverse(real(Suc n))) ----> r"
110.587 -by (cut_tac LIMSEQ_add [OF LIMSEQ_const LIMSEQ_inverse_real_of_nat], auto)
110.588 -
110.589 -lemma LIMSEQ_inverse_real_of_nat_add_minus:
110.590 - "(%n. r + -inverse(real(Suc n))) ----> r"
110.591 -by (cut_tac LIMSEQ_add_minus [OF LIMSEQ_const LIMSEQ_inverse_real_of_nat], auto)
110.592 -
110.593 -lemma LIMSEQ_inverse_real_of_nat_add_minus_mult:
110.594 - "(%n. r*( 1 + -inverse(real(Suc n)))) ----> r"
110.595 -by (cut_tac b=1 in
110.596 - LIMSEQ_mult [OF LIMSEQ_const LIMSEQ_inverse_real_of_nat_add_minus], auto)
110.597 -
110.598 -lemma LIMSEQ_le_const:
110.599 - "\<lbrakk>X ----> (x::real); \<exists>N. \<forall>n\<ge>N. a \<le> X n\<rbrakk> \<Longrightarrow> a \<le> x"
110.600 -apply (rule ccontr, simp only: linorder_not_le)
110.601 -apply (drule_tac r="a - x" in LIMSEQ_D, simp)
110.602 -apply clarsimp
110.603 -apply (drule_tac x="max N no" in spec, drule mp, rule le_maxI1)
110.604 -apply (drule_tac x="max N no" in spec, drule mp, rule le_maxI2)
110.605 -apply simp
110.606 -done
110.607 -
110.608 -lemma LIMSEQ_le_const2:
110.609 - "\<lbrakk>X ----> (x::real); \<exists>N. \<forall>n\<ge>N. X n \<le> a\<rbrakk> \<Longrightarrow> x \<le> a"
110.610 -apply (subgoal_tac "- a \<le> - x", simp)
110.611 -apply (rule LIMSEQ_le_const)
110.612 -apply (erule LIMSEQ_minus)
110.613 -apply simp
110.614 -done
110.615 -
110.616 -lemma LIMSEQ_le:
110.617 - "\<lbrakk>X ----> x; Y ----> y; \<exists>N. \<forall>n\<ge>N. X n \<le> Y n\<rbrakk> \<Longrightarrow> x \<le> (y::real)"
110.618 -apply (subgoal_tac "0 \<le> y - x", simp)
110.619 -apply (rule LIMSEQ_le_const)
110.620 -apply (erule (1) LIMSEQ_diff)
110.621 -apply (simp add: le_diff_eq)
110.622 -done
110.623 -
110.624 -
110.625 -subsection {* Convergence *}
110.626 -
110.627 -lemma limI: "X ----> L ==> lim X = L"
110.628 -apply (simp add: lim_def)
110.629 -apply (blast intro: LIMSEQ_unique)
110.630 -done
110.631 -
110.632 -lemma convergentD: "convergent X ==> \<exists>L. (X ----> L)"
110.633 -by (simp add: convergent_def)
110.634 -
110.635 -lemma convergentI: "(X ----> L) ==> convergent X"
110.636 -by (auto simp add: convergent_def)
110.637 -
110.638 -lemma convergent_LIMSEQ_iff: "convergent X = (X ----> lim X)"
110.639 -by (auto intro: theI LIMSEQ_unique simp add: convergent_def lim_def)
110.640 -
110.641 -lemma convergent_minus_iff: "(convergent X) = (convergent (%n. -(X n)))"
110.642 -apply (simp add: convergent_def)
110.643 -apply (auto dest: LIMSEQ_minus)
110.644 -apply (drule LIMSEQ_minus, auto)
110.645 -done
110.646 -
110.647 -
110.648 -subsection {* Bounded Monotonic Sequences *}
110.649 -
110.650 -text{*Subsequence (alternative definition, (e.g. Hoskins)*}
110.651 -
110.652 -lemma subseq_Suc_iff: "subseq f = (\<forall>n. (f n) < (f (Suc n)))"
110.653 -apply (simp add: subseq_def)
110.654 -apply (auto dest!: less_imp_Suc_add)
110.655 -apply (induct_tac k)
110.656 -apply (auto intro: less_trans)
110.657 -done
110.658 -
110.659 -lemma monoseq_Suc:
110.660 - "monoseq X = ((\<forall>n. X n \<le> X (Suc n))
110.661 - | (\<forall>n. X (Suc n) \<le> X n))"
110.662 -apply (simp add: monoseq_def)
110.663 -apply (auto dest!: le_imp_less_or_eq)
110.664 -apply (auto intro!: lessI [THEN less_imp_le] dest!: less_imp_Suc_add)
110.665 -apply (induct_tac "ka")
110.666 -apply (auto intro: order_trans)
110.667 -apply (erule contrapos_np)
110.668 -apply (induct_tac "k")
110.669 -apply (auto intro: order_trans)
110.670 -done
110.671 -
110.672 -lemma monoI1: "\<forall>m. \<forall> n \<ge> m. X m \<le> X n ==> monoseq X"
110.673 -by (simp add: monoseq_def)
110.674 -
110.675 -lemma monoI2: "\<forall>m. \<forall> n \<ge> m. X n \<le> X m ==> monoseq X"
110.676 -by (simp add: monoseq_def)
110.677 -
110.678 -lemma mono_SucI1: "\<forall>n. X n \<le> X (Suc n) ==> monoseq X"
110.679 -by (simp add: monoseq_Suc)
110.680 -
110.681 -lemma mono_SucI2: "\<forall>n. X (Suc n) \<le> X n ==> monoseq X"
110.682 -by (simp add: monoseq_Suc)
110.683 -
110.684 -text{*Bounded Sequence*}
110.685 -
110.686 -lemma BseqD: "Bseq X ==> \<exists>K. 0 < K & (\<forall>n. norm (X n) \<le> K)"
110.687 -by (simp add: Bseq_def)
110.688 -
110.689 -lemma BseqI: "[| 0 < K; \<forall>n. norm (X n) \<le> K |] ==> Bseq X"
110.690 -by (auto simp add: Bseq_def)
110.691 -
110.692 -lemma lemma_NBseq_def:
110.693 - "(\<exists>K > 0. \<forall>n. norm (X n) \<le> K) =
110.694 - (\<exists>N. \<forall>n. norm (X n) \<le> real(Suc N))"
110.695 -apply auto
110.696 - prefer 2 apply force
110.697 -apply (cut_tac x = K in reals_Archimedean2, clarify)
110.698 -apply (rule_tac x = n in exI, clarify)
110.699 -apply (drule_tac x = na in spec)
110.700 -apply (auto simp add: real_of_nat_Suc)
110.701 -done
110.702 -
110.703 -text{* alternative definition for Bseq *}
110.704 -lemma Bseq_iff: "Bseq X = (\<exists>N. \<forall>n. norm (X n) \<le> real(Suc N))"
110.705 -apply (simp add: Bseq_def)
110.706 -apply (simp (no_asm) add: lemma_NBseq_def)
110.707 -done
110.708 -
110.709 -lemma lemma_NBseq_def2:
110.710 - "(\<exists>K > 0. \<forall>n. norm (X n) \<le> K) = (\<exists>N. \<forall>n. norm (X n) < real(Suc N))"
110.711 -apply (subst lemma_NBseq_def, auto)
110.712 -apply (rule_tac x = "Suc N" in exI)
110.713 -apply (rule_tac [2] x = N in exI)
110.714 -apply (auto simp add: real_of_nat_Suc)
110.715 - prefer 2 apply (blast intro: order_less_imp_le)
110.716 -apply (drule_tac x = n in spec, simp)
110.717 -done
110.718 -
110.719 -(* yet another definition for Bseq *)
110.720 -lemma Bseq_iff1a: "Bseq X = (\<exists>N. \<forall>n. norm (X n) < real(Suc N))"
110.721 -by (simp add: Bseq_def lemma_NBseq_def2)
110.722 -
110.723 -subsubsection{*Upper Bounds and Lubs of Bounded Sequences*}
110.724 -
110.725 -lemma Bseq_isUb:
110.726 - "!!(X::nat=>real). Bseq X ==> \<exists>U. isUb (UNIV::real set) {x. \<exists>n. X n = x} U"
110.727 -by (auto intro: isUbI setleI simp add: Bseq_def abs_le_iff)
110.728 -
110.729 -
110.730 -text{* Use completeness of reals (supremum property)
110.731 - to show that any bounded sequence has a least upper bound*}
110.732 -
110.733 -lemma Bseq_isLub:
110.734 - "!!(X::nat=>real). Bseq X ==>
110.735 - \<exists>U. isLub (UNIV::real set) {x. \<exists>n. X n = x} U"
110.736 -by (blast intro: reals_complete Bseq_isUb)
110.737 -
110.738 -subsubsection{*A Bounded and Monotonic Sequence Converges*}
110.739 -
110.740 -lemma lemma_converg1:
110.741 - "!!(X::nat=>real). [| \<forall>m. \<forall> n \<ge> m. X m \<le> X n;
110.742 - isLub (UNIV::real set) {x. \<exists>n. X n = x} (X ma)
110.743 - |] ==> \<forall>n \<ge> ma. X n = X ma"
110.744 -apply safe
110.745 -apply (drule_tac y = "X n" in isLubD2)
110.746 -apply (blast dest: order_antisym)+
110.747 -done
110.748 -
110.749 -text{* The best of both worlds: Easier to prove this result as a standard
110.750 - theorem and then use equivalence to "transfer" it into the
110.751 - equivalent nonstandard form if needed!*}
110.752 -
110.753 -lemma Bmonoseq_LIMSEQ: "\<forall>n. m \<le> n --> X n = X m ==> \<exists>L. (X ----> L)"
110.754 -apply (simp add: LIMSEQ_def)
110.755 -apply (rule_tac x = "X m" in exI, safe)
110.756 -apply (rule_tac x = m in exI, safe)
110.757 -apply (drule spec, erule impE, auto)
110.758 -done
110.759 -
110.760 -lemma lemma_converg2:
110.761 - "!!(X::nat=>real).
110.762 - [| \<forall>m. X m ~= U; isLub UNIV {x. \<exists>n. X n = x} U |] ==> \<forall>m. X m < U"
110.763 -apply safe
110.764 -apply (drule_tac y = "X m" in isLubD2)
110.765 -apply (auto dest!: order_le_imp_less_or_eq)
110.766 -done
110.767 -
110.768 -lemma lemma_converg3: "!!(X ::nat=>real). \<forall>m. X m \<le> U ==> isUb UNIV {x. \<exists>n. X n = x} U"
110.769 -by (rule setleI [THEN isUbI], auto)
110.770 -
110.771 -text{* FIXME: @{term "U - T < U"} is redundant *}
110.772 -lemma lemma_converg4: "!!(X::nat=> real).
110.773 - [| \<forall>m. X m ~= U;
110.774 - isLub UNIV {x. \<exists>n. X n = x} U;
110.775 - 0 < T;
110.776 - U + - T < U
110.777 - |] ==> \<exists>m. U + -T < X m & X m < U"
110.778 -apply (drule lemma_converg2, assumption)
110.779 -apply (rule ccontr, simp)
110.780 -apply (simp add: linorder_not_less)
110.781 -apply (drule lemma_converg3)
110.782 -apply (drule isLub_le_isUb, assumption)
110.783 -apply (auto dest: order_less_le_trans)
110.784 -done
110.785 -
110.786 -text{*A standard proof of the theorem for monotone increasing sequence*}
110.787 -
110.788 -lemma Bseq_mono_convergent:
110.789 - "[| Bseq X; \<forall>m. \<forall>n \<ge> m. X m \<le> X n |] ==> convergent (X::nat=>real)"
110.790 -apply (simp add: convergent_def)
110.791 -apply (frule Bseq_isLub, safe)
110.792 -apply (case_tac "\<exists>m. X m = U", auto)
110.793 -apply (blast dest: lemma_converg1 Bmonoseq_LIMSEQ)
110.794 -(* second case *)
110.795 -apply (rule_tac x = U in exI)
110.796 -apply (subst LIMSEQ_iff, safe)
110.797 -apply (frule lemma_converg2, assumption)
110.798 -apply (drule lemma_converg4, auto)
110.799 -apply (rule_tac x = m in exI, safe)
110.800 -apply (subgoal_tac "X m \<le> X n")
110.801 - prefer 2 apply blast
110.802 -apply (drule_tac x=n and P="%m. X m < U" in spec, arith)
110.803 -done
110.804 -
110.805 -lemma Bseq_minus_iff: "Bseq (%n. -(X n)) = Bseq X"
110.806 -by (simp add: Bseq_def)
110.807 -
110.808 -text{*Main monotonicity theorem*}
110.809 -lemma Bseq_monoseq_convergent: "[| Bseq X; monoseq X |] ==> convergent X"
110.810 -apply (simp add: monoseq_def, safe)
110.811 -apply (rule_tac [2] convergent_minus_iff [THEN ssubst])
110.812 -apply (drule_tac [2] Bseq_minus_iff [THEN ssubst])
110.813 -apply (auto intro!: Bseq_mono_convergent)
110.814 -done
110.815 -
110.816 -subsubsection{*A Few More Equivalence Theorems for Boundedness*}
110.817 -
110.818 -text{*alternative formulation for boundedness*}
110.819 -lemma Bseq_iff2: "Bseq X = (\<exists>k > 0. \<exists>x. \<forall>n. norm (X(n) + -x) \<le> k)"
110.820 -apply (unfold Bseq_def, safe)
110.821 -apply (rule_tac [2] x = "k + norm x" in exI)
110.822 -apply (rule_tac x = K in exI, simp)
110.823 -apply (rule exI [where x = 0], auto)
110.824 -apply (erule order_less_le_trans, simp)
110.825 -apply (drule_tac x=n in spec, fold diff_def)
110.826 -apply (drule order_trans [OF norm_triangle_ineq2])
110.827 -apply simp
110.828 -done
110.829 -
110.830 -text{*alternative formulation for boundedness*}
110.831 -lemma Bseq_iff3: "Bseq X = (\<exists>k > 0. \<exists>N. \<forall>n. norm(X(n) + -X(N)) \<le> k)"
110.832 -apply safe
110.833 -apply (simp add: Bseq_def, safe)
110.834 -apply (rule_tac x = "K + norm (X N)" in exI)
110.835 -apply auto
110.836 -apply (erule order_less_le_trans, simp)
110.837 -apply (rule_tac x = N in exI, safe)
110.838 -apply (drule_tac x = n in spec)
110.839 -apply (rule order_trans [OF norm_triangle_ineq], simp)
110.840 -apply (auto simp add: Bseq_iff2)
110.841 -done
110.842 -
110.843 -lemma BseqI2: "(\<forall>n. k \<le> f n & f n \<le> (K::real)) ==> Bseq f"
110.844 -apply (simp add: Bseq_def)
110.845 -apply (rule_tac x = " (\<bar>k\<bar> + \<bar>K\<bar>) + 1" in exI, auto)
110.846 -apply (drule_tac x = n in spec, arith)
110.847 -done
110.848 -
110.849 -
110.850 -subsection {* Cauchy Sequences *}
110.851 -
110.852 -lemma CauchyI:
110.853 - "(\<And>e. 0 < e \<Longrightarrow> \<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. norm (X m - X n) < e) \<Longrightarrow> Cauchy X"
110.854 -by (simp add: Cauchy_def)
110.855 -
110.856 -lemma CauchyD:
110.857 - "\<lbrakk>Cauchy X; 0 < e\<rbrakk> \<Longrightarrow> \<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. norm (X m - X n) < e"
110.858 -by (simp add: Cauchy_def)
110.859 -
110.860 -subsubsection {* Cauchy Sequences are Bounded *}
110.861 -
110.862 -text{*A Cauchy sequence is bounded -- this is the standard
110.863 - proof mechanization rather than the nonstandard proof*}
110.864 -
110.865 -lemma lemmaCauchy: "\<forall>n \<ge> M. norm (X M - X n) < (1::real)
110.866 - ==> \<forall>n \<ge> M. norm (X n :: 'a::real_normed_vector) < 1 + norm (X M)"
110.867 -apply (clarify, drule spec, drule (1) mp)
110.868 -apply (simp only: norm_minus_commute)
110.869 -apply (drule order_le_less_trans [OF norm_triangle_ineq2])
110.870 -apply simp
110.871 -done
110.872 -
110.873 -lemma Cauchy_Bseq: "Cauchy X ==> Bseq X"
110.874 -apply (simp add: Cauchy_def)
110.875 -apply (drule spec, drule mp, rule zero_less_one, safe)
110.876 -apply (drule_tac x="M" in spec, simp)
110.877 -apply (drule lemmaCauchy)
110.878 -apply (rule_tac k="M" in Bseq_offset)
110.879 -apply (simp add: Bseq_def)
110.880 -apply (rule_tac x="1 + norm (X M)" in exI)
110.881 -apply (rule conjI, rule order_less_le_trans [OF zero_less_one], simp)
110.882 -apply (simp add: order_less_imp_le)
110.883 -done
110.884 -
110.885 -subsubsection {* Cauchy Sequences are Convergent *}
110.886 -
110.887 -axclass banach \<subseteq> real_normed_vector
110.888 - Cauchy_convergent: "Cauchy X \<Longrightarrow> convergent X"
110.889 -
110.890 -theorem LIMSEQ_imp_Cauchy:
110.891 - assumes X: "X ----> a" shows "Cauchy X"
110.892 -proof (rule CauchyI)
110.893 - fix e::real assume "0 < e"
110.894 - hence "0 < e/2" by simp
110.895 - with X have "\<exists>N. \<forall>n\<ge>N. norm (X n - a) < e/2" by (rule LIMSEQ_D)
110.896 - then obtain N where N: "\<forall>n\<ge>N. norm (X n - a) < e/2" ..
110.897 - show "\<exists>N. \<forall>m\<ge>N. \<forall>n\<ge>N. norm (X m - X n) < e"
110.898 - proof (intro exI allI impI)
110.899 - fix m assume "N \<le> m"
110.900 - hence m: "norm (X m - a) < e/2" using N by fast
110.901 - fix n assume "N \<le> n"
110.902 - hence n: "norm (X n - a) < e/2" using N by fast
110.903 - have "norm (X m - X n) = norm ((X m - a) - (X n - a))" by simp
110.904 - also have "\<dots> \<le> norm (X m - a) + norm (X n - a)"
110.905 - by (rule norm_triangle_ineq4)
110.906 - also from m n have "\<dots> < e" by(simp add:field_simps)
110.907 - finally show "norm (X m - X n) < e" .
110.908 - qed
110.909 -qed
110.910 -
110.911 -lemma convergent_Cauchy: "convergent X \<Longrightarrow> Cauchy X"
110.912 -unfolding convergent_def
110.913 -by (erule exE, erule LIMSEQ_imp_Cauchy)
110.914 -
110.915 -text {*
110.916 -Proof that Cauchy sequences converge based on the one from
110.917 -http://pirate.shu.edu/~wachsmut/ira/numseq/proofs/cauconv.html
110.918 -*}
110.919 -
110.920 -text {*
110.921 - If sequence @{term "X"} is Cauchy, then its limit is the lub of
110.922 - @{term "{r::real. \<exists>N. \<forall>n\<ge>N. r < X n}"}
110.923 -*}
110.924 -
110.925 -lemma isUb_UNIV_I: "(\<And>y. y \<in> S \<Longrightarrow> y \<le> u) \<Longrightarrow> isUb UNIV S u"
110.926 -by (simp add: isUbI setleI)
110.927 -
110.928 -lemma real_abs_diff_less_iff:
110.929 - "(\<bar>x - a\<bar> < (r::real)) = (a - r < x \<and> x < a + r)"
110.930 -by auto
110.931 -
110.932 -locale real_Cauchy =
110.933 - fixes X :: "nat \<Rightarrow> real"
110.934 - assumes X: "Cauchy X"
110.935 - fixes S :: "real set"
110.936 - defines S_def: "S \<equiv> {x::real. \<exists>N. \<forall>n\<ge>N. x < X n}"
110.937 -
110.938 -lemma real_CauchyI:
110.939 - assumes "Cauchy X"
110.940 - shows "real_Cauchy X"
110.941 - proof qed (fact assms)
110.942 -
110.943 -lemma (in real_Cauchy) mem_S: "\<forall>n\<ge>N. x < X n \<Longrightarrow> x \<in> S"
110.944 -by (unfold S_def, auto)
110.945 -
110.946 -lemma (in real_Cauchy) bound_isUb:
110.947 - assumes N: "\<forall>n\<ge>N. X n < x"
110.948 - shows "isUb UNIV S x"
110.949 -proof (rule isUb_UNIV_I)
110.950 - fix y::real assume "y \<in> S"
110.951 - hence "\<exists>M. \<forall>n\<ge>M. y < X n"
110.952 - by (simp add: S_def)
110.953 - then obtain M where "\<forall>n\<ge>M. y < X n" ..
110.954 - hence "y < X (max M N)" by simp
110.955 - also have "\<dots> < x" using N by simp
110.956 - finally show "y \<le> x"
110.957 - by (rule order_less_imp_le)
110.958 -qed
110.959 -
110.960 -lemma (in real_Cauchy) isLub_ex: "\<exists>u. isLub UNIV S u"
110.961 -proof (rule reals_complete)
110.962 - obtain N where "\<forall>m\<ge>N. \<forall>n\<ge>N. norm (X m - X n) < 1"
110.963 - using CauchyD [OF X zero_less_one] by fast
110.964 - hence N: "\<forall>n\<ge>N. norm (X n - X N) < 1" by simp
110.965 - show "\<exists>x. x \<in> S"
110.966 - proof
110.967 - from N have "\<forall>n\<ge>N. X N - 1 < X n"
110.968 - by (simp add: real_abs_diff_less_iff)
110.969 - thus "X N - 1 \<in> S" by (rule mem_S)
110.970 - qed
110.971 - show "\<exists>u. isUb UNIV S u"
110.972 - proof
110.973 - from N have "\<forall>n\<ge>N. X n < X N + 1"
110.974 - by (simp add: real_abs_diff_less_iff)
110.975 - thus "isUb UNIV S (X N + 1)"
110.976 - by (rule bound_isUb)
110.977 - qed
110.978 -qed
110.979 -
110.980 -lemma (in real_Cauchy) isLub_imp_LIMSEQ:
110.981 - assumes x: "isLub UNIV S x"
110.982 - shows "X ----> x"
110.983 -proof (rule LIMSEQ_I)
110.984 - fix r::real assume "0 < r"
110.985 - hence r: "0 < r/2" by simp
110.986 - obtain N where "\<forall>n\<ge>N. \<forall>m\<ge>N. norm (X n - X m) < r/2"
110.987 - using CauchyD [OF X r] by fast
110.988 - hence "\<forall>n\<ge>N. norm (X n - X N) < r/2" by simp
110.989 - hence N: "\<forall>n\<ge>N. X N - r/2 < X n \<and> X n < X N + r/2"
110.990 - by (simp only: real_norm_def real_abs_diff_less_iff)
110.991 -
110.992 - from N have "\<forall>n\<ge>N. X N - r/2 < X n" by fast
110.993 - hence "X N - r/2 \<in> S" by (rule mem_S)
110.994 - hence 1: "X N - r/2 \<le> x" using x isLub_isUb isUbD by fast
110.995 -
110.996 - from N have "\<forall>n\<ge>N. X n < X N + r/2" by fast
110.997 - hence "isUb UNIV S (X N + r/2)" by (rule bound_isUb)
110.998 - hence 2: "x \<le> X N + r/2" using x isLub_le_isUb by fast
110.999 -
110.1000 - show "\<exists>N. \<forall>n\<ge>N. norm (X n - x) < r"
110.1001 - proof (intro exI allI impI)
110.1002 - fix n assume n: "N \<le> n"
110.1003 - from N n have "X n < X N + r/2" and "X N - r/2 < X n" by simp+
110.1004 - thus "norm (X n - x) < r" using 1 2
110.1005 - by (simp add: real_abs_diff_less_iff)
110.1006 - qed
110.1007 -qed
110.1008 -
110.1009 -lemma (in real_Cauchy) LIMSEQ_ex: "\<exists>x. X ----> x"
110.1010 -proof -
110.1011 - obtain x where "isLub UNIV S x"
110.1012 - using isLub_ex by fast
110.1013 - hence "X ----> x"
110.1014 - by (rule isLub_imp_LIMSEQ)
110.1015 - thus ?thesis ..
110.1016 -qed
110.1017 -
110.1018 -lemma real_Cauchy_convergent:
110.1019 - fixes X :: "nat \<Rightarrow> real"
110.1020 - shows "Cauchy X \<Longrightarrow> convergent X"
110.1021 -unfolding convergent_def
110.1022 -by (rule real_Cauchy.LIMSEQ_ex)
110.1023 - (rule real_CauchyI)
110.1024 -
110.1025 -instance real :: banach
110.1026 -by intro_classes (rule real_Cauchy_convergent)
110.1027 -
110.1028 -lemma Cauchy_convergent_iff:
110.1029 - fixes X :: "nat \<Rightarrow> 'a::banach"
110.1030 - shows "Cauchy X = convergent X"
110.1031 -by (fast intro: Cauchy_convergent convergent_Cauchy)
110.1032 -
110.1033 -
110.1034 -subsection {* Power Sequences *}
110.1035 -
110.1036 -text{*The sequence @{term "x^n"} tends to 0 if @{term "0\<le>x"} and @{term
110.1037 -"x<1"}. Proof will use (NS) Cauchy equivalence for convergence and
110.1038 - also fact that bounded and monotonic sequence converges.*}
110.1039 -
110.1040 -lemma Bseq_realpow: "[| 0 \<le> (x::real); x \<le> 1 |] ==> Bseq (%n. x ^ n)"
110.1041 -apply (simp add: Bseq_def)
110.1042 -apply (rule_tac x = 1 in exI)
110.1043 -apply (simp add: power_abs)
110.1044 -apply (auto dest: power_mono)
110.1045 -done
110.1046 -
110.1047 -lemma monoseq_realpow: "[| 0 \<le> x; x \<le> 1 |] ==> monoseq (%n. x ^ n)"
110.1048 -apply (clarify intro!: mono_SucI2)
110.1049 -apply (cut_tac n = n and N = "Suc n" and a = x in power_decreasing, auto)
110.1050 -done
110.1051 -
110.1052 -lemma convergent_realpow:
110.1053 - "[| 0 \<le> (x::real); x \<le> 1 |] ==> convergent (%n. x ^ n)"
110.1054 -by (blast intro!: Bseq_monoseq_convergent Bseq_realpow monoseq_realpow)
110.1055 -
110.1056 -lemma LIMSEQ_inverse_realpow_zero_lemma:
110.1057 - fixes x :: real
110.1058 - assumes x: "0 \<le> x"
110.1059 - shows "real n * x + 1 \<le> (x + 1) ^ n"
110.1060 -apply (induct n)
110.1061 -apply simp
110.1062 -apply simp
110.1063 -apply (rule order_trans)
110.1064 -prefer 2
110.1065 -apply (erule mult_left_mono)
110.1066 -apply (rule add_increasing [OF x], simp)
110.1067 -apply (simp add: real_of_nat_Suc)
110.1068 -apply (simp add: ring_distribs)
110.1069 -apply (simp add: mult_nonneg_nonneg x)
110.1070 -done
110.1071 -
110.1072 -lemma LIMSEQ_inverse_realpow_zero:
110.1073 - "1 < (x::real) \<Longrightarrow> (\<lambda>n. inverse (x ^ n)) ----> 0"
110.1074 -proof (rule LIMSEQ_inverse_zero [rule_format])
110.1075 - fix y :: real
110.1076 - assume x: "1 < x"
110.1077 - hence "0 < x - 1" by simp
110.1078 - hence "\<forall>y. \<exists>N::nat. y < real N * (x - 1)"
110.1079 - by (rule reals_Archimedean3)
110.1080 - hence "\<exists>N::nat. y < real N * (x - 1)" ..
110.1081 - then obtain N::nat where "y < real N * (x - 1)" ..
110.1082 - also have "\<dots> \<le> real N * (x - 1) + 1" by simp
110.1083 - also have "\<dots> \<le> (x - 1 + 1) ^ N"
110.1084 - by (rule LIMSEQ_inverse_realpow_zero_lemma, cut_tac x, simp)
110.1085 - also have "\<dots> = x ^ N" by simp
110.1086 - finally have "y < x ^ N" .
110.1087 - hence "\<forall>n\<ge>N. y < x ^ n"
110.1088 - apply clarify
110.1089 - apply (erule order_less_le_trans)
110.1090 - apply (erule power_increasing)
110.1091 - apply (rule order_less_imp_le [OF x])
110.1092 - done
110.1093 - thus "\<exists>N. \<forall>n\<ge>N. y < x ^ n" ..
110.1094 -qed
110.1095 -
110.1096 -lemma LIMSEQ_realpow_zero:
110.1097 - "\<lbrakk>0 \<le> (x::real); x < 1\<rbrakk> \<Longrightarrow> (\<lambda>n. x ^ n) ----> 0"
110.1098 -proof (cases)
110.1099 - assume "x = 0"
110.1100 - hence "(\<lambda>n. x ^ Suc n) ----> 0" by (simp add: LIMSEQ_const)
110.1101 - thus ?thesis by (rule LIMSEQ_imp_Suc)
110.1102 -next
110.1103 - assume "0 \<le> x" and "x \<noteq> 0"
110.1104 - hence x0: "0 < x" by simp
110.1105 - assume x1: "x < 1"
110.1106 - from x0 x1 have "1 < inverse x"
110.1107 - by (rule real_inverse_gt_one)
110.1108 - hence "(\<lambda>n. inverse (inverse x ^ n)) ----> 0"
110.1109 - by (rule LIMSEQ_inverse_realpow_zero)
110.1110 - thus ?thesis by (simp add: power_inverse)
110.1111 -qed
110.1112 -
110.1113 -lemma LIMSEQ_power_zero:
110.1114 - fixes x :: "'a::{real_normed_algebra_1,recpower}"
110.1115 - shows "norm x < 1 \<Longrightarrow> (\<lambda>n. x ^ n) ----> 0"
110.1116 -apply (drule LIMSEQ_realpow_zero [OF norm_ge_zero])
110.1117 -apply (simp only: LIMSEQ_Zseq_iff, erule Zseq_le)
110.1118 -apply (simp add: power_abs norm_power_ineq)
110.1119 -done
110.1120 -
110.1121 -lemma LIMSEQ_divide_realpow_zero:
110.1122 - "1 < (x::real) ==> (%n. a / (x ^ n)) ----> 0"
110.1123 -apply (cut_tac a = a and x1 = "inverse x" in
110.1124 - LIMSEQ_mult [OF LIMSEQ_const LIMSEQ_realpow_zero])
110.1125 -apply (auto simp add: divide_inverse power_inverse)
110.1126 -apply (simp add: inverse_eq_divide pos_divide_less_eq)
110.1127 -done
110.1128 -
110.1129 -text{*Limit of @{term "c^n"} for @{term"\<bar>c\<bar> < 1"}*}
110.1130 -
110.1131 -lemma LIMSEQ_rabs_realpow_zero: "\<bar>c\<bar> < (1::real) ==> (%n. \<bar>c\<bar> ^ n) ----> 0"
110.1132 -by (rule LIMSEQ_realpow_zero [OF abs_ge_zero])
110.1133 -
110.1134 -lemma LIMSEQ_rabs_realpow_zero2: "\<bar>c\<bar> < (1::real) ==> (%n. c ^ n) ----> 0"
110.1135 -apply (rule LIMSEQ_rabs_zero [THEN iffD1])
110.1136 -apply (auto intro: LIMSEQ_rabs_realpow_zero simp add: power_abs)
110.1137 -done
110.1138 -
110.1139 -end
111.1 --- a/src/HOL/IsaMakefile Tue Dec 30 08:18:54 2008 +0100
111.2 +++ b/src/HOL/IsaMakefile Tue Dec 30 11:10:01 2008 +0100
111.3 @@ -112,6 +112,8 @@
111.4 Tools/dseq.ML \
111.5 Tools/function_package/auto_term.ML \
111.6 Tools/function_package/context_tree.ML \
111.7 + Tools/function_package/decompose.ML \
111.8 + Tools/function_package/descent.ML \
111.9 Tools/function_package/fundef_common.ML \
111.10 Tools/function_package/fundef_core.ML \
111.11 Tools/function_package/fundef_datatype.ML \
111.12 @@ -123,8 +125,11 @@
111.13 Tools/function_package/measure_functions.ML \
111.14 Tools/function_package/mutual.ML \
111.15 Tools/function_package/pattern_split.ML \
111.16 + Tools/function_package/scnp_reconstruct.ML \
111.17 + Tools/function_package/scnp_solve.ML \
111.18 Tools/function_package/size.ML \
111.19 Tools/function_package/sum_tree.ML \
111.20 + Tools/function_package/termination.ML \
111.21 Tools/hologic.ML \
111.22 Tools/inductive_codegen.ML \
111.23 Tools/inductive_package.ML \
111.24 @@ -179,6 +184,7 @@
111.25 $(SRC)/Tools/code/code_thingol.ML \
111.26 $(SRC)/Tools/induct.ML \
111.27 $(SRC)/Tools/induct_tacs.ML \
111.28 + $(SRC)/Tools/value.ML \
111.29 $(SRC)/Tools/nbe.ML \
111.30 $(SRC)/Tools/random_word.ML \
111.31 $(SRC)/Tools/rat.ML
111.32 @@ -255,7 +261,7 @@
111.33 $(OUT)/HOL: ROOT.ML $(MAIN_DEPENDENCIES) \
111.34 Complex_Main.thy \
111.35 Complex.thy \
111.36 - Complex/Fundamental_Theorem_Algebra.thy \
111.37 + Fundamental_Theorem_Algebra.thy \
111.38 Deriv.thy \
111.39 Fact.thy \
111.40 FrechetDeriv.thy \
111.41 @@ -265,11 +271,11 @@
111.42 Log.thy \
111.43 MacLaurin.thy \
111.44 NthRoot.thy \
111.45 - Hyperreal/SEQ.thy \
111.46 + SEQ.thy \
111.47 Series.thy \
111.48 Taylor.thy \
111.49 Transcendental.thy \
111.50 - Library/Dense_Linear_Order.thy \
111.51 + Dense_Linear_Order.thy \
111.52 GCD.thy \
111.53 Order_Relation.thy \
111.54 Parity.thy \
111.55 @@ -281,7 +287,7 @@
111.56 RealDef.thy \
111.57 RealPow.thy \
111.58 Real.thy \
111.59 - Real/RealVector.thy \
111.60 + RealVector.thy \
111.61 Tools/float_syntax.ML \
111.62 Tools/rat_arith.ML \
111.63 Tools/real_arith.ML \
111.64 @@ -331,16 +337,16 @@
111.65 HOL-HahnBanach: HOL $(LOG)/HOL-HahnBanach.gz
111.66
111.67 $(LOG)/HOL-HahnBanach.gz: $(OUT)/HOL \
111.68 - Real/HahnBanach/Bounds.thy Real/HahnBanach/FunctionNorm.thy \
111.69 - Real/HahnBanach/FunctionOrder.thy Real/HahnBanach/HahnBanach.thy \
111.70 - Real/HahnBanach/HahnBanachExtLemmas.thy \
111.71 - Real/HahnBanach/HahnBanachSupLemmas.thy \
111.72 - Real/HahnBanach/Linearform.thy Real/HahnBanach/NormedSpace.thy \
111.73 - Real/HahnBanach/README.html Real/HahnBanach/ROOT.ML \
111.74 - Real/HahnBanach/Subspace.thy Real/HahnBanach/VectorSpace.thy \
111.75 - Real/HahnBanach/ZornLemma.thy Real/HahnBanach/document/root.bib \
111.76 - Real/HahnBanach/document/root.tex
111.77 - @cd Real; $(ISABELLE_TOOL) usedir -g true $(OUT)/HOL HahnBanach
111.78 + HahnBanach/Bounds.thy HahnBanach/FunctionNorm.thy \
111.79 + HahnBanach/FunctionOrder.thy HahnBanach/HahnBanach.thy \
111.80 + HahnBanach/HahnBanachExtLemmas.thy \
111.81 + HahnBanach/HahnBanachSupLemmas.thy \
111.82 + HahnBanach/Linearform.thy HahnBanach/NormedSpace.thy \
111.83 + HahnBanach/README.html HahnBanach/ROOT.ML \
111.84 + HahnBanach/Subspace.thy HahnBanach/VectorSpace.thy \
111.85 + HahnBanach/ZornLemma.thy HahnBanach/document/root.bib \
111.86 + HahnBanach/document/root.tex
111.87 + @$(ISABELLE_TOOL) usedir -g true $(OUT)/HOL HahnBanach
111.88
111.89
111.90 ## HOL-Subst
111.91 @@ -776,20 +782,21 @@
111.92 ex/Coherent.thy ex/Dense_Linear_Order_Ex.thy ex/Eval_Examples.thy \
111.93 ex/Groebner_Examples.thy ex/Random.thy ex/Quickcheck.thy \
111.94 ex/Codegenerator.thy ex/Codegenerator_Pretty.thy \
111.95 + ex/CodegenSML_Test.thy \
111.96 ex/Commutative_RingEx.thy ex/Efficient_Nat_examples.thy \
111.97 ex/Hex_Bin_Examples.thy ex/Commutative_Ring_Complete.thy \
111.98 ex/ExecutableContent.thy ex/Fundefs.thy ex/Guess.thy ex/Hebrew.thy \
111.99 ex/Binary.thy ex/Higher_Order_Logic.thy ex/Hilbert_Classical.thy \
111.100 ex/Induction_Scheme.thy ex/InductiveInvariant.thy \
111.101 ex/InductiveInvariant_examples.thy ex/Intuitionistic.thy \
111.102 - ex/Lagrange.thy ex/LexOrds.thy ex/LocaleTest2.thy ex/MT.thy \
111.103 + ex/Lagrange.thy ex/LocaleTest2.thy ex/MT.thy \
111.104 ex/MergeSort.thy ex/MonoidGroup.thy ex/Multiquote.thy ex/NatSum.thy \
111.105 ex/Numeral.thy ex/PER.thy ex/PresburgerEx.thy ex/Primrec.thy \
111.106 ex/Quickcheck_Examples.thy ex/Reflection.thy ex/reflection_data.ML \
111.107 ex/ReflectionEx.thy ex/ROOT.ML ex/Recdefs.thy ex/Records.thy \
111.108 ex/Reflected_Presburger.thy ex/coopertac.ML \
111.109 ex/Refute_Examples.thy ex/SAT_Examples.thy ex/SVC_Oracle.thy \
111.110 - ex/Sudoku.thy ex/Tarski.thy ex/Term_Of_Syntax.thy \
111.111 + ex/Sudoku.thy ex/Tarski.thy ex/Termination.thy ex/Term_Of_Syntax.thy \
111.112 ex/Unification.thy ex/document/root.bib \
111.113 ex/document/root.tex ex/Meson_Test.thy ex/reflection.ML ex/set.thy \
111.114 ex/svc_funcs.ML ex/svc_test.thy \
112.1 --- a/src/HOL/Library/Dense_Linear_Order.thy Tue Dec 30 08:18:54 2008 +0100
112.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
112.3 @@ -1,879 +0,0 @@
112.4 -(*
112.5 - Author: Amine Chaieb, TU Muenchen
112.6 -*)
112.7 -
112.8 -header {* Dense linear order without endpoints
112.9 - and a quantifier elimination procedure in Ferrante and Rackoff style *}
112.10 -
112.11 -theory Dense_Linear_Order
112.12 -imports Plain "~~/src/HOL/Groebner_Basis"
112.13 -uses
112.14 - "~~/src/HOL/Tools/Qelim/langford_data.ML"
112.15 - "~~/src/HOL/Tools/Qelim/ferrante_rackoff_data.ML"
112.16 - ("~~/src/HOL/Tools/Qelim/langford.ML")
112.17 - ("~~/src/HOL/Tools/Qelim/ferrante_rackoff.ML")
112.18 -begin
112.19 -
112.20 -setup {* Langford_Data.setup #> Ferrante_Rackoff_Data.setup *}
112.21 -
112.22 -context linorder
112.23 -begin
112.24 -
112.25 -lemma less_not_permute: "\<not> (x < y \<and> y < x)" by (simp add: not_less linear)
112.26 -
112.27 -lemma gather_simps:
112.28 - shows
112.29 - "(\<exists>x. (\<forall>y \<in> L. y < x) \<and> (\<forall>y \<in> U. x < y) \<and> x < u \<and> P x) \<longleftrightarrow> (\<exists>x. (\<forall>y \<in> L. y < x) \<and> (\<forall>y \<in> (insert u U). x < y) \<and> P x)"
112.30 - and "(\<exists>x. (\<forall>y \<in> L. y < x) \<and> (\<forall>y \<in> U. x < y) \<and> l < x \<and> P x) \<longleftrightarrow> (\<exists>x. (\<forall>y \<in> (insert l L). y < x) \<and> (\<forall>y \<in> U. x < y) \<and> P x)"
112.31 - "(\<exists>x. (\<forall>y \<in> L. y < x) \<and> (\<forall>y \<in> U. x < y) \<and> x < u) \<longleftrightarrow> (\<exists>x. (\<forall>y \<in> L. y < x) \<and> (\<forall>y \<in> (insert u U). x < y))"
112.32 - and "(\<exists>x. (\<forall>y \<in> L. y < x) \<and> (\<forall>y \<in> U. x < y) \<and> l < x) \<longleftrightarrow> (\<exists>x. (\<forall>y \<in> (insert l L). y < x) \<and> (\<forall>y \<in> U. x < y))" by auto
112.33 -
112.34 -lemma
112.35 - gather_start: "(\<exists>x. P x) \<equiv> (\<exists>x. (\<forall>y \<in> {}. y < x) \<and> (\<forall>y\<in> {}. x < y) \<and> P x)"
112.36 - by simp
112.37 -
112.38 -text{* Theorems for @{text "\<exists>z. \<forall>x. x < z \<longrightarrow> (P x \<longleftrightarrow> P\<^bsub>-\<infinity>\<^esub>)"}*}
112.39 -lemma minf_lt: "\<exists>z . \<forall>x. x < z \<longrightarrow> (x < t \<longleftrightarrow> True)" by auto
112.40 -lemma minf_gt: "\<exists>z . \<forall>x. x < z \<longrightarrow> (t < x \<longleftrightarrow> False)"
112.41 - by (simp add: not_less) (rule exI[where x="t"], auto simp add: less_le)
112.42 -
112.43 -lemma minf_le: "\<exists>z. \<forall>x. x < z \<longrightarrow> (x \<le> t \<longleftrightarrow> True)" by (auto simp add: less_le)
112.44 -lemma minf_ge: "\<exists>z. \<forall>x. x < z \<longrightarrow> (t \<le> x \<longleftrightarrow> False)"
112.45 - by (auto simp add: less_le not_less not_le)
112.46 -lemma minf_eq: "\<exists>z. \<forall>x. x < z \<longrightarrow> (x = t \<longleftrightarrow> False)" by auto
112.47 -lemma minf_neq: "\<exists>z. \<forall>x. x < z \<longrightarrow> (x \<noteq> t \<longleftrightarrow> True)" by auto
112.48 -lemma minf_P: "\<exists>z. \<forall>x. x < z \<longrightarrow> (P \<longleftrightarrow> P)" by blast
112.49 -
112.50 -text{* Theorems for @{text "\<exists>z. \<forall>x. x < z \<longrightarrow> (P x \<longleftrightarrow> P\<^bsub>+\<infinity>\<^esub>)"}*}
112.51 -lemma pinf_gt: "\<exists>z . \<forall>x. z < x \<longrightarrow> (t < x \<longleftrightarrow> True)" by auto
112.52 -lemma pinf_lt: "\<exists>z . \<forall>x. z < x \<longrightarrow> (x < t \<longleftrightarrow> False)"
112.53 - by (simp add: not_less) (rule exI[where x="t"], auto simp add: less_le)
112.54 -
112.55 -lemma pinf_ge: "\<exists>z. \<forall>x. z < x \<longrightarrow> (t \<le> x \<longleftrightarrow> True)" by (auto simp add: less_le)
112.56 -lemma pinf_le: "\<exists>z. \<forall>x. z < x \<longrightarrow> (x \<le> t \<longleftrightarrow> False)"
112.57 - by (auto simp add: less_le not_less not_le)
112.58 -lemma pinf_eq: "\<exists>z. \<forall>x. z < x \<longrightarrow> (x = t \<longleftrightarrow> False)" by auto
112.59 -lemma pinf_neq: "\<exists>z. \<forall>x. z < x \<longrightarrow> (x \<noteq> t \<longleftrightarrow> True)" by auto
112.60 -lemma pinf_P: "\<exists>z. \<forall>x. z < x \<longrightarrow> (P \<longleftrightarrow> P)" by blast
112.61 -
112.62 -lemma nmi_lt: "t \<in> U \<Longrightarrow> \<forall>x. \<not>True \<and> x < t \<longrightarrow> (\<exists> u\<in> U. u \<le> x)" by auto
112.63 -lemma nmi_gt: "t \<in> U \<Longrightarrow> \<forall>x. \<not>False \<and> t < x \<longrightarrow> (\<exists> u\<in> U. u \<le> x)"
112.64 - by (auto simp add: le_less)
112.65 -lemma nmi_le: "t \<in> U \<Longrightarrow> \<forall>x. \<not>True \<and> x\<le> t \<longrightarrow> (\<exists> u\<in> U. u \<le> x)" by auto
112.66 -lemma nmi_ge: "t \<in> U \<Longrightarrow> \<forall>x. \<not>False \<and> t\<le> x \<longrightarrow> (\<exists> u\<in> U. u \<le> x)" by auto
112.67 -lemma nmi_eq: "t \<in> U \<Longrightarrow> \<forall>x. \<not>False \<and> x = t \<longrightarrow> (\<exists> u\<in> U. u \<le> x)" by auto
112.68 -lemma nmi_neq: "t \<in> U \<Longrightarrow>\<forall>x. \<not>True \<and> x \<noteq> t \<longrightarrow> (\<exists> u\<in> U. u \<le> x)" by auto
112.69 -lemma nmi_P: "\<forall> x. ~P \<and> P \<longrightarrow> (\<exists> u\<in> U. u \<le> x)" by auto
112.70 -lemma nmi_conj: "\<lbrakk>\<forall>x. \<not>P1' \<and> P1 x \<longrightarrow> (\<exists> u\<in> U. u \<le> x) ;
112.71 - \<forall>x. \<not>P2' \<and> P2 x \<longrightarrow> (\<exists> u\<in> U. u \<le> x)\<rbrakk> \<Longrightarrow>
112.72 - \<forall>x. \<not>(P1' \<and> P2') \<and> (P1 x \<and> P2 x) \<longrightarrow> (\<exists> u\<in> U. u \<le> x)" by auto
112.73 -lemma nmi_disj: "\<lbrakk>\<forall>x. \<not>P1' \<and> P1 x \<longrightarrow> (\<exists> u\<in> U. u \<le> x) ;
112.74 - \<forall>x. \<not>P2' \<and> P2 x \<longrightarrow> (\<exists> u\<in> U. u \<le> x)\<rbrakk> \<Longrightarrow>
112.75 - \<forall>x. \<not>(P1' \<or> P2') \<and> (P1 x \<or> P2 x) \<longrightarrow> (\<exists> u\<in> U. u \<le> x)" by auto
112.76 -
112.77 -lemma npi_lt: "t \<in> U \<Longrightarrow> \<forall>x. \<not>False \<and> x < t \<longrightarrow> (\<exists> u\<in> U. x \<le> u)" by (auto simp add: le_less)
112.78 -lemma npi_gt: "t \<in> U \<Longrightarrow> \<forall>x. \<not>True \<and> t < x \<longrightarrow> (\<exists> u\<in> U. x \<le> u)" by auto
112.79 -lemma npi_le: "t \<in> U \<Longrightarrow> \<forall>x. \<not>False \<and> x \<le> t \<longrightarrow> (\<exists> u\<in> U. x \<le> u)" by auto
112.80 -lemma npi_ge: "t \<in> U \<Longrightarrow> \<forall>x. \<not>True \<and> t \<le> x \<longrightarrow> (\<exists> u\<in> U. x \<le> u)" by auto
112.81 -lemma npi_eq: "t \<in> U \<Longrightarrow> \<forall>x. \<not>False \<and> x = t \<longrightarrow> (\<exists> u\<in> U. x \<le> u)" by auto
112.82 -lemma npi_neq: "t \<in> U \<Longrightarrow> \<forall>x. \<not>True \<and> x \<noteq> t \<longrightarrow> (\<exists> u\<in> U. x \<le> u )" by auto
112.83 -lemma npi_P: "\<forall> x. ~P \<and> P \<longrightarrow> (\<exists> u\<in> U. x \<le> u)" by auto
112.84 -lemma npi_conj: "\<lbrakk>\<forall>x. \<not>P1' \<and> P1 x \<longrightarrow> (\<exists> u\<in> U. x \<le> u) ; \<forall>x. \<not>P2' \<and> P2 x \<longrightarrow> (\<exists> u\<in> U. x \<le> u)\<rbrakk>
112.85 - \<Longrightarrow> \<forall>x. \<not>(P1' \<and> P2') \<and> (P1 x \<and> P2 x) \<longrightarrow> (\<exists> u\<in> U. x \<le> u)" by auto
112.86 -lemma npi_disj: "\<lbrakk>\<forall>x. \<not>P1' \<and> P1 x \<longrightarrow> (\<exists> u\<in> U. x \<le> u) ; \<forall>x. \<not>P2' \<and> P2 x \<longrightarrow> (\<exists> u\<in> U. x \<le> u)\<rbrakk>
112.87 - \<Longrightarrow> \<forall>x. \<not>(P1' \<or> P2') \<and> (P1 x \<or> P2 x) \<longrightarrow> (\<exists> u\<in> U. x \<le> u)" by auto
112.88 -
112.89 -lemma lin_dense_lt: "t \<in> U \<Longrightarrow> \<forall>x l u. (\<forall> t. l < t \<and> t < u \<longrightarrow> t \<notin> U) \<and> l< x \<and> x < u \<and> x < t \<longrightarrow> (\<forall> y. l < y \<and> y < u \<longrightarrow> y < t)"
112.90 -proof(clarsimp)
112.91 - fix x l u y assume tU: "t \<in> U" and noU: "\<forall>t. l < t \<and> t < u \<longrightarrow> t \<notin> U" and lx: "l < x"
112.92 - and xu: "x<u" and px: "x < t" and ly: "l<y" and yu:"y < u"
112.93 - from tU noU ly yu have tny: "t\<noteq>y" by auto
112.94 - {assume H: "t < y"
112.95 - from less_trans[OF lx px] less_trans[OF H yu]
112.96 - have "l < t \<and> t < u" by simp
112.97 - with tU noU have "False" by auto}
112.98 - hence "\<not> t < y" by auto hence "y \<le> t" by (simp add: not_less)
112.99 - thus "y < t" using tny by (simp add: less_le)
112.100 -qed
112.101 -
112.102 -lemma lin_dense_gt: "t \<in> U \<Longrightarrow> \<forall>x l u. (\<forall> t. l < t \<and> t< u \<longrightarrow> t \<notin> U) \<and> l < x \<and> x < u \<and> t < x \<longrightarrow> (\<forall> y. l < y \<and> y < u \<longrightarrow> t < y)"
112.103 -proof(clarsimp)
112.104 - fix x l u y
112.105 - assume tU: "t \<in> U" and noU: "\<forall>t. l < t \<and> t < u \<longrightarrow> t \<notin> U" and lx: "l < x" and xu: "x<u"
112.106 - and px: "t < x" and ly: "l<y" and yu:"y < u"
112.107 - from tU noU ly yu have tny: "t\<noteq>y" by auto
112.108 - {assume H: "y< t"
112.109 - from less_trans[OF ly H] less_trans[OF px xu] have "l < t \<and> t < u" by simp
112.110 - with tU noU have "False" by auto}
112.111 - hence "\<not> y<t" by auto hence "t \<le> y" by (auto simp add: not_less)
112.112 - thus "t < y" using tny by (simp add:less_le)
112.113 -qed
112.114 -
112.115 -lemma lin_dense_le: "t \<in> U \<Longrightarrow> \<forall>x l u. (\<forall> t. l < t \<and> t< u \<longrightarrow> t \<notin> U) \<and> l< x \<and> x < u \<and> x \<le> t \<longrightarrow> (\<forall> y. l < y \<and> y < u \<longrightarrow> y\<le> t)"
112.116 -proof(clarsimp)
112.117 - fix x l u y
112.118 - assume tU: "t \<in> U" and noU: "\<forall>t. l < t \<and> t < u \<longrightarrow> t \<notin> U" and lx: "l < x" and xu: "x<u"
112.119 - and px: "x \<le> t" and ly: "l<y" and yu:"y < u"
112.120 - from tU noU ly yu have tny: "t\<noteq>y" by auto
112.121 - {assume H: "t < y"
112.122 - from less_le_trans[OF lx px] less_trans[OF H yu]
112.123 - have "l < t \<and> t < u" by simp
112.124 - with tU noU have "False" by auto}
112.125 - hence "\<not> t < y" by auto thus "y \<le> t" by (simp add: not_less)
112.126 -qed
112.127 -
112.128 -lemma lin_dense_ge: "t \<in> U \<Longrightarrow> \<forall>x l u. (\<forall> t. l < t \<and> t< u \<longrightarrow> t \<notin> U) \<and> l< x \<and> x < u \<and> t \<le> x \<longrightarrow> (\<forall> y. l < y \<and> y < u \<longrightarrow> t \<le> y)"
112.129 -proof(clarsimp)
112.130 - fix x l u y
112.131 - assume tU: "t \<in> U" and noU: "\<forall>t. l < t \<and> t < u \<longrightarrow> t \<notin> U" and lx: "l < x" and xu: "x<u"
112.132 - and px: "t \<le> x" and ly: "l<y" and yu:"y < u"
112.133 - from tU noU ly yu have tny: "t\<noteq>y" by auto
112.134 - {assume H: "y< t"
112.135 - from less_trans[OF ly H] le_less_trans[OF px xu]
112.136 - have "l < t \<and> t < u" by simp
112.137 - with tU noU have "False" by auto}
112.138 - hence "\<not> y<t" by auto thus "t \<le> y" by (simp add: not_less)
112.139 -qed
112.140 -lemma lin_dense_eq: "t \<in> U \<Longrightarrow> \<forall>x l u. (\<forall> t. l < t \<and> t< u \<longrightarrow> t \<notin> U) \<and> l< x \<and> x < u \<and> x = t \<longrightarrow> (\<forall> y. l < y \<and> y < u \<longrightarrow> y= t)" by auto
112.141 -lemma lin_dense_neq: "t \<in> U \<Longrightarrow> \<forall>x l u. (\<forall> t. l < t \<and> t< u \<longrightarrow> t \<notin> U) \<and> l< x \<and> x < u \<and> x \<noteq> t \<longrightarrow> (\<forall> y. l < y \<and> y < u \<longrightarrow> y\<noteq> t)" by auto
112.142 -lemma lin_dense_P: "\<forall>x l u. (\<forall> t. l < t \<and> t< u \<longrightarrow> t \<notin> U) \<and> l< x \<and> x < u \<and> P \<longrightarrow> (\<forall> y. l < y \<and> y < u \<longrightarrow> P)" by auto
112.143 -
112.144 -lemma lin_dense_conj:
112.145 - "\<lbrakk>\<forall>x l u. (\<forall> t. l < t \<and> t< u \<longrightarrow> t \<notin> U) \<and> l< x \<and> x < u \<and> P1 x
112.146 - \<longrightarrow> (\<forall> y. l < y \<and> y < u \<longrightarrow> P1 y) ;
112.147 - \<forall>x l u. (\<forall> t. l < t \<and> t< u \<longrightarrow> t \<notin> U) \<and> l< x \<and> x < u \<and> P2 x
112.148 - \<longrightarrow> (\<forall> y. l < y \<and> y < u \<longrightarrow> P2 y)\<rbrakk> \<Longrightarrow>
112.149 - \<forall>x l u. (\<forall> t. l < t \<and> t< u \<longrightarrow> t \<notin> U) \<and> l< x \<and> x < u \<and> (P1 x \<and> P2 x)
112.150 - \<longrightarrow> (\<forall> y. l < y \<and> y < u \<longrightarrow> (P1 y \<and> P2 y))"
112.151 - by blast
112.152 -lemma lin_dense_disj:
112.153 - "\<lbrakk>\<forall>x l u. (\<forall> t. l < t \<and> t< u \<longrightarrow> t \<notin> U) \<and> l< x \<and> x < u \<and> P1 x
112.154 - \<longrightarrow> (\<forall> y. l < y \<and> y < u \<longrightarrow> P1 y) ;
112.155 - \<forall>x l u. (\<forall> t. l < t \<and> t< u \<longrightarrow> t \<notin> U) \<and> l< x \<and> x < u \<and> P2 x
112.156 - \<longrightarrow> (\<forall> y. l < y \<and> y < u \<longrightarrow> P2 y)\<rbrakk> \<Longrightarrow>
112.157 - \<forall>x l u. (\<forall> t. l < t \<and> t< u \<longrightarrow> t \<notin> U) \<and> l< x \<and> x < u \<and> (P1 x \<or> P2 x)
112.158 - \<longrightarrow> (\<forall> y. l < y \<and> y < u \<longrightarrow> (P1 y \<or> P2 y))"
112.159 - by blast
112.160 -
112.161 -lemma npmibnd: "\<lbrakk>\<forall>x. \<not> MP \<and> P x \<longrightarrow> (\<exists> u\<in> U. u \<le> x); \<forall>x. \<not>PP \<and> P x \<longrightarrow> (\<exists> u\<in> U. x \<le> u)\<rbrakk>
112.162 - \<Longrightarrow> \<forall>x. \<not> MP \<and> \<not>PP \<and> P x \<longrightarrow> (\<exists> u\<in> U. \<exists> u' \<in> U. u \<le> x \<and> x \<le> u')"
112.163 -by auto
112.164 -
112.165 -lemma finite_set_intervals:
112.166 - assumes px: "P x" and lx: "l \<le> x" and xu: "x \<le> u" and linS: "l\<in> S"
112.167 - and uinS: "u \<in> S" and fS:"finite S" and lS: "\<forall> x\<in> S. l \<le> x" and Su: "\<forall> x\<in> S. x \<le> u"
112.168 - shows "\<exists> a \<in> S. \<exists> b \<in> S. (\<forall> y. a < y \<and> y < b \<longrightarrow> y \<notin> S) \<and> a \<le> x \<and> x \<le> b \<and> P x"
112.169 -proof-
112.170 - let ?Mx = "{y. y\<in> S \<and> y \<le> x}"
112.171 - let ?xM = "{y. y\<in> S \<and> x \<le> y}"
112.172 - let ?a = "Max ?Mx"
112.173 - let ?b = "Min ?xM"
112.174 - have MxS: "?Mx \<subseteq> S" by blast
112.175 - hence fMx: "finite ?Mx" using fS finite_subset by auto
112.176 - from lx linS have linMx: "l \<in> ?Mx" by blast
112.177 - hence Mxne: "?Mx \<noteq> {}" by blast
112.178 - have xMS: "?xM \<subseteq> S" by blast
112.179 - hence fxM: "finite ?xM" using fS finite_subset by auto
112.180 - from xu uinS have linxM: "u \<in> ?xM" by blast
112.181 - hence xMne: "?xM \<noteq> {}" by blast
112.182 - have ax:"?a \<le> x" using Mxne fMx by auto
112.183 - have xb:"x \<le> ?b" using xMne fxM by auto
112.184 - have "?a \<in> ?Mx" using Max_in[OF fMx Mxne] by simp hence ainS: "?a \<in> S" using MxS by blast
112.185 - have "?b \<in> ?xM" using Min_in[OF fxM xMne] by simp hence binS: "?b \<in> S" using xMS by blast
112.186 - have noy:"\<forall> y. ?a < y \<and> y < ?b \<longrightarrow> y \<notin> S"
112.187 - proof(clarsimp)
112.188 - fix y assume ay: "?a < y" and yb: "y < ?b" and yS: "y \<in> S"
112.189 - from yS have "y\<in> ?Mx \<or> y\<in> ?xM" by (auto simp add: linear)
112.190 - moreover {assume "y \<in> ?Mx" hence "y \<le> ?a" using Mxne fMx by auto with ay have "False" by (simp add: not_le[symmetric])}
112.191 - moreover {assume "y \<in> ?xM" hence "?b \<le> y" using xMne fxM by auto with yb have "False" by (simp add: not_le[symmetric])}
112.192 - ultimately show "False" by blast
112.193 - qed
112.194 - from ainS binS noy ax xb px show ?thesis by blast
112.195 -qed
112.196 -
112.197 -lemma finite_set_intervals2:
112.198 - assumes px: "P x" and lx: "l \<le> x" and xu: "x \<le> u" and linS: "l\<in> S"
112.199 - and uinS: "u \<in> S" and fS:"finite S" and lS: "\<forall> x\<in> S. l \<le> x" and Su: "\<forall> x\<in> S. x \<le> u"
112.200 - shows "(\<exists> s\<in> S. P s) \<or> (\<exists> a \<in> S. \<exists> b \<in> S. (\<forall> y. a < y \<and> y < b \<longrightarrow> y \<notin> S) \<and> a < x \<and> x < b \<and> P x)"
112.201 -proof-
112.202 - from finite_set_intervals[where P="P", OF px lx xu linS uinS fS lS Su]
112.203 - obtain a and b where
112.204 - as: "a\<in> S" and bs: "b\<in> S" and noS:"\<forall>y. a < y \<and> y < b \<longrightarrow> y \<notin> S"
112.205 - and axb: "a \<le> x \<and> x \<le> b \<and> P x" by auto
112.206 - from axb have "x= a \<or> x= b \<or> (a < x \<and> x < b)" by (auto simp add: le_less)
112.207 - thus ?thesis using px as bs noS by blast
112.208 -qed
112.209 -
112.210 -end
112.211 -
112.212 -section {* The classical QE after Langford for dense linear orders *}
112.213 -
112.214 -context dense_linear_order
112.215 -begin
112.216 -
112.217 -lemma interval_empty_iff:
112.218 - "{y. x < y \<and> y < z} = {} \<longleftrightarrow> \<not> x < z"
112.219 - by (auto dest: dense)
112.220 -
112.221 -lemma dlo_qe_bnds:
112.222 - assumes ne: "L \<noteq> {}" and neU: "U \<noteq> {}" and fL: "finite L" and fU: "finite U"
112.223 - shows "(\<exists>x. (\<forall>y \<in> L. y < x) \<and> (\<forall>y \<in> U. x < y)) \<equiv> (\<forall> l \<in> L. \<forall>u \<in> U. l < u)"
112.224 -proof (simp only: atomize_eq, rule iffI)
112.225 - assume H: "\<exists>x. (\<forall>y\<in>L. y < x) \<and> (\<forall>y\<in>U. x < y)"
112.226 - then obtain x where xL: "\<forall>y\<in>L. y < x" and xU: "\<forall>y\<in>U. x < y" by blast
112.227 - {fix l u assume l: "l \<in> L" and u: "u \<in> U"
112.228 - have "l < x" using xL l by blast
112.229 - also have "x < u" using xU u by blast
112.230 - finally (less_trans) have "l < u" .}
112.231 - thus "\<forall>l\<in>L. \<forall>u\<in>U. l < u" by blast
112.232 -next
112.233 - assume H: "\<forall>l\<in>L. \<forall>u\<in>U. l < u"
112.234 - let ?ML = "Max L"
112.235 - let ?MU = "Min U"
112.236 - from fL ne have th1: "?ML \<in> L" and th1': "\<forall>l\<in>L. l \<le> ?ML" by auto
112.237 - from fU neU have th2: "?MU \<in> U" and th2': "\<forall>u\<in>U. ?MU \<le> u" by auto
112.238 - from th1 th2 H have "?ML < ?MU" by auto
112.239 - with dense obtain w where th3: "?ML < w" and th4: "w < ?MU" by blast
112.240 - from th3 th1' have "\<forall>l \<in> L. l < w" by auto
112.241 - moreover from th4 th2' have "\<forall>u \<in> U. w < u" by auto
112.242 - ultimately show "\<exists>x. (\<forall>y\<in>L. y < x) \<and> (\<forall>y\<in>U. x < y)" by auto
112.243 -qed
112.244 -
112.245 -lemma dlo_qe_noub:
112.246 - assumes ne: "L \<noteq> {}" and fL: "finite L"
112.247 - shows "(\<exists>x. (\<forall>y \<in> L. y < x) \<and> (\<forall>y \<in> {}. x < y)) \<equiv> True"
112.248 -proof(simp add: atomize_eq)
112.249 - from gt_ex[of "Max L"] obtain M where M: "Max L < M" by blast
112.250 - from ne fL have "\<forall>x \<in> L. x \<le> Max L" by simp
112.251 - with M have "\<forall>x\<in>L. x < M" by (auto intro: le_less_trans)
112.252 - thus "\<exists>x. \<forall>y\<in>L. y < x" by blast
112.253 -qed
112.254 -
112.255 -lemma dlo_qe_nolb:
112.256 - assumes ne: "U \<noteq> {}" and fU: "finite U"
112.257 - shows "(\<exists>x. (\<forall>y \<in> {}. y < x) \<and> (\<forall>y \<in> U. x < y)) \<equiv> True"
112.258 -proof(simp add: atomize_eq)
112.259 - from lt_ex[of "Min U"] obtain M where M: "M < Min U" by blast
112.260 - from ne fU have "\<forall>x \<in> U. Min U \<le> x" by simp
112.261 - with M have "\<forall>x\<in>U. M < x" by (auto intro: less_le_trans)
112.262 - thus "\<exists>x. \<forall>y\<in>U. x < y" by blast
112.263 -qed
112.264 -
112.265 -lemma exists_neq: "\<exists>(x::'a). x \<noteq> t" "\<exists>(x::'a). t \<noteq> x"
112.266 - using gt_ex[of t] by auto
112.267 -
112.268 -lemmas dlo_simps = order_refl less_irrefl not_less not_le exists_neq
112.269 - le_less neq_iff linear less_not_permute
112.270 -
112.271 -lemma axiom: "dense_linear_order (op \<le>) (op <)" by (rule dense_linear_order_axioms)
112.272 -lemma atoms:
112.273 - shows "TERM (less :: 'a \<Rightarrow> _)"
112.274 - and "TERM (less_eq :: 'a \<Rightarrow> _)"
112.275 - and "TERM (op = :: 'a \<Rightarrow> _)" .
112.276 -
112.277 -declare axiom[langford qe: dlo_qe_bnds dlo_qe_nolb dlo_qe_noub gather: gather_start gather_simps atoms: atoms]
112.278 -declare dlo_simps[langfordsimp]
112.279 -
112.280 -end
112.281 -
112.282 -(* FIXME: Move to HOL -- together with the conj_aci_rule in langford.ML *)
112.283 -lemma dnf:
112.284 - "(P & (Q | R)) = ((P&Q) | (P&R))"
112.285 - "((Q | R) & P) = ((Q&P) | (R&P))"
112.286 - by blast+
112.287 -
112.288 -lemmas weak_dnf_simps = simp_thms dnf
112.289 -
112.290 -lemma nnf_simps:
112.291 - "(\<not>(P \<and> Q)) = (\<not>P \<or> \<not>Q)" "(\<not>(P \<or> Q)) = (\<not>P \<and> \<not>Q)" "(P \<longrightarrow> Q) = (\<not>P \<or> Q)"
112.292 - "(P = Q) = ((P \<and> Q) \<or> (\<not>P \<and> \<not> Q))" "(\<not> \<not>(P)) = P"
112.293 - by blast+
112.294 -
112.295 -lemma ex_distrib: "(\<exists>x. P x \<or> Q x) \<longleftrightarrow> ((\<exists>x. P x) \<or> (\<exists>x. Q x))" by blast
112.296 -
112.297 -lemmas dnf_simps = weak_dnf_simps nnf_simps ex_distrib
112.298 -
112.299 -use "~~/src/HOL/Tools/Qelim/langford.ML"
112.300 -method_setup dlo = {*
112.301 - Method.ctxt_args (Method.SIMPLE_METHOD' o LangfordQE.dlo_tac)
112.302 -*} "Langford's algorithm for quantifier elimination in dense linear orders"
112.303 -
112.304 -
112.305 -section {* Contructive dense linear orders yield QE for linear arithmetic over ordered Fields -- see @{text "Arith_Tools.thy"} *}
112.306 -
112.307 -text {* Linear order without upper bounds *}
112.308 -
112.309 -class_locale linorder_stupid_syntax = linorder
112.310 -begin
112.311 -notation
112.312 - less_eq ("op \<sqsubseteq>") and
112.313 - less_eq ("(_/ \<sqsubseteq> _)" [51, 51] 50) and
112.314 - less ("op \<sqsubset>") and
112.315 - less ("(_/ \<sqsubset> _)" [51, 51] 50)
112.316 -
112.317 -end
112.318 -
112.319 -class_locale linorder_no_ub = linorder_stupid_syntax +
112.320 - assumes gt_ex: "\<exists>y. less x y"
112.321 -begin
112.322 -lemma ge_ex: "\<exists>y. x \<sqsubseteq> y" using gt_ex by auto
112.323 -
112.324 -text {* Theorems for @{text "\<exists>z. \<forall>x. z \<sqsubset> x \<longrightarrow> (P x \<longleftrightarrow> P\<^bsub>+\<infinity>\<^esub>)"} *}
112.325 -lemma pinf_conj:
112.326 - assumes ex1: "\<exists>z1. \<forall>x. z1 \<sqsubset> x \<longrightarrow> (P1 x \<longleftrightarrow> P1')"
112.327 - and ex2: "\<exists>z2. \<forall>x. z2 \<sqsubset> x \<longrightarrow> (P2 x \<longleftrightarrow> P2')"
112.328 - shows "\<exists>z. \<forall>x. z \<sqsubset> x \<longrightarrow> ((P1 x \<and> P2 x) \<longleftrightarrow> (P1' \<and> P2'))"
112.329 -proof-
112.330 - from ex1 ex2 obtain z1 and z2 where z1: "\<forall>x. z1 \<sqsubset> x \<longrightarrow> (P1 x \<longleftrightarrow> P1')"
112.331 - and z2: "\<forall>x. z2 \<sqsubset> x \<longrightarrow> (P2 x \<longleftrightarrow> P2')" by blast
112.332 - from gt_ex obtain z where z:"ord.max less_eq z1 z2 \<sqsubset> z" by blast
112.333 - from z have zz1: "z1 \<sqsubset> z" and zz2: "z2 \<sqsubset> z" by simp_all
112.334 - {fix x assume H: "z \<sqsubset> x"
112.335 - from less_trans[OF zz1 H] less_trans[OF zz2 H]
112.336 - have "(P1 x \<and> P2 x) \<longleftrightarrow> (P1' \<and> P2')" using z1 zz1 z2 zz2 by auto
112.337 - }
112.338 - thus ?thesis by blast
112.339 -qed
112.340 -
112.341 -lemma pinf_disj:
112.342 - assumes ex1: "\<exists>z1. \<forall>x. z1 \<sqsubset> x \<longrightarrow> (P1 x \<longleftrightarrow> P1')"
112.343 - and ex2: "\<exists>z2. \<forall>x. z2 \<sqsubset> x \<longrightarrow> (P2 x \<longleftrightarrow> P2')"
112.344 - shows "\<exists>z. \<forall>x. z \<sqsubset> x \<longrightarrow> ((P1 x \<or> P2 x) \<longleftrightarrow> (P1' \<or> P2'))"
112.345 -proof-
112.346 - from ex1 ex2 obtain z1 and z2 where z1: "\<forall>x. z1 \<sqsubset> x \<longrightarrow> (P1 x \<longleftrightarrow> P1')"
112.347 - and z2: "\<forall>x. z2 \<sqsubset> x \<longrightarrow> (P2 x \<longleftrightarrow> P2')" by blast
112.348 - from gt_ex obtain z where z:"ord.max less_eq z1 z2 \<sqsubset> z" by blast
112.349 - from z have zz1: "z1 \<sqsubset> z" and zz2: "z2 \<sqsubset> z" by simp_all
112.350 - {fix x assume H: "z \<sqsubset> x"
112.351 - from less_trans[OF zz1 H] less_trans[OF zz2 H]
112.352 - have "(P1 x \<or> P2 x) \<longleftrightarrow> (P1' \<or> P2')" using z1 zz1 z2 zz2 by auto
112.353 - }
112.354 - thus ?thesis by blast
112.355 -qed
112.356 -
112.357 -lemma pinf_ex: assumes ex:"\<exists>z. \<forall>x. z \<sqsubset> x \<longrightarrow> (P x \<longleftrightarrow> P1)" and p1: P1 shows "\<exists> x. P x"
112.358 -proof-
112.359 - from ex obtain z where z: "\<forall>x. z \<sqsubset> x \<longrightarrow> (P x \<longleftrightarrow> P1)" by blast
112.360 - from gt_ex obtain x where x: "z \<sqsubset> x" by blast
112.361 - from z x p1 show ?thesis by blast
112.362 -qed
112.363 -
112.364 -end
112.365 -
112.366 -text {* Linear order without upper bounds *}
112.367 -
112.368 -class_locale linorder_no_lb = linorder_stupid_syntax +
112.369 - assumes lt_ex: "\<exists>y. less y x"
112.370 -begin
112.371 -lemma le_ex: "\<exists>y. y \<sqsubseteq> x" using lt_ex by auto
112.372 -
112.373 -
112.374 -text {* Theorems for @{text "\<exists>z. \<forall>x. x \<sqsubset> z \<longrightarrow> (P x \<longleftrightarrow> P\<^bsub>-\<infinity>\<^esub>)"} *}
112.375 -lemma minf_conj:
112.376 - assumes ex1: "\<exists>z1. \<forall>x. x \<sqsubset> z1 \<longrightarrow> (P1 x \<longleftrightarrow> P1')"
112.377 - and ex2: "\<exists>z2. \<forall>x. x \<sqsubset> z2 \<longrightarrow> (P2 x \<longleftrightarrow> P2')"
112.378 - shows "\<exists>z. \<forall>x. x \<sqsubset> z \<longrightarrow> ((P1 x \<and> P2 x) \<longleftrightarrow> (P1' \<and> P2'))"
112.379 -proof-
112.380 - from ex1 ex2 obtain z1 and z2 where z1: "\<forall>x. x \<sqsubset> z1 \<longrightarrow> (P1 x \<longleftrightarrow> P1')"and z2: "\<forall>x. x \<sqsubset> z2 \<longrightarrow> (P2 x \<longleftrightarrow> P2')" by blast
112.381 - from lt_ex obtain z where z:"z \<sqsubset> ord.min less_eq z1 z2" by blast
112.382 - from z have zz1: "z \<sqsubset> z1" and zz2: "z \<sqsubset> z2" by simp_all
112.383 - {fix x assume H: "x \<sqsubset> z"
112.384 - from less_trans[OF H zz1] less_trans[OF H zz2]
112.385 - have "(P1 x \<and> P2 x) \<longleftrightarrow> (P1' \<and> P2')" using z1 zz1 z2 zz2 by auto
112.386 - }
112.387 - thus ?thesis by blast
112.388 -qed
112.389 -
112.390 -lemma minf_disj:
112.391 - assumes ex1: "\<exists>z1. \<forall>x. x \<sqsubset> z1 \<longrightarrow> (P1 x \<longleftrightarrow> P1')"
112.392 - and ex2: "\<exists>z2. \<forall>x. x \<sqsubset> z2 \<longrightarrow> (P2 x \<longleftrightarrow> P2')"
112.393 - shows "\<exists>z. \<forall>x. x \<sqsubset> z \<longrightarrow> ((P1 x \<or> P2 x) \<longleftrightarrow> (P1' \<or> P2'))"
112.394 -proof-
112.395 - from ex1 ex2 obtain z1 and z2 where z1: "\<forall>x. x \<sqsubset> z1 \<longrightarrow> (P1 x \<longleftrightarrow> P1')"and z2: "\<forall>x. x \<sqsubset> z2 \<longrightarrow> (P2 x \<longleftrightarrow> P2')" by blast
112.396 - from lt_ex obtain z where z:"z \<sqsubset> ord.min less_eq z1 z2" by blast
112.397 - from z have zz1: "z \<sqsubset> z1" and zz2: "z \<sqsubset> z2" by simp_all
112.398 - {fix x assume H: "x \<sqsubset> z"
112.399 - from less_trans[OF H zz1] less_trans[OF H zz2]
112.400 - have "(P1 x \<or> P2 x) \<longleftrightarrow> (P1' \<or> P2')" using z1 zz1 z2 zz2 by auto
112.401 - }
112.402 - thus ?thesis by blast
112.403 -qed
112.404 -
112.405 -lemma minf_ex: assumes ex:"\<exists>z. \<forall>x. x \<sqsubset> z \<longrightarrow> (P x \<longleftrightarrow> P1)" and p1: P1 shows "\<exists> x. P x"
112.406 -proof-
112.407 - from ex obtain z where z: "\<forall>x. x \<sqsubset> z \<longrightarrow> (P x \<longleftrightarrow> P1)" by blast
112.408 - from lt_ex obtain x where x: "x \<sqsubset> z" by blast
112.409 - from z x p1 show ?thesis by blast
112.410 -qed
112.411 -
112.412 -end
112.413 -
112.414 -
112.415 -class_locale constr_dense_linear_order = linorder_no_lb + linorder_no_ub +
112.416 - fixes between
112.417 - assumes between_less: "less x y \<Longrightarrow> less x (between x y) \<and> less (between x y) y"
112.418 - and between_same: "between x x = x"
112.419 -
112.420 -class_interpretation constr_dense_linear_order < dense_linear_order
112.421 - apply unfold_locales
112.422 - using gt_ex lt_ex between_less
112.423 - by (auto, rule_tac x="between x y" in exI, simp)
112.424 -
112.425 -context constr_dense_linear_order
112.426 -begin
112.427 -
112.428 -lemma rinf_U:
112.429 - assumes fU: "finite U"
112.430 - and lin_dense: "\<forall>x l u. (\<forall> t. l \<sqsubset> t \<and> t\<sqsubset> u \<longrightarrow> t \<notin> U) \<and> l\<sqsubset> x \<and> x \<sqsubset> u \<and> P x
112.431 - \<longrightarrow> (\<forall> y. l \<sqsubset> y \<and> y \<sqsubset> u \<longrightarrow> P y )"
112.432 - and nmpiU: "\<forall>x. \<not> MP \<and> \<not>PP \<and> P x \<longrightarrow> (\<exists> u\<in> U. \<exists> u' \<in> U. u \<sqsubseteq> x \<and> x \<sqsubseteq> u')"
112.433 - and nmi: "\<not> MP" and npi: "\<not> PP" and ex: "\<exists> x. P x"
112.434 - shows "\<exists> u\<in> U. \<exists> u' \<in> U. P (between u u')"
112.435 -proof-
112.436 - from ex obtain x where px: "P x" by blast
112.437 - from px nmi npi nmpiU have "\<exists> u\<in> U. \<exists> u' \<in> U. u \<sqsubseteq> x \<and> x \<sqsubseteq> u'" by auto
112.438 - then obtain u and u' where uU:"u\<in> U" and uU': "u' \<in> U" and ux:"u \<sqsubseteq> x" and xu':"x \<sqsubseteq> u'" by auto
112.439 - from uU have Une: "U \<noteq> {}" by auto
112.440 - term "linorder.Min less_eq"
112.441 - let ?l = "linorder.Min less_eq U"
112.442 - let ?u = "linorder.Max less_eq U"
112.443 - have linM: "?l \<in> U" using fU Une by simp
112.444 - have uinM: "?u \<in> U" using fU Une by simp
112.445 - have lM: "\<forall> t\<in> U. ?l \<sqsubseteq> t" using Une fU by auto
112.446 - have Mu: "\<forall> t\<in> U. t \<sqsubseteq> ?u" using Une fU by auto
112.447 - have th:"?l \<sqsubseteq> u" using uU Une lM by auto
112.448 - from order_trans[OF th ux] have lx: "?l \<sqsubseteq> x" .
112.449 - have th: "u' \<sqsubseteq> ?u" using uU' Une Mu by simp
112.450 - from order_trans[OF xu' th] have xu: "x \<sqsubseteq> ?u" .
112.451 - from finite_set_intervals2[where P="P",OF px lx xu linM uinM fU lM Mu]
112.452 - have "(\<exists> s\<in> U. P s) \<or>
112.453 - (\<exists> t1\<in> U. \<exists> t2 \<in> U. (\<forall> y. t1 \<sqsubset> y \<and> y \<sqsubset> t2 \<longrightarrow> y \<notin> U) \<and> t1 \<sqsubset> x \<and> x \<sqsubset> t2 \<and> P x)" .
112.454 - moreover { fix u assume um: "u\<in>U" and pu: "P u"
112.455 - have "between u u = u" by (simp add: between_same)
112.456 - with um pu have "P (between u u)" by simp
112.457 - with um have ?thesis by blast}
112.458 - moreover{
112.459 - assume "\<exists> t1\<in> U. \<exists> t2 \<in> U. (\<forall> y. t1 \<sqsubset> y \<and> y \<sqsubset> t2 \<longrightarrow> y \<notin> U) \<and> t1 \<sqsubset> x \<and> x \<sqsubset> t2 \<and> P x"
112.460 - then obtain t1 and t2 where t1M: "t1 \<in> U" and t2M: "t2\<in> U"
112.461 - and noM: "\<forall> y. t1 \<sqsubset> y \<and> y \<sqsubset> t2 \<longrightarrow> y \<notin> U" and t1x: "t1 \<sqsubset> x" and xt2: "x \<sqsubset> t2" and px: "P x"
112.462 - by blast
112.463 - from less_trans[OF t1x xt2] have t1t2: "t1 \<sqsubset> t2" .
112.464 - let ?u = "between t1 t2"
112.465 - from between_less t1t2 have t1lu: "t1 \<sqsubset> ?u" and ut2: "?u \<sqsubset> t2" by auto
112.466 - from lin_dense noM t1x xt2 px t1lu ut2 have "P ?u" by blast
112.467 - with t1M t2M have ?thesis by blast}
112.468 - ultimately show ?thesis by blast
112.469 - qed
112.470 -
112.471 -theorem fr_eq:
112.472 - assumes fU: "finite U"
112.473 - and lin_dense: "\<forall>x l u. (\<forall> t. l \<sqsubset> t \<and> t\<sqsubset> u \<longrightarrow> t \<notin> U) \<and> l\<sqsubset> x \<and> x \<sqsubset> u \<and> P x
112.474 - \<longrightarrow> (\<forall> y. l \<sqsubset> y \<and> y \<sqsubset> u \<longrightarrow> P y )"
112.475 - and nmibnd: "\<forall>x. \<not> MP \<and> P x \<longrightarrow> (\<exists> u\<in> U. u \<sqsubseteq> x)"
112.476 - and npibnd: "\<forall>x. \<not>PP \<and> P x \<longrightarrow> (\<exists> u\<in> U. x \<sqsubseteq> u)"
112.477 - and mi: "\<exists>z. \<forall>x. x \<sqsubset> z \<longrightarrow> (P x = MP)" and pi: "\<exists>z. \<forall>x. z \<sqsubset> x \<longrightarrow> (P x = PP)"
112.478 - shows "(\<exists> x. P x) \<equiv> (MP \<or> PP \<or> (\<exists> u \<in> U. \<exists> u'\<in> U. P (between u u')))"
112.479 - (is "_ \<equiv> (_ \<or> _ \<or> ?F)" is "?E \<equiv> ?D")
112.480 -proof-
112.481 - {
112.482 - assume px: "\<exists> x. P x"
112.483 - have "MP \<or> PP \<or> (\<not> MP \<and> \<not> PP)" by blast
112.484 - moreover {assume "MP \<or> PP" hence "?D" by blast}
112.485 - moreover {assume nmi: "\<not> MP" and npi: "\<not> PP"
112.486 - from npmibnd[OF nmibnd npibnd]
112.487 - have nmpiU: "\<forall>x. \<not> MP \<and> \<not>PP \<and> P x \<longrightarrow> (\<exists> u\<in> U. \<exists> u' \<in> U. u \<sqsubseteq> x \<and> x \<sqsubseteq> u')" .
112.488 - from rinf_U[OF fU lin_dense nmpiU nmi npi px] have "?D" by blast}
112.489 - ultimately have "?D" by blast}
112.490 - moreover
112.491 - { assume "?D"
112.492 - moreover {assume m:"MP" from minf_ex[OF mi m] have "?E" .}
112.493 - moreover {assume p: "PP" from pinf_ex[OF pi p] have "?E" . }
112.494 - moreover {assume f:"?F" hence "?E" by blast}
112.495 - ultimately have "?E" by blast}
112.496 - ultimately have "?E = ?D" by blast thus "?E \<equiv> ?D" by simp
112.497 -qed
112.498 -
112.499 -lemmas minf_thms = minf_conj minf_disj minf_eq minf_neq minf_lt minf_le minf_gt minf_ge minf_P
112.500 -lemmas pinf_thms = pinf_conj pinf_disj pinf_eq pinf_neq pinf_lt pinf_le pinf_gt pinf_ge pinf_P
112.501 -
112.502 -lemmas nmi_thms = nmi_conj nmi_disj nmi_eq nmi_neq nmi_lt nmi_le nmi_gt nmi_ge nmi_P
112.503 -lemmas npi_thms = npi_conj npi_disj npi_eq npi_neq npi_lt npi_le npi_gt npi_ge npi_P
112.504 -lemmas lin_dense_thms = lin_dense_conj lin_dense_disj lin_dense_eq lin_dense_neq lin_dense_lt lin_dense_le lin_dense_gt lin_dense_ge lin_dense_P
112.505 -
112.506 -lemma ferrack_axiom: "constr_dense_linear_order less_eq less between"
112.507 - by (rule constr_dense_linear_order_axioms)
112.508 -lemma atoms:
112.509 - shows "TERM (less :: 'a \<Rightarrow> _)"
112.510 - and "TERM (less_eq :: 'a \<Rightarrow> _)"
112.511 - and "TERM (op = :: 'a \<Rightarrow> _)" .
112.512 -
112.513 -declare ferrack_axiom [ferrack minf: minf_thms pinf: pinf_thms
112.514 - nmi: nmi_thms npi: npi_thms lindense:
112.515 - lin_dense_thms qe: fr_eq atoms: atoms]
112.516 -
112.517 -declaration {*
112.518 -let
112.519 -fun simps phi = map (Morphism.thm phi) [@{thm "not_less"}, @{thm "not_le"}]
112.520 -fun generic_whatis phi =
112.521 - let
112.522 - val [lt, le] = map (Morphism.term phi) [@{term "op \<sqsubset>"}, @{term "op \<sqsubseteq>"}]
112.523 - fun h x t =
112.524 - case term_of t of
112.525 - Const("op =", _)$y$z => if term_of x aconv y then Ferrante_Rackoff_Data.Eq
112.526 - else Ferrante_Rackoff_Data.Nox
112.527 - | @{term "Not"}$(Const("op =", _)$y$z) => if term_of x aconv y then Ferrante_Rackoff_Data.NEq
112.528 - else Ferrante_Rackoff_Data.Nox
112.529 - | b$y$z => if Term.could_unify (b, lt) then
112.530 - if term_of x aconv y then Ferrante_Rackoff_Data.Lt
112.531 - else if term_of x aconv z then Ferrante_Rackoff_Data.Gt
112.532 - else Ferrante_Rackoff_Data.Nox
112.533 - else if Term.could_unify (b, le) then
112.534 - if term_of x aconv y then Ferrante_Rackoff_Data.Le
112.535 - else if term_of x aconv z then Ferrante_Rackoff_Data.Ge
112.536 - else Ferrante_Rackoff_Data.Nox
112.537 - else Ferrante_Rackoff_Data.Nox
112.538 - | _ => Ferrante_Rackoff_Data.Nox
112.539 - in h end
112.540 - fun ss phi = HOL_ss addsimps (simps phi)
112.541 -in
112.542 - Ferrante_Rackoff_Data.funs @{thm "ferrack_axiom"}
112.543 - {isolate_conv = K (K (K Thm.reflexive)), whatis = generic_whatis, simpset = ss}
112.544 -end
112.545 -*}
112.546 -
112.547 -end
112.548 -
112.549 -use "~~/src/HOL/Tools/Qelim/ferrante_rackoff.ML"
112.550 -
112.551 -method_setup ferrack = {*
112.552 - Method.ctxt_args (Method.SIMPLE_METHOD' o FerranteRackoff.dlo_tac)
112.553 -*} "Ferrante and Rackoff's algorithm for quantifier elimination in dense linear orders"
112.554 -
112.555 -subsection {* Ferrante and Rackoff algorithm over ordered fields *}
112.556 -
112.557 -lemma neg_prod_lt:"(c\<Colon>'a\<Colon>ordered_field) < 0 \<Longrightarrow> ((c*x < 0) == (x > 0))"
112.558 -proof-
112.559 - assume H: "c < 0"
112.560 - have "c*x < 0 = (0/c < x)" by (simp only: neg_divide_less_eq[OF H] ring_simps)
112.561 - also have "\<dots> = (0 < x)" by simp
112.562 - finally show "(c*x < 0) == (x > 0)" by simp
112.563 -qed
112.564 -
112.565 -lemma pos_prod_lt:"(c\<Colon>'a\<Colon>ordered_field) > 0 \<Longrightarrow> ((c*x < 0) == (x < 0))"
112.566 -proof-
112.567 - assume H: "c > 0"
112.568 - hence "c*x < 0 = (0/c > x)" by (simp only: pos_less_divide_eq[OF H] ring_simps)
112.569 - also have "\<dots> = (0 > x)" by simp
112.570 - finally show "(c*x < 0) == (x < 0)" by simp
112.571 -qed
112.572 -
112.573 -lemma neg_prod_sum_lt: "(c\<Colon>'a\<Colon>ordered_field) < 0 \<Longrightarrow> ((c*x + t< 0) == (x > (- 1/c)*t))"
112.574 -proof-
112.575 - assume H: "c < 0"
112.576 - have "c*x + t< 0 = (c*x < -t)" by (subst less_iff_diff_less_0 [of "c*x" "-t"], simp)
112.577 - also have "\<dots> = (-t/c < x)" by (simp only: neg_divide_less_eq[OF H] ring_simps)
112.578 - also have "\<dots> = ((- 1/c)*t < x)" by simp
112.579 - finally show "(c*x + t < 0) == (x > (- 1/c)*t)" by simp
112.580 -qed
112.581 -
112.582 -lemma pos_prod_sum_lt:"(c\<Colon>'a\<Colon>ordered_field) > 0 \<Longrightarrow> ((c*x + t < 0) == (x < (- 1/c)*t))"
112.583 -proof-
112.584 - assume H: "c > 0"
112.585 - have "c*x + t< 0 = (c*x < -t)" by (subst less_iff_diff_less_0 [of "c*x" "-t"], simp)
112.586 - also have "\<dots> = (-t/c > x)" by (simp only: pos_less_divide_eq[OF H] ring_simps)
112.587 - also have "\<dots> = ((- 1/c)*t > x)" by simp
112.588 - finally show "(c*x + t < 0) == (x < (- 1/c)*t)" by simp
112.589 -qed
112.590 -
112.591 -lemma sum_lt:"((x::'a::pordered_ab_group_add) + t < 0) == (x < - t)"
112.592 - using less_diff_eq[where a= x and b=t and c=0] by simp
112.593 -
112.594 -lemma neg_prod_le:"(c\<Colon>'a\<Colon>ordered_field) < 0 \<Longrightarrow> ((c*x <= 0) == (x >= 0))"
112.595 -proof-
112.596 - assume H: "c < 0"
112.597 - have "c*x <= 0 = (0/c <= x)" by (simp only: neg_divide_le_eq[OF H] ring_simps)
112.598 - also have "\<dots> = (0 <= x)" by simp
112.599 - finally show "(c*x <= 0) == (x >= 0)" by simp
112.600 -qed
112.601 -
112.602 -lemma pos_prod_le:"(c\<Colon>'a\<Colon>ordered_field) > 0 \<Longrightarrow> ((c*x <= 0) == (x <= 0))"
112.603 -proof-
112.604 - assume H: "c > 0"
112.605 - hence "c*x <= 0 = (0/c >= x)" by (simp only: pos_le_divide_eq[OF H] ring_simps)
112.606 - also have "\<dots> = (0 >= x)" by simp
112.607 - finally show "(c*x <= 0) == (x <= 0)" by simp
112.608 -qed
112.609 -
112.610 -lemma neg_prod_sum_le: "(c\<Colon>'a\<Colon>ordered_field) < 0 \<Longrightarrow> ((c*x + t <= 0) == (x >= (- 1/c)*t))"
112.611 -proof-
112.612 - assume H: "c < 0"
112.613 - have "c*x + t <= 0 = (c*x <= -t)" by (subst le_iff_diff_le_0 [of "c*x" "-t"], simp)
112.614 - also have "\<dots> = (-t/c <= x)" by (simp only: neg_divide_le_eq[OF H] ring_simps)
112.615 - also have "\<dots> = ((- 1/c)*t <= x)" by simp
112.616 - finally show "(c*x + t <= 0) == (x >= (- 1/c)*t)" by simp
112.617 -qed
112.618 -
112.619 -lemma pos_prod_sum_le:"(c\<Colon>'a\<Colon>ordered_field) > 0 \<Longrightarrow> ((c*x + t <= 0) == (x <= (- 1/c)*t))"
112.620 -proof-
112.621 - assume H: "c > 0"
112.622 - have "c*x + t <= 0 = (c*x <= -t)" by (subst le_iff_diff_le_0 [of "c*x" "-t"], simp)
112.623 - also have "\<dots> = (-t/c >= x)" by (simp only: pos_le_divide_eq[OF H] ring_simps)
112.624 - also have "\<dots> = ((- 1/c)*t >= x)" by simp
112.625 - finally show "(c*x + t <= 0) == (x <= (- 1/c)*t)" by simp
112.626 -qed
112.627 -
112.628 -lemma sum_le:"((x::'a::pordered_ab_group_add) + t <= 0) == (x <= - t)"
112.629 - using le_diff_eq[where a= x and b=t and c=0] by simp
112.630 -
112.631 -lemma nz_prod_eq:"(c\<Colon>'a\<Colon>ordered_field) \<noteq> 0 \<Longrightarrow> ((c*x = 0) == (x = 0))" by simp
112.632 -lemma nz_prod_sum_eq: "(c\<Colon>'a\<Colon>ordered_field) \<noteq> 0 \<Longrightarrow> ((c*x + t = 0) == (x = (- 1/c)*t))"
112.633 -proof-
112.634 - assume H: "c \<noteq> 0"
112.635 - have "c*x + t = 0 = (c*x = -t)" by (subst eq_iff_diff_eq_0 [of "c*x" "-t"], simp)
112.636 - also have "\<dots> = (x = -t/c)" by (simp only: nonzero_eq_divide_eq[OF H] ring_simps)
112.637 - finally show "(c*x + t = 0) == (x = (- 1/c)*t)" by simp
112.638 -qed
112.639 -lemma sum_eq:"((x::'a::pordered_ab_group_add) + t = 0) == (x = - t)"
112.640 - using eq_diff_eq[where a= x and b=t and c=0] by simp
112.641 -
112.642 -
112.643 -class_interpretation class_ordered_field_dense_linear_order: constr_dense_linear_order
112.644 - ["op <=" "op <"
112.645 - "\<lambda> x y. 1/2 * ((x::'a::{ordered_field,recpower,number_ring}) + y)"]
112.646 -proof (unfold_locales, dlo, dlo, auto)
112.647 - fix x y::'a assume lt: "x < y"
112.648 - from less_half_sum[OF lt] show "x < (x + y) /2" by simp
112.649 -next
112.650 - fix x y::'a assume lt: "x < y"
112.651 - from gt_half_sum[OF lt] show "(x + y) /2 < y" by simp
112.652 -qed
112.653 -
112.654 -declaration{*
112.655 -let
112.656 -fun earlier [] x y = false
112.657 - | earlier (h::t) x y =
112.658 - if h aconvc y then false else if h aconvc x then true else earlier t x y;
112.659 -
112.660 -fun dest_frac ct = case term_of ct of
112.661 - Const (@{const_name "HOL.divide"},_) $ a $ b=>
112.662 - Rat.rat_of_quotient (snd (HOLogic.dest_number a), snd (HOLogic.dest_number b))
112.663 - | t => Rat.rat_of_int (snd (HOLogic.dest_number t))
112.664 -
112.665 -fun mk_frac phi cT x =
112.666 - let val (a, b) = Rat.quotient_of_rat x
112.667 - in if b = 1 then Numeral.mk_cnumber cT a
112.668 - else Thm.capply
112.669 - (Thm.capply (Drule.cterm_rule (instantiate' [SOME cT] []) @{cpat "op /"})
112.670 - (Numeral.mk_cnumber cT a))
112.671 - (Numeral.mk_cnumber cT b)
112.672 - end
112.673 -
112.674 -fun whatis x ct = case term_of ct of
112.675 - Const(@{const_name "HOL.plus"}, _)$(Const(@{const_name "HOL.times"},_)$_$y)$_ =>
112.676 - if y aconv term_of x then ("c*x+t",[(funpow 2 Thm.dest_arg1) ct, Thm.dest_arg ct])
112.677 - else ("Nox",[])
112.678 -| Const(@{const_name "HOL.plus"}, _)$y$_ =>
112.679 - if y aconv term_of x then ("x+t",[Thm.dest_arg ct])
112.680 - else ("Nox",[])
112.681 -| Const(@{const_name "HOL.times"}, _)$_$y =>
112.682 - if y aconv term_of x then ("c*x",[Thm.dest_arg1 ct])
112.683 - else ("Nox",[])
112.684 -| t => if t aconv term_of x then ("x",[]) else ("Nox",[]);
112.685 -
112.686 -fun xnormalize_conv ctxt [] ct = reflexive ct
112.687 -| xnormalize_conv ctxt (vs as (x::_)) ct =
112.688 - case term_of ct of
112.689 - Const(@{const_name HOL.less},_)$_$Const(@{const_name "HOL.zero"},_) =>
112.690 - (case whatis x (Thm.dest_arg1 ct) of
112.691 - ("c*x+t",[c,t]) =>
112.692 - let
112.693 - val cr = dest_frac c
112.694 - val clt = Thm.dest_fun2 ct
112.695 - val cz = Thm.dest_arg ct
112.696 - val neg = cr </ Rat.zero
112.697 - val cthp = Simplifier.rewrite (local_simpset_of ctxt)
112.698 - (Thm.capply @{cterm "Trueprop"}
112.699 - (if neg then Thm.capply (Thm.capply clt c) cz
112.700 - else Thm.capply (Thm.capply clt cz) c))
112.701 - val cth = equal_elim (symmetric cthp) TrueI
112.702 - val th = implies_elim (instantiate' [SOME (ctyp_of_term x)] (map SOME [c,x,t])
112.703 - (if neg then @{thm neg_prod_sum_lt} else @{thm pos_prod_sum_lt})) cth
112.704 - val rth = Conv.fconv_rule (Conv.arg_conv (Conv.binop_conv
112.705 - (Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
112.706 - in rth end
112.707 - | ("x+t",[t]) =>
112.708 - let
112.709 - val T = ctyp_of_term x
112.710 - val th = instantiate' [SOME T] [SOME x, SOME t] @{thm "sum_lt"}
112.711 - val rth = Conv.fconv_rule (Conv.arg_conv (Conv.binop_conv
112.712 - (Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
112.713 - in rth end
112.714 - | ("c*x",[c]) =>
112.715 - let
112.716 - val cr = dest_frac c
112.717 - val clt = Thm.dest_fun2 ct
112.718 - val cz = Thm.dest_arg ct
112.719 - val neg = cr </ Rat.zero
112.720 - val cthp = Simplifier.rewrite (local_simpset_of ctxt)
112.721 - (Thm.capply @{cterm "Trueprop"}
112.722 - (if neg then Thm.capply (Thm.capply clt c) cz
112.723 - else Thm.capply (Thm.capply clt cz) c))
112.724 - val cth = equal_elim (symmetric cthp) TrueI
112.725 - val th = implies_elim (instantiate' [SOME (ctyp_of_term x)] (map SOME [c,x])
112.726 - (if neg then @{thm neg_prod_lt} else @{thm pos_prod_lt})) cth
112.727 - val rth = th
112.728 - in rth end
112.729 - | _ => reflexive ct)
112.730 -
112.731 -
112.732 -| Const(@{const_name HOL.less_eq},_)$_$Const(@{const_name "HOL.zero"},_) =>
112.733 - (case whatis x (Thm.dest_arg1 ct) of
112.734 - ("c*x+t",[c,t]) =>
112.735 - let
112.736 - val T = ctyp_of_term x
112.737 - val cr = dest_frac c
112.738 - val clt = Drule.cterm_rule (instantiate' [SOME T] []) @{cpat "op <"}
112.739 - val cz = Thm.dest_arg ct
112.740 - val neg = cr </ Rat.zero
112.741 - val cthp = Simplifier.rewrite (local_simpset_of ctxt)
112.742 - (Thm.capply @{cterm "Trueprop"}
112.743 - (if neg then Thm.capply (Thm.capply clt c) cz
112.744 - else Thm.capply (Thm.capply clt cz) c))
112.745 - val cth = equal_elim (symmetric cthp) TrueI
112.746 - val th = implies_elim (instantiate' [SOME T] (map SOME [c,x,t])
112.747 - (if neg then @{thm neg_prod_sum_le} else @{thm pos_prod_sum_le})) cth
112.748 - val rth = Conv.fconv_rule (Conv.arg_conv (Conv.binop_conv
112.749 - (Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
112.750 - in rth end
112.751 - | ("x+t",[t]) =>
112.752 - let
112.753 - val T = ctyp_of_term x
112.754 - val th = instantiate' [SOME T] [SOME x, SOME t] @{thm "sum_le"}
112.755 - val rth = Conv.fconv_rule (Conv.arg_conv (Conv.binop_conv
112.756 - (Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
112.757 - in rth end
112.758 - | ("c*x",[c]) =>
112.759 - let
112.760 - val T = ctyp_of_term x
112.761 - val cr = dest_frac c
112.762 - val clt = Drule.cterm_rule (instantiate' [SOME T] []) @{cpat "op <"}
112.763 - val cz = Thm.dest_arg ct
112.764 - val neg = cr </ Rat.zero
112.765 - val cthp = Simplifier.rewrite (local_simpset_of ctxt)
112.766 - (Thm.capply @{cterm "Trueprop"}
112.767 - (if neg then Thm.capply (Thm.capply clt c) cz
112.768 - else Thm.capply (Thm.capply clt cz) c))
112.769 - val cth = equal_elim (symmetric cthp) TrueI
112.770 - val th = implies_elim (instantiate' [SOME (ctyp_of_term x)] (map SOME [c,x])
112.771 - (if neg then @{thm neg_prod_le} else @{thm pos_prod_le})) cth
112.772 - val rth = th
112.773 - in rth end
112.774 - | _ => reflexive ct)
112.775 -
112.776 -| Const("op =",_)$_$Const(@{const_name "HOL.zero"},_) =>
112.777 - (case whatis x (Thm.dest_arg1 ct) of
112.778 - ("c*x+t",[c,t]) =>
112.779 - let
112.780 - val T = ctyp_of_term x
112.781 - val cr = dest_frac c
112.782 - val ceq = Thm.dest_fun2 ct
112.783 - val cz = Thm.dest_arg ct
112.784 - val cthp = Simplifier.rewrite (local_simpset_of ctxt)
112.785 - (Thm.capply @{cterm "Trueprop"}
112.786 - (Thm.capply @{cterm "Not"} (Thm.capply (Thm.capply ceq c) cz)))
112.787 - val cth = equal_elim (symmetric cthp) TrueI
112.788 - val th = implies_elim
112.789 - (instantiate' [SOME T] (map SOME [c,x,t]) @{thm nz_prod_sum_eq}) cth
112.790 - val rth = Conv.fconv_rule (Conv.arg_conv (Conv.binop_conv
112.791 - (Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
112.792 - in rth end
112.793 - | ("x+t",[t]) =>
112.794 - let
112.795 - val T = ctyp_of_term x
112.796 - val th = instantiate' [SOME T] [SOME x, SOME t] @{thm "sum_eq"}
112.797 - val rth = Conv.fconv_rule (Conv.arg_conv (Conv.binop_conv
112.798 - (Normalizer.semiring_normalize_ord_conv ctxt (earlier vs)))) th
112.799 - in rth end
112.800 - | ("c*x",[c]) =>
112.801 - let
112.802 - val T = ctyp_of_term x
112.803 - val cr = dest_frac c
112.804 - val ceq = Thm.dest_fun2 ct
112.805 - val cz = Thm.dest_arg ct
112.806 - val cthp = Simplifier.rewrite (local_simpset_of ctxt)
112.807 - (Thm.capply @{cterm "Trueprop"}
112.808 - (Thm.capply @{cterm "Not"} (Thm.capply (Thm.capply ceq c) cz)))
112.809 - val cth = equal_elim (symmetric cthp) TrueI
112.810 - val rth = implies_elim
112.811 - (instantiate' [SOME T] (map SOME [c,x]) @{thm nz_prod_eq}) cth
112.812 - in rth end
112.813 - | _ => reflexive ct);
112.814 -
112.815 -local
112.816 - val less_iff_diff_less_0 = mk_meta_eq @{thm "less_iff_diff_less_0"}
112.817 - val le_iff_diff_le_0 = mk_meta_eq @{thm "le_iff_diff_le_0"}
112.818 - val eq_iff_diff_eq_0 = mk_meta_eq @{thm "eq_iff_diff_eq_0"}
112.819 -in
112.820 -fun field_isolate_conv phi ctxt vs ct = case term_of ct of
112.821 - Const(@{const_name HOL.less},_)$a$b =>
112.822 - let val (ca,cb) = Thm.dest_binop ct
112.823 - val T = ctyp_of_term ca
112.824 - val th = instantiate' [SOME T] [SOME ca, SOME cb] less_iff_diff_less_0
112.825 - val nth = Conv.fconv_rule
112.826 - (Conv.arg_conv (Conv.arg1_conv
112.827 - (Normalizer.semiring_normalize_ord_conv @{context} (earlier vs)))) th
112.828 - val rth = transitive nth (xnormalize_conv ctxt vs (Thm.rhs_of nth))
112.829 - in rth end
112.830 -| Const(@{const_name HOL.less_eq},_)$a$b =>
112.831 - let val (ca,cb) = Thm.dest_binop ct
112.832 - val T = ctyp_of_term ca
112.833 - val th = instantiate' [SOME T] [SOME ca, SOME cb] le_iff_diff_le_0
112.834 - val nth = Conv.fconv_rule
112.835 - (Conv.arg_conv (Conv.arg1_conv
112.836 - (Normalizer.semiring_normalize_ord_conv @{context} (earlier vs)))) th
112.837 - val rth = transitive nth (xnormalize_conv ctxt vs (Thm.rhs_of nth))
112.838 - in rth end
112.839 -
112.840 -| Const("op =",_)$a$b =>
112.841 - let val (ca,cb) = Thm.dest_binop ct
112.842 - val T = ctyp_of_term ca
112.843 - val th = instantiate' [SOME T] [SOME ca, SOME cb] eq_iff_diff_eq_0
112.844 - val nth = Conv.fconv_rule
112.845 - (Conv.arg_conv (Conv.arg1_conv
112.846 - (Normalizer.semiring_normalize_ord_conv @{context} (earlier vs)))) th
112.847 - val rth = transitive nth (xnormalize_conv ctxt vs (Thm.rhs_of nth))
112.848 - in rth end
112.849 -| @{term "Not"} $(Const("op =",_)$a$b) => Conv.arg_conv (field_isolate_conv phi ctxt vs) ct
112.850 -| _ => reflexive ct
112.851 -end;
112.852 -
112.853 -fun classfield_whatis phi =
112.854 - let
112.855 - fun h x t =
112.856 - case term_of t of
112.857 - Const("op =", _)$y$z => if term_of x aconv y then Ferrante_Rackoff_Data.Eq
112.858 - else Ferrante_Rackoff_Data.Nox
112.859 - | @{term "Not"}$(Const("op =", _)$y$z) => if term_of x aconv y then Ferrante_Rackoff_Data.NEq
112.860 - else Ferrante_Rackoff_Data.Nox
112.861 - | Const(@{const_name HOL.less},_)$y$z =>
112.862 - if term_of x aconv y then Ferrante_Rackoff_Data.Lt
112.863 - else if term_of x aconv z then Ferrante_Rackoff_Data.Gt
112.864 - else Ferrante_Rackoff_Data.Nox
112.865 - | Const (@{const_name HOL.less_eq},_)$y$z =>
112.866 - if term_of x aconv y then Ferrante_Rackoff_Data.Le
112.867 - else if term_of x aconv z then Ferrante_Rackoff_Data.Ge
112.868 - else Ferrante_Rackoff_Data.Nox
112.869 - | _ => Ferrante_Rackoff_Data.Nox
112.870 - in h end;
112.871 -fun class_field_ss phi =
112.872 - HOL_basic_ss addsimps ([@{thm "linorder_not_less"}, @{thm "linorder_not_le"}])
112.873 - addsplits [@{thm "abs_split"},@{thm "split_max"}, @{thm "split_min"}]
112.874 -
112.875 -in
112.876 -Ferrante_Rackoff_Data.funs @{thm "class_ordered_field_dense_linear_order.ferrack_axiom"}
112.877 - {isolate_conv = field_isolate_conv, whatis = classfield_whatis, simpset = class_field_ss}
112.878 -end
112.879 -*}
112.880 -
112.881 -
112.882 -end
113.1 --- a/src/HOL/Library/Executable_Set.thy Tue Dec 30 08:18:54 2008 +0100
113.2 +++ b/src/HOL/Library/Executable_Set.thy Tue Dec 30 11:10:01 2008 +0100
113.3 @@ -28,6 +28,10 @@
113.4 lemma [code]: "eq_set A B \<longleftrightarrow> A \<subseteq> B \<and> B \<subseteq> A"
113.5 unfolding eq_set_def by auto
113.6
113.7 +(* FIXME allow for Stefan's code generator:
113.8 +declare set_eq_subset[code unfold]
113.9 +*)
113.10 +
113.11 lemma [code]:
113.12 "a \<in> A \<longleftrightarrow> (\<exists>x\<in>A. x = a)"
113.13 unfolding bex_triv_one_point1 ..
113.14 @@ -35,6 +39,8 @@
113.15 definition filter_set :: "('a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> 'a set" where
113.16 "filter_set P xs = {x\<in>xs. P x}"
113.17
113.18 +declare filter_set_def[symmetric, code unfold]
113.19 +
113.20
113.21 subsection {* Operations on lists *}
113.22
113.23 @@ -269,5 +275,6 @@
113.24 Ball ("{*Blall*}")
113.25 Bex ("{*Blex*}")
113.26 filter_set ("{*filter*}")
113.27 + fold ("{* foldl o flip *}")
113.28
113.29 end
114.1 --- a/src/HOL/Library/Library.thy Tue Dec 30 08:18:54 2008 +0100
114.2 +++ b/src/HOL/Library/Library.thy Tue Dec 30 11:10:01 2008 +0100
114.3 @@ -16,7 +16,6 @@
114.4 Continuity
114.5 ContNotDenum
114.6 Countable
114.7 - Dense_Linear_Order
114.8 Efficient_Nat
114.9 Enum
114.10 Eval_Witness
115.1 --- a/src/HOL/Library/Multiset.thy Tue Dec 30 08:18:54 2008 +0100
115.2 +++ b/src/HOL/Library/Multiset.thy Tue Dec 30 11:10:01 2008 +0100
115.3 @@ -1481,4 +1481,155 @@
115.4 @{term "{#x+x|x:#M. x<c#}"}.
115.5 *}
115.6
115.7 +
115.8 +subsection {* Termination proofs with multiset orders *}
115.9 +
115.10 +lemma multi_member_skip: "x \<in># XS \<Longrightarrow> x \<in># {# y #} + XS"
115.11 + and multi_member_this: "x \<in># {# x #} + XS"
115.12 + and multi_member_last: "x \<in># {# x #}"
115.13 + by auto
115.14 +
115.15 +definition "ms_strict = mult pair_less"
115.16 +definition "ms_weak = ms_strict \<union> Id"
115.17 +
115.18 +lemma ms_reduction_pair: "reduction_pair (ms_strict, ms_weak)"
115.19 +unfolding reduction_pair_def ms_strict_def ms_weak_def pair_less_def
115.20 +by (auto intro: wf_mult1 wf_trancl simp: mult_def)
115.21 +
115.22 +lemma smsI:
115.23 + "(set_of A, set_of B) \<in> max_strict \<Longrightarrow> (Z + A, Z + B) \<in> ms_strict"
115.24 + unfolding ms_strict_def
115.25 +by (rule one_step_implies_mult) (auto simp add: max_strict_def pair_less_def elim!:max_ext.cases)
115.26 +
115.27 +lemma wmsI:
115.28 + "(set_of A, set_of B) \<in> max_strict \<or> A = {#} \<and> B = {#}
115.29 + \<Longrightarrow> (Z + A, Z + B) \<in> ms_weak"
115.30 +unfolding ms_weak_def ms_strict_def
115.31 +by (auto simp add: pair_less_def max_strict_def elim!:max_ext.cases intro: one_step_implies_mult)
115.32 +
115.33 +inductive pw_leq
115.34 +where
115.35 + pw_leq_empty: "pw_leq {#} {#}"
115.36 +| pw_leq_step: "\<lbrakk>(x,y) \<in> pair_leq; pw_leq X Y \<rbrakk> \<Longrightarrow> pw_leq ({#x#} + X) ({#y#} + Y)"
115.37 +
115.38 +lemma pw_leq_lstep:
115.39 + "(x, y) \<in> pair_leq \<Longrightarrow> pw_leq {#x#} {#y#}"
115.40 +by (drule pw_leq_step) (rule pw_leq_empty, simp)
115.41 +
115.42 +lemma pw_leq_split:
115.43 + assumes "pw_leq X Y"
115.44 + shows "\<exists>A B Z. X = A + Z \<and> Y = B + Z \<and> ((set_of A, set_of B) \<in> max_strict \<or> (B = {#} \<and> A = {#}))"
115.45 + using assms
115.46 +proof (induct)
115.47 + case pw_leq_empty thus ?case by auto
115.48 +next
115.49 + case (pw_leq_step x y X Y)
115.50 + then obtain A B Z where
115.51 + [simp]: "X = A + Z" "Y = B + Z"
115.52 + and 1[simp]: "(set_of A, set_of B) \<in> max_strict \<or> (B = {#} \<and> A = {#})"
115.53 + by auto
115.54 + from pw_leq_step have "x = y \<or> (x, y) \<in> pair_less"
115.55 + unfolding pair_leq_def by auto
115.56 + thus ?case
115.57 + proof
115.58 + assume [simp]: "x = y"
115.59 + have
115.60 + "{#x#} + X = A + ({#y#}+Z)
115.61 + \<and> {#y#} + Y = B + ({#y#}+Z)
115.62 + \<and> ((set_of A, set_of B) \<in> max_strict \<or> (B = {#} \<and> A = {#}))"
115.63 + by (auto simp: add_ac)
115.64 + thus ?case by (intro exI)
115.65 + next
115.66 + assume A: "(x, y) \<in> pair_less"
115.67 + let ?A' = "{#x#} + A" and ?B' = "{#y#} + B"
115.68 + have "{#x#} + X = ?A' + Z"
115.69 + "{#y#} + Y = ?B' + Z"
115.70 + by (auto simp add: add_ac)
115.71 + moreover have
115.72 + "(set_of ?A', set_of ?B') \<in> max_strict"
115.73 + using 1 A unfolding max_strict_def
115.74 + by (auto elim!: max_ext.cases)
115.75 + ultimately show ?thesis by blast
115.76 + qed
115.77 +qed
115.78 +
115.79 +lemma
115.80 + assumes pwleq: "pw_leq Z Z'"
115.81 + shows ms_strictI: "(set_of A, set_of B) \<in> max_strict \<Longrightarrow> (Z + A, Z' + B) \<in> ms_strict"
115.82 + and ms_weakI1: "(set_of A, set_of B) \<in> max_strict \<Longrightarrow> (Z + A, Z' + B) \<in> ms_weak"
115.83 + and ms_weakI2: "(Z + {#}, Z' + {#}) \<in> ms_weak"
115.84 +proof -
115.85 + from pw_leq_split[OF pwleq]
115.86 + obtain A' B' Z''
115.87 + where [simp]: "Z = A' + Z''" "Z' = B' + Z''"
115.88 + and mx_or_empty: "(set_of A', set_of B') \<in> max_strict \<or> (A' = {#} \<and> B' = {#})"
115.89 + by blast
115.90 + {
115.91 + assume max: "(set_of A, set_of B) \<in> max_strict"
115.92 + from mx_or_empty
115.93 + have "(Z'' + (A + A'), Z'' + (B + B')) \<in> ms_strict"
115.94 + proof
115.95 + assume max': "(set_of A', set_of B') \<in> max_strict"
115.96 + with max have "(set_of (A + A'), set_of (B + B')) \<in> max_strict"
115.97 + by (auto simp: max_strict_def intro: max_ext_additive)
115.98 + thus ?thesis by (rule smsI)
115.99 + next
115.100 + assume [simp]: "A' = {#} \<and> B' = {#}"
115.101 + show ?thesis by (rule smsI) (auto intro: max)
115.102 + qed
115.103 + thus "(Z + A, Z' + B) \<in> ms_strict" by (simp add:add_ac)
115.104 + thus "(Z + A, Z' + B) \<in> ms_weak" by (simp add: ms_weak_def)
115.105 + }
115.106 + from mx_or_empty
115.107 + have "(Z'' + A', Z'' + B') \<in> ms_weak" by (rule wmsI)
115.108 + thus "(Z + {#}, Z' + {#}) \<in> ms_weak" by (simp add:add_ac)
115.109 +qed
115.110 +
115.111 +lemma empty_idemp: "{#} + x = x" "x + {#} = x"
115.112 +and nonempty_plus: "{# x #} + rs \<noteq> {#}"
115.113 +and nonempty_single: "{# x #} \<noteq> {#}"
115.114 +by auto
115.115 +
115.116 +setup {*
115.117 +let
115.118 + fun msetT T = Type ("Multiset.multiset", [T]);
115.119 +
115.120 + fun mk_mset T [] = Const (@{const_name Mempty}, msetT T)
115.121 + | mk_mset T [x] = Const (@{const_name single}, T --> msetT T) $ x
115.122 + | mk_mset T (x :: xs) =
115.123 + Const (@{const_name plus}, msetT T --> msetT T --> msetT T) $
115.124 + mk_mset T [x] $ mk_mset T xs
115.125 +
115.126 + fun mset_member_tac m i =
115.127 + (if m <= 0 then
115.128 + rtac @{thm multi_member_this} i ORELSE rtac @{thm multi_member_last} i
115.129 + else
115.130 + rtac @{thm multi_member_skip} i THEN mset_member_tac (m - 1) i)
115.131 +
115.132 + val mset_nonempty_tac =
115.133 + rtac @{thm nonempty_plus} ORELSE' rtac @{thm nonempty_single}
115.134 +
115.135 + val regroup_munion_conv =
115.136 + FundefLib.regroup_conv @{const_name Multiset.Mempty} @{const_name plus}
115.137 + (map (fn t => t RS eq_reflection) (@{thms union_ac} @ @{thms empty_idemp}))
115.138 +
115.139 + fun unfold_pwleq_tac i =
115.140 + (rtac @{thm pw_leq_step} i THEN (fn st => unfold_pwleq_tac (i + 1) st))
115.141 + ORELSE (rtac @{thm pw_leq_lstep} i)
115.142 + ORELSE (rtac @{thm pw_leq_empty} i)
115.143 +
115.144 + val set_of_simps = [@{thm set_of_empty}, @{thm set_of_single}, @{thm set_of_union},
115.145 + @{thm Un_insert_left}, @{thm Un_empty_left}]
115.146 +in
115.147 + ScnpReconstruct.multiset_setup (ScnpReconstruct.Multiset
115.148 + {
115.149 + msetT=msetT, mk_mset=mk_mset, mset_regroup_conv=regroup_munion_conv,
115.150 + mset_member_tac=mset_member_tac, mset_nonempty_tac=mset_nonempty_tac,
115.151 + mset_pwleq_tac=unfold_pwleq_tac, set_of_simps=set_of_simps,
115.152 + smsI'=@{thm ms_strictI}, wmsI2''=@{thm ms_weakI2}, wmsI1=@{thm ms_weakI1},
115.153 + reduction_pair=@{thm ms_reduction_pair}
115.154 + })
115.155 end
115.156 +*}
115.157 +
115.158 +end
116.1 --- a/src/HOL/Lim.thy Tue Dec 30 08:18:54 2008 +0100
116.2 +++ b/src/HOL/Lim.thy Tue Dec 30 11:10:01 2008 +0100
116.3 @@ -7,7 +7,7 @@
116.4 header{* Limits and Continuity *}
116.5
116.6 theory Lim
116.7 -imports "~~/src/HOL/Hyperreal/SEQ"
116.8 +imports SEQ
116.9 begin
116.10
116.11 text{*Standard Definitions*}
117.1 --- a/src/HOL/MacLaurin.thy Tue Dec 30 08:18:54 2008 +0100
117.2 +++ b/src/HOL/MacLaurin.thy Tue Dec 30 11:10:01 2008 +0100
117.3 @@ -58,129 +58,157 @@
117.4 *}
117.5
117.6 lemma Maclaurin_lemma2:
117.7 - "[| \<forall>m t. m < n \<and> 0\<le>t \<and> t\<le>h \<longrightarrow> DERIV (diff m) t :> diff (Suc m) t;
117.8 - n = Suc k;
117.9 - difg =
117.10 + assumes diff: "\<forall>m t. m < n \<and> 0\<le>t \<and> t\<le>h \<longrightarrow> DERIV (diff m) t :> diff (Suc m) t"
117.11 + assumes n: "n = Suc k"
117.12 + assumes difg: "difg =
117.13 (\<lambda>m t. diff m t -
117.14 ((\<Sum>p = 0..<n - m. diff (m + p) 0 / real (fact p) * t ^ p) +
117.15 - B * (t ^ (n - m) / real (fact (n - m)))))|] ==>
117.16 - \<forall>m t. m < n & 0 \<le> t & t \<le> h -->
117.17 - DERIV (difg m) t :> difg (Suc m) t"
117.18 -apply clarify
117.19 -apply (rule DERIV_diff)
117.20 -apply (simp (no_asm_simp))
117.21 -apply (tactic {* DERIV_tac @{context} *})
117.22 -apply (tactic {* DERIV_tac @{context} *})
117.23 -apply (rule_tac [2] lemma_DERIV_subst)
117.24 -apply (rule_tac [2] DERIV_quotient)
117.25 -apply (rule_tac [3] DERIV_const)
117.26 -apply (rule_tac [2] DERIV_pow)
117.27 - prefer 3 apply (simp add: fact_diff_Suc)
117.28 - prefer 2 apply simp
117.29 -apply (frule_tac m = m in less_add_one, clarify)
117.30 -apply (simp del: setsum_op_ivl_Suc)
117.31 -apply (insert sumr_offset4 [of 1])
117.32 -apply (simp del: setsum_op_ivl_Suc fact_Suc realpow_Suc)
117.33 -apply (rule lemma_DERIV_subst)
117.34 -apply (rule DERIV_add)
117.35 -apply (rule_tac [2] DERIV_const)
117.36 -apply (rule DERIV_sumr, clarify)
117.37 - prefer 2 apply simp
117.38 -apply (simp (no_asm) add: divide_inverse mult_assoc del: fact_Suc realpow_Suc)
117.39 -apply (rule DERIV_cmult)
117.40 -apply (rule lemma_DERIV_subst)
117.41 -apply (best intro: DERIV_chain2 intro!: DERIV_intros)
117.42 -apply (subst fact_Suc)
117.43 -apply (subst real_of_nat_mult)
117.44 -apply (simp add: mult_ac)
117.45 + B * (t ^ (n - m) / real (fact (n - m)))))"
117.46 + shows
117.47 + "\<forall>m t. m < n & 0 \<le> t & t \<le> h --> DERIV (difg m) t :> difg (Suc m) t"
117.48 +unfolding difg
117.49 + apply clarify
117.50 + apply (rule DERIV_diff)
117.51 + apply (simp add: diff)
117.52 + apply (simp only: n)
117.53 + apply (rule DERIV_add)
117.54 + apply (rule_tac [2] DERIV_cmult)
117.55 + apply (rule_tac [2] lemma_DERIV_subst)
117.56 + apply (rule_tac [2] DERIV_quotient)
117.57 + apply (rule_tac [3] DERIV_const)
117.58 + apply (rule_tac [2] DERIV_pow)
117.59 + prefer 3 apply (simp add: fact_diff_Suc)
117.60 + prefer 2 apply simp
117.61 + apply (frule less_iff_Suc_add [THEN iffD1], clarify)
117.62 + apply (simp del: setsum_op_ivl_Suc)
117.63 + apply (insert sumr_offset4 [of 1])
117.64 + apply (simp del: setsum_op_ivl_Suc fact_Suc realpow_Suc)
117.65 + apply (rule lemma_DERIV_subst)
117.66 + apply (rule DERIV_add)
117.67 + apply (rule_tac [2] DERIV_const)
117.68 + apply (rule DERIV_sumr, clarify)
117.69 + prefer 2 apply simp
117.70 + apply (simp (no_asm) add: divide_inverse mult_assoc del: fact_Suc realpow_Suc)
117.71 + apply (rule DERIV_cmult)
117.72 + apply (rule lemma_DERIV_subst)
117.73 + apply (best intro: DERIV_chain2 intro!: DERIV_intros)
117.74 + apply (subst fact_Suc)
117.75 + apply (subst real_of_nat_mult)
117.76 + apply (simp add: mult_ac)
117.77 done
117.78
117.79
117.80 -lemma Maclaurin_lemma3:
117.81 - fixes difg :: "nat => real => real" shows
117.82 - "[|\<forall>k t. k < Suc m \<and> 0\<le>t & t\<le>h \<longrightarrow> DERIV (difg k) t :> difg (Suc k) t;
117.83 - \<forall>k<Suc m. difg k 0 = 0; DERIV (difg n) t :> 0; n < m; 0 < t;
117.84 - t < h|]
117.85 - ==> \<exists>ta. 0 < ta & ta < t & DERIV (difg (Suc n)) ta :> 0"
117.86 -apply (rule Rolle, assumption, simp)
117.87 -apply (drule_tac x = n and P="%k. k<Suc m --> difg k 0 = 0" in spec)
117.88 -apply (rule DERIV_unique)
117.89 -prefer 2 apply assumption
117.90 -apply force
117.91 -apply (metis DERIV_isCont dlo_simps(4) dlo_simps(9) less_trans_Suc nat_less_le not_less_eq real_le_trans)
117.92 -apply (metis Suc_less_eq differentiableI dlo_simps(7) dlo_simps(8) dlo_simps(9) real_le_trans xt1(8))
117.93 -done
117.94 -
117.95 lemma Maclaurin:
117.96 - "[| 0 < h; n > 0; diff 0 = f;
117.97 - \<forall>m t. m < n & 0 \<le> t & t \<le> h --> DERIV (diff m) t :> diff (Suc m) t |]
117.98 - ==> \<exists>t. 0 < t &
117.99 - t < h &
117.100 + assumes h: "0 < h"
117.101 + assumes n: "0 < n"
117.102 + assumes diff_0: "diff 0 = f"
117.103 + assumes diff_Suc:
117.104 + "\<forall>m t. m < n & 0 \<le> t & t \<le> h --> DERIV (diff m) t :> diff (Suc m) t"
117.105 + shows
117.106 + "\<exists>t. 0 < t & t < h &
117.107 f h =
117.108 setsum (%m. (diff m 0 / real (fact m)) * h ^ m) {0..<n} +
117.109 (diff n t / real (fact n)) * h ^ n"
117.110 -apply (case_tac "n = 0", force)
117.111 -apply (drule not0_implies_Suc)
117.112 -apply (erule exE)
117.113 -apply (frule_tac f=f and n=n and j="%m. diff m 0" in Maclaurin_lemma)
117.114 -apply (erule exE)
117.115 -apply (subgoal_tac "\<exists>g.
117.116 - g = (%t. f t - (setsum (%m. (diff m 0 / real(fact m)) * t^m) {0..<n} + (B * (t^n / real(fact n)))))")
117.117 - prefer 2 apply blast
117.118 -apply (erule exE)
117.119 -apply (subgoal_tac "g 0 = 0 & g h =0")
117.120 - prefer 2
117.121 - apply (simp del: setsum_op_ivl_Suc)
117.122 - apply (cut_tac n = m and k = 1 in sumr_offset2)
117.123 - apply (simp add: eq_diff_eq' del: setsum_op_ivl_Suc)
117.124 -apply (subgoal_tac "\<exists>difg. difg = (%m t. diff m t - (setsum (%p. (diff (m + p) 0 / real (fact p)) * (t ^ p)) {0..<n-m} + (B * ((t ^ (n - m)) / real (fact (n - m))))))")
117.125 - prefer 2 apply blast
117.126 -apply (erule exE)
117.127 -apply (subgoal_tac "difg 0 = g")
117.128 - prefer 2 apply simp
117.129 -apply (frule Maclaurin_lemma2, assumption+)
117.130 -apply (subgoal_tac "\<forall>ma. ma < n --> (\<exists>t. 0 < t & t < h & difg (Suc ma) t = 0) ")
117.131 - apply (drule_tac x = m and P="%m. m<n --> (\<exists>t. ?QQ m t)" in spec)
117.132 - apply (erule impE)
117.133 - apply (simp (no_asm_simp))
117.134 - apply (erule exE)
117.135 - apply (rule_tac x = t in exI)
117.136 - apply (simp del: realpow_Suc fact_Suc)
117.137 -apply (subgoal_tac "\<forall>m. m < n --> difg m 0 = 0")
117.138 - prefer 2
117.139 - apply clarify
117.140 - apply simp
117.141 - apply (frule_tac m = ma in less_add_one, clarify)
117.142 - apply (simp del: setsum_op_ivl_Suc)
117.143 -apply (insert sumr_offset4 [of 1])
117.144 -apply (simp del: setsum_op_ivl_Suc fact_Suc realpow_Suc)
117.145 -apply (subgoal_tac "\<forall>m. m < n --> (\<exists>t. 0 < t & t < h & DERIV (difg m) t :> 0) ")
117.146 -apply (rule allI, rule impI)
117.147 -apply (drule_tac x = ma and P="%m. m<n --> (\<exists>t. ?QQ m t)" in spec)
117.148 -apply (erule impE, assumption)
117.149 -apply (erule exE)
117.150 -apply (rule_tac x = t in exI)
117.151 -(* do some tidying up *)
117.152 -apply (erule_tac [!] V= "difg = (%m t. diff m t - (setsum (%p. diff (m + p) 0 / real (fact p) * t ^ p) {0..<n-m} + B * (t ^ (n - m) / real (fact (n - m)))))"
117.153 - in thin_rl)
117.154 -apply (erule_tac [!] V="g = (%t. f t - (setsum (%m. diff m 0 / real (fact m) * t ^ m) {0..<n} + B * (t ^ n / real (fact n))))"
117.155 - in thin_rl)
117.156 -apply (erule_tac [!] V="f h = setsum (%m. diff m 0 / real (fact m) * h ^ m) {0..<n} + B * (h ^ n / real (fact n))"
117.157 - in thin_rl)
117.158 -(* back to business *)
117.159 -apply (simp (no_asm_simp))
117.160 -apply (rule DERIV_unique)
117.161 -prefer 2 apply blast
117.162 -apply force
117.163 -apply (rule allI, induct_tac "ma")
117.164 -apply (rule impI, rule Rolle, assumption, simp, simp)
117.165 -apply (metis DERIV_isCont zero_less_Suc)
117.166 -apply (metis One_nat_def differentiableI dlo_simps(7))
117.167 -apply safe
117.168 -apply force
117.169 -apply (frule Maclaurin_lemma3, assumption+, safe)
117.170 -apply (rule_tac x = ta in exI, force)
117.171 -done
117.172 +proof -
117.173 + from n obtain m where m: "n = Suc m"
117.174 + by (cases n, simp add: n)
117.175 +
117.176 + obtain B where f_h: "f h =
117.177 + (\<Sum>m = 0..<n. diff m (0\<Colon>real) / real (fact m) * h ^ m) +
117.178 + B * (h ^ n / real (fact n))"
117.179 + using Maclaurin_lemma [OF h] ..
117.180 +
117.181 + obtain g where g_def: "g = (%t. f t -
117.182 + (setsum (%m. (diff m 0 / real(fact m)) * t^m) {0..<n}
117.183 + + (B * (t^n / real(fact n)))))" by blast
117.184 +
117.185 + have g2: "g 0 = 0 & g h = 0"
117.186 + apply (simp add: m f_h g_def del: setsum_op_ivl_Suc)
117.187 + apply (cut_tac n = m and k = 1 in sumr_offset2)
117.188 + apply (simp add: eq_diff_eq' diff_0 del: setsum_op_ivl_Suc)
117.189 + done
117.190 +
117.191 + obtain difg where difg_def: "difg = (%m t. diff m t -
117.192 + (setsum (%p. (diff (m + p) 0 / real (fact p)) * (t ^ p)) {0..<n-m}
117.193 + + (B * ((t ^ (n - m)) / real (fact (n - m))))))" by blast
117.194 +
117.195 + have difg_0: "difg 0 = g"
117.196 + unfolding difg_def g_def by (simp add: diff_0)
117.197 +
117.198 + have difg_Suc: "\<forall>(m\<Colon>nat) t\<Colon>real.
117.199 + m < n \<and> (0\<Colon>real) \<le> t \<and> t \<le> h \<longrightarrow> DERIV (difg m) t :> difg (Suc m) t"
117.200 + using diff_Suc m difg_def by (rule Maclaurin_lemma2)
117.201 +
117.202 + have difg_eq_0: "\<forall>m. m < n --> difg m 0 = 0"
117.203 + apply clarify
117.204 + apply (simp add: m difg_def)
117.205 + apply (frule less_iff_Suc_add [THEN iffD1], clarify)
117.206 + apply (simp del: setsum_op_ivl_Suc)
117.207 + apply (insert sumr_offset4 [of 1])
117.208 + apply (simp del: setsum_op_ivl_Suc fact_Suc realpow_Suc)
117.209 + done
117.210 +
117.211 + have isCont_difg: "\<And>m x. \<lbrakk>m < n; 0 \<le> x; x \<le> h\<rbrakk> \<Longrightarrow> isCont (difg m) x"
117.212 + by (rule DERIV_isCont [OF difg_Suc [rule_format]]) simp
117.213 +
117.214 + have differentiable_difg:
117.215 + "\<And>m x. \<lbrakk>m < n; 0 \<le> x; x \<le> h\<rbrakk> \<Longrightarrow> difg m differentiable x"
117.216 + by (rule differentiableI [OF difg_Suc [rule_format]]) simp
117.217 +
117.218 + have difg_Suc_eq_0: "\<And>m t. \<lbrakk>m < n; 0 \<le> t; t \<le> h; DERIV (difg m) t :> 0\<rbrakk>
117.219 + \<Longrightarrow> difg (Suc m) t = 0"
117.220 + by (rule DERIV_unique [OF difg_Suc [rule_format]]) simp
117.221 +
117.222 + have "m < n" using m by simp
117.223 +
117.224 + have "\<exists>t. 0 < t \<and> t < h \<and> DERIV (difg m) t :> 0"
117.225 + using `m < n`
117.226 + proof (induct m)
117.227 + case 0
117.228 + show ?case
117.229 + proof (rule Rolle)
117.230 + show "0 < h" by fact
117.231 + show "difg 0 0 = difg 0 h" by (simp add: difg_0 g2)
117.232 + show "\<forall>x. 0 \<le> x \<and> x \<le> h \<longrightarrow> isCont (difg (0\<Colon>nat)) x"
117.233 + by (simp add: isCont_difg n)
117.234 + show "\<forall>x. 0 < x \<and> x < h \<longrightarrow> difg (0\<Colon>nat) differentiable x"
117.235 + by (simp add: differentiable_difg n)
117.236 + qed
117.237 + next
117.238 + case (Suc m')
117.239 + hence "\<exists>t. 0 < t \<and> t < h \<and> DERIV (difg m') t :> 0" by simp
117.240 + then obtain t where t: "0 < t" "t < h" "DERIV (difg m') t :> 0" by fast
117.241 + have "\<exists>t'. 0 < t' \<and> t' < t \<and> DERIV (difg (Suc m')) t' :> 0"
117.242 + proof (rule Rolle)
117.243 + show "0 < t" by fact
117.244 + show "difg (Suc m') 0 = difg (Suc m') t"
117.245 + using t `Suc m' < n` by (simp add: difg_Suc_eq_0 difg_eq_0)
117.246 + show "\<forall>x. 0 \<le> x \<and> x \<le> t \<longrightarrow> isCont (difg (Suc m')) x"
117.247 + using `t < h` `Suc m' < n` by (simp add: isCont_difg)
117.248 + show "\<forall>x. 0 < x \<and> x < t \<longrightarrow> difg (Suc m') differentiable x"
117.249 + using `t < h` `Suc m' < n` by (simp add: differentiable_difg)
117.250 + qed
117.251 + thus ?case
117.252 + using `t < h` by auto
117.253 + qed
117.254 +
117.255 + then obtain t where "0 < t" "t < h" "DERIV (difg m) t :> 0" by fast
117.256 +
117.257 + hence "difg (Suc m) t = 0"
117.258 + using `m < n` by (simp add: difg_Suc_eq_0)
117.259 +
117.260 + show ?thesis
117.261 + proof (intro exI conjI)
117.262 + show "0 < t" by fact
117.263 + show "t < h" by fact
117.264 + show "f h =
117.265 + (\<Sum>m = 0..<n. diff m 0 / real (fact m) * h ^ m) +
117.266 + diff n t / real (fact n) * h ^ n"
117.267 + using `difg (Suc m) t = 0`
117.268 + by (simp add: m f_h difg_def del: realpow_Suc fact_Suc)
117.269 + qed
117.270 +
117.271 +qed
117.272
117.273 lemma Maclaurin_objl:
117.274 "0 < h & n>0 & diff 0 = f &
118.1 --- a/src/HOL/Nominal/Examples/CK_Machine.thy Tue Dec 30 08:18:54 2008 +0100
118.2 +++ b/src/HOL/Nominal/Examples/CK_Machine.thy Tue Dec 30 11:10:01 2008 +0100
118.3 @@ -1,5 +1,3 @@
118.4 -(* $Id$ *)
118.5 -
118.6 theory CK_Machine
118.7 imports "../Nominal"
118.8 begin
118.9 @@ -41,21 +39,21 @@
118.10
118.11 section {* Capture-Avoiding Substitution *}
118.12
118.13 -consts subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam" ("_[_::=_]" [100,100,100] 100)
118.14 -
118.15 nominal_primrec
118.16 + subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam" ("_[_::=_]" [100,100,100] 100)
118.17 +where
118.18 "(VAR x)[y::=s] = (if x=y then s else (VAR x))"
118.19 - "(APP t\<^isub>1 t\<^isub>2)[y::=s] = APP (t\<^isub>1[y::=s]) (t\<^isub>2[y::=s])"
118.20 - "x\<sharp>(y,s) \<Longrightarrow> (LAM [x].t)[y::=s] = LAM [x].(t[y::=s])"
118.21 - "(NUM n)[y::=s] = NUM n"
118.22 - "(t\<^isub>1 -- t\<^isub>2)[y::=s] = (t\<^isub>1[y::=s]) -- (t\<^isub>2[y::=s])"
118.23 - "(t\<^isub>1 ++ t\<^isub>2)[y::=s] = (t\<^isub>1[y::=s]) ++ (t\<^isub>2[y::=s])"
118.24 - "x\<sharp>(y,s) \<Longrightarrow> (FIX [x].t)[y::=s] = FIX [x].(t[y::=s])"
118.25 - "TRUE[y::=s] = TRUE"
118.26 - "FALSE[y::=s] = FALSE"
118.27 - "(IF t1 t2 t3)[y::=s] = IF (t1[y::=s]) (t2[y::=s]) (t3[y::=s])"
118.28 - "(ZET t)[y::=s] = ZET (t[y::=s])"
118.29 - "(EQI t1 t2)[y::=s] = EQI (t1[y::=s]) (t2[y::=s])"
118.30 +| "(APP t\<^isub>1 t\<^isub>2)[y::=s] = APP (t\<^isub>1[y::=s]) (t\<^isub>2[y::=s])"
118.31 +| "x\<sharp>(y,s) \<Longrightarrow> (LAM [x].t)[y::=s] = LAM [x].(t[y::=s])"
118.32 +| "(NUM n)[y::=s] = NUM n"
118.33 +| "(t\<^isub>1 -- t\<^isub>2)[y::=s] = (t\<^isub>1[y::=s]) -- (t\<^isub>2[y::=s])"
118.34 +| "(t\<^isub>1 ++ t\<^isub>2)[y::=s] = (t\<^isub>1[y::=s]) ++ (t\<^isub>2[y::=s])"
118.35 +| "x\<sharp>(y,s) \<Longrightarrow> (FIX [x].t)[y::=s] = FIX [x].(t[y::=s])"
118.36 +| "TRUE[y::=s] = TRUE"
118.37 +| "FALSE[y::=s] = FALSE"
118.38 +| "(IF t1 t2 t3)[y::=s] = IF (t1[y::=s]) (t2[y::=s]) (t3[y::=s])"
118.39 +| "(ZET t)[y::=s] = ZET (t[y::=s])"
118.40 +| "(EQI t1 t2)[y::=s] = EQI (t1[y::=s]) (t2[y::=s])"
118.41 apply(finite_guess)+
118.42 apply(rule TrueI)+
118.43 apply(simp add: abs_fresh)+
119.1 --- a/src/HOL/Nominal/Examples/CR_Takahashi.thy Tue Dec 30 08:18:54 2008 +0100
119.2 +++ b/src/HOL/Nominal/Examples/CR_Takahashi.thy Tue Dec 30 11:10:01 2008 +0100
119.3 @@ -1,5 +1,3 @@
119.4 -(* $Id$ *)
119.5 -
119.6 (* Authors: Christian Urban and Mathilde Arnaud *)
119.7 (* *)
119.8 (* A formalisation of the Church-Rosser proof by Masako Takahashi.*)
119.9 @@ -20,12 +18,12 @@
119.10 | App "lam" "lam"
119.11 | Lam "\<guillemotleft>name\<guillemotright>lam" ("Lam [_]._" [100,100] 100)
119.12
119.13 -consts subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam" ("_[_::=_]" [100,100,100] 100)
119.14 -
119.15 nominal_primrec
119.16 + subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam" ("_[_::=_]" [100,100,100] 100)
119.17 +where
119.18 "(Var x)[y::=s] = (if x=y then s else (Var x))"
119.19 - "(App t\<^isub>1 t\<^isub>2)[y::=s] = App (t\<^isub>1[y::=s]) (t\<^isub>2[y::=s])"
119.20 - "x\<sharp>(y,s) \<Longrightarrow> (Lam [x].t)[y::=s] = Lam [x].(t[y::=s])"
119.21 +| "(App t\<^isub>1 t\<^isub>2)[y::=s] = App (t\<^isub>1[y::=s]) (t\<^isub>2[y::=s])"
119.22 +| "x\<sharp>(y,s) \<Longrightarrow> (Lam [x].t)[y::=s] = Lam [x].(t[y::=s])"
119.23 apply(finite_guess)+
119.24 apply(rule TrueI)+
119.25 apply(simp add: abs_fresh)
119.26 @@ -54,14 +52,16 @@
119.27 lemma substitution_lemma:
119.28 assumes a: "x\<noteq>y" "x\<sharp>u"
119.29 shows "t[x::=s][y::=u] = t[y::=u][x::=s[y::=u]]"
119.30 -using a by (nominal_induct t avoiding: x y s u rule: lam.strong_induct)
119.31 - (auto simp add: fresh_fact forget)
119.32 +using a
119.33 +by (nominal_induct t avoiding: x y s u rule: lam.strong_induct)
119.34 + (auto simp add: fresh_fact forget)
119.35
119.36 lemma subst_rename:
119.37 assumes a: "y\<sharp>t"
119.38 shows "t[x::=s] = ([(y,x)]\<bullet>t)[y::=s]"
119.39 -using a by (nominal_induct t avoiding: x y s rule: lam.strong_induct)
119.40 - (auto simp add: calc_atm fresh_atm abs_fresh)
119.41 +using a
119.42 +by (nominal_induct t avoiding: x y s rule: lam.strong_induct)
119.43 + (auto simp add: swap_simps fresh_atm abs_fresh)
119.44
119.45 section {* Beta-Reduction *}
119.46
119.47 @@ -103,8 +103,9 @@
119.48 lemma One_subst:
119.49 assumes a: "t1 \<longrightarrow>\<^isub>1 t2" "s1 \<longrightarrow>\<^isub>1 s2"
119.50 shows "t1[x::=s1] \<longrightarrow>\<^isub>1 t2[x::=s2]"
119.51 -using a by (nominal_induct t1 t2 avoiding: s1 s2 x rule: One.strong_induct)
119.52 - (auto simp add: substitution_lemma fresh_atm fresh_fact)
119.53 +using a
119.54 +by (nominal_induct t1 t2 avoiding: s1 s2 x rule: One.strong_induct)
119.55 + (auto simp add: substitution_lemma fresh_atm fresh_fact)
119.56
119.57 lemma better_o4_intro:
119.58 assumes a: "t1 \<longrightarrow>\<^isub>1 t2" "s1 \<longrightarrow>\<^isub>1 s2"
119.59 @@ -202,35 +203,30 @@
119.60 by (nominal_induct M rule: lam.strong_induct)
119.61 (auto dest!: Dev_Lam intro: better_d4_intro)
119.62
119.63 -(* needs fixing *)
119.64 lemma Triangle:
119.65 assumes a: "t \<longrightarrow>\<^isub>d t1" "t \<longrightarrow>\<^isub>1 t2"
119.66 shows "t2 \<longrightarrow>\<^isub>1 t1"
119.67 using a
119.68 proof(nominal_induct avoiding: t2 rule: Dev.strong_induct)
119.69 case (d4 x s1 s2 t1 t1' t2)
119.70 - have ih1: "\<And>t. t1 \<longrightarrow>\<^isub>1 t \<Longrightarrow> t \<longrightarrow>\<^isub>1 t1'"
119.71 - and ih2: "\<And>s. s1 \<longrightarrow>\<^isub>1 s \<Longrightarrow> s \<longrightarrow>\<^isub>1 s2"
119.72 - and fc: "x\<sharp>t2" "x\<sharp>s1" "x\<sharp>s2" by fact+
119.73 + have fc: "x\<sharp>t2" "x\<sharp>s1" by fact+
119.74 have "App (Lam [x].t1) s1 \<longrightarrow>\<^isub>1 t2" by fact
119.75 - then obtain t' s' where "(t2 = App (Lam [x].t') s' \<and> t1 \<longrightarrow>\<^isub>1 t' \<and> s1 \<longrightarrow>\<^isub>1 s') \<or>
119.76 - (t2 = t'[x::=s'] \<and> t1 \<longrightarrow>\<^isub>1 t' \<and> s1 \<longrightarrow>\<^isub>1 s')"
119.77 + then obtain t' s' where reds:
119.78 + "(t2 = App (Lam [x].t') s' \<and> t1 \<longrightarrow>\<^isub>1 t' \<and> s1 \<longrightarrow>\<^isub>1 s') \<or>
119.79 + (t2 = t'[x::=s'] \<and> t1 \<longrightarrow>\<^isub>1 t' \<and> s1 \<longrightarrow>\<^isub>1 s')"
119.80 using fc by (auto dest!: One_Redex)
119.81 - then show "t2 \<longrightarrow>\<^isub>1 t1'[x::=s2]"
119.82 - apply -
119.83 - apply(erule disjE)
119.84 - apply(erule conjE)+
119.85 - apply(simp)
119.86 - apply(rule o4)
119.87 - using fc apply(simp)
119.88 - using ih1 apply(simp)
119.89 - using ih2 apply(simp)
119.90 - apply(erule conjE)+
119.91 - apply(simp)
119.92 - apply(rule One_subst)
119.93 - using ih1 apply(simp)
119.94 - using ih2 apply(simp)
119.95 - done
119.96 + have ih1: "t1 \<longrightarrow>\<^isub>1 t' \<Longrightarrow> t' \<longrightarrow>\<^isub>1 t1'" by fact
119.97 + have ih2: "s1 \<longrightarrow>\<^isub>1 s' \<Longrightarrow> s' \<longrightarrow>\<^isub>1 s2" by fact
119.98 + { assume "t1 \<longrightarrow>\<^isub>1 t'" "s1 \<longrightarrow>\<^isub>1 s'"
119.99 + then have "App (Lam [x].t') s' \<longrightarrow>\<^isub>1 t1'[x::=s2]"
119.100 + using ih1 ih2 by (auto intro: better_o4_intro)
119.101 + }
119.102 + moreover
119.103 + { assume "t1 \<longrightarrow>\<^isub>1 t'" "s1 \<longrightarrow>\<^isub>1 s'"
119.104 + then have "t'[x::=s'] \<longrightarrow>\<^isub>1 t1'[x::=s2]"
119.105 + using ih1 ih2 by (auto intro: One_subst)
119.106 + }
119.107 + ultimately show "t2 \<longrightarrow>\<^isub>1 t1'[x::=s2]" using reds by auto
119.108 qed (auto dest!: One_Lam One_Var One_App)
119.109
119.110 lemma Diamond_for_One:
119.111 @@ -310,4 +306,6 @@
119.112 then show "\<exists>t3. t1 \<longrightarrow>\<^isub>\<beta>\<^sup>* t3 \<and> t2 \<longrightarrow>\<^isub>\<beta>\<^sup>* t3" by (simp add: Beta_star_equals_One_star)
119.113 qed
119.114
119.115 +
119.116 +
119.117 end
120.1 --- a/src/HOL/Nominal/Examples/Class.thy Tue Dec 30 08:18:54 2008 +0100
120.2 +++ b/src/HOL/Nominal/Examples/Class.thy Tue Dec 30 11:10:01 2008 +0100
120.3 @@ -1,5 +1,3 @@
120.4 -(* $Id$ *)
120.5 -
120.6 theory Class
120.7 imports "../Nominal"
120.8 begin
120.9 @@ -17,16 +15,22 @@
120.10 | OR "ty" "ty" ("_ OR _" [100,100] 100)
120.11 | IMP "ty" "ty" ("_ IMP _" [100,100] 100)
120.12
120.13 -instance ty :: size ..
120.14 -
120.15 -nominal_primrec
120.16 +instantiation ty :: size
120.17 +begin
120.18 +
120.19 +nominal_primrec size_ty
120.20 +where
120.21 "size (PR s) = (1::nat)"
120.22 - "size (NOT T) = 1 + size T"
120.23 - "size (T1 AND T2) = 1 + size T1 + size T2"
120.24 - "size (T1 OR T2) = 1 + size T1 + size T2"
120.25 - "size (T1 IMP T2) = 1 + size T1 + size T2"
120.26 +| "size (NOT T) = 1 + size T"
120.27 +| "size (T1 AND T2) = 1 + size T1 + size T2"
120.28 +| "size (T1 OR T2) = 1 + size T1 + size T2"
120.29 +| "size (T1 IMP T2) = 1 + size T1 + size T2"
120.30 by (rule TrueI)+
120.31
120.32 +instance ..
120.33 +
120.34 +end
120.35 +
120.36 lemma ty_cases:
120.37 fixes T::ty
120.38 shows "(\<exists>s. T=PR s) \<or> (\<exists>T'. T=NOT T') \<or> (\<exists>S U. T=S OR U) \<or> (\<exists>S U. T=S AND U) \<or> (\<exists>S U. T=S IMP U)"
120.39 @@ -66,25 +70,23 @@
120.40
120.41 text {* renaming functions *}
120.42
120.43 -consts
120.44 - nrename :: "trm \<Rightarrow> name \<Rightarrow> name \<Rightarrow> trm" ("_[_\<turnstile>n>_]" [100,100,100] 100)
120.45 +nominal_primrec (freshness_context: "(d::coname,e::coname)")
120.46 crename :: "trm \<Rightarrow> coname \<Rightarrow> coname \<Rightarrow> trm" ("_[_\<turnstile>c>_]" [100,100,100] 100)
120.47 -
120.48 -nominal_primrec (freshness_context: "(d::coname,e::coname)")
120.49 +where
120.50 "(Ax x a)[d\<turnstile>c>e] = (if a=d then Ax x e else Ax x a)"
120.51 - "\<lbrakk>a\<sharp>(d,e,N);x\<sharp>M\<rbrakk> \<Longrightarrow> (Cut <a>.M (x).N)[d\<turnstile>c>e] = Cut <a>.(M[d\<turnstile>c>e]) (x).(N[d\<turnstile>c>e])"
120.52 - "(NotR (x).M a)[d\<turnstile>c>e] = (if a=d then NotR (x).(M[d\<turnstile>c>e]) e else NotR (x).(M[d\<turnstile>c>e]) a)"
120.53 - "a\<sharp>(d,e) \<Longrightarrow> (NotL <a>.M x)[d\<turnstile>c>e] = (NotL <a>.(M[d\<turnstile>c>e]) x)"
120.54 - "\<lbrakk>a\<sharp>(d,e,N,c);b\<sharp>(d,e,M,c);b\<noteq>a\<rbrakk> \<Longrightarrow> (AndR <a>.M <b>.N c)[d\<turnstile>c>e] =
120.55 +| "\<lbrakk>a\<sharp>(d,e,N);x\<sharp>M\<rbrakk> \<Longrightarrow> (Cut <a>.M (x).N)[d\<turnstile>c>e] = Cut <a>.(M[d\<turnstile>c>e]) (x).(N[d\<turnstile>c>e])"
120.56 +| "(NotR (x).M a)[d\<turnstile>c>e] = (if a=d then NotR (x).(M[d\<turnstile>c>e]) e else NotR (x).(M[d\<turnstile>c>e]) a)"
120.57 +| "a\<sharp>(d,e) \<Longrightarrow> (NotL <a>.M x)[d\<turnstile>c>e] = (NotL <a>.(M[d\<turnstile>c>e]) x)"
120.58 +| "\<lbrakk>a\<sharp>(d,e,N,c);b\<sharp>(d,e,M,c);b\<noteq>a\<rbrakk> \<Longrightarrow> (AndR <a>.M <b>.N c)[d\<turnstile>c>e] =
120.59 (if c=d then AndR <a>.(M[d\<turnstile>c>e]) <b>.(N[d \<turnstile>c>e]) e else AndR <a>.(M[d\<turnstile>c>e]) <b>.(N[d\<turnstile>c>e]) c)"
120.60 - "x\<sharp>y \<Longrightarrow> (AndL1 (x).M y)[d\<turnstile>c>e] = AndL1 (x).(M[d\<turnstile>c>e]) y"
120.61 - "x\<sharp>y \<Longrightarrow> (AndL2 (x).M y)[d\<turnstile>c>e] = AndL2 (x).(M[d\<turnstile>c>e]) y"
120.62 - "a\<sharp>(d,e,b) \<Longrightarrow> (OrR1 <a>.M b)[d\<turnstile>c>e] = (if b=d then OrR1 <a>.(M[d\<turnstile>c>e]) e else OrR1 <a>.(M[d\<turnstile>c>e]) b)"
120.63 - "a\<sharp>(d,e,b) \<Longrightarrow> (OrR2 <a>.M b)[d\<turnstile>c>e] = (if b=d then OrR2 <a>.(M[d\<turnstile>c>e]) e else OrR2 <a>.(M[d\<turnstile>c>e]) b)"
120.64 - "\<lbrakk>x\<sharp>(N,z);y\<sharp>(M,z);y\<noteq>x\<rbrakk> \<Longrightarrow> (OrL (x).M (y).N z)[d\<turnstile>c>e] = OrL (x).(M[d\<turnstile>c>e]) (y).(N[d\<turnstile>c>e]) z"
120.65 - "a\<sharp>(d,e,b) \<Longrightarrow> (ImpR (x).<a>.M b)[d\<turnstile>c>e] =
120.66 +| "x\<sharp>y \<Longrightarrow> (AndL1 (x).M y)[d\<turnstile>c>e] = AndL1 (x).(M[d\<turnstile>c>e]) y"
120.67 +| "x\<sharp>y \<Longrightarrow> (AndL2 (x).M y)[d\<turnstile>c>e] = AndL2 (x).(M[d\<turnstile>c>e]) y"
120.68 +| "a\<sharp>(d,e,b) \<Longrightarrow> (OrR1 <a>.M b)[d\<turnstile>c>e] = (if b=d then OrR1 <a>.(M[d\<turnstile>c>e]) e else OrR1 <a>.(M[d\<turnstile>c>e]) b)"
120.69 +| "a\<sharp>(d,e,b) \<Longrightarrow> (OrR2 <a>.M b)[d\<turnstile>c>e] = (if b=d then OrR2 <a>.(M[d\<turnstile>c>e]) e else OrR2 <a>.(M[d\<turnstile>c>e]) b)"
120.70 +| "\<lbrakk>x\<sharp>(N,z);y\<sharp>(M,z);y\<noteq>x\<rbrakk> \<Longrightarrow> (OrL (x).M (y).N z)[d\<turnstile>c>e] = OrL (x).(M[d\<turnstile>c>e]) (y).(N[d\<turnstile>c>e]) z"
120.71 +| "a\<sharp>(d,e,b) \<Longrightarrow> (ImpR (x).<a>.M b)[d\<turnstile>c>e] =
120.72 (if b=d then ImpR (x).<a>.(M[d\<turnstile>c>e]) e else ImpR (x).<a>.(M[d\<turnstile>c>e]) b)"
120.73 - "\<lbrakk>a\<sharp>(d,e,N);x\<sharp>(M,y)\<rbrakk> \<Longrightarrow> (ImpL <a>.M (x).N y)[d\<turnstile>c>e] = ImpL <a>.(M[d\<turnstile>c>e]) (x).(N[d\<turnstile>c>e]) y"
120.74 +| "\<lbrakk>a\<sharp>(d,e,N);x\<sharp>(M,y)\<rbrakk> \<Longrightarrow> (ImpL <a>.M (x).N y)[d\<turnstile>c>e] = ImpL <a>.(M[d\<turnstile>c>e]) (x).(N[d\<turnstile>c>e]) y"
120.75 apply(finite_guess)+
120.76 apply(rule TrueI)+
120.77 apply(simp add: abs_fresh abs_supp fin_supp)+
120.78 @@ -92,19 +94,21 @@
120.79 done
120.80
120.81 nominal_primrec (freshness_context: "(u::name,v::name)")
120.82 + nrename :: "trm \<Rightarrow> name \<Rightarrow> name \<Rightarrow> trm" ("_[_\<turnstile>n>_]" [100,100,100] 100)
120.83 +where
120.84 "(Ax x a)[u\<turnstile>n>v] = (if x=u then Ax v a else Ax x a)"
120.85 - "\<lbrakk>a\<sharp>N;x\<sharp>(u,v,M)\<rbrakk> \<Longrightarrow> (Cut <a>.M (x).N)[u\<turnstile>n>v] = Cut <a>.(M[u\<turnstile>n>v]) (x).(N[u\<turnstile>n>v])"
120.86 - "x\<sharp>(u,v) \<Longrightarrow> (NotR (x).M a)[u\<turnstile>n>v] = NotR (x).(M[u\<turnstile>n>v]) a"
120.87 - "(NotL <a>.M x)[u\<turnstile>n>v] = (if x=u then NotL <a>.(M[u\<turnstile>n>v]) v else NotL <a>.(M[u\<turnstile>n>v]) x)"
120.88 - "\<lbrakk>a\<sharp>(N,c);b\<sharp>(M,c);b\<noteq>a\<rbrakk> \<Longrightarrow> (AndR <a>.M <b>.N c)[u\<turnstile>n>v] = AndR <a>.(M[u\<turnstile>n>v]) <b>.(N[u\<turnstile>n>v]) c"
120.89 - "x\<sharp>(u,v,y) \<Longrightarrow> (AndL1 (x).M y)[u\<turnstile>n>v] = (if y=u then AndL1 (x).(M[u\<turnstile>n>v]) v else AndL1 (x).(M[u\<turnstile>n>v]) y)"
120.90 - "x\<sharp>(u,v,y) \<Longrightarrow> (AndL2 (x).M y)[u\<turnstile>n>v] = (if y=u then AndL2 (x).(M[u\<turnstile>n>v]) v else AndL2 (x).(M[u\<turnstile>n>v]) y)"
120.91 - "a\<sharp>b \<Longrightarrow> (OrR1 <a>.M b)[u\<turnstile>n>v] = OrR1 <a>.(M[u\<turnstile>n>v]) b"
120.92 - "a\<sharp>b \<Longrightarrow> (OrR2 <a>.M b)[u\<turnstile>n>v] = OrR2 <a>.(M[u\<turnstile>n>v]) b"
120.93 - "\<lbrakk>x\<sharp>(u,v,N,z);y\<sharp>(u,v,M,z);y\<noteq>x\<rbrakk> \<Longrightarrow> (OrL (x).M (y).N z)[u\<turnstile>n>v] =
120.94 +| "\<lbrakk>a\<sharp>N;x\<sharp>(u,v,M)\<rbrakk> \<Longrightarrow> (Cut <a>.M (x).N)[u\<turnstile>n>v] = Cut <a>.(M[u\<turnstile>n>v]) (x).(N[u\<turnstile>n>v])"
120.95 +| "x\<sharp>(u,v) \<Longrightarrow> (NotR (x).M a)[u\<turnstile>n>v] = NotR (x).(M[u\<turnstile>n>v]) a"
120.96 +| "(NotL <a>.M x)[u\<turnstile>n>v] = (if x=u then NotL <a>.(M[u\<turnstile>n>v]) v else NotL <a>.(M[u\<turnstile>n>v]) x)"
120.97 +| "\<lbrakk>a\<sharp>(N,c);b\<sharp>(M,c);b\<noteq>a\<rbrakk> \<Longrightarrow> (AndR <a>.M <b>.N c)[u\<turnstile>n>v] = AndR <a>.(M[u\<turnstile>n>v]) <b>.(N[u\<turnstile>n>v]) c"
120.98 +| "x\<sharp>(u,v,y) \<Longrightarrow> (AndL1 (x).M y)[u\<turnstile>n>v] = (if y=u then AndL1 (x).(M[u\<turnstile>n>v]) v else AndL1 (x).(M[u\<turnstile>n>v]) y)"
120.99 +| "x\<sharp>(u,v,y) \<Longrightarrow> (AndL2 (x).M y)[u\<turnstile>n>v] = (if y=u then AndL2 (x).(M[u\<turnstile>n>v]) v else AndL2 (x).(M[u\<turnstile>n>v]) y)"
120.100 +| "a\<sharp>b \<Longrightarrow> (OrR1 <a>.M b)[u\<turnstile>n>v] = OrR1 <a>.(M[u\<turnstile>n>v]) b"
120.101 +| "a\<sharp>b \<Longrightarrow> (OrR2 <a>.M b)[u\<turnstile>n>v] = OrR2 <a>.(M[u\<turnstile>n>v]) b"
120.102 +| "\<lbrakk>x\<sharp>(u,v,N,z);y\<sharp>(u,v,M,z);y\<noteq>x\<rbrakk> \<Longrightarrow> (OrL (x).M (y).N z)[u\<turnstile>n>v] =
120.103 (if z=u then OrL (x).(M[u\<turnstile>n>v]) (y).(N[u\<turnstile>n>v]) v else OrL (x).(M[u\<turnstile>n>v]) (y).(N[u\<turnstile>n>v]) z)"
120.104 - "\<lbrakk>a\<sharp>b; x\<sharp>(u,v)\<rbrakk> \<Longrightarrow> (ImpR (x).<a>.M b)[u\<turnstile>n>v] = ImpR (x).<a>.(M[u\<turnstile>n>v]) b"
120.105 - "\<lbrakk>a\<sharp>N;x\<sharp>(u,v,M,y)\<rbrakk> \<Longrightarrow> (ImpL <a>.M (x).N y)[u\<turnstile>n>v] =
120.106 +| "\<lbrakk>a\<sharp>b; x\<sharp>(u,v)\<rbrakk> \<Longrightarrow> (ImpR (x).<a>.M b)[u\<turnstile>n>v] = ImpR (x).<a>.(M[u\<turnstile>n>v]) b"
120.107 +| "\<lbrakk>a\<sharp>N;x\<sharp>(u,v,M,y)\<rbrakk> \<Longrightarrow> (ImpL <a>.M (x).N y)[u\<turnstile>n>v] =
120.108 (if y=u then ImpL <a>.(M[u\<turnstile>n>v]) (x).(N[u\<turnstile>n>v]) v else ImpL <a>.(M[u\<turnstile>n>v]) (x).(N[u\<turnstile>n>v]) y)"
120.109 apply(finite_guess)+
120.110 apply(rule TrueI)+
120.111 @@ -766,32 +770,30 @@
120.112 apply(simp add: fin_supp)
120.113 done
120.114
120.115 -consts
120.116 +nominal_primrec (freshness_context: "(y::name,c::coname,P::trm)")
120.117 substn :: "trm \<Rightarrow> name \<Rightarrow> coname \<Rightarrow> trm \<Rightarrow> trm" ("_{_:=<_>._}" [100,100,100,100] 100)
120.118 - substc :: "trm \<Rightarrow> coname \<Rightarrow> name \<Rightarrow> trm \<Rightarrow> trm" ("_{_:=(_)._}" [100,100,100,100] 100)
120.119 -
120.120 -nominal_primrec (freshness_context: "(y::name,c::coname,P::trm)")
120.121 +where
120.122 "(Ax x a){y:=<c>.P} = (if x=y then Cut <c>.P (y).Ax y a else Ax x a)"
120.123 - "\<lbrakk>a\<sharp>(c,P,N);x\<sharp>(y,P,M)\<rbrakk> \<Longrightarrow> (Cut <a>.M (x).N){y:=<c>.P} =
120.124 +| "\<lbrakk>a\<sharp>(c,P,N);x\<sharp>(y,P,M)\<rbrakk> \<Longrightarrow> (Cut <a>.M (x).N){y:=<c>.P} =
120.125 (if M=Ax y a then Cut <c>.P (x).(N{y:=<c>.P}) else Cut <a>.(M{y:=<c>.P}) (x).(N{y:=<c>.P}))"
120.126 - "x\<sharp>(y,P) \<Longrightarrow> (NotR (x).M a){y:=<c>.P} = NotR (x).(M{y:=<c>.P}) a"
120.127 - "a\<sharp>(c,P) \<Longrightarrow> (NotL <a>.M x){y:=<c>.P} =
120.128 +| "x\<sharp>(y,P) \<Longrightarrow> (NotR (x).M a){y:=<c>.P} = NotR (x).(M{y:=<c>.P}) a"
120.129 +| "a\<sharp>(c,P) \<Longrightarrow> (NotL <a>.M x){y:=<c>.P} =
120.130 (if x=y then fresh_fun (\<lambda>x'. Cut <c>.P (x').NotL <a>.(M{y:=<c>.P}) x') else NotL <a>.(M{y:=<c>.P}) x)"
120.131 - "\<lbrakk>a\<sharp>(c,P,N,d);b\<sharp>(c,P,M,d);b\<noteq>a\<rbrakk> \<Longrightarrow>
120.132 +| "\<lbrakk>a\<sharp>(c,P,N,d);b\<sharp>(c,P,M,d);b\<noteq>a\<rbrakk> \<Longrightarrow>
120.133 (AndR <a>.M <b>.N d){y:=<c>.P} = AndR <a>.(M{y:=<c>.P}) <b>.(N{y:=<c>.P}) d"
120.134 - "x\<sharp>(y,P,z) \<Longrightarrow> (AndL1 (x).M z){y:=<c>.P} =
120.135 +| "x\<sharp>(y,P,z) \<Longrightarrow> (AndL1 (x).M z){y:=<c>.P} =
120.136 (if z=y then fresh_fun (\<lambda>z'. Cut <c>.P (z').AndL1 (x).(M{y:=<c>.P}) z')
120.137 else AndL1 (x).(M{y:=<c>.P}) z)"
120.138 - "x\<sharp>(y,P,z) \<Longrightarrow> (AndL2 (x).M z){y:=<c>.P} =
120.139 +| "x\<sharp>(y,P,z) \<Longrightarrow> (AndL2 (x).M z){y:=<c>.P} =
120.140 (if z=y then fresh_fun (\<lambda>z'. Cut <c>.P (z').AndL2 (x).(M{y:=<c>.P}) z')
120.141 else AndL2 (x).(M{y:=<c>.P}) z)"
120.142 - "a\<sharp>(c,P,b) \<Longrightarrow> (OrR1 <a>.M b){y:=<c>.P} = OrR1 <a>.(M{y:=<c>.P}) b"
120.143 - "a\<sharp>(c,P,b) \<Longrightarrow> (OrR2 <a>.M b){y:=<c>.P} = OrR2 <a>.(M{y:=<c>.P}) b"
120.144 - "\<lbrakk>x\<sharp>(y,N,P,z);u\<sharp>(y,M,P,z);x\<noteq>u\<rbrakk> \<Longrightarrow> (OrL (x).M (u).N z){y:=<c>.P} =
120.145 +| "a\<sharp>(c,P,b) \<Longrightarrow> (OrR1 <a>.M b){y:=<c>.P} = OrR1 <a>.(M{y:=<c>.P}) b"
120.146 +| "a\<sharp>(c,P,b) \<Longrightarrow> (OrR2 <a>.M b){y:=<c>.P} = OrR2 <a>.(M{y:=<c>.P}) b"
120.147 +| "\<lbrakk>x\<sharp>(y,N,P,z);u\<sharp>(y,M,P,z);x\<noteq>u\<rbrakk> \<Longrightarrow> (OrL (x).M (u).N z){y:=<c>.P} =
120.148 (if z=y then fresh_fun (\<lambda>z'. Cut <c>.P (z').OrL (x).(M{y:=<c>.P}) (u).(N{y:=<c>.P}) z')
120.149 else OrL (x).(M{y:=<c>.P}) (u).(N{y:=<c>.P}) z)"
120.150 - "\<lbrakk>a\<sharp>(b,c,P); x\<sharp>(y,P)\<rbrakk> \<Longrightarrow> (ImpR (x).<a>.M b){y:=<c>.P} = ImpR (x).<a>.(M{y:=<c>.P}) b"
120.151 - "\<lbrakk>a\<sharp>(N,c,P);x\<sharp>(y,P,M,z)\<rbrakk> \<Longrightarrow> (ImpL <a>.M (x).N z){y:=<c>.P} =
120.152 +| "\<lbrakk>a\<sharp>(b,c,P); x\<sharp>(y,P)\<rbrakk> \<Longrightarrow> (ImpR (x).<a>.M b){y:=<c>.P} = ImpR (x).<a>.(M{y:=<c>.P}) b"
120.153 +| "\<lbrakk>a\<sharp>(N,c,P);x\<sharp>(y,P,M,z)\<rbrakk> \<Longrightarrow> (ImpL <a>.M (x).N z){y:=<c>.P} =
120.154 (if y=z then fresh_fun (\<lambda>z'. Cut <c>.P (z').ImpL <a>.(M{y:=<c>.P}) (x).(N{y:=<c>.P}) z')
120.155 else ImpL <a>.(M{y:=<c>.P}) (x).(N{y:=<c>.P}) z)"
120.156 apply(finite_guess)+
120.157 @@ -842,27 +844,29 @@
120.158 done
120.159
120.160 nominal_primrec (freshness_context: "(d::name,z::coname,P::trm)")
120.161 + substc :: "trm \<Rightarrow> coname \<Rightarrow> name \<Rightarrow> trm \<Rightarrow> trm" ("_{_:=(_)._}" [100,100,100,100] 100)
120.162 +where
120.163 "(Ax x a){d:=(z).P} = (if d=a then Cut <a>.(Ax x a) (z).P else Ax x a)"
120.164 - "\<lbrakk>a\<sharp>(d,P,N);x\<sharp>(z,P,M)\<rbrakk> \<Longrightarrow> (Cut <a>.M (x).N){d:=(z).P} =
120.165 +| "\<lbrakk>a\<sharp>(d,P,N);x\<sharp>(z,P,M)\<rbrakk> \<Longrightarrow> (Cut <a>.M (x).N){d:=(z).P} =
120.166 (if N=Ax x d then Cut <a>.(M{d:=(z).P}) (z).P else Cut <a>.(M{d:=(z).P}) (x).(N{d:=(z).P}))"
120.167 - "x\<sharp>(z,P) \<Longrightarrow> (NotR (x).M a){d:=(z).P} =
120.168 +| "x\<sharp>(z,P) \<Longrightarrow> (NotR (x).M a){d:=(z).P} =
120.169 (if d=a then fresh_fun (\<lambda>a'. Cut <a'>.NotR (x).(M{d:=(z).P}) a' (z).P) else NotR (x).(M{d:=(z).P}) a)"
120.170 - "a\<sharp>(d,P) \<Longrightarrow> (NotL <a>.M x){d:=(z).P} = NotL <a>.(M{d:=(z).P}) x"
120.171 - "\<lbrakk>a\<sharp>(P,c,N,d);b\<sharp>(P,c,M,d);b\<noteq>a\<rbrakk> \<Longrightarrow> (AndR <a>.M <b>.N c){d:=(z).P} =
120.172 +| "a\<sharp>(d,P) \<Longrightarrow> (NotL <a>.M x){d:=(z).P} = NotL <a>.(M{d:=(z).P}) x"
120.173 +| "\<lbrakk>a\<sharp>(P,c,N,d);b\<sharp>(P,c,M,d);b\<noteq>a\<rbrakk> \<Longrightarrow> (AndR <a>.M <b>.N c){d:=(z).P} =
120.174 (if d=c then fresh_fun (\<lambda>a'. Cut <a'>.(AndR <a>.(M{d:=(z).P}) <b>.(N{d:=(z).P}) a') (z).P)
120.175 else AndR <a>.(M{d:=(z).P}) <b>.(N{d:=(z).P}) c)"
120.176 - "x\<sharp>(y,z,P) \<Longrightarrow> (AndL1 (x).M y){d:=(z).P} = AndL1 (x).(M{d:=(z).P}) y"
120.177 - "x\<sharp>(y,P,z) \<Longrightarrow> (AndL2 (x).M y){d:=(z).P} = AndL2 (x).(M{d:=(z).P}) y"
120.178 - "a\<sharp>(d,P,b) \<Longrightarrow> (OrR1 <a>.M b){d:=(z).P} =
120.179 +| "x\<sharp>(y,z,P) \<Longrightarrow> (AndL1 (x).M y){d:=(z).P} = AndL1 (x).(M{d:=(z).P}) y"
120.180 +| "x\<sharp>(y,P,z) \<Longrightarrow> (AndL2 (x).M y){d:=(z).P} = AndL2 (x).(M{d:=(z).P}) y"
120.181 +| "a\<sharp>(d,P,b) \<Longrightarrow> (OrR1 <a>.M b){d:=(z).P} =
120.182 (if d=b then fresh_fun (\<lambda>a'. Cut <a'>.OrR1 <a>.(M{d:=(z).P}) a' (z).P) else OrR1 <a>.(M{d:=(z).P}) b)"
120.183 - "a\<sharp>(d,P,b) \<Longrightarrow> (OrR2 <a>.M b){d:=(z).P} =
120.184 +| "a\<sharp>(d,P,b) \<Longrightarrow> (OrR2 <a>.M b){d:=(z).P} =
120.185 (if d=b then fresh_fun (\<lambda>a'. Cut <a'>.OrR2 <a>.(M{d:=(z).P}) a' (z).P) else OrR2 <a>.(M{d:=(z).P}) b)"
120.186 - "\<lbrakk>x\<sharp>(N,z,P,u);y\<sharp>(M,z,P,u);x\<noteq>y\<rbrakk> \<Longrightarrow> (OrL (x).M (y).N u){d:=(z).P} =
120.187 +| "\<lbrakk>x\<sharp>(N,z,P,u);y\<sharp>(M,z,P,u);x\<noteq>y\<rbrakk> \<Longrightarrow> (OrL (x).M (y).N u){d:=(z).P} =
120.188 OrL (x).(M{d:=(z).P}) (y).(N{d:=(z).P}) u"
120.189 - "\<lbrakk>a\<sharp>(b,d,P); x\<sharp>(z,P)\<rbrakk> \<Longrightarrow> (ImpR (x).<a>.M b){d:=(z).P} =
120.190 +| "\<lbrakk>a\<sharp>(b,d,P); x\<sharp>(z,P)\<rbrakk> \<Longrightarrow> (ImpR (x).<a>.M b){d:=(z).P} =
120.191 (if d=b then fresh_fun (\<lambda>a'. Cut <a'>.ImpR (x).<a>.(M{d:=(z).P}) a' (z).P)
120.192 else ImpR (x).<a>.(M{d:=(z).P}) b)"
120.193 - "\<lbrakk>a\<sharp>(N,d,P);x\<sharp>(y,z,P,M)\<rbrakk> \<Longrightarrow> (ImpL <a>.M (x).N y){d:=(z).P} =
120.194 +| "\<lbrakk>a\<sharp>(N,d,P);x\<sharp>(y,z,P,M)\<rbrakk> \<Longrightarrow> (ImpL <a>.M (x).N y){d:=(z).P} =
120.195 ImpL <a>.(M{d:=(z).P}) (x).(N{d:=(z).P}) y"
120.196 apply(finite_guess)+
120.197 apply(rule TrueI)+
120.198 @@ -10305,11 +10309,10 @@
120.199 lemma BINDINGc_decreasing:
120.200 shows "X\<subseteq>Y \<Longrightarrow> BINDINGc B Y \<subseteq> BINDINGc B X"
120.201 by (simp add: BINDINGc_def) (blast)
120.202 -
120.203 -consts
120.204 - NOTRIGHT::"ty \<Rightarrow> ntrm set \<Rightarrow> ctrm set"
120.205
120.206 nominal_primrec
120.207 + NOTRIGHT :: "ty \<Rightarrow> ntrm set \<Rightarrow> ctrm set"
120.208 +where
120.209 "NOTRIGHT (NOT B) X = { <a>:NotR (x).M a | a x M. fic (NotR (x).M a) a \<and> (x):M \<in> X }"
120.210 apply(rule TrueI)+
120.211 done
120.212 @@ -10365,11 +10368,10 @@
120.213 apply(drule pt_bij1[OF pt_coname_inst, OF at_coname_inst])
120.214 apply(simp add: swap_simps)
120.215 done
120.216 -
120.217 -consts
120.218 - NOTLEFT::"ty \<Rightarrow> ctrm set \<Rightarrow> ntrm set"
120.219
120.220 nominal_primrec
120.221 + NOTLEFT :: "ty \<Rightarrow> ctrm set \<Rightarrow> ntrm set"
120.222 +where
120.223 "NOTLEFT (NOT B) X = { (x):NotL <a>.M x | a x M. fin (NotL <a>.M x) x \<and> <a>:M \<in> X }"
120.224 apply(rule TrueI)+
120.225 done
120.226 @@ -10425,11 +10427,10 @@
120.227 apply(drule pt_bij1[OF pt_coname_inst, OF at_coname_inst])
120.228 apply(simp add: swap_simps)
120.229 done
120.230 -
120.231 -consts
120.232 - ANDRIGHT::"ty \<Rightarrow> ctrm set \<Rightarrow> ctrm set \<Rightarrow> ctrm set"
120.233
120.234 nominal_primrec
120.235 + ANDRIGHT :: "ty \<Rightarrow> ctrm set \<Rightarrow> ctrm set \<Rightarrow> ctrm set"
120.236 +where
120.237 "ANDRIGHT (B AND C) X Y =
120.238 { <c>:AndR <a>.M <b>.N c | c a b M N. fic (AndR <a>.M <b>.N c) c \<and> <a>:M \<in> X \<and> <b>:N \<in> Y }"
120.239 apply(rule TrueI)+
120.240 @@ -10505,10 +10506,9 @@
120.241 apply(simp)
120.242 done
120.243
120.244 -consts
120.245 - ANDLEFT1::"ty \<Rightarrow> ntrm set \<Rightarrow> ntrm set"
120.246 -
120.247 nominal_primrec
120.248 + ANDLEFT1 :: "ty \<Rightarrow> ntrm set \<Rightarrow> ntrm set"
120.249 +where
120.250 "ANDLEFT1 (B AND C) X = { (y):AndL1 (x).M y | x y M. fin (AndL1 (x).M y) y \<and> (x):M \<in> X }"
120.251 apply(rule TrueI)+
120.252 done
120.253 @@ -10565,10 +10565,9 @@
120.254 apply(simp add: swap_simps)
120.255 done
120.256
120.257 -consts
120.258 - ANDLEFT2::"ty \<Rightarrow> ntrm set \<Rightarrow> ntrm set"
120.259 -
120.260 nominal_primrec
120.261 + ANDLEFT2 :: "ty \<Rightarrow> ntrm set \<Rightarrow> ntrm set"
120.262 +where
120.263 "ANDLEFT2 (B AND C) X = { (y):AndL2 (x).M y | x y M. fin (AndL2 (x).M y) y \<and> (x):M \<in> X }"
120.264 apply(rule TrueI)+
120.265 done
120.266 @@ -10625,10 +10624,9 @@
120.267 apply(simp add: swap_simps)
120.268 done
120.269
120.270 -consts
120.271 - ORLEFT::"ty \<Rightarrow> ntrm set \<Rightarrow> ntrm set \<Rightarrow> ntrm set"
120.272 -
120.273 nominal_primrec
120.274 + ORLEFT :: "ty \<Rightarrow> ntrm set \<Rightarrow> ntrm set \<Rightarrow> ntrm set"
120.275 +where
120.276 "ORLEFT (B OR C) X Y =
120.277 { (z):OrL (x).M (y).N z | x y z M N. fin (OrL (x).M (y).N z) z \<and> (x):M \<in> X \<and> (y):N \<in> Y }"
120.278 apply(rule TrueI)+
120.279 @@ -10704,10 +10702,9 @@
120.280 apply(simp add: swap_simps)
120.281 done
120.282
120.283 -consts
120.284 - ORRIGHT1::"ty \<Rightarrow> ctrm set \<Rightarrow> ctrm set"
120.285 -
120.286 nominal_primrec
120.287 + ORRIGHT1 :: "ty \<Rightarrow> ctrm set \<Rightarrow> ctrm set"
120.288 +where
120.289 "ORRIGHT1 (B OR C) X = { <b>:OrR1 <a>.M b | a b M. fic (OrR1 <a>.M b) b \<and> <a>:M \<in> X }"
120.290 apply(rule TrueI)+
120.291 done
120.292 @@ -10764,10 +10761,9 @@
120.293 apply(simp)
120.294 done
120.295
120.296 -consts
120.297 - ORRIGHT2::"ty \<Rightarrow> ctrm set \<Rightarrow> ctrm set"
120.298 -
120.299 nominal_primrec
120.300 + ORRIGHT2 :: "ty \<Rightarrow> ctrm set \<Rightarrow> ctrm set"
120.301 +where
120.302 "ORRIGHT2 (B OR C) X = { <b>:OrR2 <a>.M b | a b M. fic (OrR2 <a>.M b) b \<and> <a>:M \<in> X }"
120.303 apply(rule TrueI)+
120.304 done
120.305 @@ -10824,10 +10820,9 @@
120.306 apply(simp)
120.307 done
120.308
120.309 -consts
120.310 - IMPRIGHT::"ty \<Rightarrow> ntrm set \<Rightarrow> ctrm set \<Rightarrow> ntrm set \<Rightarrow> ctrm set \<Rightarrow> ctrm set"
120.311 -
120.312 nominal_primrec
120.313 + IMPRIGHT :: "ty \<Rightarrow> ntrm set \<Rightarrow> ctrm set \<Rightarrow> ntrm set \<Rightarrow> ctrm set \<Rightarrow> ctrm set"
120.314 +where
120.315 "IMPRIGHT (B IMP C) X Y Z U=
120.316 { <b>:ImpR (x).<a>.M b | x a b M. fic (ImpR (x).<a>.M b) b
120.317 \<and> (\<forall>z P. x\<sharp>(z,P) \<and> (z):P \<in> Z \<longrightarrow> (x):(M{a:=(z).P}) \<in> X)
120.318 @@ -10954,10 +10949,9 @@
120.319 apply(perm_simp add: nsubst_eqvt fresh_right)
120.320 done
120.321
120.322 -consts
120.323 - IMPLEFT::"ty \<Rightarrow> ctrm set \<Rightarrow> ntrm set \<Rightarrow> ntrm set"
120.324 -
120.325 nominal_primrec
120.326 + IMPLEFT :: "ty \<Rightarrow> ctrm set \<Rightarrow> ntrm set \<Rightarrow> ntrm set"
120.327 +where
120.328 "IMPLEFT (B IMP C) X Y =
120.329 { (y):ImpL <a>.M (x).N y | x a y M N. fin (ImpL <a>.M (x).N y) y \<and> <a>:M \<in> X \<and> (x):N \<in> Y }"
120.330 apply(rule TrueI)+
120.331 @@ -17800,23 +17794,21 @@
120.332 apply(auto)
120.333 done
120.334
120.335 -consts
120.336 +nominal_primrec (freshness_context: "\<theta>n::(name\<times>coname\<times>trm)")
120.337 stn :: "trm\<Rightarrow>(name\<times>coname\<times>trm) list\<Rightarrow>trm"
120.338 - stc :: "trm\<Rightarrow>(coname\<times>name\<times>trm) list\<Rightarrow>trm"
120.339 -
120.340 -nominal_primrec (freshness_context: "\<theta>n::(name\<times>coname\<times>trm)")
120.341 +where
120.342 "stn (Ax x a) \<theta>n = lookupc x a \<theta>n"
120.343 - "\<lbrakk>a\<sharp>(N,\<theta>n);x\<sharp>(M,\<theta>n)\<rbrakk> \<Longrightarrow> stn (Cut <a>.M (x).N) \<theta>n = (Cut <a>.M (x).N)"
120.344 - "x\<sharp>\<theta>n \<Longrightarrow> stn (NotR (x).M a) \<theta>n = (NotR (x).M a)"
120.345 - "a\<sharp>\<theta>n \<Longrightarrow>stn (NotL <a>.M x) \<theta>n = (NotL <a>.M x)"
120.346 - "\<lbrakk>a\<sharp>(N,d,b,\<theta>n);b\<sharp>(M,d,a,\<theta>n)\<rbrakk> \<Longrightarrow> stn (AndR <a>.M <b>.N d) \<theta>n = (AndR <a>.M <b>.N d)"
120.347 - "x\<sharp>(z,\<theta>n) \<Longrightarrow> stn (AndL1 (x).M z) \<theta>n = (AndL1 (x).M z)"
120.348 - "x\<sharp>(z,\<theta>n) \<Longrightarrow> stn (AndL2 (x).M z) \<theta>n = (AndL2 (x).M z)"
120.349 - "a\<sharp>(b,\<theta>n) \<Longrightarrow> stn (OrR1 <a>.M b) \<theta>n = (OrR1 <a>.M b)"
120.350 - "a\<sharp>(b,\<theta>n) \<Longrightarrow> stn (OrR2 <a>.M b) \<theta>n = (OrR2 <a>.M b)"
120.351 - "\<lbrakk>x\<sharp>(N,z,u,\<theta>n);u\<sharp>(M,z,x,\<theta>n)\<rbrakk> \<Longrightarrow> stn (OrL (x).M (u).N z) \<theta>n = (OrL (x).M (u).N z)"
120.352 - "\<lbrakk>a\<sharp>(b,\<theta>n);x\<sharp>\<theta>n\<rbrakk> \<Longrightarrow> stn (ImpR (x).<a>.M b) \<theta>n = (ImpR (x).<a>.M b)"
120.353 - "\<lbrakk>a\<sharp>(N,\<theta>n);x\<sharp>(M,z,\<theta>n)\<rbrakk> \<Longrightarrow> stn (ImpL <a>.M (x).N z) \<theta>n = (ImpL <a>.M (x).N z)"
120.354 +| "\<lbrakk>a\<sharp>(N,\<theta>n);x\<sharp>(M,\<theta>n)\<rbrakk> \<Longrightarrow> stn (Cut <a>.M (x).N) \<theta>n = (Cut <a>.M (x).N)"
120.355 +| "x\<sharp>\<theta>n \<Longrightarrow> stn (NotR (x).M a) \<theta>n = (NotR (x).M a)"
120.356 +| "a\<sharp>\<theta>n \<Longrightarrow>stn (NotL <a>.M x) \<theta>n = (NotL <a>.M x)"
120.357 +| "\<lbrakk>a\<sharp>(N,d,b,\<theta>n);b\<sharp>(M,d,a,\<theta>n)\<rbrakk> \<Longrightarrow> stn (AndR <a>.M <b>.N d) \<theta>n = (AndR <a>.M <b>.N d)"
120.358 +| "x\<sharp>(z,\<theta>n) \<Longrightarrow> stn (AndL1 (x).M z) \<theta>n = (AndL1 (x).M z)"
120.359 +| "x\<sharp>(z,\<theta>n) \<Longrightarrow> stn (AndL2 (x).M z) \<theta>n = (AndL2 (x).M z)"
120.360 +| "a\<sharp>(b,\<theta>n) \<Longrightarrow> stn (OrR1 <a>.M b) \<theta>n = (OrR1 <a>.M b)"
120.361 +| "a\<sharp>(b,\<theta>n) \<Longrightarrow> stn (OrR2 <a>.M b) \<theta>n = (OrR2 <a>.M b)"
120.362 +| "\<lbrakk>x\<sharp>(N,z,u,\<theta>n);u\<sharp>(M,z,x,\<theta>n)\<rbrakk> \<Longrightarrow> stn (OrL (x).M (u).N z) \<theta>n = (OrL (x).M (u).N z)"
120.363 +| "\<lbrakk>a\<sharp>(b,\<theta>n);x\<sharp>\<theta>n\<rbrakk> \<Longrightarrow> stn (ImpR (x).<a>.M b) \<theta>n = (ImpR (x).<a>.M b)"
120.364 +| "\<lbrakk>a\<sharp>(N,\<theta>n);x\<sharp>(M,z,\<theta>n)\<rbrakk> \<Longrightarrow> stn (ImpL <a>.M (x).N z) \<theta>n = (ImpL <a>.M (x).N z)"
120.365 apply(finite_guess)+
120.366 apply(rule TrueI)+
120.367 apply(simp add: abs_fresh abs_supp fin_supp)+
120.368 @@ -17824,18 +17816,20 @@
120.369 done
120.370
120.371 nominal_primrec (freshness_context: "\<theta>c::(coname\<times>name\<times>trm)")
120.372 + stc :: "trm\<Rightarrow>(coname\<times>name\<times>trm) list\<Rightarrow>trm"
120.373 +where
120.374 "stc (Ax x a) \<theta>c = lookupd x a \<theta>c"
120.375 - "\<lbrakk>a\<sharp>(N,\<theta>c);x\<sharp>(M,\<theta>c)\<rbrakk> \<Longrightarrow> stc (Cut <a>.M (x).N) \<theta>c = (Cut <a>.M (x).N)"
120.376 - "x\<sharp>\<theta>c \<Longrightarrow> stc (NotR (x).M a) \<theta>c = (NotR (x).M a)"
120.377 - "a\<sharp>\<theta>c \<Longrightarrow> stc (NotL <a>.M x) \<theta>c = (NotL <a>.M x)"
120.378 - "\<lbrakk>a\<sharp>(N,d,b,\<theta>c);b\<sharp>(M,d,a,\<theta>c)\<rbrakk> \<Longrightarrow> stc (AndR <a>.M <b>.N d) \<theta>c = (AndR <a>.M <b>.N d)"
120.379 - "x\<sharp>(z,\<theta>c) \<Longrightarrow> stc (AndL1 (x).M z) \<theta>c = (AndL1 (x).M z)"
120.380 - "x\<sharp>(z,\<theta>c) \<Longrightarrow> stc (AndL2 (x).M z) \<theta>c = (AndL2 (x).M z)"
120.381 - "a\<sharp>(b,\<theta>c) \<Longrightarrow> stc (OrR1 <a>.M b) \<theta>c = (OrR1 <a>.M b)"
120.382 - "a\<sharp>(b,\<theta>c) \<Longrightarrow> stc (OrR2 <a>.M b) \<theta>c = (OrR2 <a>.M b)"
120.383 - "\<lbrakk>x\<sharp>(N,z,u,\<theta>c);u\<sharp>(M,z,x,\<theta>c)\<rbrakk> \<Longrightarrow> stc (OrL (x).M (u).N z) \<theta>c = (OrL (x).M (u).N z)"
120.384 - "\<lbrakk>a\<sharp>(b,\<theta>c);x\<sharp>\<theta>c\<rbrakk> \<Longrightarrow> stc (ImpR (x).<a>.M b) \<theta>c = (ImpR (x).<a>.M b)"
120.385 - "\<lbrakk>a\<sharp>(N,\<theta>c);x\<sharp>(M,z,\<theta>c)\<rbrakk> \<Longrightarrow> stc (ImpL <a>.M (x).N z) \<theta>c = (ImpL <a>.M (x).N z)"
120.386 +| "\<lbrakk>a\<sharp>(N,\<theta>c);x\<sharp>(M,\<theta>c)\<rbrakk> \<Longrightarrow> stc (Cut <a>.M (x).N) \<theta>c = (Cut <a>.M (x).N)"
120.387 +| "x\<sharp>\<theta>c \<Longrightarrow> stc (NotR (x).M a) \<theta>c = (NotR (x).M a)"
120.388 +| "a\<sharp>\<theta>c \<Longrightarrow> stc (NotL <a>.M x) \<theta>c = (NotL <a>.M x)"
120.389 +| "\<lbrakk>a\<sharp>(N,d,b,\<theta>c);b\<sharp>(M,d,a,\<theta>c)\<rbrakk> \<Longrightarrow> stc (AndR <a>.M <b>.N d) \<theta>c = (AndR <a>.M <b>.N d)"
120.390 +| "x\<sharp>(z,\<theta>c) \<Longrightarrow> stc (AndL1 (x).M z) \<theta>c = (AndL1 (x).M z)"
120.391 +| "x\<sharp>(z,\<theta>c) \<Longrightarrow> stc (AndL2 (x).M z) \<theta>c = (AndL2 (x).M z)"
120.392 +| "a\<sharp>(b,\<theta>c) \<Longrightarrow> stc (OrR1 <a>.M b) \<theta>c = (OrR1 <a>.M b)"
120.393 +| "a\<sharp>(b,\<theta>c) \<Longrightarrow> stc (OrR2 <a>.M b) \<theta>c = (OrR2 <a>.M b)"
120.394 +| "\<lbrakk>x\<sharp>(N,z,u,\<theta>c);u\<sharp>(M,z,x,\<theta>c)\<rbrakk> \<Longrightarrow> stc (OrL (x).M (u).N z) \<theta>c = (OrL (x).M (u).N z)"
120.395 +| "\<lbrakk>a\<sharp>(b,\<theta>c);x\<sharp>\<theta>c\<rbrakk> \<Longrightarrow> stc (ImpR (x).<a>.M b) \<theta>c = (ImpR (x).<a>.M b)"
120.396 +| "\<lbrakk>a\<sharp>(N,\<theta>c);x\<sharp>(M,z,\<theta>c)\<rbrakk> \<Longrightarrow> stc (ImpL <a>.M (x).N z) \<theta>c = (ImpL <a>.M (x).N z)"
120.397 apply(finite_guess)+
120.398 apply(rule TrueI)+
120.399 apply(simp add: abs_fresh abs_supp fin_supp)+
120.400 @@ -17926,51 +17920,50 @@
120.401 apply(perm_simp)
120.402 done
120.403
120.404 -consts
120.405 +nominal_primrec (freshness_context: "(\<theta>n::(name\<times>coname\<times>trm) list,\<theta>c::(coname\<times>name\<times>trm) list)")
120.406 psubst :: "(name\<times>coname\<times>trm) list\<Rightarrow>(coname\<times>name\<times>trm) list\<Rightarrow>trm\<Rightarrow>trm" ("_,_<_>" [100,100,100] 100)
120.407 -
120.408 -nominal_primrec (freshness_context: "(\<theta>n::(name\<times>coname\<times>trm) list,\<theta>c::(coname\<times>name\<times>trm) list)")
120.409 +where
120.410 "\<theta>n,\<theta>c<Ax x a> = lookup x a \<theta>n \<theta>c"
120.411 - "\<lbrakk>a\<sharp>(N,\<theta>n,\<theta>c);x\<sharp>(M,\<theta>n,\<theta>c)\<rbrakk> \<Longrightarrow> \<theta>n,\<theta>c<Cut <a>.M (x).N> =
120.412 +| "\<lbrakk>a\<sharp>(N,\<theta>n,\<theta>c);x\<sharp>(M,\<theta>n,\<theta>c)\<rbrakk> \<Longrightarrow> \<theta>n,\<theta>c<Cut <a>.M (x).N> =
120.413 Cut <a>.(if \<exists>x. M=Ax x a then stn M \<theta>n else \<theta>n,\<theta>c<M>)
120.414 (x).(if \<exists>a. N=Ax x a then stc N \<theta>c else \<theta>n,\<theta>c<N>)"
120.415 - "x\<sharp>(\<theta>n,\<theta>c) \<Longrightarrow> \<theta>n,\<theta>c<NotR (x).M a> =
120.416 +| "x\<sharp>(\<theta>n,\<theta>c) \<Longrightarrow> \<theta>n,\<theta>c<NotR (x).M a> =
120.417 (case (findc \<theta>c a) of
120.418 Some (u,P) \<Rightarrow> fresh_fun (\<lambda>a'. Cut <a'>.NotR (x).(\<theta>n,\<theta>c<M>) a' (u).P)
120.419 | None \<Rightarrow> NotR (x).(\<theta>n,\<theta>c<M>) a)"
120.420 - "a\<sharp>(\<theta>n,\<theta>c) \<Longrightarrow> \<theta>n,\<theta>c<NotL <a>.M x> =
120.421 +| "a\<sharp>(\<theta>n,\<theta>c) \<Longrightarrow> \<theta>n,\<theta>c<NotL <a>.M x> =
120.422 (case (findn \<theta>n x) of
120.423 Some (c,P) \<Rightarrow> fresh_fun (\<lambda>x'. Cut <c>.P (x').(NotL <a>.(\<theta>n,\<theta>c<M>) x'))
120.424 | None \<Rightarrow> NotL <a>.(\<theta>n,\<theta>c<M>) x)"
120.425 - "\<lbrakk>a\<sharp>(N,c,\<theta>n,\<theta>c);b\<sharp>(M,c,\<theta>n,\<theta>c);b\<noteq>a\<rbrakk> \<Longrightarrow> (\<theta>n,\<theta>c<AndR <a>.M <b>.N c>) =
120.426 +| "\<lbrakk>a\<sharp>(N,c,\<theta>n,\<theta>c);b\<sharp>(M,c,\<theta>n,\<theta>c);b\<noteq>a\<rbrakk> \<Longrightarrow> (\<theta>n,\<theta>c<AndR <a>.M <b>.N c>) =
120.427 (case (findc \<theta>c c) of
120.428 Some (x,P) \<Rightarrow> fresh_fun (\<lambda>a'. Cut <a'>.(AndR <a>.(\<theta>n,\<theta>c<M>) <b>.(\<theta>n,\<theta>c<N>) a') (x).P)
120.429 | None \<Rightarrow> AndR <a>.(\<theta>n,\<theta>c<M>) <b>.(\<theta>n,\<theta>c<N>) c)"
120.430 - "x\<sharp>(z,\<theta>n,\<theta>c) \<Longrightarrow> (\<theta>n,\<theta>c<AndL1 (x).M z>) =
120.431 +| "x\<sharp>(z,\<theta>n,\<theta>c) \<Longrightarrow> (\<theta>n,\<theta>c<AndL1 (x).M z>) =
120.432 (case (findn \<theta>n z) of
120.433 Some (c,P) \<Rightarrow> fresh_fun (\<lambda>z'. Cut <c>.P (z').AndL1 (x).(\<theta>n,\<theta>c<M>) z')
120.434 | None \<Rightarrow> AndL1 (x).(\<theta>n,\<theta>c<M>) z)"
120.435 - "x\<sharp>(z,\<theta>n,\<theta>c) \<Longrightarrow> (\<theta>n,\<theta>c<AndL2 (x).M z>) =
120.436 +| "x\<sharp>(z,\<theta>n,\<theta>c) \<Longrightarrow> (\<theta>n,\<theta>c<AndL2 (x).M z>) =
120.437 (case (findn \<theta>n z) of
120.438 Some (c,P) \<Rightarrow> fresh_fun (\<lambda>z'. Cut <c>.P (z').AndL2 (x).(\<theta>n,\<theta>c<M>) z')
120.439 | None \<Rightarrow> AndL2 (x).(\<theta>n,\<theta>c<M>) z)"
120.440 - "\<lbrakk>x\<sharp>(N,z,\<theta>n,\<theta>c);u\<sharp>(M,z,\<theta>n,\<theta>c);x\<noteq>u\<rbrakk> \<Longrightarrow> (\<theta>n,\<theta>c<OrL (x).M (u).N z>) =
120.441 +| "\<lbrakk>x\<sharp>(N,z,\<theta>n,\<theta>c);u\<sharp>(M,z,\<theta>n,\<theta>c);x\<noteq>u\<rbrakk> \<Longrightarrow> (\<theta>n,\<theta>c<OrL (x).M (u).N z>) =
120.442 (case (findn \<theta>n z) of
120.443 Some (c,P) \<Rightarrow> fresh_fun (\<lambda>z'. Cut <c>.P (z').OrL (x).(\<theta>n,\<theta>c<M>) (u).(\<theta>n,\<theta>c<N>) z')
120.444 | None \<Rightarrow> OrL (x).(\<theta>n,\<theta>c<M>) (u).(\<theta>n,\<theta>c<N>) z)"
120.445 - "a\<sharp>(b,\<theta>n,\<theta>c) \<Longrightarrow> (\<theta>n,\<theta>c<OrR1 <a>.M b>) =
120.446 +| "a\<sharp>(b,\<theta>n,\<theta>c) \<Longrightarrow> (\<theta>n,\<theta>c<OrR1 <a>.M b>) =
120.447 (case (findc \<theta>c b) of
120.448 Some (x,P) \<Rightarrow> fresh_fun (\<lambda>a'. Cut <a'>.OrR1 <a>.(\<theta>n,\<theta>c<M>) a' (x).P)
120.449 | None \<Rightarrow> OrR1 <a>.(\<theta>n,\<theta>c<M>) b)"
120.450 - "a\<sharp>(b,\<theta>n,\<theta>c) \<Longrightarrow> (\<theta>n,\<theta>c<OrR2 <a>.M b>) =
120.451 +| "a\<sharp>(b,\<theta>n,\<theta>c) \<Longrightarrow> (\<theta>n,\<theta>c<OrR2 <a>.M b>) =
120.452 (case (findc \<theta>c b) of
120.453 Some (x,P) \<Rightarrow> fresh_fun (\<lambda>a'. Cut <a'>.OrR2 <a>.(\<theta>n,\<theta>c<M>) a' (x).P)
120.454 | None \<Rightarrow> OrR2 <a>.(\<theta>n,\<theta>c<M>) b)"
120.455 - "\<lbrakk>a\<sharp>(b,\<theta>n,\<theta>c); x\<sharp>(\<theta>n,\<theta>c)\<rbrakk> \<Longrightarrow> (\<theta>n,\<theta>c<ImpR (x).<a>.M b>) =
120.456 +| "\<lbrakk>a\<sharp>(b,\<theta>n,\<theta>c); x\<sharp>(\<theta>n,\<theta>c)\<rbrakk> \<Longrightarrow> (\<theta>n,\<theta>c<ImpR (x).<a>.M b>) =
120.457 (case (findc \<theta>c b) of
120.458 Some (z,P) \<Rightarrow> fresh_fun (\<lambda>a'. Cut <a'>.ImpR (x).<a>.(\<theta>n,\<theta>c<M>) a' (z).P)
120.459 | None \<Rightarrow> ImpR (x).<a>.(\<theta>n,\<theta>c<M>) b)"
120.460 - "\<lbrakk>a\<sharp>(N,\<theta>n,\<theta>c); x\<sharp>(z,M,\<theta>n,\<theta>c)\<rbrakk> \<Longrightarrow> (\<theta>n,\<theta>c<ImpL <a>.M (x).N z>) =
120.461 +| "\<lbrakk>a\<sharp>(N,\<theta>n,\<theta>c); x\<sharp>(z,M,\<theta>n,\<theta>c)\<rbrakk> \<Longrightarrow> (\<theta>n,\<theta>c<ImpL <a>.M (x).N z>) =
120.462 (case (findn \<theta>n z) of
120.463 Some (c,P) \<Rightarrow> fresh_fun (\<lambda>z'. Cut <c>.P (z').ImpL <a>.(\<theta>n,\<theta>c<M>) (x).(\<theta>n,\<theta>c<N>) z')
120.464 | None \<Rightarrow> ImpL <a>.(\<theta>n,\<theta>c<M>) (x).(\<theta>n,\<theta>c<N>) z)"
121.1 --- a/src/HOL/Nominal/Examples/Compile.thy Tue Dec 30 08:18:54 2008 +0100
121.2 +++ b/src/HOL/Nominal/Examples/Compile.thy Tue Dec 30 11:10:01 2008 +0100
121.3 @@ -1,5 +1,3 @@
121.4 -(* $Id$ *)
121.5 -
121.6 (* The definitions for a challenge suggested by Adam Chlipala *)
121.7
121.8 theory Compile
121.9 @@ -92,20 +90,24 @@
121.10
121.11 text {* capture-avoiding substitution *}
121.12
121.13 -consts
121.14 - subst :: "'a \<Rightarrow> name \<Rightarrow> 'a \<Rightarrow> 'a" ("_[_::=_]" [100,100,100] 100)
121.15 +class subst =
121.16 + fixes subst :: "'a \<Rightarrow> name \<Rightarrow> 'a \<Rightarrow> 'a" ("_[_::=_]" [100,100,100] 100)
121.17
121.18 -nominal_primrec
121.19 +instantiation trm :: subst
121.20 +begin
121.21 +
121.22 +nominal_primrec subst_trm
121.23 +where
121.24 "(Var x)[y::=t'] = (if x=y then t' else (Var x))"
121.25 - "(App t1 t2)[y::=t'] = App (t1[y::=t']) (t2[y::=t'])"
121.26 - "\<lbrakk>x\<sharp>y; x\<sharp>t'\<rbrakk> \<Longrightarrow> (Lam [x].t)[y::=t'] = Lam [x].(t[y::=t'])"
121.27 - "(Const n)[y::=t'] = Const n"
121.28 - "(Pr e1 e2)[y::=t'] = Pr (e1[y::=t']) (e2[y::=t'])"
121.29 - "(Fst e)[y::=t'] = Fst (e[y::=t'])"
121.30 - "(Snd e)[y::=t'] = Snd (e[y::=t'])"
121.31 - "(InL e)[y::=t'] = InL (e[y::=t'])"
121.32 - "(InR e)[y::=t'] = InR (e[y::=t'])"
121.33 - "\<lbrakk>z\<noteq>x; x\<sharp>y; x\<sharp>e; x\<sharp>e2; z\<sharp>y; z\<sharp>e; z\<sharp>e1; x\<sharp>t'; z\<sharp>t'\<rbrakk> \<Longrightarrow>
121.34 +| "(App t1 t2)[y::=t'] = App (t1[y::=t']) (t2[y::=t'])"
121.35 +| "\<lbrakk>x\<sharp>y; x\<sharp>t'\<rbrakk> \<Longrightarrow> (Lam [x].t)[y::=t'] = Lam [x].(t[y::=t'])"
121.36 +| "(Const n)[y::=t'] = Const n"
121.37 +| "(Pr e1 e2)[y::=t'] = Pr (e1[y::=t']) (e2[y::=t'])"
121.38 +| "(Fst e)[y::=t'] = Fst (e[y::=t'])"
121.39 +| "(Snd e)[y::=t'] = Snd (e[y::=t'])"
121.40 +| "(InL e)[y::=t'] = InL (e[y::=t'])"
121.41 +| "(InR e)[y::=t'] = InR (e[y::=t'])"
121.42 +| "\<lbrakk>z\<noteq>x; x\<sharp>y; x\<sharp>e; x\<sharp>e2; z\<sharp>y; z\<sharp>e; z\<sharp>e1; x\<sharp>t'; z\<sharp>t'\<rbrakk> \<Longrightarrow>
121.43 (Case e of inl x \<rightarrow> e1 | inr z \<rightarrow> e2)[y::=t'] =
121.44 (Case (e[y::=t']) of inl x \<rightarrow> (e1[y::=t']) | inr z \<rightarrow> (e2[y::=t']))"
121.45 apply(finite_guess)+
121.46 @@ -114,23 +116,35 @@
121.47 apply(fresh_guess)+
121.48 done
121.49
121.50 -nominal_primrec (Isubst)
121.51 +instance ..
121.52 +
121.53 +end
121.54 +
121.55 +instantiation trmI :: subst
121.56 +begin
121.57 +
121.58 +nominal_primrec subst_trmI
121.59 +where
121.60 "(IVar x)[y::=t'] = (if x=y then t' else (IVar x))"
121.61 - "(IApp t1 t2)[y::=t'] = IApp (t1[y::=t']) (t2[y::=t'])"
121.62 - "\<lbrakk>x\<sharp>y; x\<sharp>t'\<rbrakk> \<Longrightarrow> (ILam [x].t)[y::=t'] = ILam [x].(t[y::=t'])"
121.63 - "(INat n)[y::=t'] = INat n"
121.64 - "(IUnit)[y::=t'] = IUnit"
121.65 - "(ISucc e)[y::=t'] = ISucc (e[y::=t'])"
121.66 - "(IAss e1 e2)[y::=t'] = IAss (e1[y::=t']) (e2[y::=t'])"
121.67 - "(IRef e)[y::=t'] = IRef (e[y::=t'])"
121.68 - "(ISeq e1 e2)[y::=t'] = ISeq (e1[y::=t']) (e2[y::=t'])"
121.69 - "(Iif e e1 e2)[y::=t'] = Iif (e[y::=t']) (e1[y::=t']) (e2[y::=t'])"
121.70 +| "(IApp t1 t2)[y::=t'] = IApp (t1[y::=t']) (t2[y::=t'])"
121.71 +| "\<lbrakk>x\<sharp>y; x\<sharp>t'\<rbrakk> \<Longrightarrow> (ILam [x].t)[y::=t'] = ILam [x].(t[y::=t'])"
121.72 +| "(INat n)[y::=t'] = INat n"
121.73 +| "(IUnit)[y::=t'] = IUnit"
121.74 +| "(ISucc e)[y::=t'] = ISucc (e[y::=t'])"
121.75 +| "(IAss e1 e2)[y::=t'] = IAss (e1[y::=t']) (e2[y::=t'])"
121.76 +| "(IRef e)[y::=t'] = IRef (e[y::=t'])"
121.77 +| "(ISeq e1 e2)[y::=t'] = ISeq (e1[y::=t']) (e2[y::=t'])"
121.78 +| "(Iif e e1 e2)[y::=t'] = Iif (e[y::=t']) (e1[y::=t']) (e2[y::=t'])"
121.79 apply(finite_guess)+
121.80 apply(rule TrueI)+
121.81 apply(simp add: abs_fresh)+
121.82 apply(fresh_guess)+
121.83 done
121.84
121.85 +instance ..
121.86 +
121.87 +end
121.88 +
121.89 lemma Isubst_eqvt[eqvt]:
121.90 fixes pi::"name prm"
121.91 and t1::"trmI"
121.92 @@ -138,7 +152,7 @@
121.93 and x::"name"
121.94 shows "pi\<bullet>(t1[x::=t2]) = ((pi\<bullet>t1)[(pi\<bullet>x)::=(pi\<bullet>t2)])"
121.95 apply (nominal_induct t1 avoiding: x t2 rule: trmI.strong_induct)
121.96 - apply (simp_all add: Isubst.simps eqvts fresh_bij)
121.97 + apply (simp_all add: subst_trmI.simps eqvts fresh_bij)
121.98 done
121.99
121.100 lemma Isubst_supp:
121.101 @@ -147,7 +161,7 @@
121.102 and x::"name"
121.103 shows "((supp (t1[x::=t2]))::name set) \<subseteq> (supp t2)\<union>((supp t1)-{x})"
121.104 apply (nominal_induct t1 avoiding: x t2 rule: trmI.strong_induct)
121.105 - apply (auto simp add: Isubst.simps trmI.supp supp_atm abs_supp supp_nat)
121.106 + apply (auto simp add: subst_trmI.simps trmI.supp supp_atm abs_supp supp_nat)
121.107 apply blast+
121.108 done
121.109
121.110 @@ -198,29 +212,29 @@
121.111
121.112 text {* Translation functions *}
121.113
121.114 -consts trans :: "trm \<Rightarrow> trmI"
121.115 -
121.116 nominal_primrec
121.117 + trans :: "trm \<Rightarrow> trmI"
121.118 +where
121.119 "trans (Var x) = (IVar x)"
121.120 - "trans (App e1 e2) = IApp (trans e1) (trans e2)"
121.121 - "trans (Lam [x].e) = ILam [x].(trans e)"
121.122 - "trans (Const n) = INat n"
121.123 - "trans (Pr e1 e2) =
121.124 +| "trans (App e1 e2) = IApp (trans e1) (trans e2)"
121.125 +| "trans (Lam [x].e) = ILam [x].(trans e)"
121.126 +| "trans (Const n) = INat n"
121.127 +| "trans (Pr e1 e2) =
121.128 (let limit = IRef(INat 0) in
121.129 let v1 = (trans e1) in
121.130 let v2 = (trans e2) in
121.131 (((ISucc limit)\<mapsto>v1);;(ISucc(ISucc limit)\<mapsto>v2));;(INat 0 \<mapsto> ISucc(ISucc(limit))))"
121.132 - "trans (Fst e) = IRef (ISucc (trans e))"
121.133 - "trans (Snd e) = IRef (ISucc (ISucc (trans e)))"
121.134 - "trans (InL e) =
121.135 +| "trans (Fst e) = IRef (ISucc (trans e))"
121.136 +| "trans (Snd e) = IRef (ISucc (ISucc (trans e)))"
121.137 +| "trans (InL e) =
121.138 (let limit = IRef(INat 0) in
121.139 let v = (trans e) in
121.140 (((ISucc limit)\<mapsto>INat(0));;(ISucc(ISucc limit)\<mapsto>v));;(INat 0 \<mapsto> ISucc(ISucc(limit))))"
121.141 - "trans (InR e) =
121.142 +| "trans (InR e) =
121.143 (let limit = IRef(INat 0) in
121.144 let v = (trans e) in
121.145 (((ISucc limit)\<mapsto>INat(1));;(ISucc(ISucc limit)\<mapsto>v));;(INat 0 \<mapsto> ISucc(ISucc(limit))))"
121.146 - "\<lbrakk>x2\<noteq>x1; x1\<sharp>e; x1\<sharp>e2; x2\<sharp>e; x2\<sharp>e1\<rbrakk> \<Longrightarrow>
121.147 +| "\<lbrakk>x2\<noteq>x1; x1\<sharp>e; x1\<sharp>e2; x2\<sharp>e; x2\<sharp>e1\<rbrakk> \<Longrightarrow>
121.148 trans (Case e of inl x1 \<rightarrow> e1 | inr x2 \<rightarrow> e2) =
121.149 (let v = (trans e) in
121.150 let v1 = (trans e1) in
121.151 @@ -232,11 +246,11 @@
121.152 apply(fresh_guess add: Let_def)+
121.153 done
121.154
121.155 -consts trans_type :: "ty \<Rightarrow> tyI"
121.156 -
121.157 nominal_primrec
121.158 + trans_type :: "ty \<Rightarrow> tyI"
121.159 +where
121.160 "trans_type (Data \<sigma>) = DataI(NatI)"
121.161 - "trans_type (\<tau>1\<rightarrow>\<tau>2) = (trans_type \<tau>1)\<rightarrow>(trans_type \<tau>2)"
121.162 +| "trans_type (\<tau>1\<rightarrow>\<tau>2) = (trans_type \<tau>1)\<rightarrow>(trans_type \<tau>2)"
121.163 by (rule TrueI)+
121.164
121.165 end
121.166 \ No newline at end of file
122.1 --- a/src/HOL/Nominal/Examples/Contexts.thy Tue Dec 30 08:18:54 2008 +0100
122.2 +++ b/src/HOL/Nominal/Examples/Contexts.thy Tue Dec 30 11:10:01 2008 +0100
122.3 @@ -1,5 +1,3 @@
122.4 -(* $Id$ *)
122.5 -
122.6 theory Contexts
122.7 imports "../Nominal"
122.8 begin
122.9 @@ -42,12 +40,12 @@
122.10
122.11 text {* Capture-Avoiding Substitution *}
122.12
122.13 -consts subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam" ("_[_::=_]" [100,100,100] 100)
122.14 -
122.15 nominal_primrec
122.16 + subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam" ("_[_::=_]" [100,100,100] 100)
122.17 +where
122.18 "(Var x)[y::=s] = (if x=y then s else (Var x))"
122.19 - "(App t\<^isub>1 t\<^isub>2)[y::=s] = App (t\<^isub>1[y::=s]) (t\<^isub>2[y::=s])"
122.20 - "x\<sharp>(y,s) \<Longrightarrow> (Lam [x].t)[y::=s] = Lam [x].(t[y::=s])"
122.21 +| "(App t\<^isub>1 t\<^isub>2)[y::=s] = App (t\<^isub>1[y::=s]) (t\<^isub>2[y::=s])"
122.22 +| "x\<sharp>(y,s) \<Longrightarrow> (Lam [x].t)[y::=s] = Lam [x].(t[y::=s])"
122.23 apply(finite_guess)+
122.24 apply(rule TrueI)+
122.25 apply(simp add: abs_fresh)
122.26 @@ -59,14 +57,13 @@
122.27 This operation is possibly capturing.
122.28 *}
122.29
122.30 -consts
122.31 +nominal_primrec
122.32 filling :: "ctx \<Rightarrow> lam \<Rightarrow> lam" ("_\<lbrakk>_\<rbrakk>" [100,100] 100)
122.33 -
122.34 -nominal_primrec
122.35 +where
122.36 "\<box>\<lbrakk>t\<rbrakk> = t"
122.37 - "(CAppL E t')\<lbrakk>t\<rbrakk> = App (E\<lbrakk>t\<rbrakk>) t'"
122.38 - "(CAppR t' E)\<lbrakk>t\<rbrakk> = App t' (E\<lbrakk>t\<rbrakk>)"
122.39 - "(CLam [x].E)\<lbrakk>t\<rbrakk> = Lam [x].(E\<lbrakk>t\<rbrakk>)"
122.40 +| "(CAppL E t')\<lbrakk>t\<rbrakk> = App (E\<lbrakk>t\<rbrakk>) t'"
122.41 +| "(CAppR t' E)\<lbrakk>t\<rbrakk> = App t' (E\<lbrakk>t\<rbrakk>)"
122.42 +| "(CLam [x].E)\<lbrakk>t\<rbrakk> = Lam [x].(E\<lbrakk>t\<rbrakk>)"
122.43 by (rule TrueI)+
122.44
122.45 text {*
122.46 @@ -81,14 +78,13 @@
122.47
122.48 text {* The composition of two contexts. *}
122.49
122.50 -consts
122.51 +nominal_primrec
122.52 ctx_compose :: "ctx \<Rightarrow> ctx \<Rightarrow> ctx" ("_ \<circ> _" [100,100] 100)
122.53 -
122.54 -nominal_primrec
122.55 +where
122.56 "\<box> \<circ> E' = E'"
122.57 - "(CAppL E t') \<circ> E' = CAppL (E \<circ> E') t'"
122.58 - "(CAppR t' E) \<circ> E' = CAppR t' (E \<circ> E')"
122.59 - "(CLam [x].E) \<circ> E' = CLam [x].(E \<circ> E')"
122.60 +| "(CAppL E t') \<circ> E' = CAppL (E \<circ> E') t'"
122.61 +| "(CAppR t' E) \<circ> E' = CAppR t' (E \<circ> E')"
122.62 +| "(CLam [x].E) \<circ> E' = CLam [x].(E \<circ> E')"
122.63 by (rule TrueI)+
122.64
122.65 lemma ctx_compose:
123.1 --- a/src/HOL/Nominal/Examples/Crary.thy Tue Dec 30 08:18:54 2008 +0100
123.2 +++ b/src/HOL/Nominal/Examples/Crary.thy Tue Dec 30 11:10:01 2008 +0100
123.3 @@ -1,4 +1,3 @@
123.4 -(* "$Id$" *)
123.5 (* *)
123.6 (* Formalisation of the chapter on Logical Relations *)
123.7 (* and a Case Study in Equivalence Checking *)
123.8 @@ -47,14 +46,20 @@
123.9 shows "(\<exists> T\<^isub>1 T\<^isub>2. T=T\<^isub>1\<rightarrow>T\<^isub>2) \<or> T=TUnit \<or> T=TBase"
123.10 by (induct T rule:ty.induct) (auto)
123.11
123.12 -instance ty :: size ..
123.13 +instantiation ty :: size
123.14 +begin
123.15
123.16 -nominal_primrec
123.17 +nominal_primrec size_ty
123.18 +where
123.19 "size (TBase) = 1"
123.20 - "size (TUnit) = 1"
123.21 - "size (T\<^isub>1\<rightarrow>T\<^isub>2) = size T\<^isub>1 + size T\<^isub>2"
123.22 +| "size (TUnit) = 1"
123.23 +| "size (T\<^isub>1\<rightarrow>T\<^isub>2) = size T\<^isub>1 + size T\<^isub>2"
123.24 by (rule TrueI)+
123.25
123.26 +instance ..
123.27 +
123.28 +end
123.29 +
123.30 lemma ty_size_greater_zero[simp]:
123.31 fixes T::"ty"
123.32 shows "size T > 0"
123.33 @@ -87,16 +92,15 @@
123.34 using a
123.35 by (induct rule: lookup.induct)
123.36 (auto simp add: fresh_list_cons fresh_prod fresh_atm)
123.37 -
123.38 -consts
123.39 - psubst :: "Subst \<Rightarrow> trm \<Rightarrow> trm" ("_<_>" [100,100] 130)
123.40
123.41 nominal_primrec
123.42 + psubst :: "Subst \<Rightarrow> trm \<Rightarrow> trm" ("_<_>" [100,100] 130)
123.43 +where
123.44 "\<theta><(Var x)> = (lookup \<theta> x)"
123.45 - "\<theta><(App t\<^isub>1 t\<^isub>2)> = App \<theta><t\<^isub>1> \<theta><t\<^isub>2>"
123.46 - "x\<sharp>\<theta> \<Longrightarrow> \<theta><(Lam [x].t)> = Lam [x].(\<theta><t>)"
123.47 - "\<theta><(Const n)> = Const n"
123.48 - "\<theta><(Unit)> = Unit"
123.49 +| "\<theta><(App t\<^isub>1 t\<^isub>2)> = App \<theta><t\<^isub>1> \<theta><t\<^isub>2>"
123.50 +| "x\<sharp>\<theta> \<Longrightarrow> \<theta><(Lam [x].t)> = Lam [x].(\<theta><t>)"
123.51 +| "\<theta><(Const n)> = Const n"
123.52 +| "\<theta><(Unit)> = Unit"
123.53 apply(finite_guess)+
123.54 apply(rule TrueI)+
123.55 apply(simp add: abs_fresh)+
124.1 --- a/src/HOL/Nominal/Examples/Fsub.thy Tue Dec 30 08:18:54 2008 +0100
124.2 +++ b/src/HOL/Nominal/Examples/Fsub.thy Tue Dec 30 11:10:01 2008 +0100
124.3 @@ -1,5 +1,3 @@
124.4 -(* $Id$ *)
124.5 -
124.6 (*<*)
124.7 theory Fsub
124.8 imports "../Nominal"
124.9 @@ -229,32 +227,26 @@
124.10
124.11 section {* Size and Capture-Avoiding Substitution for Types *}
124.12
124.13 -consts size_ty :: "ty \<Rightarrow> nat"
124.14 -
124.15 nominal_primrec
124.16 + size_ty :: "ty \<Rightarrow> nat"
124.17 +where
124.18 "size_ty (Tvar X) = 1"
124.19 - "size_ty (Top) = 1"
124.20 - "size_ty (T1 \<rightarrow> T2) = (size_ty T1) + (size_ty T2) + 1"
124.21 - "X\<sharp>T1 \<Longrightarrow> size_ty (\<forall>[X<:T1].T2) = (size_ty T1) + (size_ty T2) + 1"
124.22 +| "size_ty (Top) = 1"
124.23 +| "size_ty (T1 \<rightarrow> T2) = (size_ty T1) + (size_ty T2) + 1"
124.24 +| "X\<sharp>T1 \<Longrightarrow> size_ty (\<forall>[X<:T1].T2) = (size_ty T1) + (size_ty T2) + 1"
124.25 apply (finite_guess)+
124.26 apply (rule TrueI)+
124.27 apply (simp add: fresh_nat)
124.28 apply (fresh_guess)+
124.29 done
124.30
124.31 -consts subst_ty :: "tyvrs \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> ty"
124.32 -
124.33 -syntax
124.34 - subst_ty_syn :: "ty \<Rightarrow> tyvrs \<Rightarrow> ty \<Rightarrow> ty" ("_[_:=_]\<^isub>t\<^isub>y" [100,100,100] 100)
124.35 -
124.36 -translations
124.37 - "T1[Y:=T2]\<^isub>t\<^isub>y" \<rightleftharpoons> "subst_ty Y T2 T1"
124.38 -
124.39 nominal_primrec
124.40 + subst_ty :: "ty \<Rightarrow> tyvrs \<Rightarrow> ty \<Rightarrow> ty" ("_[_:=_]\<^isub>t\<^isub>y" [100,100,100] 100)
124.41 +where
124.42 "(Tvar X)[Y:=T]\<^isub>t\<^isub>y= (if X=Y then T else (Tvar X))"
124.43 - "(Top)[Y:=T]\<^isub>t\<^isub>y = Top"
124.44 - "(T\<^isub>1 \<rightarrow> T\<^isub>2)[Y:=T]\<^isub>t\<^isub>y = (T\<^isub>1[Y:=T]\<^isub>t\<^isub>y) \<rightarrow> (T\<^isub>2[Y:=T]\<^isub>t\<^isub>y)"
124.45 - "\<lbrakk>X\<sharp>(Y,T); X\<sharp>T\<^isub>1\<rbrakk> \<Longrightarrow> (\<forall>[X<:T\<^isub>1].T\<^isub>2)[Y:=T]\<^isub>t\<^isub>y = (\<forall>[X<:(T\<^isub>1[Y:=T]\<^isub>t\<^isub>y)].(T\<^isub>2[Y:=T]\<^isub>t\<^isub>y))"
124.46 +| "(Top)[Y:=T]\<^isub>t\<^isub>y = Top"
124.47 +| "(T\<^isub>1 \<rightarrow> T\<^isub>2)[Y:=T]\<^isub>t\<^isub>y = (T\<^isub>1[Y:=T]\<^isub>t\<^isub>y) \<rightarrow> (T\<^isub>2[Y:=T]\<^isub>t\<^isub>y)"
124.48 +| "\<lbrakk>X\<sharp>(Y,T); X\<sharp>T\<^isub>1\<rbrakk> \<Longrightarrow> (\<forall>[X<:T\<^isub>1].T\<^isub>2)[Y:=T]\<^isub>t\<^isub>y = (\<forall>[X<:(T\<^isub>1[Y:=T]\<^isub>t\<^isub>y)].(T\<^isub>2[Y:=T]\<^isub>t\<^isub>y))"
124.49 apply (finite_guess)+
124.50 apply (rule TrueI)+
124.51 apply (simp add: abs_fresh)
125.1 --- a/src/HOL/Nominal/Examples/Height.thy Tue Dec 30 08:18:54 2008 +0100
125.2 +++ b/src/HOL/Nominal/Examples/Height.thy Tue Dec 30 11:10:01 2008 +0100
125.3 @@ -1,5 +1,3 @@
125.4 -(* $Id$ *)
125.5 -
125.6 theory Height
125.7 imports "../Nominal"
125.8 begin
125.9 @@ -17,13 +15,13 @@
125.10 | Lam "\<guillemotleft>name\<guillemotright>lam" ("Lam [_]._" [100,100] 100)
125.11
125.12 text {* Definition of the height-function on lambda-terms. *}
125.13 -consts
125.14 - height :: "lam \<Rightarrow> int"
125.15
125.16 nominal_primrec
125.17 + height :: "lam \<Rightarrow> int"
125.18 +where
125.19 "height (Var x) = 1"
125.20 - "height (App t1 t2) = (max (height t1) (height t2)) + 1"
125.21 - "height (Lam [a].t) = (height t) + 1"
125.22 +| "height (App t1 t2) = (max (height t1) (height t2)) + 1"
125.23 +| "height (Lam [a].t) = (height t) + 1"
125.24 apply(finite_guess add: perm_int_def)+
125.25 apply(rule TrueI)+
125.26 apply(simp add: fresh_int)
125.27 @@ -32,13 +30,12 @@
125.28
125.29 text {* Definition of capture-avoiding substitution. *}
125.30
125.31 -consts
125.32 +nominal_primrec
125.33 subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam" ("_[_::=_]" [100,100,100] 100)
125.34 -
125.35 -nominal_primrec
125.36 +where
125.37 "(Var x)[y::=t'] = (if x=y then t' else (Var x))"
125.38 - "(App t1 t2)[y::=t'] = App (t1[y::=t']) (t2[y::=t'])"
125.39 - "\<lbrakk>x\<sharp>y; x\<sharp>t'\<rbrakk> \<Longrightarrow> (Lam [x].t)[y::=t'] = Lam [x].(t[y::=t'])"
125.40 +| "(App t1 t2)[y::=t'] = App (t1[y::=t']) (t2[y::=t'])"
125.41 +| "\<lbrakk>x\<sharp>y; x\<sharp>t'\<rbrakk> \<Longrightarrow> (Lam [x].t)[y::=t'] = Lam [x].(t[y::=t'])"
125.42 apply(finite_guess)+
125.43 apply(rule TrueI)+
125.44 apply(simp add: abs_fresh)
126.1 --- a/src/HOL/Nominal/Examples/Lam_Funs.thy Tue Dec 30 08:18:54 2008 +0100
126.2 +++ b/src/HOL/Nominal/Examples/Lam_Funs.thy Tue Dec 30 11:10:01 2008 +0100
126.3 @@ -1,5 +1,3 @@
126.4 -(* $Id$ *)
126.5 -
126.6 theory Lam_Funs
126.7 imports "../Nominal"
126.8 begin
126.9 @@ -18,13 +16,12 @@
126.10
126.11 text {* The depth of a lambda-term. *}
126.12
126.13 -consts
126.14 +nominal_primrec
126.15 depth :: "lam \<Rightarrow> nat"
126.16 -
126.17 -nominal_primrec
126.18 +where
126.19 "depth (Var x) = 1"
126.20 - "depth (App t1 t2) = (max (depth t1) (depth t2)) + 1"
126.21 - "depth (Lam [a].t) = (depth t) + 1"
126.22 +| "depth (App t1 t2) = (max (depth t1) (depth t2)) + 1"
126.23 +| "depth (Lam [a].t) = (depth t) + 1"
126.24 apply(finite_guess)+
126.25 apply(rule TrueI)+
126.26 apply(simp add: fresh_nat)
126.27 @@ -38,13 +35,12 @@
126.28 the invariant that frees always returns a finite set of names.
126.29 *}
126.30
126.31 -consts
126.32 +nominal_primrec (invariant: "\<lambda>s::name set. finite s")
126.33 frees :: "lam \<Rightarrow> name set"
126.34 -
126.35 -nominal_primrec (invariant: "\<lambda>s::name set. finite s")
126.36 +where
126.37 "frees (Var a) = {a}"
126.38 - "frees (App t1 t2) = (frees t1) \<union> (frees t2)"
126.39 - "frees (Lam [a].t) = (frees t) - {a}"
126.40 +| "frees (App t1 t2) = (frees t1) \<union> (frees t2)"
126.41 +| "frees (Lam [a].t) = (frees t) - {a}"
126.42 apply(finite_guess)+
126.43 apply(simp)+
126.44 apply(simp add: fresh_def)
126.45 @@ -78,14 +74,13 @@
126.46 and X::"name"
126.47 shows "pi\<bullet>(lookup \<theta> X) = lookup (pi\<bullet>\<theta>) (pi\<bullet>X)"
126.48 by (induct \<theta>) (auto simp add: eqvts)
126.49 -
126.50 -consts
126.51 - psubst :: "(name\<times>lam) list \<Rightarrow> lam \<Rightarrow> lam" ("_<_>" [95,95] 105)
126.52
126.53 nominal_primrec
126.54 + psubst :: "(name\<times>lam) list \<Rightarrow> lam \<Rightarrow> lam" ("_<_>" [95,95] 105)
126.55 +where
126.56 "\<theta><(Var x)> = (lookup \<theta> x)"
126.57 - "\<theta><(App e\<^isub>1 e\<^isub>2)> = App (\<theta><e\<^isub>1>) (\<theta><e\<^isub>2>)"
126.58 - "x\<sharp>\<theta> \<Longrightarrow> \<theta><(Lam [x].e)> = Lam [x].(\<theta><e>)"
126.59 +| "\<theta><(App e\<^isub>1 e\<^isub>2)> = App (\<theta><e\<^isub>1>) (\<theta><e\<^isub>2>)"
126.60 +| "x\<sharp>\<theta> \<Longrightarrow> \<theta><(Lam [x].e)> = Lam [x].(\<theta><e>)"
126.61 apply(finite_guess)+
126.62 apply(rule TrueI)+
126.63 apply(simp add: abs_fresh)+
126.64 @@ -130,26 +125,24 @@
126.65
126.66 text {* Filling a lambda-term into a context. *}
126.67
126.68 -consts
126.69 +nominal_primrec
126.70 filling :: "clam \<Rightarrow> lam \<Rightarrow> lam" ("_\<lbrakk>_\<rbrakk>" [100,100] 100)
126.71 -
126.72 -nominal_primrec
126.73 +where
126.74 "\<box>\<lbrakk>t\<rbrakk> = t"
126.75 - "(CAppL E t')\<lbrakk>t\<rbrakk> = App (E\<lbrakk>t\<rbrakk>) t'"
126.76 - "(CAppR t' E)\<lbrakk>t\<rbrakk> = App t' (E\<lbrakk>t\<rbrakk>)"
126.77 - "(CLam [x].E)\<lbrakk>t\<rbrakk> = Lam [x].(E\<lbrakk>t\<rbrakk>)"
126.78 +| "(CAppL E t')\<lbrakk>t\<rbrakk> = App (E\<lbrakk>t\<rbrakk>) t'"
126.79 +| "(CAppR t' E)\<lbrakk>t\<rbrakk> = App t' (E\<lbrakk>t\<rbrakk>)"
126.80 +| "(CLam [x].E)\<lbrakk>t\<rbrakk> = Lam [x].(E\<lbrakk>t\<rbrakk>)"
126.81 by (rule TrueI)+
126.82
126.83 text {* Composition od two contexts *}
126.84
126.85 -consts
126.86 +nominal_primrec
126.87 clam_compose :: "clam \<Rightarrow> clam \<Rightarrow> clam" ("_ \<circ> _" [100,100] 100)
126.88 -
126.89 -nominal_primrec
126.90 +where
126.91 "\<box> \<circ> E' = E'"
126.92 - "(CAppL E t') \<circ> E' = CAppL (E \<circ> E') t'"
126.93 - "(CAppR t' E) \<circ> E' = CAppR t' (E \<circ> E')"
126.94 - "(CLam [x].E) \<circ> E' = CLam [x].(E \<circ> E')"
126.95 +| "(CAppL E t') \<circ> E' = CAppL (E \<circ> E') t'"
126.96 +| "(CAppR t' E) \<circ> E' = CAppR t' (E \<circ> E')"
126.97 +| "(CLam [x].E) \<circ> E' = CLam [x].(E \<circ> E')"
126.98 by (rule TrueI)+
126.99
126.100 lemma clam_compose:
127.1 --- a/src/HOL/Nominal/Examples/LocalWeakening.thy Tue Dec 30 08:18:54 2008 +0100
127.2 +++ b/src/HOL/Nominal/Examples/LocalWeakening.thy Tue Dec 30 11:10:01 2008 +0100
127.3 @@ -1,5 +1,3 @@
127.4 -(* $Id$ *)
127.5 -
127.6 (* Formalisation of weakening using locally nameless *)
127.7 (* terms; the nominal infrastructure can also derive *)
127.8 (* strong induction principles for such representations *)
127.9 @@ -29,13 +27,13 @@
127.10 by (induct t rule: llam.induct)
127.11 (auto simp add: llam.inject)
127.12
127.13 -consts llam_size :: "llam \<Rightarrow> nat"
127.14 -
127.15 nominal_primrec
127.16 - "llam_size (lPar a) = 1"
127.17 - "llam_size (lVar n) = 1"
127.18 - "llam_size (lApp t1 t2) = 1 + (llam_size t1) + (llam_size t2)"
127.19 - "llam_size (lLam t) = 1 + (llam_size t)"
127.20 + llam_size :: "llam \<Rightarrow> nat"
127.21 +where
127.22 + "llam_size (lPar a) = 1"
127.23 +| "llam_size (lVar n) = 1"
127.24 +| "llam_size (lApp t1 t2) = 1 + (llam_size t1) + (llam_size t2)"
127.25 +| "llam_size (lLam t) = 1 + (llam_size t)"
127.26 by (rule TrueI)+
127.27
127.28 function
128.1 --- a/src/HOL/Nominal/Examples/SN.thy Tue Dec 30 08:18:54 2008 +0100
128.2 +++ b/src/HOL/Nominal/Examples/SN.thy Tue Dec 30 11:10:01 2008 +0100
128.3 @@ -1,5 +1,3 @@
128.4 -(* $Id$ *)
128.5 -
128.6 theory SN
128.7 imports Lam_Funs
128.8 begin
128.9 @@ -228,12 +226,11 @@
128.10
128.11 section {* Candidates *}
128.12
128.13 -consts
128.14 +nominal_primrec
128.15 RED :: "ty \<Rightarrow> lam set"
128.16 -
128.17 -nominal_primrec
128.18 +where
128.19 "RED (TVar X) = {t. SN(t)}"
128.20 - "RED (\<tau>\<rightarrow>\<sigma>) = {t. \<forall>u. (u\<in>RED \<tau> \<longrightarrow> (App t u)\<in>RED \<sigma>)}"
128.21 +| "RED (\<tau>\<rightarrow>\<sigma>) = {t. \<forall>u. (u\<in>RED \<tau> \<longrightarrow> (App t u)\<in>RED \<sigma>)}"
128.22 by (rule TrueI)+
128.23
128.24 text {* neutral terms *}
128.25 @@ -248,13 +245,12 @@
128.26 where
128.27 fst[intro!]: "(App t s) \<guillemotright> t"
128.28
128.29 -consts
128.30 +nominal_primrec
128.31 fst_app_aux::"lam\<Rightarrow>lam option"
128.32 -
128.33 -nominal_primrec
128.34 +where
128.35 "fst_app_aux (Var a) = None"
128.36 - "fst_app_aux (App t1 t2) = Some t1"
128.37 - "fst_app_aux (Lam [x].t) = None"
128.38 +| "fst_app_aux (App t1 t2) = Some t1"
128.39 +| "fst_app_aux (Lam [x].t) = None"
128.40 apply(finite_guess)+
128.41 apply(rule TrueI)+
128.42 apply(simp add: fresh_none)
129.1 --- a/src/HOL/Nominal/Examples/SOS.thy Tue Dec 30 08:18:54 2008 +0100
129.2 +++ b/src/HOL/Nominal/Examples/SOS.thy Tue Dec 30 11:10:01 2008 +0100
129.3 @@ -1,4 +1,3 @@
129.4 -(* "$Id$" *)
129.5 (* *)
129.6 (* Formalisation of some typical SOS-proofs. *)
129.7 (* *)
129.8 @@ -62,13 +61,12 @@
129.9
129.10 (* parallel substitution *)
129.11
129.12 -consts
129.13 +nominal_primrec
129.14 psubst :: "(name\<times>trm) list \<Rightarrow> trm \<Rightarrow> trm" ("_<_>" [95,95] 105)
129.15 -
129.16 -nominal_primrec
129.17 +where
129.18 "\<theta><(Var x)> = (lookup \<theta> x)"
129.19 - "\<theta><(App e\<^isub>1 e\<^isub>2)> = App (\<theta><e\<^isub>1>) (\<theta><e\<^isub>2>)"
129.20 - "x\<sharp>\<theta> \<Longrightarrow> \<theta><(Lam [x].e)> = Lam [x].(\<theta><e>)"
129.21 +| "\<theta><(App e\<^isub>1 e\<^isub>2)> = App (\<theta><e\<^isub>1>) (\<theta><e\<^isub>2>)"
129.22 +| "x\<sharp>\<theta> \<Longrightarrow> \<theta><(Lam [x].e)> = Lam [x].(\<theta><e>)"
129.23 apply(finite_guess)+
129.24 apply(rule TrueI)+
129.25 apply(simp add: abs_fresh)+
129.26 @@ -349,12 +347,12 @@
129.27 using h by (induct) (auto)
129.28
129.29 (* Valuation *)
129.30 -consts
129.31 - V :: "ty \<Rightarrow> trm set"
129.32
129.33 nominal_primrec
129.34 + V :: "ty \<Rightarrow> trm set"
129.35 +where
129.36 "V (TVar x) = {e. val e}"
129.37 - "V (T\<^isub>1 \<rightarrow> T\<^isub>2) = {Lam [x].e | x e. \<forall> v \<in> (V T\<^isub>1). \<exists> v'. e[x::=v] \<Down> v' \<and> v' \<in> V T\<^isub>2}"
129.38 +| "V (T\<^isub>1 \<rightarrow> T\<^isub>2) = {Lam [x].e | x e. \<forall> v \<in> (V T\<^isub>1). \<exists> v'. e[x::=v] \<Down> v' \<and> v' \<in> V T\<^isub>2}"
129.39 by (rule TrueI)+
129.40
129.41 lemma V_eqvt:
130.1 --- a/src/HOL/Nominal/Examples/Standardization.thy Tue Dec 30 08:18:54 2008 +0100
130.2 +++ b/src/HOL/Nominal/Examples/Standardization.thy Tue Dec 30 11:10:01 2008 +0100
130.3 @@ -1,5 +1,4 @@
130.4 (* Title: HOL/Nominal/Examples/Standardization.thy
130.5 - ID: $Id$
130.6 Author: Stefan Berghofer and Tobias Nipkow
130.7 Copyright 2005, 2008 TU Muenchen
130.8 *)
130.9 @@ -24,24 +23,30 @@
130.10 | App "lam" "lam" (infixl "\<degree>" 200)
130.11 | Lam "\<guillemotleft>name\<guillemotright>lam" ("Lam [_]._" [0, 10] 10)
130.12
130.13 -instance lam :: size ..
130.14 +instantiation lam :: size
130.15 +begin
130.16
130.17 -nominal_primrec
130.18 +nominal_primrec size_lam
130.19 +where
130.20 "size (Var n) = 0"
130.21 - "size (t \<degree> u) = size t + size u + 1"
130.22 - "size (Lam [x].t) = size t + 1"
130.23 +| "size (t \<degree> u) = size t + size u + 1"
130.24 +| "size (Lam [x].t) = size t + 1"
130.25 apply finite_guess+
130.26 apply (rule TrueI)+
130.27 apply (simp add: fresh_nat)
130.28 apply fresh_guess+
130.29 done
130.30
130.31 -consts subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam" ("_[_::=_]" [300, 0, 0] 300)
130.32 +instance ..
130.33 +
130.34 +end
130.35
130.36 nominal_primrec
130.37 + subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam" ("_[_::=_]" [300, 0, 0] 300)
130.38 +where
130.39 subst_Var: "(Var x)[y::=s] = (if x=y then s else (Var x))"
130.40 - subst_App: "(t\<^isub>1 \<degree> t\<^isub>2)[y::=s] = t\<^isub>1[y::=s] \<degree> t\<^isub>2[y::=s]"
130.41 - subst_Lam: "x \<sharp> (y, s) \<Longrightarrow> (Lam [x].t)[y::=s] = (Lam [x].(t[y::=s]))"
130.42 +| subst_App: "(t\<^isub>1 \<degree> t\<^isub>2)[y::=s] = t\<^isub>1[y::=s] \<degree> t\<^isub>2[y::=s]"
130.43 +| subst_Lam: "x \<sharp> (y, s) \<Longrightarrow> (Lam [x].t)[y::=s] = (Lam [x].(t[y::=s]))"
130.44 apply(finite_guess)+
130.45 apply(rule TrueI)+
130.46 apply(simp add: abs_fresh)
131.1 --- a/src/HOL/Nominal/Examples/Type_Preservation.thy Tue Dec 30 08:18:54 2008 +0100
131.2 +++ b/src/HOL/Nominal/Examples/Type_Preservation.thy Tue Dec 30 11:10:01 2008 +0100
131.3 @@ -1,5 +1,3 @@
131.4 -(* $Id$ *)
131.5 -
131.6 theory Type_Preservation
131.7 imports Nominal
131.8 begin
131.9 @@ -21,13 +19,12 @@
131.10
131.11 text {* Capture-Avoiding Substitution *}
131.12
131.13 -consts
131.14 +nominal_primrec
131.15 subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam" ("_[_::=_]")
131.16 -
131.17 -nominal_primrec
131.18 +where
131.19 "(Var x)[y::=s] = (if x=y then s else (Var x))"
131.20 - "(App t\<^isub>1 t\<^isub>2)[y::=s] = App (t\<^isub>1[y::=s]) (t\<^isub>2[y::=s])"
131.21 - "x\<sharp>(y,s) \<Longrightarrow> (Lam [x].t)[y::=s] = Lam [x].(t[y::=s])"
131.22 +| "(App t\<^isub>1 t\<^isub>2)[y::=s] = App (t\<^isub>1[y::=s]) (t\<^isub>2[y::=s])"
131.23 +| "x\<sharp>(y,s) \<Longrightarrow> (Lam [x].t)[y::=s] = Lam [x].(t[y::=s])"
131.24 apply(finite_guess)+
131.25 apply(rule TrueI)+
131.26 apply(simp add: abs_fresh)
132.1 --- a/src/HOL/Nominal/Examples/W.thy Tue Dec 30 08:18:54 2008 +0100
132.2 +++ b/src/HOL/Nominal/Examples/W.thy Tue Dec 30 11:10:01 2008 +0100
132.3 @@ -1,5 +1,3 @@
132.4 -(* "$Id$" *)
132.5 -
132.6 theory W
132.7 imports Nominal
132.8 begin
132.9 @@ -50,26 +48,68 @@
132.10 Ctxt = "(var\<times>tyS) list"
132.11
132.12 text {* free type variables *}
132.13 -consts
132.14 - ftv :: "'a \<Rightarrow> tvar list"
132.15
132.16 -primrec (ftv_of_prod)
132.17 - "ftv (x,y) = (ftv x)@(ftv y)"
132.18 +class ftv = type +
132.19 + fixes ftv :: "'a \<Rightarrow> tvar list"
132.20
132.21 -defs (overloaded)
132.22 +instantiation * :: (ftv, ftv) ftv
132.23 +begin
132.24 +
132.25 +primrec ftv_prod
132.26 +where
132.27 + "ftv (x::'a::ftv, y::'b::ftv) = (ftv x)@(ftv y)"
132.28 +
132.29 +instance ..
132.30 +
132.31 +end
132.32 +
132.33 +instantiation tvar :: ftv
132.34 +begin
132.35 +
132.36 +definition
132.37 ftv_of_tvar[simp]: "ftv X \<equiv> [(X::tvar)]"
132.38 +
132.39 +instance ..
132.40 +
132.41 +end
132.42 +
132.43 +instantiation var :: ftv
132.44 +begin
132.45 +
132.46 +definition
132.47 ftv_of_var[simp]: "ftv (x::var) \<equiv> []"
132.48
132.49 -primrec (ftv_of_list)
132.50 +instance ..
132.51 +
132.52 +end
132.53 +
132.54 +instantiation list :: (ftv) ftv
132.55 +begin
132.56 +
132.57 +primrec ftv_list
132.58 +where
132.59 "ftv [] = []"
132.60 - "ftv (x#xs) = (ftv x)@(ftv xs)"
132.61 +| "ftv (x#xs) = (ftv x)@(ftv xs)"
132.62 +
132.63 +instance ..
132.64 +
132.65 +end
132.66
132.67 (* free type-variables of types *)
132.68 -nominal_primrec (ftv_ty)
132.69 +
132.70 +instantiation ty :: ftv
132.71 +begin
132.72 +
132.73 +nominal_primrec ftv_ty
132.74 +where
132.75 "ftv (TVar X) = [X]"
132.76 - "ftv (T\<^isub>1\<rightarrow>T\<^isub>2) = (ftv T\<^isub>1)@(ftv T\<^isub>2)"
132.77 +| "ftv (T\<^isub>1\<rightarrow>T\<^isub>2) = (ftv T\<^isub>1)@(ftv T\<^isub>2)"
132.78 by (rule TrueI)+
132.79
132.80 +instance ..
132.81 +
132.82 +end
132.83 +
132.84 lemma ftv_ty_eqvt[eqvt]:
132.85 fixes pi::"tvar prm"
132.86 and T::"ty"
132.87 @@ -77,9 +117,13 @@
132.88 by (nominal_induct T rule: ty.strong_induct)
132.89 (perm_simp add: append_eqvt)+
132.90
132.91 -nominal_primrec (ftv_tyS)
132.92 +instantiation tyS :: ftv
132.93 +begin
132.94 +
132.95 +nominal_primrec ftv_tyS
132.96 +where
132.97 "ftv (Ty T) = ftv T"
132.98 - "ftv (\<forall>[X].S) = (ftv S) - [X]"
132.99 +| "ftv (\<forall>[X].S) = (ftv S) - [X]"
132.100 apply(finite_guess add: ftv_ty_eqvt fs_tvar1)+
132.101 apply(rule TrueI)+
132.102 apply(rule difference_fresh)
132.103 @@ -87,6 +131,10 @@
132.104 apply(fresh_guess add: ftv_ty_eqvt fs_tvar1)+
132.105 done
132.106
132.107 +instance ..
132.108 +
132.109 +end
132.110 +
132.111 lemma ftv_tyS_eqvt[eqvt]:
132.112 fixes pi::"tvar prm"
132.113 and S::"tyS"
132.114 @@ -140,11 +188,11 @@
132.115
132.116 types Subst = "(tvar\<times>ty) list"
132.117
132.118 -consts
132.119 - psubst :: "Subst \<Rightarrow> 'a \<Rightarrow> 'a" ("_<_>" [100,60] 120)
132.120 +class psubst =
132.121 + fixes psubst :: "Subst \<Rightarrow> 'a \<Rightarrow> 'a" ("_<_>" [100,60] 120)
132.122
132.123 abbreviation
132.124 - subst :: "'a \<Rightarrow> tvar \<Rightarrow> ty \<Rightarrow> 'a" ("_[_::=_]" [100,100,100] 100)
132.125 + subst :: "'a::psubst \<Rightarrow> tvar \<Rightarrow> ty \<Rightarrow> 'a" ("_[_::=_]" [100,100,100] 100)
132.126 where
132.127 "smth[X::=T] \<equiv> ([(X,T)])<smth>"
132.128
132.129 @@ -159,11 +207,19 @@
132.130 shows "pi\<bullet>(lookup \<theta> X) = lookup (pi\<bullet>\<theta>) (pi\<bullet>X)"
132.131 by (induct \<theta>) (auto simp add: eqvts)
132.132
132.133 -nominal_primrec (psubst_ty)
132.134 +instantiation ty :: psubst
132.135 +begin
132.136 +
132.137 +nominal_primrec psubst_ty
132.138 +where
132.139 "\<theta><TVar X> = lookup \<theta> X"
132.140 - "\<theta><T\<^isub>1 \<rightarrow> T\<^isub>2> = (\<theta><T\<^isub>1>) \<rightarrow> (\<theta><T\<^isub>2>)"
132.141 +| "\<theta><T\<^isub>1 \<rightarrow> T\<^isub>2> = (\<theta><T\<^isub>1>) \<rightarrow> (\<theta><T\<^isub>2>)"
132.142 by (rule TrueI)+
132.143
132.144 +instance ..
132.145 +
132.146 +end
132.147 +
132.148 lemma psubst_ty_eqvt[eqvt]:
132.149 fixes pi1::"tvar prm"
132.150 and \<theta>::"Subst"
133.1 --- a/src/HOL/Nominal/Nominal.thy Tue Dec 30 08:18:54 2008 +0100
133.2 +++ b/src/HOL/Nominal/Nominal.thy Tue Dec 30 11:10:01 2008 +0100
133.3 @@ -1262,19 +1262,21 @@
133.4 apply (simp add: pt_rev_pi [OF pt at])
133.5 done
133.6
133.7 -lemma insert_eqvt:
133.8 +lemma pt_insert_eqvt:
133.9 + fixes pi::"'x prm"
133.10 + and x::"'a"
133.11 assumes pt: "pt TYPE('a) TYPE('x)"
133.12 and at: "at TYPE('x)"
133.13 - shows "(pi::'x prm)\<bullet>(insert (x::'a) X) = insert (pi\<bullet>x) (pi\<bullet>X)"
133.14 + shows "(pi\<bullet>(insert x X)) = insert (pi\<bullet>x) (pi\<bullet>X)"
133.15 by (auto simp add: perm_set_eq [OF pt at])
133.16
133.17 -lemma set_eqvt:
133.18 +lemma pt_set_eqvt:
133.19 fixes pi :: "'x prm"
133.20 and xs :: "'a list"
133.21 assumes pt: "pt TYPE('a) TYPE('x)"
133.22 and at: "at TYPE('x)"
133.23 shows "pi\<bullet>(set xs) = set (pi\<bullet>xs)"
133.24 -by (induct xs) (auto simp add: empty_eqvt insert_eqvt [OF pt at])
133.25 +by (induct xs) (auto simp add: empty_eqvt pt_insert_eqvt [OF pt at])
133.26
133.27 lemma supp_singleton:
133.28 assumes pt: "pt TYPE('a) TYPE('x)"
133.29 @@ -1568,10 +1570,10 @@
133.30 apply(simp add: pt_fresh_left_ineq[OF pta, OF ptb, OF at, OF cp])
133.31 apply(drule_tac x="pi\<bullet>xa" in bspec)
133.32 apply(simp add: pt_set_bij1[OF ptb, OF at])
133.33 -apply(simp add: set_eqvt [OF ptb at] pt_rev_pi[OF pt_list_inst[OF ptb], OF at])
133.34 +apply(simp add: pt_set_eqvt [OF ptb at] pt_rev_pi[OF pt_list_inst[OF ptb], OF at])
133.35 apply(simp add: pt_fresh_bij_ineq[OF pta, OF ptb, OF at, OF cp])
133.36 apply(drule_tac x="(rev pi)\<bullet>xa" in bspec)
133.37 -apply(simp add: pt_set_bij1[OF ptb, OF at] set_eqvt [OF ptb at])
133.38 +apply(simp add: pt_set_bij1[OF ptb, OF at] pt_set_eqvt [OF ptb at])
133.39 apply(simp add: pt_fresh_left_ineq[OF pta, OF ptb, OF at, OF cp])
133.40 done
133.41
134.1 --- a/src/HOL/Nominal/nominal_atoms.ML Tue Dec 30 08:18:54 2008 +0100
134.2 +++ b/src/HOL/Nominal/nominal_atoms.ML Tue Dec 30 11:10:01 2008 +0100
134.3 @@ -798,8 +798,8 @@
134.4 val pt_perm_supp_ineq = @{thm "Nominal.pt_perm_supp_ineq"};
134.5 val pt_perm_supp = @{thm "Nominal.pt_perm_supp"};
134.6 val subseteq_eqvt = @{thm "Nominal.pt_subseteq_eqvt"};
134.7 - val insert_eqvt = @{thm "Nominal.insert_eqvt"};
134.8 - val set_eqvt = @{thm "Nominal.set_eqvt"};
134.9 + val insert_eqvt = @{thm "Nominal.pt_insert_eqvt"};
134.10 + val set_eqvt = @{thm "Nominal.pt_set_eqvt"};
134.11 val perm_set_eq = @{thm "Nominal.perm_set_eq"};
134.12
134.13 (* Now we collect and instantiate some lemmas w.r.t. all atom *)
135.1 --- a/src/HOL/Nominal/nominal_primrec.ML Tue Dec 30 08:18:54 2008 +0100
135.2 +++ b/src/HOL/Nominal/nominal_primrec.ML Tue Dec 30 11:10:01 2008 +0100
135.3 @@ -1,5 +1,4 @@
135.4 (* Title: HOL/Nominal/nominal_primrec.ML
135.5 - ID: $Id$
135.6 Author: Stefan Berghofer, TU Muenchen and Norbert Voelker, FernUni Hagen
135.7
135.8 Package for defining functions on nominal datatypes by primitive recursion.
135.9 @@ -8,14 +7,10 @@
135.10
135.11 signature NOMINAL_PRIMREC =
135.12 sig
135.13 - val add_primrec: string -> string list option -> string option ->
135.14 - ((Binding.T * string) * Attrib.src list) list -> theory -> Proof.state
135.15 - val add_primrec_unchecked: string -> string list option -> string option ->
135.16 - ((Binding.T * string) * Attrib.src list) list -> theory -> Proof.state
135.17 - val add_primrec_i: string -> term list option -> term option ->
135.18 - ((Binding.T * term) * attribute list) list -> theory -> Proof.state
135.19 - val add_primrec_unchecked_i: string -> term list option -> term option ->
135.20 - ((Binding.T * term) * attribute list) list -> theory -> Proof.state
135.21 + val add_primrec: term list option -> term option ->
135.22 + (Binding.T * typ option * mixfix) list ->
135.23 + (Binding.T * typ option * mixfix) list ->
135.24 + (Attrib.binding * term) list -> local_theory -> Proof.state
135.25 end;
135.26
135.27 structure NominalPrimrec : NOMINAL_PRIMREC =
135.28 @@ -26,23 +21,31 @@
135.29 exception RecError of string;
135.30
135.31 fun primrec_err s = error ("Nominal primrec definition error:\n" ^ s);
135.32 -fun primrec_eq_err thy s eq =
135.33 - primrec_err (s ^ "\nin\n" ^ quote (Syntax.string_of_term_global thy eq));
135.34 +fun primrec_eq_err lthy s eq =
135.35 + primrec_err (s ^ "\nin\n" ^ quote (Syntax.string_of_term lthy eq));
135.36
135.37
135.38 (* preprocessing of equations *)
135.39
135.40 -fun process_eqn thy eq rec_fns =
135.41 +fun unquantify t =
135.42 let
135.43 + val (vs, Ts) = split_list (strip_qnt_vars "all" t);
135.44 + val body = strip_qnt_body "all" t;
135.45 + val (vs', _) = Name.variants vs (Name.make_context (fold_aterms
135.46 + (fn Free (v, _) => insert (op =) v | _ => I) body []))
135.47 + in (curry subst_bounds (map2 (curry Free) vs' Ts |> rev) body) end;
135.48 +
135.49 +fun process_eqn lthy is_fixed spec rec_fns =
135.50 + let
135.51 + val eq = unquantify spec;
135.52 val (lhs, rhs) =
135.53 - if null (term_vars eq) then
135.54 - HOLogic.dest_eq (HOLogic.dest_Trueprop (Logic.strip_imp_concl eq))
135.55 - handle TERM _ => raise RecError "not a proper equation"
135.56 - else raise RecError "illegal schematic variable(s)";
135.57 + HOLogic.dest_eq (HOLogic.dest_Trueprop (Logic.strip_imp_concl eq))
135.58 + handle TERM _ => raise RecError "not a proper equation";
135.59
135.60 val (recfun, args) = strip_comb lhs;
135.61 - val fnameT = dest_Const recfun handle TERM _ =>
135.62 - raise RecError "function is not declared as constant in theory";
135.63 + val fname = case recfun of Free (v, _) => if is_fixed v then v
135.64 + else raise RecError "illegal head of function equation"
135.65 + | _ => raise RecError "illegal head of function equation";
135.66
135.67 val (ls', rest) = take_prefix is_Free args;
135.68 val (middle, rs') = take_suffix is_Free rest;
135.69 @@ -68,26 +71,28 @@
135.70 else
135.71 (check_vars "repeated variable names in pattern: " (duplicates (op =) lfrees);
135.72 check_vars "extra variables on rhs: "
135.73 - (map dest_Free (term_frees rhs) \\ lfrees);
135.74 - case AList.lookup (op =) rec_fns fnameT of
135.75 + (map dest_Free (term_frees rhs) |> subtract (op =) lfrees
135.76 + |> filter_out (is_fixed o fst));
135.77 + case AList.lookup (op =) rec_fns fname of
135.78 NONE =>
135.79 - (fnameT, (tname, rpos, [(cname, (ls, cargs, rs, rhs, eq))]))::rec_fns
135.80 + (fname, (tname, rpos, [(cname, (ls, cargs, rs, rhs, eq))]))::rec_fns
135.81 | SOME (_, rpos', eqns) =>
135.82 if AList.defined (op =) eqns cname then
135.83 raise RecError "constructor already occurred as pattern"
135.84 else if rpos <> rpos' then
135.85 raise RecError "position of recursive argument inconsistent"
135.86 else
135.87 - AList.update (op =) (fnameT, (tname, rpos, (cname, (ls, cargs, rs, rhs, eq))::eqns))
135.88 + AList.update (op =)
135.89 + (fname, (tname, rpos, (cname, (ls, cargs, rs, rhs, eq))::eqns))
135.90 rec_fns)
135.91 end
135.92 - handle RecError s => primrec_eq_err thy s eq;
135.93 + handle RecError s => primrec_eq_err lthy s spec;
135.94
135.95 val param_err = "Parameters must be the same for all recursive functions";
135.96
135.97 -fun process_fun thy descr rec_eqns (i, fnameT as (fname, _)) (fnameTs, fnss) =
135.98 +fun process_fun lthy descr eqns (i, fname) (fnames, fnss) =
135.99 let
135.100 - val (_, (tname, _, constrs)) = List.nth (descr, i);
135.101 + val (_, (tname, _, constrs)) = nth descr i;
135.102
135.103 (* substitute "fname ls x rs" by "y" for (x, (_, y)) in subs *)
135.104
135.105 @@ -100,16 +105,17 @@
135.106 let
135.107 val (f, ts) = strip_comb t;
135.108 in
135.109 - if is_Const f andalso dest_Const f mem map fst rec_eqns then
135.110 + if is_Free f
135.111 + andalso member (fn ((v, _), (w, _)) => v = w) eqns (dest_Free f) then
135.112 let
135.113 - val fnameT' as (fname', _) = dest_Const f;
135.114 - val (_, rpos, eqns) = the (AList.lookup (op =) rec_eqns fnameT');
135.115 - val ls = Library.take (rpos, ts);
135.116 - val rest = Library.drop (rpos, ts);
135.117 - val (x', rs) = (hd rest, tl rest)
135.118 - handle Empty => raise RecError ("not enough arguments\
135.119 - \ in recursive application\nof function " ^ quote fname' ^ " on rhs");
135.120 - val rs' = (case eqns of
135.121 + val (fname', _) = dest_Free f;
135.122 + val (_, rpos, eqns') = the (AList.lookup (op =) eqns fname');
135.123 + val (ls, rs'') = chop rpos ts
135.124 + val (x', rs) = case rs'' of
135.125 + x' :: rs => (x', rs)
135.126 + | [] => raise RecError ("not enough arguments in recursive application\n"
135.127 + ^ "of function " ^ quote fname' ^ " on rhs");
135.128 + val rs' = (case eqns' of
135.129 (_, (ls', _, rs', _, _)) :: _ =>
135.130 let val (rs1, rs2) = chop (length rs') rs
135.131 in
135.132 @@ -126,7 +132,7 @@
135.133 | SOME (i', y) =>
135.134 fs
135.135 |> fold_map (subst subs) (xs @ rs')
135.136 - ||> process_fun thy descr rec_eqns (i', fnameT')
135.137 + ||> process_fun lthy descr eqns (i', fname')
135.138 |-> (fn ts' => pair (list_comb (y, ts')))
135.139 end
135.140 else
135.141 @@ -138,41 +144,39 @@
135.142
135.143 (* translate rec equations into function arguments suitable for rec comb *)
135.144
135.145 - fun trans eqns (cname, cargs) (fnameTs', fnss', fns) =
135.146 + fun trans eqns (cname, cargs) (fnames', fnss', fns) =
135.147 (case AList.lookup (op =) eqns cname of
135.148 NONE => (warning ("No equation for constructor " ^ quote cname ^
135.149 "\nin definition of function " ^ quote fname);
135.150 - (fnameTs', fnss', (Const (@{const_name undefined}, dummyT))::fns))
135.151 + (fnames', fnss', (Const (@{const_name undefined}, dummyT))::fns))
135.152 | SOME (ls, cargs', rs, rhs, eq) =>
135.153 let
135.154 val recs = filter (is_rec_type o snd) (cargs' ~~ cargs);
135.155 val rargs = map fst recs;
135.156 - val subs = map (rpair dummyT o fst)
135.157 + val subs = map (rpair dummyT o fst)
135.158 (rev (rename_wrt_term rhs rargs));
135.159 - val (rhs', (fnameTs'', fnss'')) =
135.160 - (subst (map (fn ((x, y), z) =>
135.161 - (Free x, (body_index y, Free z)))
135.162 - (recs ~~ subs)) rhs (fnameTs', fnss'))
135.163 - handle RecError s => primrec_eq_err thy s eq
135.164 - in (fnameTs'', fnss'',
135.165 + val (rhs', (fnames'', fnss'')) = subst (map2 (fn (x, y) => fn z =>
135.166 + (Free x, (body_index y, Free z))) recs subs) rhs (fnames', fnss')
135.167 + handle RecError s => primrec_eq_err lthy s eq
135.168 + in (fnames'', fnss'',
135.169 (list_abs_free (cargs' @ subs, rhs'))::fns)
135.170 end)
135.171
135.172 - in (case AList.lookup (op =) fnameTs i of
135.173 + in (case AList.lookup (op =) fnames i of
135.174 NONE =>
135.175 - if exists (equal fnameT o snd) fnameTs then
135.176 + if exists (fn (_, v) => fname = v) fnames then
135.177 raise RecError ("inconsistent functions for datatype " ^ quote tname)
135.178 else
135.179 let
135.180 - val SOME (_, _, eqns as (_, (ls, _, rs, _, _)) :: _) =
135.181 - AList.lookup (op =) rec_eqns fnameT;
135.182 - val (fnameTs', fnss', fns) = fold_rev (trans eqns) constrs
135.183 - ((i, fnameT)::fnameTs, fnss, [])
135.184 + val SOME (_, _, eqns' as (_, (ls, _, rs, _, _)) :: _) =
135.185 + AList.lookup (op =) eqns fname;
135.186 + val (fnames', fnss', fns) = fold_rev (trans eqns') constrs
135.187 + ((i, fname)::fnames, fnss, [])
135.188 in
135.189 - (fnameTs', (i, (fname, ls, rs, fns))::fnss')
135.190 + (fnames', (i, (fname, ls, rs, fns))::fnss')
135.191 end
135.192 - | SOME fnameT' =>
135.193 - if fnameT = fnameT' then (fnameTs, fnss)
135.194 + | SOME fname' =>
135.195 + if fname = fname' then (fnames, fnss)
135.196 else raise RecError ("inconsistent functions for datatype " ^ quote tname))
135.197 end;
135.198
135.199 @@ -195,18 +199,21 @@
135.200
135.201 (* make definition *)
135.202
135.203 -fun make_def thy fs (fname, ls, rs, rec_name, tname) =
135.204 +fun make_def ctxt fixes fs (fname, ls, rs, rec_name, tname) =
135.205 let
135.206 val used = map fst (fold Term.add_frees fs []);
135.207 val x = (Name.variant used "x", dummyT);
135.208 val frees = ls @ x :: rs;
135.209 - val rhs = list_abs_free (frees,
135.210 + val raw_rhs = list_abs_free (frees,
135.211 list_comb (Const (rec_name, dummyT), fs @ [Free x]))
135.212 - val def_name = Sign.base_name fname ^ "_" ^ Sign.base_name tname ^ "_def";
135.213 - val def_prop as _ $ _ $ t =
135.214 - singleton (Syntax.check_terms (ProofContext.init thy))
135.215 - (Logic.mk_equals (Const (fname, dummyT), rhs));
135.216 - in ((def_name, def_prop), subst_bounds (rev (map Free frees), strip_abs_body t)) end;
135.217 + val def_name = Thm.def_name (Sign.base_name fname);
135.218 + val rhs = singleton (Syntax.check_terms ctxt) raw_rhs;
135.219 + val SOME var = get_first (fn ((b, _), mx) =>
135.220 + if Binding.base_name b = fname then SOME (b, mx) else NONE) fixes;
135.221 + in
135.222 + ((var, ((Binding.name def_name, []), rhs)),
135.223 + subst_bounds (rev (map Free frees), strip_abs_body rhs))
135.224 + end;
135.225
135.226
135.227 (* find datatypes which contain all datatypes in tnames' *)
135.228 @@ -227,27 +234,36 @@
135.229
135.230 local
135.231
135.232 -fun gen_primrec_i note def alt_name invs fctxt eqns_atts thy =
135.233 +fun prepare_spec prep_spec ctxt raw_fixes raw_spec =
135.234 let
135.235 - val (raw_eqns, atts) = split_list eqns_atts;
135.236 - val eqns = map (apfst Binding.base_name) raw_eqns;
135.237 - val dt_info = NominalPackage.get_nominal_datatypes thy;
135.238 - val rec_eqns = fold_rev (process_eqn thy o snd) eqns [];
135.239 + val ((fixes, spec), _) = prep_spec
135.240 + raw_fixes (map (single o apsnd single) raw_spec) ctxt
135.241 + in (fixes, map (apsnd the_single) spec) end;
135.242 +
135.243 +fun gen_primrec set_group prep_spec prep_term invs fctxt raw_fixes raw_params raw_spec lthy =
135.244 + let
135.245 + val (fixes', spec) = prepare_spec prep_spec lthy (raw_fixes @ raw_params) raw_spec;
135.246 + val fixes = List.take (fixes', length raw_fixes);
135.247 + val (names_atts, spec') = split_list spec;
135.248 + val eqns' = map unquantify spec'
135.249 + val eqns = fold_rev (process_eqn lthy (fn v => Variable.is_fixed lthy v
135.250 + orelse exists (fn ((w, _), _) => v = Binding.base_name w) fixes)) spec' [];
135.251 + val dt_info = NominalPackage.get_nominal_datatypes (ProofContext.theory_of lthy);
135.252 val lsrs :: lsrss = maps (fn (_, (_, _, eqns)) =>
135.253 - map (fn (_, (ls, _, rs, _, _)) => ls @ rs) eqns) rec_eqns
135.254 + map (fn (_, (ls, _, rs, _, _)) => ls @ rs) eqns) eqns
135.255 val _ =
135.256 (if forall (curry eq_set lsrs) lsrss andalso forall
135.257 (fn (_, (_, _, (_, (ls, _, rs, _, _)) :: eqns)) =>
135.258 forall (fn (_, (ls', _, rs', _, _)) =>
135.259 ls = ls' andalso rs = rs') eqns
135.260 - | _ => true) rec_eqns
135.261 + | _ => true) eqns
135.262 then () else primrec_err param_err);
135.263 - val tnames = distinct (op =) (map (#1 o snd) rec_eqns);
135.264 + val tnames = distinct (op =) (map (#1 o snd) eqns);
135.265 val dts = find_dts dt_info tnames tnames;
135.266 val main_fns =
135.267 map (fn (tname, {index, ...}) =>
135.268 (index,
135.269 - (fst o the o find_first (fn f => (#1 o snd) f = tname)) rec_eqns))
135.270 + (fst o the o find_first (fn (_, x) => #1 x = tname)) eqns))
135.271 dts;
135.272 val {descr, rec_names, rec_rewrites, ...} =
135.273 if null dts then
135.274 @@ -256,32 +272,32 @@
135.275 val descr = map (fn (i, (tname, args, constrs)) => (i, (tname, args,
135.276 map (fn (cname, cargs) => (cname, fold (fn (dTs, dT) => fn dTs' =>
135.277 dTs' @ dTs @ [dT]) cargs [])) constrs))) descr;
135.278 - val (fnameTs, fnss) =
135.279 - fold_rev (process_fun thy descr rec_eqns) main_fns ([], []);
135.280 + val (fnames, fnss) = fold_rev (process_fun lthy descr eqns) main_fns ([], []);
135.281 val (fs, defs) = fold_rev (get_fns fnss) (descr ~~ rec_names) ([], []);
135.282 - val defs' = map (make_def thy fs) defs;
135.283 - val nameTs1 = map snd fnameTs;
135.284 - val nameTs2 = map fst rec_eqns;
135.285 - val _ = if gen_eq_set (op =) (nameTs1, nameTs2) then ()
135.286 - else primrec_err ("functions " ^ commas_quote (map fst nameTs2) ^
135.287 - "\nare not mutually recursive");
135.288 - val primrec_name =
135.289 - if alt_name = "" then (space_implode "_" (map (Sign.base_name o #1) defs)) else alt_name;
135.290 - val (defs_thms', thy') =
135.291 - thy
135.292 - |> Sign.add_path primrec_name
135.293 - |> fold_map def (map (fn ((name, t), _) => ((name, []), t)) defs');
135.294 - val cert = cterm_of thy';
135.295 + val defs' = map (make_def lthy fixes fs) defs;
135.296 + val names1 = map snd fnames;
135.297 + val names2 = map fst eqns;
135.298 + val _ = if gen_eq_set (op =) (names1, names2) then ()
135.299 + else primrec_err ("functions " ^ commas_quote names2 ^
135.300 + "\nare not mutually recursive");
135.301 + val (defs_thms, lthy') = lthy |>
135.302 + set_group ? LocalTheory.set_group (serial_string ()) |>
135.303 + fold_map (apfst (snd o snd) oo
135.304 + LocalTheory.define Thm.definitionK o fst) defs';
135.305 + val qualify = Binding.qualify
135.306 + (space_implode "_" (map (Sign.base_name o #1) defs));
135.307 + val names_atts' = map (apfst qualify) names_atts;
135.308 + val cert = cterm_of (ProofContext.theory_of lthy');
135.309
135.310 fun mk_idx eq =
135.311 let
135.312 - val Const c = head_of (fst (HOLogic.dest_eq (HOLogic.dest_Trueprop
135.313 + val Free (name, _) = head_of (fst (HOLogic.dest_eq (HOLogic.dest_Trueprop
135.314 (Logic.strip_imp_concl eq))));
135.315 - val SOME i = AList.lookup op = (map swap fnameTs) c;
135.316 + val SOME i = AList.lookup op = (map swap fnames) name;
135.317 val SOME (_, _, constrs) = AList.lookup op = descr i;
135.318 - val SOME (_, _, eqns) = AList.lookup op = rec_eqns c;
135.319 + val SOME (_, _, eqns'') = AList.lookup op = eqns name;
135.320 val SOME (cname, (_, cargs, _, _, _)) = find_first
135.321 - (fn (_, (_, _, _, _, eq')) => eq = eq') eqns
135.322 + (fn (_, (_, _, _, _, eq')) => eq = eq') eqns''
135.323 in (i, find_index (fn (cname', _) => cname = cname') constrs, cargs) end;
135.324
135.325 val rec_rewritess =
135.326 @@ -296,19 +312,15 @@
135.327 curry (List.take o swap) (length fvars) |> map cert;
135.328 val invs' = (case invs of
135.329 NONE => map (fn (i, _) =>
135.330 - let
135.331 - val SOME (_, T) = AList.lookup op = fnameTs i
135.332 - val (Ts, U) = strip_type T
135.333 - in
135.334 - Abs ("x", List.drop (Ts, length lsrs + 1) ---> U, HOLogic.true_const)
135.335 - end) descr
135.336 - | SOME invs' => invs');
135.337 + Abs ("x", fastype_of (snd (nth defs' i)), HOLogic.true_const)) descr
135.338 + | SOME invs' => map (prep_term lthy') invs');
135.339 val inst = (map cert fvars ~~ cfs) @
135.340 (map (cert o Var) pvars ~~ map cert invs') @
135.341 (case ctxtvars of
135.342 - [ctxtvar] => [(cert (Var ctxtvar), cert (the_default HOLogic.unit fctxt))]
135.343 + [ctxtvar] => [(cert (Var ctxtvar),
135.344 + cert (the_default HOLogic.unit (Option.map (prep_term lthy') fctxt)))]
135.345 | _ => []);
135.346 - val rec_rewrites' = map (fn (_, eq) =>
135.347 + val rec_rewrites' = map (fn eq =>
135.348 let
135.349 val (i, j, cargs) = mk_idx eq
135.350 val th = nth (nth rec_rewritess i) j;
135.351 @@ -317,8 +329,8 @@
135.352 strip_comb |> snd
135.353 in (cargs, Logic.strip_imp_prems eq,
135.354 Drule.cterm_instantiate (inst @
135.355 - (map (cterm_of thy') cargs' ~~ map (cterm_of thy' o Free) cargs)) th)
135.356 - end) eqns;
135.357 + (map cert cargs' ~~ map (cert o Free) cargs)) th)
135.358 + end) eqns';
135.359
135.360 val prems = foldr1 (common_prefix op aconv) (map (prems_of o #3) rec_rewrites');
135.361 val cprems = map cert prems;
135.362 @@ -346,64 +358,37 @@
135.363 val rule = implies_intr_list rule_prems
135.364 (Conjunction.intr_balanced (map mk_eqn (rec_rewrites' ~~ asmss)));
135.365
135.366 - val goals = map (fn ((cargs, _, _), (_, eqn)) =>
135.367 - (list_all_free (cargs, eqn), [])) (rec_rewrites' ~~ eqns);
135.368 + val goals = map (fn ((cargs, _, _), eqn) =>
135.369 + (list_all_free (cargs, eqn), [])) (rec_rewrites' ~~ eqns');
135.370
135.371 in
135.372 - thy' |>
135.373 - ProofContext.init |>
135.374 + lthy' |>
135.375 + Variable.add_fixes (map fst lsrs) |> snd |>
135.376 Proof.theorem_i NONE
135.377 - (fn thss => ProofContext.theory (fn thy =>
135.378 + (fn thss => fn goal_ctxt =>
135.379 let
135.380 - val simps = map standard (flat thss);
135.381 - val (simps', thy') =
135.382 - fold_map note ((map fst eqns ~~ atts) ~~ map single simps) thy;
135.383 - val simps'' = maps snd simps'
135.384 + val simps = ProofContext.export goal_ctxt lthy' (flat thss);
135.385 + val (simps', lthy'') = fold_map (LocalTheory.note Thm.theoremK)
135.386 + (names_atts' ~~ map single simps) lthy'
135.387 in
135.388 - thy'
135.389 - |> note (("simps", [Simplifier.simp_add]), simps'')
135.390 + lthy''
135.391 + |> LocalTheory.note Thm.theoremK ((qualify (Binding.name "simps"),
135.392 + [Attrib.internal (K Simplifier.simp_add)]), maps snd simps')
135.393 |> snd
135.394 - |> Sign.parent_path
135.395 - end))
135.396 + end)
135.397 [goals] |>
135.398 Proof.apply (Method.Basic (fn _ => Method.RAW_METHOD (fn _ =>
135.399 - rewrite_goals_tac (map snd defs_thms') THEN
135.400 + rewrite_goals_tac defs_thms THEN
135.401 compose_tac (false, rule, length rule_prems) 1), Position.none)) |>
135.402 Seq.hd
135.403 end;
135.404
135.405 -fun gen_primrec note def alt_name invs fctxt eqns thy =
135.406 - let
135.407 - val ((names, strings), srcss) = apfst split_list (split_list eqns);
135.408 - val atts = map (map (Attrib.attribute thy)) srcss;
135.409 - val eqn_ts = map (fn s => Syntax.read_prop_global thy s
135.410 - handle ERROR msg => cat_error msg ("The error(s) above occurred for " ^ s)) strings;
135.411 - val rec_ts = map (fn eq => head_of (fst (HOLogic.dest_eq
135.412 - (HOLogic.dest_Trueprop (Logic.strip_imp_concl eq))))
135.413 - handle TERM _ => primrec_eq_err thy "not a proper equation" eq) eqn_ts;
135.414 - val (_, eqn_ts') = OldPrimrecPackage.unify_consts thy rec_ts eqn_ts
135.415 - in
135.416 - gen_primrec_i note def alt_name
135.417 - (Option.map (map (Syntax.read_term_global thy)) invs)
135.418 - (Option.map (Syntax.read_term_global thy) fctxt)
135.419 - (names ~~ eqn_ts' ~~ atts) thy
135.420 - end;
135.421 -
135.422 -fun thy_note ((name, atts), thms) =
135.423 - PureThy.add_thmss [((name, thms), atts)] #-> (fn [thms] => pair (name, thms));
135.424 -fun thy_def false ((name, atts), t) =
135.425 - PureThy.add_defs false [((name, t), atts)] #-> (fn [thm] => pair (name, thm))
135.426 - | thy_def true ((name, atts), t) =
135.427 - PureThy.add_defs_unchecked false [((name, t), atts)] #-> (fn [thm] => pair (name, thm));
135.428 -
135.429 in
135.430
135.431 -val add_primrec = gen_primrec thy_note (thy_def false);
135.432 -val add_primrec_unchecked = gen_primrec thy_note (thy_def true);
135.433 -val add_primrec_i = gen_primrec_i thy_note (thy_def false);
135.434 -val add_primrec_unchecked_i = gen_primrec_i thy_note (thy_def true);
135.435 +val add_primrec = gen_primrec false Specification.check_specification (K I);
135.436 +val add_primrec_cmd = gen_primrec true Specification.read_specification Syntax.read_term;
135.437
135.438 -end; (*local*)
135.439 +end;
135.440
135.441
135.442 (* outer syntax *)
135.443 @@ -419,25 +404,26 @@
135.444 val parser2 = (invariant -- P.$$$ ":") |--
135.445 (Scan.repeat1 (unless_flag P.term) >> SOME) -- Scan.optional parser1 NONE ||
135.446 (parser1 >> pair NONE);
135.447 -val parser3 =
135.448 - unless_flag P.name -- Scan.optional parser2 (NONE, NONE) ||
135.449 - (parser2 >> pair "");
135.450 -val parser4 =
135.451 - (P.$$$ "unchecked" >> K true) -- Scan.optional parser3 ("", (NONE, NONE)) ||
135.452 - (parser3 >> pair false);
135.453 val options =
135.454 Scan.optional (P.$$$ "(" |-- P.!!!
135.455 - (parser4 --| P.$$$ ")")) (false, ("", (NONE, NONE)));
135.456 + (parser2 --| P.$$$ ")")) (NONE, NONE);
135.457
135.458 -val primrec_decl =
135.459 - options -- Scan.repeat1 (SpecParse.opt_thm_name ":" -- P.prop);
135.460 +fun pipe_error t = P.!!! (Scan.fail_with (K
135.461 + (cat_lines ["Equations must be separated by " ^ quote "|", quote t])));
135.462 +
135.463 +val statement = SpecParse.opt_thm_name ":" -- P.prop --| Scan.ahead
135.464 + ((P.term :-- pipe_error) || Scan.succeed ("",""));
135.465 +
135.466 +val statements = P.enum1 "|" statement;
135.467 +
135.468 +val primrec_decl = P.opt_target -- options --
135.469 + P.fixes -- P.for_fixes --| P.$$$ "where" -- statements;
135.470
135.471 val _ =
135.472 OuterSyntax.command "nominal_primrec" "define primitive recursive functions on nominal datatypes" K.thy_goal
135.473 - (primrec_decl >> (fn ((unchecked, (alt_name, (invs, fctxt))), eqns) =>
135.474 - Toplevel.print o Toplevel.theory_to_proof
135.475 - ((if unchecked then add_primrec_unchecked else add_primrec) alt_name invs fctxt
135.476 - (map P.triple_swap eqns))));
135.477 + (primrec_decl >> (fn ((((opt_target, (invs, fctxt)), raw_fixes), raw_params), raw_spec) =>
135.478 + Toplevel.print o Toplevel.local_theory_to_proof opt_target
135.479 + (add_primrec_cmd invs fctxt raw_fixes raw_params raw_spec)));
135.480
135.481 end;
135.482
136.1 --- a/src/HOL/PReal.thy Tue Dec 30 08:18:54 2008 +0100
136.2 +++ b/src/HOL/PReal.thy Tue Dec 30 11:10:01 2008 +0100
136.3 @@ -9,7 +9,7 @@
136.4 header {* Positive real numbers *}
136.5
136.6 theory PReal
136.7 -imports Rational "~~/src/HOL/Library/Dense_Linear_Order"
136.8 +imports Rational Dense_Linear_Order
136.9 begin
136.10
136.11 text{*Could be generalized and moved to @{text Ring_and_Field}*}
137.1 --- a/src/HOL/Real.thy Tue Dec 30 08:18:54 2008 +0100
137.2 +++ b/src/HOL/Real.thy Tue Dec 30 11:10:01 2008 +0100
137.3 @@ -1,5 +1,5 @@
137.4 theory Real
137.5 -imports "~~/src/HOL/Real/RealVector"
137.6 +imports RComplete RealVector
137.7 begin
137.8
137.9 end
138.1 --- a/src/HOL/Real/HahnBanach/Bounds.thy Tue Dec 30 08:18:54 2008 +0100
138.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
138.3 @@ -1,82 +0,0 @@
138.4 -(* Title: HOL/Real/HahnBanach/Bounds.thy
138.5 - Author: Gertrud Bauer, TU Munich
138.6 -*)
138.7 -
138.8 -header {* Bounds *}
138.9 -
138.10 -theory Bounds
138.11 -imports Main ContNotDenum
138.12 -begin
138.13 -
138.14 -locale lub =
138.15 - fixes A and x
138.16 - assumes least [intro?]: "(\<And>a. a \<in> A \<Longrightarrow> a \<le> b) \<Longrightarrow> x \<le> b"
138.17 - and upper [intro?]: "a \<in> A \<Longrightarrow> a \<le> x"
138.18 -
138.19 -lemmas [elim?] = lub.least lub.upper
138.20 -
138.21 -definition
138.22 - the_lub :: "'a::order set \<Rightarrow> 'a" where
138.23 - "the_lub A = The (lub A)"
138.24 -
138.25 -notation (xsymbols)
138.26 - the_lub ("\<Squnion>_" [90] 90)
138.27 -
138.28 -lemma the_lub_equality [elim?]:
138.29 - assumes "lub A x"
138.30 - shows "\<Squnion>A = (x::'a::order)"
138.31 -proof -
138.32 - interpret lub A x by fact
138.33 - show ?thesis
138.34 - proof (unfold the_lub_def)
138.35 - from `lub A x` show "The (lub A) = x"
138.36 - proof
138.37 - fix x' assume lub': "lub A x'"
138.38 - show "x' = x"
138.39 - proof (rule order_antisym)
138.40 - from lub' show "x' \<le> x"
138.41 - proof
138.42 - fix a assume "a \<in> A"
138.43 - then show "a \<le> x" ..
138.44 - qed
138.45 - show "x \<le> x'"
138.46 - proof
138.47 - fix a assume "a \<in> A"
138.48 - with lub' show "a \<le> x'" ..
138.49 - qed
138.50 - qed
138.51 - qed
138.52 - qed
138.53 -qed
138.54 -
138.55 -lemma the_lubI_ex:
138.56 - assumes ex: "\<exists>x. lub A x"
138.57 - shows "lub A (\<Squnion>A)"
138.58 -proof -
138.59 - from ex obtain x where x: "lub A x" ..
138.60 - also from x have [symmetric]: "\<Squnion>A = x" ..
138.61 - finally show ?thesis .
138.62 -qed
138.63 -
138.64 -lemma lub_compat: "lub A x = isLub UNIV A x"
138.65 -proof -
138.66 - have "isUb UNIV A = (\<lambda>x. A *<= x \<and> x \<in> UNIV)"
138.67 - by (rule ext) (simp only: isUb_def)
138.68 - then show ?thesis
138.69 - by (simp only: lub_def isLub_def leastP_def setge_def setle_def) blast
138.70 -qed
138.71 -
138.72 -lemma real_complete:
138.73 - fixes A :: "real set"
138.74 - assumes nonempty: "\<exists>a. a \<in> A"
138.75 - and ex_upper: "\<exists>y. \<forall>a \<in> A. a \<le> y"
138.76 - shows "\<exists>x. lub A x"
138.77 -proof -
138.78 - from ex_upper have "\<exists>y. isUb UNIV A y"
138.79 - unfolding isUb_def setle_def by blast
138.80 - with nonempty have "\<exists>x. isLub UNIV A x"
138.81 - by (rule reals_complete)
138.82 - then show ?thesis by (simp only: lub_compat)
138.83 -qed
138.84 -
138.85 -end
139.1 --- a/src/HOL/Real/HahnBanach/FunctionNorm.thy Tue Dec 30 08:18:54 2008 +0100
139.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
139.3 @@ -1,278 +0,0 @@
139.4 -(* Title: HOL/Real/HahnBanach/FunctionNorm.thy
139.5 - Author: Gertrud Bauer, TU Munich
139.6 -*)
139.7 -
139.8 -header {* The norm of a function *}
139.9 -
139.10 -theory FunctionNorm
139.11 -imports NormedSpace FunctionOrder
139.12 -begin
139.13 -
139.14 -subsection {* Continuous linear forms*}
139.15 -
139.16 -text {*
139.17 - A linear form @{text f} on a normed vector space @{text "(V, \<parallel>\<cdot>\<parallel>)"}
139.18 - is \emph{continuous}, iff it is bounded, i.e.
139.19 - \begin{center}
139.20 - @{text "\<exists>c \<in> R. \<forall>x \<in> V. \<bar>f x\<bar> \<le> c \<cdot> \<parallel>x\<parallel>"}
139.21 - \end{center}
139.22 - In our application no other functions than linear forms are
139.23 - considered, so we can define continuous linear forms as bounded
139.24 - linear forms:
139.25 -*}
139.26 -
139.27 -locale continuous = var_V + norm_syntax + linearform +
139.28 - assumes bounded: "\<exists>c. \<forall>x \<in> V. \<bar>f x\<bar> \<le> c * \<parallel>x\<parallel>"
139.29 -
139.30 -declare continuous.intro [intro?] continuous_axioms.intro [intro?]
139.31 -
139.32 -lemma continuousI [intro]:
139.33 - fixes norm :: "_ \<Rightarrow> real" ("\<parallel>_\<parallel>")
139.34 - assumes "linearform V f"
139.35 - assumes r: "\<And>x. x \<in> V \<Longrightarrow> \<bar>f x\<bar> \<le> c * \<parallel>x\<parallel>"
139.36 - shows "continuous V norm f"
139.37 -proof
139.38 - show "linearform V f" by fact
139.39 - from r have "\<exists>c. \<forall>x\<in>V. \<bar>f x\<bar> \<le> c * \<parallel>x\<parallel>" by blast
139.40 - then show "continuous_axioms V norm f" ..
139.41 -qed
139.42 -
139.43 -
139.44 -subsection {* The norm of a linear form *}
139.45 -
139.46 -text {*
139.47 - The least real number @{text c} for which holds
139.48 - \begin{center}
139.49 - @{text "\<forall>x \<in> V. \<bar>f x\<bar> \<le> c \<cdot> \<parallel>x\<parallel>"}
139.50 - \end{center}
139.51 - is called the \emph{norm} of @{text f}.
139.52 -
139.53 - For non-trivial vector spaces @{text "V \<noteq> {0}"} the norm can be
139.54 - defined as
139.55 - \begin{center}
139.56 - @{text "\<parallel>f\<parallel> = \<sup>x \<noteq> 0. \<bar>f x\<bar> / \<parallel>x\<parallel>"}
139.57 - \end{center}
139.58 -
139.59 - For the case @{text "V = {0}"} the supremum would be taken from an
139.60 - empty set. Since @{text \<real>} is unbounded, there would be no supremum.
139.61 - To avoid this situation it must be guaranteed that there is an
139.62 - element in this set. This element must be @{text "{} \<ge> 0"} so that
139.63 - @{text fn_norm} has the norm properties. Furthermore it does not
139.64 - have to change the norm in all other cases, so it must be @{text 0},
139.65 - as all other elements are @{text "{} \<ge> 0"}.
139.66 -
139.67 - Thus we define the set @{text B} where the supremum is taken from as
139.68 - follows:
139.69 - \begin{center}
139.70 - @{text "{0} \<union> {\<bar>f x\<bar> / \<parallel>x\<parallel>. x \<noteq> 0 \<and> x \<in> F}"}
139.71 - \end{center}
139.72 -
139.73 - @{text fn_norm} is equal to the supremum of @{text B}, if the
139.74 - supremum exists (otherwise it is undefined).
139.75 -*}
139.76 -
139.77 -locale fn_norm = norm_syntax +
139.78 - fixes B defines "B V f \<equiv> {0} \<union> {\<bar>f x\<bar> / \<parallel>x\<parallel> | x. x \<noteq> 0 \<and> x \<in> V}"
139.79 - fixes fn_norm ("\<parallel>_\<parallel>\<hyphen>_" [0, 1000] 999)
139.80 - defines "\<parallel>f\<parallel>\<hyphen>V \<equiv> \<Squnion>(B V f)"
139.81 -
139.82 -locale normed_vectorspace_with_fn_norm = normed_vectorspace + fn_norm
139.83 -
139.84 -lemma (in fn_norm) B_not_empty [intro]: "0 \<in> B V f"
139.85 - by (simp add: B_def)
139.86 -
139.87 -text {*
139.88 - The following lemma states that every continuous linear form on a
139.89 - normed space @{text "(V, \<parallel>\<cdot>\<parallel>)"} has a function norm.
139.90 -*}
139.91 -
139.92 -lemma (in normed_vectorspace_with_fn_norm) fn_norm_works:
139.93 - assumes "continuous V norm f"
139.94 - shows "lub (B V f) (\<parallel>f\<parallel>\<hyphen>V)"
139.95 -proof -
139.96 - interpret continuous V norm f by fact
139.97 - txt {* The existence of the supremum is shown using the
139.98 - completeness of the reals. Completeness means, that every
139.99 - non-empty bounded set of reals has a supremum. *}
139.100 - have "\<exists>a. lub (B V f) a"
139.101 - proof (rule real_complete)
139.102 - txt {* First we have to show that @{text B} is non-empty: *}
139.103 - have "0 \<in> B V f" ..
139.104 - then show "\<exists>x. x \<in> B V f" ..
139.105 -
139.106 - txt {* Then we have to show that @{text B} is bounded: *}
139.107 - show "\<exists>c. \<forall>y \<in> B V f. y \<le> c"
139.108 - proof -
139.109 - txt {* We know that @{text f} is bounded by some value @{text c}. *}
139.110 - from bounded obtain c where c: "\<forall>x \<in> V. \<bar>f x\<bar> \<le> c * \<parallel>x\<parallel>" ..
139.111 -
139.112 - txt {* To prove the thesis, we have to show that there is some
139.113 - @{text b}, such that @{text "y \<le> b"} for all @{text "y \<in>
139.114 - B"}. Due to the definition of @{text B} there are two cases. *}
139.115 -
139.116 - def b \<equiv> "max c 0"
139.117 - have "\<forall>y \<in> B V f. y \<le> b"
139.118 - proof
139.119 - fix y assume y: "y \<in> B V f"
139.120 - show "y \<le> b"
139.121 - proof cases
139.122 - assume "y = 0"
139.123 - then show ?thesis unfolding b_def by arith
139.124 - next
139.125 - txt {* The second case is @{text "y = \<bar>f x\<bar> / \<parallel>x\<parallel>"} for some
139.126 - @{text "x \<in> V"} with @{text "x \<noteq> 0"}. *}
139.127 - assume "y \<noteq> 0"
139.128 - with y obtain x where y_rep: "y = \<bar>f x\<bar> * inverse \<parallel>x\<parallel>"
139.129 - and x: "x \<in> V" and neq: "x \<noteq> 0"
139.130 - by (auto simp add: B_def real_divide_def)
139.131 - from x neq have gt: "0 < \<parallel>x\<parallel>" ..
139.132 -
139.133 - txt {* The thesis follows by a short calculation using the
139.134 - fact that @{text f} is bounded. *}
139.135 -
139.136 - note y_rep
139.137 - also have "\<bar>f x\<bar> * inverse \<parallel>x\<parallel> \<le> (c * \<parallel>x\<parallel>) * inverse \<parallel>x\<parallel>"
139.138 - proof (rule mult_right_mono)
139.139 - from c x show "\<bar>f x\<bar> \<le> c * \<parallel>x\<parallel>" ..
139.140 - from gt have "0 < inverse \<parallel>x\<parallel>"
139.141 - by (rule positive_imp_inverse_positive)
139.142 - then show "0 \<le> inverse \<parallel>x\<parallel>" by (rule order_less_imp_le)
139.143 - qed
139.144 - also have "\<dots> = c * (\<parallel>x\<parallel> * inverse \<parallel>x\<parallel>)"
139.145 - by (rule real_mult_assoc)
139.146 - also
139.147 - from gt have "\<parallel>x\<parallel> \<noteq> 0" by simp
139.148 - then have "\<parallel>x\<parallel> * inverse \<parallel>x\<parallel> = 1" by simp
139.149 - also have "c * 1 \<le> b" by (simp add: b_def le_maxI1)
139.150 - finally show "y \<le> b" .
139.151 - qed
139.152 - qed
139.153 - then show ?thesis ..
139.154 - qed
139.155 - qed
139.156 - then show ?thesis unfolding fn_norm_def by (rule the_lubI_ex)
139.157 -qed
139.158 -
139.159 -lemma (in normed_vectorspace_with_fn_norm) fn_norm_ub [iff?]:
139.160 - assumes "continuous V norm f"
139.161 - assumes b: "b \<in> B V f"
139.162 - shows "b \<le> \<parallel>f\<parallel>\<hyphen>V"
139.163 -proof -
139.164 - interpret continuous V norm f by fact
139.165 - have "lub (B V f) (\<parallel>f\<parallel>\<hyphen>V)"
139.166 - using `continuous V norm f` by (rule fn_norm_works)
139.167 - from this and b show ?thesis ..
139.168 -qed
139.169 -
139.170 -lemma (in normed_vectorspace_with_fn_norm) fn_norm_leastB:
139.171 - assumes "continuous V norm f"
139.172 - assumes b: "\<And>b. b \<in> B V f \<Longrightarrow> b \<le> y"
139.173 - shows "\<parallel>f\<parallel>\<hyphen>V \<le> y"
139.174 -proof -
139.175 - interpret continuous V norm f by fact
139.176 - have "lub (B V f) (\<parallel>f\<parallel>\<hyphen>V)"
139.177 - using `continuous V norm f` by (rule fn_norm_works)
139.178 - from this and b show ?thesis ..
139.179 -qed
139.180 -
139.181 -text {* The norm of a continuous function is always @{text "\<ge> 0"}. *}
139.182 -
139.183 -lemma (in normed_vectorspace_with_fn_norm) fn_norm_ge_zero [iff]:
139.184 - assumes "continuous V norm f"
139.185 - shows "0 \<le> \<parallel>f\<parallel>\<hyphen>V"
139.186 -proof -
139.187 - interpret continuous V norm f by fact
139.188 - txt {* The function norm is defined as the supremum of @{text B}.
139.189 - So it is @{text "\<ge> 0"} if all elements in @{text B} are @{text "\<ge>
139.190 - 0"}, provided the supremum exists and @{text B} is not empty. *}
139.191 - have "lub (B V f) (\<parallel>f\<parallel>\<hyphen>V)"
139.192 - using `continuous V norm f` by (rule fn_norm_works)
139.193 - moreover have "0 \<in> B V f" ..
139.194 - ultimately show ?thesis ..
139.195 -qed
139.196 -
139.197 -text {*
139.198 - \medskip The fundamental property of function norms is:
139.199 - \begin{center}
139.200 - @{text "\<bar>f x\<bar> \<le> \<parallel>f\<parallel> \<cdot> \<parallel>x\<parallel>"}
139.201 - \end{center}
139.202 -*}
139.203 -
139.204 -lemma (in normed_vectorspace_with_fn_norm) fn_norm_le_cong:
139.205 - assumes "continuous V norm f" "linearform V f"
139.206 - assumes x: "x \<in> V"
139.207 - shows "\<bar>f x\<bar> \<le> \<parallel>f\<parallel>\<hyphen>V * \<parallel>x\<parallel>"
139.208 -proof -
139.209 - interpret continuous V norm f by fact
139.210 - interpret linearform V f .
139.211 - show ?thesis
139.212 - proof cases
139.213 - assume "x = 0"
139.214 - then have "\<bar>f x\<bar> = \<bar>f 0\<bar>" by simp
139.215 - also have "f 0 = 0" by rule unfold_locales
139.216 - also have "\<bar>\<dots>\<bar> = 0" by simp
139.217 - also have a: "0 \<le> \<parallel>f\<parallel>\<hyphen>V"
139.218 - using `continuous V norm f` by (rule fn_norm_ge_zero)
139.219 - from x have "0 \<le> norm x" ..
139.220 - with a have "0 \<le> \<parallel>f\<parallel>\<hyphen>V * \<parallel>x\<parallel>" by (simp add: zero_le_mult_iff)
139.221 - finally show "\<bar>f x\<bar> \<le> \<parallel>f\<parallel>\<hyphen>V * \<parallel>x\<parallel>" .
139.222 - next
139.223 - assume "x \<noteq> 0"
139.224 - with x have neq: "\<parallel>x\<parallel> \<noteq> 0" by simp
139.225 - then have "\<bar>f x\<bar> = (\<bar>f x\<bar> * inverse \<parallel>x\<parallel>) * \<parallel>x\<parallel>" by simp
139.226 - also have "\<dots> \<le> \<parallel>f\<parallel>\<hyphen>V * \<parallel>x\<parallel>"
139.227 - proof (rule mult_right_mono)
139.228 - from x show "0 \<le> \<parallel>x\<parallel>" ..
139.229 - from x and neq have "\<bar>f x\<bar> * inverse \<parallel>x\<parallel> \<in> B V f"
139.230 - by (auto simp add: B_def real_divide_def)
139.231 - with `continuous V norm f` show "\<bar>f x\<bar> * inverse \<parallel>x\<parallel> \<le> \<parallel>f\<parallel>\<hyphen>V"
139.232 - by (rule fn_norm_ub)
139.233 - qed
139.234 - finally show ?thesis .
139.235 - qed
139.236 -qed
139.237 -
139.238 -text {*
139.239 - \medskip The function norm is the least positive real number for
139.240 - which the following inequation holds:
139.241 - \begin{center}
139.242 - @{text "\<bar>f x\<bar> \<le> c \<cdot> \<parallel>x\<parallel>"}
139.243 - \end{center}
139.244 -*}
139.245 -
139.246 -lemma (in normed_vectorspace_with_fn_norm) fn_norm_least [intro?]:
139.247 - assumes "continuous V norm f"
139.248 - assumes ineq: "\<forall>x \<in> V. \<bar>f x\<bar> \<le> c * \<parallel>x\<parallel>" and ge: "0 \<le> c"
139.249 - shows "\<parallel>f\<parallel>\<hyphen>V \<le> c"
139.250 -proof -
139.251 - interpret continuous V norm f by fact
139.252 - show ?thesis
139.253 - proof (rule fn_norm_leastB [folded B_def fn_norm_def])
139.254 - fix b assume b: "b \<in> B V f"
139.255 - show "b \<le> c"
139.256 - proof cases
139.257 - assume "b = 0"
139.258 - with ge show ?thesis by simp
139.259 - next
139.260 - assume "b \<noteq> 0"
139.261 - with b obtain x where b_rep: "b = \<bar>f x\<bar> * inverse \<parallel>x\<parallel>"
139.262 - and x_neq: "x \<noteq> 0" and x: "x \<in> V"
139.263 - by (auto simp add: B_def real_divide_def)
139.264 - note b_rep
139.265 - also have "\<bar>f x\<bar> * inverse \<parallel>x\<parallel> \<le> (c * \<parallel>x\<parallel>) * inverse \<parallel>x\<parallel>"
139.266 - proof (rule mult_right_mono)
139.267 - have "0 < \<parallel>x\<parallel>" using x x_neq ..
139.268 - then show "0 \<le> inverse \<parallel>x\<parallel>" by simp
139.269 - from ineq and x show "\<bar>f x\<bar> \<le> c * \<parallel>x\<parallel>" ..
139.270 - qed
139.271 - also have "\<dots> = c"
139.272 - proof -
139.273 - from x_neq and x have "\<parallel>x\<parallel> \<noteq> 0" by simp
139.274 - then show ?thesis by simp
139.275 - qed
139.276 - finally show ?thesis .
139.277 - qed
139.278 - qed (insert `continuous V norm f`, simp_all add: continuous_def)
139.279 -qed
139.280 -
139.281 -end
140.1 --- a/src/HOL/Real/HahnBanach/FunctionOrder.thy Tue Dec 30 08:18:54 2008 +0100
140.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
140.3 @@ -1,142 +0,0 @@
140.4 -(* Title: HOL/Real/HahnBanach/FunctionOrder.thy
140.5 - ID: $Id$
140.6 - Author: Gertrud Bauer, TU Munich
140.7 -*)
140.8 -
140.9 -header {* An order on functions *}
140.10 -
140.11 -theory FunctionOrder
140.12 -imports Subspace Linearform
140.13 -begin
140.14 -
140.15 -subsection {* The graph of a function *}
140.16 -
140.17 -text {*
140.18 - We define the \emph{graph} of a (real) function @{text f} with
140.19 - domain @{text F} as the set
140.20 - \begin{center}
140.21 - @{text "{(x, f x). x \<in> F}"}
140.22 - \end{center}
140.23 - So we are modeling partial functions by specifying the domain and
140.24 - the mapping function. We use the term ``function'' also for its
140.25 - graph.
140.26 -*}
140.27 -
140.28 -types 'a graph = "('a \<times> real) set"
140.29 -
140.30 -definition
140.31 - graph :: "'a set \<Rightarrow> ('a \<Rightarrow> real) \<Rightarrow> 'a graph" where
140.32 - "graph F f = {(x, f x) | x. x \<in> F}"
140.33 -
140.34 -lemma graphI [intro]: "x \<in> F \<Longrightarrow> (x, f x) \<in> graph F f"
140.35 - unfolding graph_def by blast
140.36 -
140.37 -lemma graphI2 [intro?]: "x \<in> F \<Longrightarrow> \<exists>t \<in> graph F f. t = (x, f x)"
140.38 - unfolding graph_def by blast
140.39 -
140.40 -lemma graphE [elim?]:
140.41 - "(x, y) \<in> graph F f \<Longrightarrow> (x \<in> F \<Longrightarrow> y = f x \<Longrightarrow> C) \<Longrightarrow> C"
140.42 - unfolding graph_def by blast
140.43 -
140.44 -
140.45 -subsection {* Functions ordered by domain extension *}
140.46 -
140.47 -text {*
140.48 - A function @{text h'} is an extension of @{text h}, iff the graph of
140.49 - @{text h} is a subset of the graph of @{text h'}.
140.50 -*}
140.51 -
140.52 -lemma graph_extI:
140.53 - "(\<And>x. x \<in> H \<Longrightarrow> h x = h' x) \<Longrightarrow> H \<subseteq> H'
140.54 - \<Longrightarrow> graph H h \<subseteq> graph H' h'"
140.55 - unfolding graph_def by blast
140.56 -
140.57 -lemma graph_extD1 [dest?]:
140.58 - "graph H h \<subseteq> graph H' h' \<Longrightarrow> x \<in> H \<Longrightarrow> h x = h' x"
140.59 - unfolding graph_def by blast
140.60 -
140.61 -lemma graph_extD2 [dest?]:
140.62 - "graph H h \<subseteq> graph H' h' \<Longrightarrow> H \<subseteq> H'"
140.63 - unfolding graph_def by blast
140.64 -
140.65 -
140.66 -subsection {* Domain and function of a graph *}
140.67 -
140.68 -text {*
140.69 - The inverse functions to @{text graph} are @{text domain} and @{text
140.70 - funct}.
140.71 -*}
140.72 -
140.73 -definition
140.74 - "domain" :: "'a graph \<Rightarrow> 'a set" where
140.75 - "domain g = {x. \<exists>y. (x, y) \<in> g}"
140.76 -
140.77 -definition
140.78 - funct :: "'a graph \<Rightarrow> ('a \<Rightarrow> real)" where
140.79 - "funct g = (\<lambda>x. (SOME y. (x, y) \<in> g))"
140.80 -
140.81 -text {*
140.82 - The following lemma states that @{text g} is the graph of a function
140.83 - if the relation induced by @{text g} is unique.
140.84 -*}
140.85 -
140.86 -lemma graph_domain_funct:
140.87 - assumes uniq: "\<And>x y z. (x, y) \<in> g \<Longrightarrow> (x, z) \<in> g \<Longrightarrow> z = y"
140.88 - shows "graph (domain g) (funct g) = g"
140.89 - unfolding domain_def funct_def graph_def
140.90 -proof auto (* FIXME !? *)
140.91 - fix a b assume g: "(a, b) \<in> g"
140.92 - from g show "(a, SOME y. (a, y) \<in> g) \<in> g" by (rule someI2)
140.93 - from g show "\<exists>y. (a, y) \<in> g" ..
140.94 - from g show "b = (SOME y. (a, y) \<in> g)"
140.95 - proof (rule some_equality [symmetric])
140.96 - fix y assume "(a, y) \<in> g"
140.97 - with g show "y = b" by (rule uniq)
140.98 - qed
140.99 -qed
140.100 -
140.101 -
140.102 -subsection {* Norm-preserving extensions of a function *}
140.103 -
140.104 -text {*
140.105 - Given a linear form @{text f} on the space @{text F} and a seminorm
140.106 - @{text p} on @{text E}. The set of all linear extensions of @{text
140.107 - f}, to superspaces @{text H} of @{text F}, which are bounded by
140.108 - @{text p}, is defined as follows.
140.109 -*}
140.110 -
140.111 -definition
140.112 - norm_pres_extensions ::
140.113 - "'a::{plus, minus, uminus, zero} set \<Rightarrow> ('a \<Rightarrow> real) \<Rightarrow> 'a set \<Rightarrow> ('a \<Rightarrow> real)
140.114 - \<Rightarrow> 'a graph set" where
140.115 - "norm_pres_extensions E p F f
140.116 - = {g. \<exists>H h. g = graph H h
140.117 - \<and> linearform H h
140.118 - \<and> H \<unlhd> E
140.119 - \<and> F \<unlhd> H
140.120 - \<and> graph F f \<subseteq> graph H h
140.121 - \<and> (\<forall>x \<in> H. h x \<le> p x)}"
140.122 -
140.123 -lemma norm_pres_extensionE [elim]:
140.124 - "g \<in> norm_pres_extensions E p F f
140.125 - \<Longrightarrow> (\<And>H h. g = graph H h \<Longrightarrow> linearform H h
140.126 - \<Longrightarrow> H \<unlhd> E \<Longrightarrow> F \<unlhd> H \<Longrightarrow> graph F f \<subseteq> graph H h
140.127 - \<Longrightarrow> \<forall>x \<in> H. h x \<le> p x \<Longrightarrow> C) \<Longrightarrow> C"
140.128 - unfolding norm_pres_extensions_def by blast
140.129 -
140.130 -lemma norm_pres_extensionI2 [intro]:
140.131 - "linearform H h \<Longrightarrow> H \<unlhd> E \<Longrightarrow> F \<unlhd> H
140.132 - \<Longrightarrow> graph F f \<subseteq> graph H h \<Longrightarrow> \<forall>x \<in> H. h x \<le> p x
140.133 - \<Longrightarrow> graph H h \<in> norm_pres_extensions E p F f"
140.134 - unfolding norm_pres_extensions_def by blast
140.135 -
140.136 -lemma norm_pres_extensionI: (* FIXME ? *)
140.137 - "\<exists>H h. g = graph H h
140.138 - \<and> linearform H h
140.139 - \<and> H \<unlhd> E
140.140 - \<and> F \<unlhd> H
140.141 - \<and> graph F f \<subseteq> graph H h
140.142 - \<and> (\<forall>x \<in> H. h x \<le> p x) \<Longrightarrow> g \<in> norm_pres_extensions E p F f"
140.143 - unfolding norm_pres_extensions_def by blast
140.144 -
140.145 -end
141.1 --- a/src/HOL/Real/HahnBanach/HahnBanach.thy Tue Dec 30 08:18:54 2008 +0100
141.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
141.3 @@ -1,509 +0,0 @@
141.4 -(* Title: HOL/Real/HahnBanach/HahnBanach.thy
141.5 - Author: Gertrud Bauer, TU Munich
141.6 -*)
141.7 -
141.8 -header {* The Hahn-Banach Theorem *}
141.9 -
141.10 -theory HahnBanach
141.11 -imports HahnBanachLemmas
141.12 -begin
141.13 -
141.14 -text {*
141.15 - We present the proof of two different versions of the Hahn-Banach
141.16 - Theorem, closely following \cite[\S36]{Heuser:1986}.
141.17 -*}
141.18 -
141.19 -subsection {* The Hahn-Banach Theorem for vector spaces *}
141.20 -
141.21 -text {*
141.22 - \textbf{Hahn-Banach Theorem.} Let @{text F} be a subspace of a real
141.23 - vector space @{text E}, let @{text p} be a semi-norm on @{text E},
141.24 - and @{text f} be a linear form defined on @{text F} such that @{text
141.25 - f} is bounded by @{text p}, i.e. @{text "\<forall>x \<in> F. f x \<le> p x"}. Then
141.26 - @{text f} can be extended to a linear form @{text h} on @{text E}
141.27 - such that @{text h} is norm-preserving, i.e. @{text h} is also
141.28 - bounded by @{text p}.
141.29 -
141.30 - \bigskip
141.31 - \textbf{Proof Sketch.}
141.32 - \begin{enumerate}
141.33 -
141.34 - \item Define @{text M} as the set of norm-preserving extensions of
141.35 - @{text f} to subspaces of @{text E}. The linear forms in @{text M}
141.36 - are ordered by domain extension.
141.37 -
141.38 - \item We show that every non-empty chain in @{text M} has an upper
141.39 - bound in @{text M}.
141.40 -
141.41 - \item With Zorn's Lemma we conclude that there is a maximal function
141.42 - @{text g} in @{text M}.
141.43 -
141.44 - \item The domain @{text H} of @{text g} is the whole space @{text
141.45 - E}, as shown by classical contradiction:
141.46 -
141.47 - \begin{itemize}
141.48 -
141.49 - \item Assuming @{text g} is not defined on whole @{text E}, it can
141.50 - still be extended in a norm-preserving way to a super-space @{text
141.51 - H'} of @{text H}.
141.52 -
141.53 - \item Thus @{text g} can not be maximal. Contradiction!
141.54 -
141.55 - \end{itemize}
141.56 - \end{enumerate}
141.57 -*}
141.58 -
141.59 -theorem HahnBanach:
141.60 - assumes E: "vectorspace E" and "subspace F E"
141.61 - and "seminorm E p" and "linearform F f"
141.62 - assumes fp: "\<forall>x \<in> F. f x \<le> p x"
141.63 - shows "\<exists>h. linearform E h \<and> (\<forall>x \<in> F. h x = f x) \<and> (\<forall>x \<in> E. h x \<le> p x)"
141.64 - -- {* Let @{text E} be a vector space, @{text F} a subspace of @{text E}, @{text p} a seminorm on @{text E}, *}
141.65 - -- {* and @{text f} a linear form on @{text F} such that @{text f} is bounded by @{text p}, *}
141.66 - -- {* then @{text f} can be extended to a linear form @{text h} on @{text E} in a norm-preserving way. \skp *}
141.67 -proof -
141.68 - interpret vectorspace E by fact
141.69 - interpret subspace F E by fact
141.70 - interpret seminorm E p by fact
141.71 - interpret linearform F f by fact
141.72 - def M \<equiv> "norm_pres_extensions E p F f"
141.73 - then have M: "M = \<dots>" by (simp only:)
141.74 - from E have F: "vectorspace F" ..
141.75 - note FE = `F \<unlhd> E`
141.76 - {
141.77 - fix c assume cM: "c \<in> chain M" and ex: "\<exists>x. x \<in> c"
141.78 - have "\<Union>c \<in> M"
141.79 - -- {* Show that every non-empty chain @{text c} of @{text M} has an upper bound in @{text M}: *}
141.80 - -- {* @{text "\<Union>c"} is greater than any element of the chain @{text c}, so it suffices to show @{text "\<Union>c \<in> M"}. *}
141.81 - unfolding M_def
141.82 - proof (rule norm_pres_extensionI)
141.83 - let ?H = "domain (\<Union>c)"
141.84 - let ?h = "funct (\<Union>c)"
141.85 -
141.86 - have a: "graph ?H ?h = \<Union>c"
141.87 - proof (rule graph_domain_funct)
141.88 - fix x y z assume "(x, y) \<in> \<Union>c" and "(x, z) \<in> \<Union>c"
141.89 - with M_def cM show "z = y" by (rule sup_definite)
141.90 - qed
141.91 - moreover from M cM a have "linearform ?H ?h"
141.92 - by (rule sup_lf)
141.93 - moreover from a M cM ex FE E have "?H \<unlhd> E"
141.94 - by (rule sup_subE)
141.95 - moreover from a M cM ex FE have "F \<unlhd> ?H"
141.96 - by (rule sup_supF)
141.97 - moreover from a M cM ex have "graph F f \<subseteq> graph ?H ?h"
141.98 - by (rule sup_ext)
141.99 - moreover from a M cM have "\<forall>x \<in> ?H. ?h x \<le> p x"
141.100 - by (rule sup_norm_pres)
141.101 - ultimately show "\<exists>H h. \<Union>c = graph H h
141.102 - \<and> linearform H h
141.103 - \<and> H \<unlhd> E
141.104 - \<and> F \<unlhd> H
141.105 - \<and> graph F f \<subseteq> graph H h
141.106 - \<and> (\<forall>x \<in> H. h x \<le> p x)" by blast
141.107 - qed
141.108 - }
141.109 - then have "\<exists>g \<in> M. \<forall>x \<in> M. g \<subseteq> x \<longrightarrow> g = x"
141.110 - -- {* With Zorn's Lemma we can conclude that there is a maximal element in @{text M}. \skp *}
141.111 - proof (rule Zorn's_Lemma)
141.112 - -- {* We show that @{text M} is non-empty: *}
141.113 - show "graph F f \<in> M"
141.114 - unfolding M_def
141.115 - proof (rule norm_pres_extensionI2)
141.116 - show "linearform F f" by fact
141.117 - show "F \<unlhd> E" by fact
141.118 - from F show "F \<unlhd> F" by (rule vectorspace.subspace_refl)
141.119 - show "graph F f \<subseteq> graph F f" ..
141.120 - show "\<forall>x\<in>F. f x \<le> p x" by fact
141.121 - qed
141.122 - qed
141.123 - then obtain g where gM: "g \<in> M" and gx: "\<forall>x \<in> M. g \<subseteq> x \<longrightarrow> g = x"
141.124 - by blast
141.125 - from gM obtain H h where
141.126 - g_rep: "g = graph H h"
141.127 - and linearform: "linearform H h"
141.128 - and HE: "H \<unlhd> E" and FH: "F \<unlhd> H"
141.129 - and graphs: "graph F f \<subseteq> graph H h"
141.130 - and hp: "\<forall>x \<in> H. h x \<le> p x" unfolding M_def ..
141.131 - -- {* @{text g} is a norm-preserving extension of @{text f}, in other words: *}
141.132 - -- {* @{text g} is the graph of some linear form @{text h} defined on a subspace @{text H} of @{text E}, *}
141.133 - -- {* and @{text h} is an extension of @{text f} that is again bounded by @{text p}. \skp *}
141.134 - from HE E have H: "vectorspace H"
141.135 - by (rule subspace.vectorspace)
141.136 -
141.137 - have HE_eq: "H = E"
141.138 - -- {* We show that @{text h} is defined on whole @{text E} by classical contradiction. \skp *}
141.139 - proof (rule classical)
141.140 - assume neq: "H \<noteq> E"
141.141 - -- {* Assume @{text h} is not defined on whole @{text E}. Then show that @{text h} can be extended *}
141.142 - -- {* in a norm-preserving way to a function @{text h'} with the graph @{text g'}. \skp *}
141.143 - have "\<exists>g' \<in> M. g \<subseteq> g' \<and> g \<noteq> g'"
141.144 - proof -
141.145 - from HE have "H \<subseteq> E" ..
141.146 - with neq obtain x' where x'E: "x' \<in> E" and "x' \<notin> H" by blast
141.147 - obtain x': "x' \<noteq> 0"
141.148 - proof
141.149 - show "x' \<noteq> 0"
141.150 - proof
141.151 - assume "x' = 0"
141.152 - with H have "x' \<in> H" by (simp only: vectorspace.zero)
141.153 - with `x' \<notin> H` show False by contradiction
141.154 - qed
141.155 - qed
141.156 -
141.157 - def H' \<equiv> "H + lin x'"
141.158 - -- {* Define @{text H'} as the direct sum of @{text H} and the linear closure of @{text x'}. \skp *}
141.159 - have HH': "H \<unlhd> H'"
141.160 - proof (unfold H'_def)
141.161 - from x'E have "vectorspace (lin x')" ..
141.162 - with H show "H \<unlhd> H + lin x'" ..
141.163 - qed
141.164 -
141.165 - obtain xi where
141.166 - xi: "\<forall>y \<in> H. - p (y + x') - h y \<le> xi
141.167 - \<and> xi \<le> p (y + x') - h y"
141.168 - -- {* Pick a real number @{text \<xi>} that fulfills certain inequations; this will *}
141.169 - -- {* be used to establish that @{text h'} is a norm-preserving extension of @{text h}.
141.170 - \label{ex-xi-use}\skp *}
141.171 - proof -
141.172 - from H have "\<exists>xi. \<forall>y \<in> H. - p (y + x') - h y \<le> xi
141.173 - \<and> xi \<le> p (y + x') - h y"
141.174 - proof (rule ex_xi)
141.175 - fix u v assume u: "u \<in> H" and v: "v \<in> H"
141.176 - with HE have uE: "u \<in> E" and vE: "v \<in> E" by auto
141.177 - from H u v linearform have "h v - h u = h (v - u)"
141.178 - by (simp add: linearform.diff)
141.179 - also from hp and H u v have "\<dots> \<le> p (v - u)"
141.180 - by (simp only: vectorspace.diff_closed)
141.181 - also from x'E uE vE have "v - u = x' + - x' + v + - u"
141.182 - by (simp add: diff_eq1)
141.183 - also from x'E uE vE have "\<dots> = v + x' + - (u + x')"
141.184 - by (simp add: add_ac)
141.185 - also from x'E uE vE have "\<dots> = (v + x') - (u + x')"
141.186 - by (simp add: diff_eq1)
141.187 - also from x'E uE vE E have "p \<dots> \<le> p (v + x') + p (u + x')"
141.188 - by (simp add: diff_subadditive)
141.189 - finally have "h v - h u \<le> p (v + x') + p (u + x')" .
141.190 - then show "- p (u + x') - h u \<le> p (v + x') - h v" by simp
141.191 - qed
141.192 - then show thesis by (blast intro: that)
141.193 - qed
141.194 -
141.195 - def h' \<equiv> "\<lambda>x. let (y, a) =
141.196 - SOME (y, a). x = y + a \<cdot> x' \<and> y \<in> H in h y + a * xi"
141.197 - -- {* Define the extension @{text h'} of @{text h} to @{text H'} using @{text \<xi>}. \skp *}
141.198 -
141.199 - have "g \<subseteq> graph H' h' \<and> g \<noteq> graph H' h'"
141.200 - -- {* @{text h'} is an extension of @{text h} \dots \skp *}
141.201 - proof
141.202 - show "g \<subseteq> graph H' h'"
141.203 - proof -
141.204 - have "graph H h \<subseteq> graph H' h'"
141.205 - proof (rule graph_extI)
141.206 - fix t assume t: "t \<in> H"
141.207 - from E HE t have "(SOME (y, a). t = y + a \<cdot> x' \<and> y \<in> H) = (t, 0)"
141.208 - using `x' \<notin> H` `x' \<in> E` `x' \<noteq> 0` by (rule decomp_H'_H)
141.209 - with h'_def show "h t = h' t" by (simp add: Let_def)
141.210 - next
141.211 - from HH' show "H \<subseteq> H'" ..
141.212 - qed
141.213 - with g_rep show ?thesis by (simp only:)
141.214 - qed
141.215 -
141.216 - show "g \<noteq> graph H' h'"
141.217 - proof -
141.218 - have "graph H h \<noteq> graph H' h'"
141.219 - proof
141.220 - assume eq: "graph H h = graph H' h'"
141.221 - have "x' \<in> H'"
141.222 - unfolding H'_def
141.223 - proof
141.224 - from H show "0 \<in> H" by (rule vectorspace.zero)
141.225 - from x'E show "x' \<in> lin x'" by (rule x_lin_x)
141.226 - from x'E show "x' = 0 + x'" by simp
141.227 - qed
141.228 - then have "(x', h' x') \<in> graph H' h'" ..
141.229 - with eq have "(x', h' x') \<in> graph H h" by (simp only:)
141.230 - then have "x' \<in> H" ..
141.231 - with `x' \<notin> H` show False by contradiction
141.232 - qed
141.233 - with g_rep show ?thesis by simp
141.234 - qed
141.235 - qed
141.236 - moreover have "graph H' h' \<in> M"
141.237 - -- {* and @{text h'} is norm-preserving. \skp *}
141.238 - proof (unfold M_def)
141.239 - show "graph H' h' \<in> norm_pres_extensions E p F f"
141.240 - proof (rule norm_pres_extensionI2)
141.241 - show "linearform H' h'"
141.242 - using h'_def H'_def HE linearform `x' \<notin> H` `x' \<in> E` `x' \<noteq> 0` E
141.243 - by (rule h'_lf)
141.244 - show "H' \<unlhd> E"
141.245 - unfolding H'_def
141.246 - proof
141.247 - show "H \<unlhd> E" by fact
141.248 - show "vectorspace E" by fact
141.249 - from x'E show "lin x' \<unlhd> E" ..
141.250 - qed
141.251 - from H `F \<unlhd> H` HH' show FH': "F \<unlhd> H'"
141.252 - by (rule vectorspace.subspace_trans)
141.253 - show "graph F f \<subseteq> graph H' h'"
141.254 - proof (rule graph_extI)
141.255 - fix x assume x: "x \<in> F"
141.256 - with graphs have "f x = h x" ..
141.257 - also have "\<dots> = h x + 0 * xi" by simp
141.258 - also have "\<dots> = (let (y, a) = (x, 0) in h y + a * xi)"
141.259 - by (simp add: Let_def)
141.260 - also have "(x, 0) =
141.261 - (SOME (y, a). x = y + a \<cdot> x' \<and> y \<in> H)"
141.262 - using E HE
141.263 - proof (rule decomp_H'_H [symmetric])
141.264 - from FH x show "x \<in> H" ..
141.265 - from x' show "x' \<noteq> 0" .
141.266 - show "x' \<notin> H" by fact
141.267 - show "x' \<in> E" by fact
141.268 - qed
141.269 - also have
141.270 - "(let (y, a) = (SOME (y, a). x = y + a \<cdot> x' \<and> y \<in> H)
141.271 - in h y + a * xi) = h' x" by (simp only: h'_def)
141.272 - finally show "f x = h' x" .
141.273 - next
141.274 - from FH' show "F \<subseteq> H'" ..
141.275 - qed
141.276 - show "\<forall>x \<in> H'. h' x \<le> p x"
141.277 - using h'_def H'_def `x' \<notin> H` `x' \<in> E` `x' \<noteq> 0` E HE
141.278 - `seminorm E p` linearform and hp xi
141.279 - by (rule h'_norm_pres)
141.280 - qed
141.281 - qed
141.282 - ultimately show ?thesis ..
141.283 - qed
141.284 - then have "\<not> (\<forall>x \<in> M. g \<subseteq> x \<longrightarrow> g = x)" by simp
141.285 - -- {* So the graph @{text g} of @{text h} cannot be maximal. Contradiction! \skp *}
141.286 - with gx show "H = E" by contradiction
141.287 - qed
141.288 -
141.289 - from HE_eq and linearform have "linearform E h"
141.290 - by (simp only:)
141.291 - moreover have "\<forall>x \<in> F. h x = f x"
141.292 - proof
141.293 - fix x assume "x \<in> F"
141.294 - with graphs have "f x = h x" ..
141.295 - then show "h x = f x" ..
141.296 - qed
141.297 - moreover from HE_eq and hp have "\<forall>x \<in> E. h x \<le> p x"
141.298 - by (simp only:)
141.299 - ultimately show ?thesis by blast
141.300 -qed
141.301 -
141.302 -
141.303 -subsection {* Alternative formulation *}
141.304 -
141.305 -text {*
141.306 - The following alternative formulation of the Hahn-Banach
141.307 - Theorem\label{abs-HahnBanach} uses the fact that for a real linear
141.308 - form @{text f} and a seminorm @{text p} the following inequations
141.309 - are equivalent:\footnote{This was shown in lemma @{thm [source]
141.310 - abs_ineq_iff} (see page \pageref{abs-ineq-iff}).}
141.311 - \begin{center}
141.312 - \begin{tabular}{lll}
141.313 - @{text "\<forall>x \<in> H. \<bar>h x\<bar> \<le> p x"} & and &
141.314 - @{text "\<forall>x \<in> H. h x \<le> p x"} \\
141.315 - \end{tabular}
141.316 - \end{center}
141.317 -*}
141.318 -
141.319 -theorem abs_HahnBanach:
141.320 - assumes E: "vectorspace E" and FE: "subspace F E"
141.321 - and lf: "linearform F f" and sn: "seminorm E p"
141.322 - assumes fp: "\<forall>x \<in> F. \<bar>f x\<bar> \<le> p x"
141.323 - shows "\<exists>g. linearform E g
141.324 - \<and> (\<forall>x \<in> F. g x = f x)
141.325 - \<and> (\<forall>x \<in> E. \<bar>g x\<bar> \<le> p x)"
141.326 -proof -
141.327 - interpret vectorspace E by fact
141.328 - interpret subspace F E by fact
141.329 - interpret linearform F f by fact
141.330 - interpret seminorm E p by fact
141.331 - have "\<exists>g. linearform E g \<and> (\<forall>x \<in> F. g x = f x) \<and> (\<forall>x \<in> E. g x \<le> p x)"
141.332 - using E FE sn lf
141.333 - proof (rule HahnBanach)
141.334 - show "\<forall>x \<in> F. f x \<le> p x"
141.335 - using FE E sn lf and fp by (rule abs_ineq_iff [THEN iffD1])
141.336 - qed
141.337 - then obtain g where lg: "linearform E g" and *: "\<forall>x \<in> F. g x = f x"
141.338 - and **: "\<forall>x \<in> E. g x \<le> p x" by blast
141.339 - have "\<forall>x \<in> E. \<bar>g x\<bar> \<le> p x"
141.340 - using _ E sn lg **
141.341 - proof (rule abs_ineq_iff [THEN iffD2])
141.342 - show "E \<unlhd> E" ..
141.343 - qed
141.344 - with lg * show ?thesis by blast
141.345 -qed
141.346 -
141.347 -
141.348 -subsection {* The Hahn-Banach Theorem for normed spaces *}
141.349 -
141.350 -text {*
141.351 - Every continuous linear form @{text f} on a subspace @{text F} of a
141.352 - norm space @{text E}, can be extended to a continuous linear form
141.353 - @{text g} on @{text E} such that @{text "\<parallel>f\<parallel> = \<parallel>g\<parallel>"}.
141.354 -*}
141.355 -
141.356 -theorem norm_HahnBanach:
141.357 - fixes V and norm ("\<parallel>_\<parallel>")
141.358 - fixes B defines "\<And>V f. B V f \<equiv> {0} \<union> {\<bar>f x\<bar> / \<parallel>x\<parallel> | x. x \<noteq> 0 \<and> x \<in> V}"
141.359 - fixes fn_norm ("\<parallel>_\<parallel>\<hyphen>_" [0, 1000] 999)
141.360 - defines "\<And>V f. \<parallel>f\<parallel>\<hyphen>V \<equiv> \<Squnion>(B V f)"
141.361 - assumes E_norm: "normed_vectorspace E norm" and FE: "subspace F E"
141.362 - and linearform: "linearform F f" and "continuous F norm f"
141.363 - shows "\<exists>g. linearform E g
141.364 - \<and> continuous E norm g
141.365 - \<and> (\<forall>x \<in> F. g x = f x)
141.366 - \<and> \<parallel>g\<parallel>\<hyphen>E = \<parallel>f\<parallel>\<hyphen>F"
141.367 -proof -
141.368 - interpret normed_vectorspace E norm by fact
141.369 - interpret normed_vectorspace_with_fn_norm E norm B fn_norm
141.370 - by (auto simp: B_def fn_norm_def) intro_locales
141.371 - interpret subspace F E by fact
141.372 - interpret linearform F f by fact
141.373 - interpret continuous F norm f by fact
141.374 - have E: "vectorspace E" by intro_locales
141.375 - have F: "vectorspace F" by rule intro_locales
141.376 - have F_norm: "normed_vectorspace F norm"
141.377 - using FE E_norm by (rule subspace_normed_vs)
141.378 - have ge_zero: "0 \<le> \<parallel>f\<parallel>\<hyphen>F"
141.379 - by (rule normed_vectorspace_with_fn_norm.fn_norm_ge_zero
141.380 - [OF normed_vectorspace_with_fn_norm.intro,
141.381 - OF F_norm `continuous F norm f` , folded B_def fn_norm_def])
141.382 - txt {* We define a function @{text p} on @{text E} as follows:
141.383 - @{text "p x = \<parallel>f\<parallel> \<cdot> \<parallel>x\<parallel>"} *}
141.384 - def p \<equiv> "\<lambda>x. \<parallel>f\<parallel>\<hyphen>F * \<parallel>x\<parallel>"
141.385 -
141.386 - txt {* @{text p} is a seminorm on @{text E}: *}
141.387 - have q: "seminorm E p"
141.388 - proof
141.389 - fix x y a assume x: "x \<in> E" and y: "y \<in> E"
141.390 -
141.391 - txt {* @{text p} is positive definite: *}
141.392 - have "0 \<le> \<parallel>f\<parallel>\<hyphen>F" by (rule ge_zero)
141.393 - moreover from x have "0 \<le> \<parallel>x\<parallel>" ..
141.394 - ultimately show "0 \<le> p x"
141.395 - by (simp add: p_def zero_le_mult_iff)
141.396 -
141.397 - txt {* @{text p} is absolutely homogenous: *}
141.398 -
141.399 - show "p (a \<cdot> x) = \<bar>a\<bar> * p x"
141.400 - proof -
141.401 - have "p (a \<cdot> x) = \<parallel>f\<parallel>\<hyphen>F * \<parallel>a \<cdot> x\<parallel>" by (simp only: p_def)
141.402 - also from x have "\<parallel>a \<cdot> x\<parallel> = \<bar>a\<bar> * \<parallel>x\<parallel>" by (rule abs_homogenous)
141.403 - also have "\<parallel>f\<parallel>\<hyphen>F * (\<bar>a\<bar> * \<parallel>x\<parallel>) = \<bar>a\<bar> * (\<parallel>f\<parallel>\<hyphen>F * \<parallel>x\<parallel>)" by simp
141.404 - also have "\<dots> = \<bar>a\<bar> * p x" by (simp only: p_def)
141.405 - finally show ?thesis .
141.406 - qed
141.407 -
141.408 - txt {* Furthermore, @{text p} is subadditive: *}
141.409 -
141.410 - show "p (x + y) \<le> p x + p y"
141.411 - proof -
141.412 - have "p (x + y) = \<parallel>f\<parallel>\<hyphen>F * \<parallel>x + y\<parallel>" by (simp only: p_def)
141.413 - also have a: "0 \<le> \<parallel>f\<parallel>\<hyphen>F" by (rule ge_zero)
141.414 - from x y have "\<parallel>x + y\<parallel> \<le> \<parallel>x\<parallel> + \<parallel>y\<parallel>" ..
141.415 - with a have " \<parallel>f\<parallel>\<hyphen>F * \<parallel>x + y\<parallel> \<le> \<parallel>f\<parallel>\<hyphen>F * (\<parallel>x\<parallel> + \<parallel>y\<parallel>)"
141.416 - by (simp add: mult_left_mono)
141.417 - also have "\<dots> = \<parallel>f\<parallel>\<hyphen>F * \<parallel>x\<parallel> + \<parallel>f\<parallel>\<hyphen>F * \<parallel>y\<parallel>" by (simp only: right_distrib)
141.418 - also have "\<dots> = p x + p y" by (simp only: p_def)
141.419 - finally show ?thesis .
141.420 - qed
141.421 - qed
141.422 -
141.423 - txt {* @{text f} is bounded by @{text p}. *}
141.424 -
141.425 - have "\<forall>x \<in> F. \<bar>f x\<bar> \<le> p x"
141.426 - proof
141.427 - fix x assume "x \<in> F"
141.428 - with `continuous F norm f` and linearform
141.429 - show "\<bar>f x\<bar> \<le> p x"
141.430 - unfolding p_def by (rule normed_vectorspace_with_fn_norm.fn_norm_le_cong
141.431 - [OF normed_vectorspace_with_fn_norm.intro,
141.432 - OF F_norm, folded B_def fn_norm_def])
141.433 - qed
141.434 -
141.435 - txt {* Using the fact that @{text p} is a seminorm and @{text f} is bounded
141.436 - by @{text p} we can apply the Hahn-Banach Theorem for real vector
141.437 - spaces. So @{text f} can be extended in a norm-preserving way to
141.438 - some function @{text g} on the whole vector space @{text E}. *}
141.439 -
141.440 - with E FE linearform q obtain g where
141.441 - linearformE: "linearform E g"
141.442 - and a: "\<forall>x \<in> F. g x = f x"
141.443 - and b: "\<forall>x \<in> E. \<bar>g x\<bar> \<le> p x"
141.444 - by (rule abs_HahnBanach [elim_format]) iprover
141.445 -
141.446 - txt {* We furthermore have to show that @{text g} is also continuous: *}
141.447 -
141.448 - have g_cont: "continuous E norm g" using linearformE
141.449 - proof
141.450 - fix x assume "x \<in> E"
141.451 - with b show "\<bar>g x\<bar> \<le> \<parallel>f\<parallel>\<hyphen>F * \<parallel>x\<parallel>"
141.452 - by (simp only: p_def)
141.453 - qed
141.454 -
141.455 - txt {* To complete the proof, we show that @{text "\<parallel>g\<parallel> = \<parallel>f\<parallel>"}. *}
141.456 -
141.457 - have "\<parallel>g\<parallel>\<hyphen>E = \<parallel>f\<parallel>\<hyphen>F"
141.458 - proof (rule order_antisym)
141.459 - txt {*
141.460 - First we show @{text "\<parallel>g\<parallel> \<le> \<parallel>f\<parallel>"}. The function norm @{text
141.461 - "\<parallel>g\<parallel>"} is defined as the smallest @{text "c \<in> \<real>"} such that
141.462 - \begin{center}
141.463 - \begin{tabular}{l}
141.464 - @{text "\<forall>x \<in> E. \<bar>g x\<bar> \<le> c \<cdot> \<parallel>x\<parallel>"}
141.465 - \end{tabular}
141.466 - \end{center}
141.467 - \noindent Furthermore holds
141.468 - \begin{center}
141.469 - \begin{tabular}{l}
141.470 - @{text "\<forall>x \<in> E. \<bar>g x\<bar> \<le> \<parallel>f\<parallel> \<cdot> \<parallel>x\<parallel>"}
141.471 - \end{tabular}
141.472 - \end{center}
141.473 - *}
141.474 -
141.475 - have "\<forall>x \<in> E. \<bar>g x\<bar> \<le> \<parallel>f\<parallel>\<hyphen>F * \<parallel>x\<parallel>"
141.476 - proof
141.477 - fix x assume "x \<in> E"
141.478 - with b show "\<bar>g x\<bar> \<le> \<parallel>f\<parallel>\<hyphen>F * \<parallel>x\<parallel>"
141.479 - by (simp only: p_def)
141.480 - qed
141.481 - from g_cont this ge_zero
141.482 - show "\<parallel>g\<parallel>\<hyphen>E \<le> \<parallel>f\<parallel>\<hyphen>F"
141.483 - by (rule fn_norm_least [of g, folded B_def fn_norm_def])
141.484 -
141.485 - txt {* The other direction is achieved by a similar argument. *}
141.486 -
141.487 - show "\<parallel>f\<parallel>\<hyphen>F \<le> \<parallel>g\<parallel>\<hyphen>E"
141.488 - proof (rule normed_vectorspace_with_fn_norm.fn_norm_least
141.489 - [OF normed_vectorspace_with_fn_norm.intro,
141.490 - OF F_norm, folded B_def fn_norm_def])
141.491 - show "\<forall>x \<in> F. \<bar>f x\<bar> \<le> \<parallel>g\<parallel>\<hyphen>E * \<parallel>x\<parallel>"
141.492 - proof
141.493 - fix x assume x: "x \<in> F"
141.494 - from a x have "g x = f x" ..
141.495 - then have "\<bar>f x\<bar> = \<bar>g x\<bar>" by (simp only:)
141.496 - also from g_cont
141.497 - have "\<dots> \<le> \<parallel>g\<parallel>\<hyphen>E * \<parallel>x\<parallel>"
141.498 - proof (rule fn_norm_le_cong [of g, folded B_def fn_norm_def])
141.499 - from FE x show "x \<in> E" ..
141.500 - qed
141.501 - finally show "\<bar>f x\<bar> \<le> \<parallel>g\<parallel>\<hyphen>E * \<parallel>x\<parallel>" .
141.502 - qed
141.503 - show "0 \<le> \<parallel>g\<parallel>\<hyphen>E"
141.504 - using g_cont
141.505 - by (rule fn_norm_ge_zero [of g, folded B_def fn_norm_def])
141.506 - show "continuous F norm f" by fact
141.507 - qed
141.508 - qed
141.509 - with linearformE a g_cont show ?thesis by blast
141.510 -qed
141.511 -
141.512 -end
142.1 --- a/src/HOL/Real/HahnBanach/HahnBanachExtLemmas.thy Tue Dec 30 08:18:54 2008 +0100
142.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
142.3 @@ -1,280 +0,0 @@
142.4 -(* Title: HOL/Real/HahnBanach/HahnBanachExtLemmas.thy
142.5 - Author: Gertrud Bauer, TU Munich
142.6 -*)
142.7 -
142.8 -header {* Extending non-maximal functions *}
142.9 -
142.10 -theory HahnBanachExtLemmas
142.11 -imports FunctionNorm
142.12 -begin
142.13 -
142.14 -text {*
142.15 - In this section the following context is presumed. Let @{text E} be
142.16 - a real vector space with a seminorm @{text q} on @{text E}. @{text
142.17 - F} is a subspace of @{text E} and @{text f} a linear function on
142.18 - @{text F}. We consider a subspace @{text H} of @{text E} that is a
142.19 - superspace of @{text F} and a linear form @{text h} on @{text
142.20 - H}. @{text H} is a not equal to @{text E} and @{text "x\<^sub>0"} is
142.21 - an element in @{text "E - H"}. @{text H} is extended to the direct
142.22 - sum @{text "H' = H + lin x\<^sub>0"}, so for any @{text "x \<in> H'"}
142.23 - the decomposition of @{text "x = y + a \<cdot> x"} with @{text "y \<in> H"} is
142.24 - unique. @{text h'} is defined on @{text H'} by @{text "h' x = h y +
142.25 - a \<cdot> \<xi>"} for a certain @{text \<xi>}.
142.26 -
142.27 - Subsequently we show some properties of this extension @{text h'} of
142.28 - @{text h}.
142.29 -
142.30 - \medskip This lemma will be used to show the existence of a linear
142.31 - extension of @{text f} (see page \pageref{ex-xi-use}). It is a
142.32 - consequence of the completeness of @{text \<real>}. To show
142.33 - \begin{center}
142.34 - \begin{tabular}{l}
142.35 - @{text "\<exists>\<xi>. \<forall>y \<in> F. a y \<le> \<xi> \<and> \<xi> \<le> b y"}
142.36 - \end{tabular}
142.37 - \end{center}
142.38 - \noindent it suffices to show that
142.39 - \begin{center}
142.40 - \begin{tabular}{l}
142.41 - @{text "\<forall>u \<in> F. \<forall>v \<in> F. a u \<le> b v"}
142.42 - \end{tabular}
142.43 - \end{center}
142.44 -*}
142.45 -
142.46 -lemma ex_xi:
142.47 - assumes "vectorspace F"
142.48 - assumes r: "\<And>u v. u \<in> F \<Longrightarrow> v \<in> F \<Longrightarrow> a u \<le> b v"
142.49 - shows "\<exists>xi::real. \<forall>y \<in> F. a y \<le> xi \<and> xi \<le> b y"
142.50 -proof -
142.51 - interpret vectorspace F by fact
142.52 - txt {* From the completeness of the reals follows:
142.53 - The set @{text "S = {a u. u \<in> F}"} has a supremum, if it is
142.54 - non-empty and has an upper bound. *}
142.55 -
142.56 - let ?S = "{a u | u. u \<in> F}"
142.57 - have "\<exists>xi. lub ?S xi"
142.58 - proof (rule real_complete)
142.59 - have "a 0 \<in> ?S" by blast
142.60 - then show "\<exists>X. X \<in> ?S" ..
142.61 - have "\<forall>y \<in> ?S. y \<le> b 0"
142.62 - proof
142.63 - fix y assume y: "y \<in> ?S"
142.64 - then obtain u where u: "u \<in> F" and y: "y = a u" by blast
142.65 - from u and zero have "a u \<le> b 0" by (rule r)
142.66 - with y show "y \<le> b 0" by (simp only:)
142.67 - qed
142.68 - then show "\<exists>u. \<forall>y \<in> ?S. y \<le> u" ..
142.69 - qed
142.70 - then obtain xi where xi: "lub ?S xi" ..
142.71 - {
142.72 - fix y assume "y \<in> F"
142.73 - then have "a y \<in> ?S" by blast
142.74 - with xi have "a y \<le> xi" by (rule lub.upper)
142.75 - } moreover {
142.76 - fix y assume y: "y \<in> F"
142.77 - from xi have "xi \<le> b y"
142.78 - proof (rule lub.least)
142.79 - fix au assume "au \<in> ?S"
142.80 - then obtain u where u: "u \<in> F" and au: "au = a u" by blast
142.81 - from u y have "a u \<le> b y" by (rule r)
142.82 - with au show "au \<le> b y" by (simp only:)
142.83 - qed
142.84 - } ultimately show "\<exists>xi. \<forall>y \<in> F. a y \<le> xi \<and> xi \<le> b y" by blast
142.85 -qed
142.86 -
142.87 -text {*
142.88 - \medskip The function @{text h'} is defined as a @{text "h' x = h y
142.89 - + a \<cdot> \<xi>"} where @{text "x = y + a \<cdot> \<xi>"} is a linear extension of
142.90 - @{text h} to @{text H'}.
142.91 -*}
142.92 -
142.93 -lemma h'_lf:
142.94 - assumes h'_def: "h' \<equiv> \<lambda>x. let (y, a) =
142.95 - SOME (y, a). x = y + a \<cdot> x0 \<and> y \<in> H in h y + a * xi"
142.96 - and H'_def: "H' \<equiv> H + lin x0"
142.97 - and HE: "H \<unlhd> E"
142.98 - assumes "linearform H h"
142.99 - assumes x0: "x0 \<notin> H" "x0 \<in> E" "x0 \<noteq> 0"
142.100 - assumes E: "vectorspace E"
142.101 - shows "linearform H' h'"
142.102 -proof -
142.103 - interpret linearform H h by fact
142.104 - interpret vectorspace E by fact
142.105 - show ?thesis
142.106 - proof
142.107 - note E = `vectorspace E`
142.108 - have H': "vectorspace H'"
142.109 - proof (unfold H'_def)
142.110 - from `x0 \<in> E`
142.111 - have "lin x0 \<unlhd> E" ..
142.112 - with HE show "vectorspace (H + lin x0)" using E ..
142.113 - qed
142.114 - {
142.115 - fix x1 x2 assume x1: "x1 \<in> H'" and x2: "x2 \<in> H'"
142.116 - show "h' (x1 + x2) = h' x1 + h' x2"
142.117 - proof -
142.118 - from H' x1 x2 have "x1 + x2 \<in> H'"
142.119 - by (rule vectorspace.add_closed)
142.120 - with x1 x2 obtain y y1 y2 a a1 a2 where
142.121 - x1x2: "x1 + x2 = y + a \<cdot> x0" and y: "y \<in> H"
142.122 - and x1_rep: "x1 = y1 + a1 \<cdot> x0" and y1: "y1 \<in> H"
142.123 - and x2_rep: "x2 = y2 + a2 \<cdot> x0" and y2: "y2 \<in> H"
142.124 - unfolding H'_def sum_def lin_def by blast
142.125 -
142.126 - have ya: "y1 + y2 = y \<and> a1 + a2 = a" using E HE _ y x0
142.127 - proof (rule decomp_H') txt_raw {* \label{decomp-H-use} *}
142.128 - from HE y1 y2 show "y1 + y2 \<in> H"
142.129 - by (rule subspace.add_closed)
142.130 - from x0 and HE y y1 y2
142.131 - have "x0 \<in> E" "y \<in> E" "y1 \<in> E" "y2 \<in> E" by auto
142.132 - with x1_rep x2_rep have "(y1 + y2) + (a1 + a2) \<cdot> x0 = x1 + x2"
142.133 - by (simp add: add_ac add_mult_distrib2)
142.134 - also note x1x2
142.135 - finally show "(y1 + y2) + (a1 + a2) \<cdot> x0 = y + a \<cdot> x0" .
142.136 - qed
142.137 -
142.138 - from h'_def x1x2 E HE y x0
142.139 - have "h' (x1 + x2) = h y + a * xi"
142.140 - by (rule h'_definite)
142.141 - also have "\<dots> = h (y1 + y2) + (a1 + a2) * xi"
142.142 - by (simp only: ya)
142.143 - also from y1 y2 have "h (y1 + y2) = h y1 + h y2"
142.144 - by simp
142.145 - also have "\<dots> + (a1 + a2) * xi = (h y1 + a1 * xi) + (h y2 + a2 * xi)"
142.146 - by (simp add: left_distrib)
142.147 - also from h'_def x1_rep E HE y1 x0
142.148 - have "h y1 + a1 * xi = h' x1"
142.149 - by (rule h'_definite [symmetric])
142.150 - also from h'_def x2_rep E HE y2 x0
142.151 - have "h y2 + a2 * xi = h' x2"
142.152 - by (rule h'_definite [symmetric])
142.153 - finally show ?thesis .
142.154 - qed
142.155 - next
142.156 - fix x1 c assume x1: "x1 \<in> H'"
142.157 - show "h' (c \<cdot> x1) = c * (h' x1)"
142.158 - proof -
142.159 - from H' x1 have ax1: "c \<cdot> x1 \<in> H'"
142.160 - by (rule vectorspace.mult_closed)
142.161 - with x1 obtain y a y1 a1 where
142.162 - cx1_rep: "c \<cdot> x1 = y + a \<cdot> x0" and y: "y \<in> H"
142.163 - and x1_rep: "x1 = y1 + a1 \<cdot> x0" and y1: "y1 \<in> H"
142.164 - unfolding H'_def sum_def lin_def by blast
142.165 -
142.166 - have ya: "c \<cdot> y1 = y \<and> c * a1 = a" using E HE _ y x0
142.167 - proof (rule decomp_H')
142.168 - from HE y1 show "c \<cdot> y1 \<in> H"
142.169 - by (rule subspace.mult_closed)
142.170 - from x0 and HE y y1
142.171 - have "x0 \<in> E" "y \<in> E" "y1 \<in> E" by auto
142.172 - with x1_rep have "c \<cdot> y1 + (c * a1) \<cdot> x0 = c \<cdot> x1"
142.173 - by (simp add: mult_assoc add_mult_distrib1)
142.174 - also note cx1_rep
142.175 - finally show "c \<cdot> y1 + (c * a1) \<cdot> x0 = y + a \<cdot> x0" .
142.176 - qed
142.177 -
142.178 - from h'_def cx1_rep E HE y x0 have "h' (c \<cdot> x1) = h y + a * xi"
142.179 - by (rule h'_definite)
142.180 - also have "\<dots> = h (c \<cdot> y1) + (c * a1) * xi"
142.181 - by (simp only: ya)
142.182 - also from y1 have "h (c \<cdot> y1) = c * h y1"
142.183 - by simp
142.184 - also have "\<dots> + (c * a1) * xi = c * (h y1 + a1 * xi)"
142.185 - by (simp only: right_distrib)
142.186 - also from h'_def x1_rep E HE y1 x0 have "h y1 + a1 * xi = h' x1"
142.187 - by (rule h'_definite [symmetric])
142.188 - finally show ?thesis .
142.189 - qed
142.190 - }
142.191 - qed
142.192 -qed
142.193 -
142.194 -text {* \medskip The linear extension @{text h'} of @{text h}
142.195 - is bounded by the seminorm @{text p}. *}
142.196 -
142.197 -lemma h'_norm_pres:
142.198 - assumes h'_def: "h' \<equiv> \<lambda>x. let (y, a) =
142.199 - SOME (y, a). x = y + a \<cdot> x0 \<and> y \<in> H in h y + a * xi"
142.200 - and H'_def: "H' \<equiv> H + lin x0"
142.201 - and x0: "x0 \<notin> H" "x0 \<in> E" "x0 \<noteq> 0"
142.202 - assumes E: "vectorspace E" and HE: "subspace H E"
142.203 - and "seminorm E p" and "linearform H h"
142.204 - assumes a: "\<forall>y \<in> H. h y \<le> p y"
142.205 - and a': "\<forall>y \<in> H. - p (y + x0) - h y \<le> xi \<and> xi \<le> p (y + x0) - h y"
142.206 - shows "\<forall>x \<in> H'. h' x \<le> p x"
142.207 -proof -
142.208 - interpret vectorspace E by fact
142.209 - interpret subspace H E by fact
142.210 - interpret seminorm E p by fact
142.211 - interpret linearform H h by fact
142.212 - show ?thesis
142.213 - proof
142.214 - fix x assume x': "x \<in> H'"
142.215 - show "h' x \<le> p x"
142.216 - proof -
142.217 - from a' have a1: "\<forall>ya \<in> H. - p (ya + x0) - h ya \<le> xi"
142.218 - and a2: "\<forall>ya \<in> H. xi \<le> p (ya + x0) - h ya" by auto
142.219 - from x' obtain y a where
142.220 - x_rep: "x = y + a \<cdot> x0" and y: "y \<in> H"
142.221 - unfolding H'_def sum_def lin_def by blast
142.222 - from y have y': "y \<in> E" ..
142.223 - from y have ay: "inverse a \<cdot> y \<in> H" by simp
142.224 -
142.225 - from h'_def x_rep E HE y x0 have "h' x = h y + a * xi"
142.226 - by (rule h'_definite)
142.227 - also have "\<dots> \<le> p (y + a \<cdot> x0)"
142.228 - proof (rule linorder_cases)
142.229 - assume z: "a = 0"
142.230 - then have "h y + a * xi = h y" by simp
142.231 - also from a y have "\<dots> \<le> p y" ..
142.232 - also from x0 y' z have "p y = p (y + a \<cdot> x0)" by simp
142.233 - finally show ?thesis .
142.234 - next
142.235 - txt {* In the case @{text "a < 0"}, we use @{text "a\<^sub>1"}
142.236 - with @{text ya} taken as @{text "y / a"}: *}
142.237 - assume lz: "a < 0" then have nz: "a \<noteq> 0" by simp
142.238 - from a1 ay
142.239 - have "- p (inverse a \<cdot> y + x0) - h (inverse a \<cdot> y) \<le> xi" ..
142.240 - with lz have "a * xi \<le>
142.241 - a * (- p (inverse a \<cdot> y + x0) - h (inverse a \<cdot> y))"
142.242 - by (simp add: mult_left_mono_neg order_less_imp_le)
142.243 -
142.244 - also have "\<dots> =
142.245 - - a * (p (inverse a \<cdot> y + x0)) - a * (h (inverse a \<cdot> y))"
142.246 - by (simp add: right_diff_distrib)
142.247 - also from lz x0 y' have "- a * (p (inverse a \<cdot> y + x0)) =
142.248 - p (a \<cdot> (inverse a \<cdot> y + x0))"
142.249 - by (simp add: abs_homogenous)
142.250 - also from nz x0 y' have "\<dots> = p (y + a \<cdot> x0)"
142.251 - by (simp add: add_mult_distrib1 mult_assoc [symmetric])
142.252 - also from nz y have "a * (h (inverse a \<cdot> y)) = h y"
142.253 - by simp
142.254 - finally have "a * xi \<le> p (y + a \<cdot> x0) - h y" .
142.255 - then show ?thesis by simp
142.256 - next
142.257 - txt {* In the case @{text "a > 0"}, we use @{text "a\<^sub>2"}
142.258 - with @{text ya} taken as @{text "y / a"}: *}
142.259 - assume gz: "0 < a" then have nz: "a \<noteq> 0" by simp
142.260 - from a2 ay
142.261 - have "xi \<le> p (inverse a \<cdot> y + x0) - h (inverse a \<cdot> y)" ..
142.262 - with gz have "a * xi \<le>
142.263 - a * (p (inverse a \<cdot> y + x0) - h (inverse a \<cdot> y))"
142.264 - by simp
142.265 - also have "\<dots> = a * p (inverse a \<cdot> y + x0) - a * h (inverse a \<cdot> y)"
142.266 - by (simp add: right_diff_distrib)
142.267 - also from gz x0 y'
142.268 - have "a * p (inverse a \<cdot> y + x0) = p (a \<cdot> (inverse a \<cdot> y + x0))"
142.269 - by (simp add: abs_homogenous)
142.270 - also from nz x0 y' have "\<dots> = p (y + a \<cdot> x0)"
142.271 - by (simp add: add_mult_distrib1 mult_assoc [symmetric])
142.272 - also from nz y have "a * h (inverse a \<cdot> y) = h y"
142.273 - by simp
142.274 - finally have "a * xi \<le> p (y + a \<cdot> x0) - h y" .
142.275 - then show ?thesis by simp
142.276 - qed
142.277 - also from x_rep have "\<dots> = p x" by (simp only:)
142.278 - finally show ?thesis .
142.279 - qed
142.280 - qed
142.281 -qed
142.282 -
142.283 -end
143.1 --- a/src/HOL/Real/HahnBanach/HahnBanachLemmas.thy Tue Dec 30 08:18:54 2008 +0100
143.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
143.3 @@ -1,4 +0,0 @@
143.4 -(*<*)
143.5 -theory HahnBanachLemmas imports HahnBanachSupLemmas HahnBanachExtLemmas begin
143.6 -end
143.7 -(*>*)
143.8 \ No newline at end of file
144.1 --- a/src/HOL/Real/HahnBanach/HahnBanachSupLemmas.thy Tue Dec 30 08:18:54 2008 +0100
144.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
144.3 @@ -1,446 +0,0 @@
144.4 -(* Title: HOL/Real/HahnBanach/HahnBanachSupLemmas.thy
144.5 - ID: $Id$
144.6 - Author: Gertrud Bauer, TU Munich
144.7 -*)
144.8 -
144.9 -header {* The supremum w.r.t.~the function order *}
144.10 -
144.11 -theory HahnBanachSupLemmas
144.12 -imports FunctionNorm ZornLemma
144.13 -begin
144.14 -
144.15 -text {*
144.16 - This section contains some lemmas that will be used in the proof of
144.17 - the Hahn-Banach Theorem. In this section the following context is
144.18 - presumed. Let @{text E} be a real vector space with a seminorm
144.19 - @{text p} on @{text E}. @{text F} is a subspace of @{text E} and
144.20 - @{text f} a linear form on @{text F}. We consider a chain @{text c}
144.21 - of norm-preserving extensions of @{text f}, such that @{text "\<Union>c =
144.22 - graph H h"}. We will show some properties about the limit function
144.23 - @{text h}, i.e.\ the supremum of the chain @{text c}.
144.24 -
144.25 - \medskip Let @{text c} be a chain of norm-preserving extensions of
144.26 - the function @{text f} and let @{text "graph H h"} be the supremum
144.27 - of @{text c}. Every element in @{text H} is member of one of the
144.28 - elements of the chain.
144.29 -*}
144.30 -lemmas [dest?] = chainD
144.31 -lemmas chainE2 [elim?] = chainD2 [elim_format, standard]
144.32 -
144.33 -lemma some_H'h't:
144.34 - assumes M: "M = norm_pres_extensions E p F f"
144.35 - and cM: "c \<in> chain M"
144.36 - and u: "graph H h = \<Union>c"
144.37 - and x: "x \<in> H"
144.38 - shows "\<exists>H' h'. graph H' h' \<in> c
144.39 - \<and> (x, h x) \<in> graph H' h'
144.40 - \<and> linearform H' h' \<and> H' \<unlhd> E
144.41 - \<and> F \<unlhd> H' \<and> graph F f \<subseteq> graph H' h'
144.42 - \<and> (\<forall>x \<in> H'. h' x \<le> p x)"
144.43 -proof -
144.44 - from x have "(x, h x) \<in> graph H h" ..
144.45 - also from u have "\<dots> = \<Union>c" .
144.46 - finally obtain g where gc: "g \<in> c" and gh: "(x, h x) \<in> g" by blast
144.47 -
144.48 - from cM have "c \<subseteq> M" ..
144.49 - with gc have "g \<in> M" ..
144.50 - also from M have "\<dots> = norm_pres_extensions E p F f" .
144.51 - finally obtain H' and h' where g: "g = graph H' h'"
144.52 - and * : "linearform H' h'" "H' \<unlhd> E" "F \<unlhd> H'"
144.53 - "graph F f \<subseteq> graph H' h'" "\<forall>x \<in> H'. h' x \<le> p x" ..
144.54 -
144.55 - from gc and g have "graph H' h' \<in> c" by (simp only:)
144.56 - moreover from gh and g have "(x, h x) \<in> graph H' h'" by (simp only:)
144.57 - ultimately show ?thesis using * by blast
144.58 -qed
144.59 -
144.60 -text {*
144.61 - \medskip Let @{text c} be a chain of norm-preserving extensions of
144.62 - the function @{text f} and let @{text "graph H h"} be the supremum
144.63 - of @{text c}. Every element in the domain @{text H} of the supremum
144.64 - function is member of the domain @{text H'} of some function @{text
144.65 - h'}, such that @{text h} extends @{text h'}.
144.66 -*}
144.67 -
144.68 -lemma some_H'h':
144.69 - assumes M: "M = norm_pres_extensions E p F f"
144.70 - and cM: "c \<in> chain M"
144.71 - and u: "graph H h = \<Union>c"
144.72 - and x: "x \<in> H"
144.73 - shows "\<exists>H' h'. x \<in> H' \<and> graph H' h' \<subseteq> graph H h
144.74 - \<and> linearform H' h' \<and> H' \<unlhd> E \<and> F \<unlhd> H'
144.75 - \<and> graph F f \<subseteq> graph H' h' \<and> (\<forall>x \<in> H'. h' x \<le> p x)"
144.76 -proof -
144.77 - from M cM u x obtain H' h' where
144.78 - x_hx: "(x, h x) \<in> graph H' h'"
144.79 - and c: "graph H' h' \<in> c"
144.80 - and * : "linearform H' h'" "H' \<unlhd> E" "F \<unlhd> H'"
144.81 - "graph F f \<subseteq> graph H' h'" "\<forall>x \<in> H'. h' x \<le> p x"
144.82 - by (rule some_H'h't [elim_format]) blast
144.83 - from x_hx have "x \<in> H'" ..
144.84 - moreover from cM u c have "graph H' h' \<subseteq> graph H h"
144.85 - by (simp only: chain_ball_Union_upper)
144.86 - ultimately show ?thesis using * by blast
144.87 -qed
144.88 -
144.89 -text {*
144.90 - \medskip Any two elements @{text x} and @{text y} in the domain
144.91 - @{text H} of the supremum function @{text h} are both in the domain
144.92 - @{text H'} of some function @{text h'}, such that @{text h} extends
144.93 - @{text h'}.
144.94 -*}
144.95 -
144.96 -lemma some_H'h'2:
144.97 - assumes M: "M = norm_pres_extensions E p F f"
144.98 - and cM: "c \<in> chain M"
144.99 - and u: "graph H h = \<Union>c"
144.100 - and x: "x \<in> H"
144.101 - and y: "y \<in> H"
144.102 - shows "\<exists>H' h'. x \<in> H' \<and> y \<in> H'
144.103 - \<and> graph H' h' \<subseteq> graph H h
144.104 - \<and> linearform H' h' \<and> H' \<unlhd> E \<and> F \<unlhd> H'
144.105 - \<and> graph F f \<subseteq> graph H' h' \<and> (\<forall>x \<in> H'. h' x \<le> p x)"
144.106 -proof -
144.107 - txt {* @{text y} is in the domain @{text H''} of some function @{text h''},
144.108 - such that @{text h} extends @{text h''}. *}
144.109 -
144.110 - from M cM u and y obtain H' h' where
144.111 - y_hy: "(y, h y) \<in> graph H' h'"
144.112 - and c': "graph H' h' \<in> c"
144.113 - and * :
144.114 - "linearform H' h'" "H' \<unlhd> E" "F \<unlhd> H'"
144.115 - "graph F f \<subseteq> graph H' h'" "\<forall>x \<in> H'. h' x \<le> p x"
144.116 - by (rule some_H'h't [elim_format]) blast
144.117 -
144.118 - txt {* @{text x} is in the domain @{text H'} of some function @{text h'},
144.119 - such that @{text h} extends @{text h'}. *}
144.120 -
144.121 - from M cM u and x obtain H'' h'' where
144.122 - x_hx: "(x, h x) \<in> graph H'' h''"
144.123 - and c'': "graph H'' h'' \<in> c"
144.124 - and ** :
144.125 - "linearform H'' h''" "H'' \<unlhd> E" "F \<unlhd> H''"
144.126 - "graph F f \<subseteq> graph H'' h''" "\<forall>x \<in> H''. h'' x \<le> p x"
144.127 - by (rule some_H'h't [elim_format]) blast
144.128 -
144.129 - txt {* Since both @{text h'} and @{text h''} are elements of the chain,
144.130 - @{text h''} is an extension of @{text h'} or vice versa. Thus both
144.131 - @{text x} and @{text y} are contained in the greater
144.132 - one. \label{cases1}*}
144.133 -
144.134 - from cM c'' c' have "graph H'' h'' \<subseteq> graph H' h' \<or> graph H' h' \<subseteq> graph H'' h''"
144.135 - (is "?case1 \<or> ?case2") ..
144.136 - then show ?thesis
144.137 - proof
144.138 - assume ?case1
144.139 - have "(x, h x) \<in> graph H'' h''" by fact
144.140 - also have "\<dots> \<subseteq> graph H' h'" by fact
144.141 - finally have xh:"(x, h x) \<in> graph H' h'" .
144.142 - then have "x \<in> H'" ..
144.143 - moreover from y_hy have "y \<in> H'" ..
144.144 - moreover from cM u and c' have "graph H' h' \<subseteq> graph H h"
144.145 - by (simp only: chain_ball_Union_upper)
144.146 - ultimately show ?thesis using * by blast
144.147 - next
144.148 - assume ?case2
144.149 - from x_hx have "x \<in> H''" ..
144.150 - moreover {
144.151 - have "(y, h y) \<in> graph H' h'" by (rule y_hy)
144.152 - also have "\<dots> \<subseteq> graph H'' h''" by fact
144.153 - finally have "(y, h y) \<in> graph H'' h''" .
144.154 - } then have "y \<in> H''" ..
144.155 - moreover from cM u and c'' have "graph H'' h'' \<subseteq> graph H h"
144.156 - by (simp only: chain_ball_Union_upper)
144.157 - ultimately show ?thesis using ** by blast
144.158 - qed
144.159 -qed
144.160 -
144.161 -text {*
144.162 - \medskip The relation induced by the graph of the supremum of a
144.163 - chain @{text c} is definite, i.~e.~t is the graph of a function.
144.164 -*}
144.165 -
144.166 -lemma sup_definite:
144.167 - assumes M_def: "M \<equiv> norm_pres_extensions E p F f"
144.168 - and cM: "c \<in> chain M"
144.169 - and xy: "(x, y) \<in> \<Union>c"
144.170 - and xz: "(x, z) \<in> \<Union>c"
144.171 - shows "z = y"
144.172 -proof -
144.173 - from cM have c: "c \<subseteq> M" ..
144.174 - from xy obtain G1 where xy': "(x, y) \<in> G1" and G1: "G1 \<in> c" ..
144.175 - from xz obtain G2 where xz': "(x, z) \<in> G2" and G2: "G2 \<in> c" ..
144.176 -
144.177 - from G1 c have "G1 \<in> M" ..
144.178 - then obtain H1 h1 where G1_rep: "G1 = graph H1 h1"
144.179 - unfolding M_def by blast
144.180 -
144.181 - from G2 c have "G2 \<in> M" ..
144.182 - then obtain H2 h2 where G2_rep: "G2 = graph H2 h2"
144.183 - unfolding M_def by blast
144.184 -
144.185 - txt {* @{text "G\<^sub>1"} is contained in @{text "G\<^sub>2"}
144.186 - or vice versa, since both @{text "G\<^sub>1"} and @{text
144.187 - "G\<^sub>2"} are members of @{text c}. \label{cases2}*}
144.188 -
144.189 - from cM G1 G2 have "G1 \<subseteq> G2 \<or> G2 \<subseteq> G1" (is "?case1 \<or> ?case2") ..
144.190 - then show ?thesis
144.191 - proof
144.192 - assume ?case1
144.193 - with xy' G2_rep have "(x, y) \<in> graph H2 h2" by blast
144.194 - then have "y = h2 x" ..
144.195 - also
144.196 - from xz' G2_rep have "(x, z) \<in> graph H2 h2" by (simp only:)
144.197 - then have "z = h2 x" ..
144.198 - finally show ?thesis .
144.199 - next
144.200 - assume ?case2
144.201 - with xz' G1_rep have "(x, z) \<in> graph H1 h1" by blast
144.202 - then have "z = h1 x" ..
144.203 - also
144.204 - from xy' G1_rep have "(x, y) \<in> graph H1 h1" by (simp only:)
144.205 - then have "y = h1 x" ..
144.206 - finally show ?thesis ..
144.207 - qed
144.208 -qed
144.209 -
144.210 -text {*
144.211 - \medskip The limit function @{text h} is linear. Every element
144.212 - @{text x} in the domain of @{text h} is in the domain of a function
144.213 - @{text h'} in the chain of norm preserving extensions. Furthermore,
144.214 - @{text h} is an extension of @{text h'} so the function values of
144.215 - @{text x} are identical for @{text h'} and @{text h}. Finally, the
144.216 - function @{text h'} is linear by construction of @{text M}.
144.217 -*}
144.218 -
144.219 -lemma sup_lf:
144.220 - assumes M: "M = norm_pres_extensions E p F f"
144.221 - and cM: "c \<in> chain M"
144.222 - and u: "graph H h = \<Union>c"
144.223 - shows "linearform H h"
144.224 -proof
144.225 - fix x y assume x: "x \<in> H" and y: "y \<in> H"
144.226 - with M cM u obtain H' h' where
144.227 - x': "x \<in> H'" and y': "y \<in> H'"
144.228 - and b: "graph H' h' \<subseteq> graph H h"
144.229 - and linearform: "linearform H' h'"
144.230 - and subspace: "H' \<unlhd> E"
144.231 - by (rule some_H'h'2 [elim_format]) blast
144.232 -
144.233 - show "h (x + y) = h x + h y"
144.234 - proof -
144.235 - from linearform x' y' have "h' (x + y) = h' x + h' y"
144.236 - by (rule linearform.add)
144.237 - also from b x' have "h' x = h x" ..
144.238 - also from b y' have "h' y = h y" ..
144.239 - also from subspace x' y' have "x + y \<in> H'"
144.240 - by (rule subspace.add_closed)
144.241 - with b have "h' (x + y) = h (x + y)" ..
144.242 - finally show ?thesis .
144.243 - qed
144.244 -next
144.245 - fix x a assume x: "x \<in> H"
144.246 - with M cM u obtain H' h' where
144.247 - x': "x \<in> H'"
144.248 - and b: "graph H' h' \<subseteq> graph H h"
144.249 - and linearform: "linearform H' h'"
144.250 - and subspace: "H' \<unlhd> E"
144.251 - by (rule some_H'h' [elim_format]) blast
144.252 -
144.253 - show "h (a \<cdot> x) = a * h x"
144.254 - proof -
144.255 - from linearform x' have "h' (a \<cdot> x) = a * h' x"
144.256 - by (rule linearform.mult)
144.257 - also from b x' have "h' x = h x" ..
144.258 - also from subspace x' have "a \<cdot> x \<in> H'"
144.259 - by (rule subspace.mult_closed)
144.260 - with b have "h' (a \<cdot> x) = h (a \<cdot> x)" ..
144.261 - finally show ?thesis .
144.262 - qed
144.263 -qed
144.264 -
144.265 -text {*
144.266 - \medskip The limit of a non-empty chain of norm preserving
144.267 - extensions of @{text f} is an extension of @{text f}, since every
144.268 - element of the chain is an extension of @{text f} and the supremum
144.269 - is an extension for every element of the chain.
144.270 -*}
144.271 -
144.272 -lemma sup_ext:
144.273 - assumes graph: "graph H h = \<Union>c"
144.274 - and M: "M = norm_pres_extensions E p F f"
144.275 - and cM: "c \<in> chain M"
144.276 - and ex: "\<exists>x. x \<in> c"
144.277 - shows "graph F f \<subseteq> graph H h"
144.278 -proof -
144.279 - from ex obtain x where xc: "x \<in> c" ..
144.280 - from cM have "c \<subseteq> M" ..
144.281 - with xc have "x \<in> M" ..
144.282 - with M have "x \<in> norm_pres_extensions E p F f"
144.283 - by (simp only:)
144.284 - then obtain G g where "x = graph G g" and "graph F f \<subseteq> graph G g" ..
144.285 - then have "graph F f \<subseteq> x" by (simp only:)
144.286 - also from xc have "\<dots> \<subseteq> \<Union>c" by blast
144.287 - also from graph have "\<dots> = graph H h" ..
144.288 - finally show ?thesis .
144.289 -qed
144.290 -
144.291 -text {*
144.292 - \medskip The domain @{text H} of the limit function is a superspace
144.293 - of @{text F}, since @{text F} is a subset of @{text H}. The
144.294 - existence of the @{text 0} element in @{text F} and the closure
144.295 - properties follow from the fact that @{text F} is a vector space.
144.296 -*}
144.297 -
144.298 -lemma sup_supF:
144.299 - assumes graph: "graph H h = \<Union>c"
144.300 - and M: "M = norm_pres_extensions E p F f"
144.301 - and cM: "c \<in> chain M"
144.302 - and ex: "\<exists>x. x \<in> c"
144.303 - and FE: "F \<unlhd> E"
144.304 - shows "F \<unlhd> H"
144.305 -proof
144.306 - from FE show "F \<noteq> {}" by (rule subspace.non_empty)
144.307 - from graph M cM ex have "graph F f \<subseteq> graph H h" by (rule sup_ext)
144.308 - then show "F \<subseteq> H" ..
144.309 - fix x y assume "x \<in> F" and "y \<in> F"
144.310 - with FE show "x + y \<in> F" by (rule subspace.add_closed)
144.311 -next
144.312 - fix x a assume "x \<in> F"
144.313 - with FE show "a \<cdot> x \<in> F" by (rule subspace.mult_closed)
144.314 -qed
144.315 -
144.316 -text {*
144.317 - \medskip The domain @{text H} of the limit function is a subspace of
144.318 - @{text E}.
144.319 -*}
144.320 -
144.321 -lemma sup_subE:
144.322 - assumes graph: "graph H h = \<Union>c"
144.323 - and M: "M = norm_pres_extensions E p F f"
144.324 - and cM: "c \<in> chain M"
144.325 - and ex: "\<exists>x. x \<in> c"
144.326 - and FE: "F \<unlhd> E"
144.327 - and E: "vectorspace E"
144.328 - shows "H \<unlhd> E"
144.329 -proof
144.330 - show "H \<noteq> {}"
144.331 - proof -
144.332 - from FE E have "0 \<in> F" by (rule subspace.zero)
144.333 - also from graph M cM ex FE have "F \<unlhd> H" by (rule sup_supF)
144.334 - then have "F \<subseteq> H" ..
144.335 - finally show ?thesis by blast
144.336 - qed
144.337 - show "H \<subseteq> E"
144.338 - proof
144.339 - fix x assume "x \<in> H"
144.340 - with M cM graph
144.341 - obtain H' h' where x: "x \<in> H'" and H'E: "H' \<unlhd> E"
144.342 - by (rule some_H'h' [elim_format]) blast
144.343 - from H'E have "H' \<subseteq> E" ..
144.344 - with x show "x \<in> E" ..
144.345 - qed
144.346 - fix x y assume x: "x \<in> H" and y: "y \<in> H"
144.347 - show "x + y \<in> H"
144.348 - proof -
144.349 - from M cM graph x y obtain H' h' where
144.350 - x': "x \<in> H'" and y': "y \<in> H'" and H'E: "H' \<unlhd> E"
144.351 - and graphs: "graph H' h' \<subseteq> graph H h"
144.352 - by (rule some_H'h'2 [elim_format]) blast
144.353 - from H'E x' y' have "x + y \<in> H'"
144.354 - by (rule subspace.add_closed)
144.355 - also from graphs have "H' \<subseteq> H" ..
144.356 - finally show ?thesis .
144.357 - qed
144.358 -next
144.359 - fix x a assume x: "x \<in> H"
144.360 - show "a \<cdot> x \<in> H"
144.361 - proof -
144.362 - from M cM graph x
144.363 - obtain H' h' where x': "x \<in> H'" and H'E: "H' \<unlhd> E"
144.364 - and graphs: "graph H' h' \<subseteq> graph H h"
144.365 - by (rule some_H'h' [elim_format]) blast
144.366 - from H'E x' have "a \<cdot> x \<in> H'" by (rule subspace.mult_closed)
144.367 - also from graphs have "H' \<subseteq> H" ..
144.368 - finally show ?thesis .
144.369 - qed
144.370 -qed
144.371 -
144.372 -text {*
144.373 - \medskip The limit function is bounded by the norm @{text p} as
144.374 - well, since all elements in the chain are bounded by @{text p}.
144.375 -*}
144.376 -
144.377 -lemma sup_norm_pres:
144.378 - assumes graph: "graph H h = \<Union>c"
144.379 - and M: "M = norm_pres_extensions E p F f"
144.380 - and cM: "c \<in> chain M"
144.381 - shows "\<forall>x \<in> H. h x \<le> p x"
144.382 -proof
144.383 - fix x assume "x \<in> H"
144.384 - with M cM graph obtain H' h' where x': "x \<in> H'"
144.385 - and graphs: "graph H' h' \<subseteq> graph H h"
144.386 - and a: "\<forall>x \<in> H'. h' x \<le> p x"
144.387 - by (rule some_H'h' [elim_format]) blast
144.388 - from graphs x' have [symmetric]: "h' x = h x" ..
144.389 - also from a x' have "h' x \<le> p x " ..
144.390 - finally show "h x \<le> p x" .
144.391 -qed
144.392 -
144.393 -text {*
144.394 - \medskip The following lemma is a property of linear forms on real
144.395 - vector spaces. It will be used for the lemma @{text abs_HahnBanach}
144.396 - (see page \pageref{abs-HahnBanach}). \label{abs-ineq-iff} For real
144.397 - vector spaces the following inequations are equivalent:
144.398 - \begin{center}
144.399 - \begin{tabular}{lll}
144.400 - @{text "\<forall>x \<in> H. \<bar>h x\<bar> \<le> p x"} & and &
144.401 - @{text "\<forall>x \<in> H. h x \<le> p x"} \\
144.402 - \end{tabular}
144.403 - \end{center}
144.404 -*}
144.405 -
144.406 -lemma abs_ineq_iff:
144.407 - assumes "subspace H E" and "vectorspace E" and "seminorm E p"
144.408 - and "linearform H h"
144.409 - shows "(\<forall>x \<in> H. \<bar>h x\<bar> \<le> p x) = (\<forall>x \<in> H. h x \<le> p x)" (is "?L = ?R")
144.410 -proof
144.411 - interpret subspace H E by fact
144.412 - interpret vectorspace E by fact
144.413 - interpret seminorm E p by fact
144.414 - interpret linearform H h by fact
144.415 - have H: "vectorspace H" using `vectorspace E` ..
144.416 - {
144.417 - assume l: ?L
144.418 - show ?R
144.419 - proof
144.420 - fix x assume x: "x \<in> H"
144.421 - have "h x \<le> \<bar>h x\<bar>" by arith
144.422 - also from l x have "\<dots> \<le> p x" ..
144.423 - finally show "h x \<le> p x" .
144.424 - qed
144.425 - next
144.426 - assume r: ?R
144.427 - show ?L
144.428 - proof
144.429 - fix x assume x: "x \<in> H"
144.430 - show "\<And>a b :: real. - a \<le> b \<Longrightarrow> b \<le> a \<Longrightarrow> \<bar>b\<bar> \<le> a"
144.431 - by arith
144.432 - from `linearform H h` and H x
144.433 - have "- h x = h (- x)" by (rule linearform.neg [symmetric])
144.434 - also
144.435 - from H x have "- x \<in> H" by (rule vectorspace.neg_closed)
144.436 - with r have "h (- x) \<le> p (- x)" ..
144.437 - also have "\<dots> = p x"
144.438 - using `seminorm E p` `vectorspace E`
144.439 - proof (rule seminorm.minus)
144.440 - from x show "x \<in> E" ..
144.441 - qed
144.442 - finally have "- h x \<le> p x" .
144.443 - then show "- p x \<le> h x" by simp
144.444 - from r x show "h x \<le> p x" ..
144.445 - qed
144.446 - }
144.447 -qed
144.448 -
144.449 -end
145.1 --- a/src/HOL/Real/HahnBanach/Linearform.thy Tue Dec 30 08:18:54 2008 +0100
145.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
145.3 @@ -1,60 +0,0 @@
145.4 -(* Title: HOL/Real/HahnBanach/Linearform.thy
145.5 - Author: Gertrud Bauer, TU Munich
145.6 -*)
145.7 -
145.8 -header {* Linearforms *}
145.9 -
145.10 -theory Linearform
145.11 -imports VectorSpace
145.12 -begin
145.13 -
145.14 -text {*
145.15 - A \emph{linear form} is a function on a vector space into the reals
145.16 - that is additive and multiplicative.
145.17 -*}
145.18 -
145.19 -locale linearform =
145.20 - fixes V :: "'a\<Colon>{minus, plus, zero, uminus} set" and f
145.21 - assumes add [iff]: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> f (x + y) = f x + f y"
145.22 - and mult [iff]: "x \<in> V \<Longrightarrow> f (a \<cdot> x) = a * f x"
145.23 -
145.24 -declare linearform.intro [intro?]
145.25 -
145.26 -lemma (in linearform) neg [iff]:
145.27 - assumes "vectorspace V"
145.28 - shows "x \<in> V \<Longrightarrow> f (- x) = - f x"
145.29 -proof -
145.30 - interpret vectorspace V by fact
145.31 - assume x: "x \<in> V"
145.32 - then have "f (- x) = f ((- 1) \<cdot> x)" by (simp add: negate_eq1)
145.33 - also from x have "\<dots> = (- 1) * (f x)" by (rule mult)
145.34 - also from x have "\<dots> = - (f x)" by simp
145.35 - finally show ?thesis .
145.36 -qed
145.37 -
145.38 -lemma (in linearform) diff [iff]:
145.39 - assumes "vectorspace V"
145.40 - shows "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> f (x - y) = f x - f y"
145.41 -proof -
145.42 - interpret vectorspace V by fact
145.43 - assume x: "x \<in> V" and y: "y \<in> V"
145.44 - then have "x - y = x + - y" by (rule diff_eq1)
145.45 - also have "f \<dots> = f x + f (- y)" by (rule add) (simp_all add: x y)
145.46 - also have "f (- y) = - f y" using `vectorspace V` y by (rule neg)
145.47 - finally show ?thesis by simp
145.48 -qed
145.49 -
145.50 -text {* Every linear form yields @{text 0} for the @{text 0} vector. *}
145.51 -
145.52 -lemma (in linearform) zero [iff]:
145.53 - assumes "vectorspace V"
145.54 - shows "f 0 = 0"
145.55 -proof -
145.56 - interpret vectorspace V by fact
145.57 - have "f 0 = f (0 - 0)" by simp
145.58 - also have "\<dots> = f 0 - f 0" using `vectorspace V` by (rule diff) simp_all
145.59 - also have "\<dots> = 0" by simp
145.60 - finally show ?thesis .
145.61 -qed
145.62 -
145.63 -end
146.1 --- a/src/HOL/Real/HahnBanach/NormedSpace.thy Tue Dec 30 08:18:54 2008 +0100
146.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
146.3 @@ -1,117 +0,0 @@
146.4 -(* Title: HOL/Real/HahnBanach/NormedSpace.thy
146.5 - Author: Gertrud Bauer, TU Munich
146.6 -*)
146.7 -
146.8 -header {* Normed vector spaces *}
146.9 -
146.10 -theory NormedSpace
146.11 -imports Subspace
146.12 -begin
146.13 -
146.14 -subsection {* Quasinorms *}
146.15 -
146.16 -text {*
146.17 - A \emph{seminorm} @{text "\<parallel>\<cdot>\<parallel>"} is a function on a real vector space
146.18 - into the reals that has the following properties: it is positive
146.19 - definite, absolute homogenous and subadditive.
146.20 -*}
146.21 -
146.22 -locale norm_syntax =
146.23 - fixes norm :: "'a \<Rightarrow> real" ("\<parallel>_\<parallel>")
146.24 -
146.25 -locale seminorm = var_V + norm_syntax +
146.26 - constrains V :: "'a\<Colon>{minus, plus, zero, uminus} set"
146.27 - assumes ge_zero [iff?]: "x \<in> V \<Longrightarrow> 0 \<le> \<parallel>x\<parallel>"
146.28 - and abs_homogenous [iff?]: "x \<in> V \<Longrightarrow> \<parallel>a \<cdot> x\<parallel> = \<bar>a\<bar> * \<parallel>x\<parallel>"
146.29 - and subadditive [iff?]: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> \<parallel>x + y\<parallel> \<le> \<parallel>x\<parallel> + \<parallel>y\<parallel>"
146.30 -
146.31 -declare seminorm.intro [intro?]
146.32 -
146.33 -lemma (in seminorm) diff_subadditive:
146.34 - assumes "vectorspace V"
146.35 - shows "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> \<parallel>x - y\<parallel> \<le> \<parallel>x\<parallel> + \<parallel>y\<parallel>"
146.36 -proof -
146.37 - interpret vectorspace V by fact
146.38 - assume x: "x \<in> V" and y: "y \<in> V"
146.39 - then have "x - y = x + - 1 \<cdot> y"
146.40 - by (simp add: diff_eq2 negate_eq2a)
146.41 - also from x y have "\<parallel>\<dots>\<parallel> \<le> \<parallel>x\<parallel> + \<parallel>- 1 \<cdot> y\<parallel>"
146.42 - by (simp add: subadditive)
146.43 - also from y have "\<parallel>- 1 \<cdot> y\<parallel> = \<bar>- 1\<bar> * \<parallel>y\<parallel>"
146.44 - by (rule abs_homogenous)
146.45 - also have "\<dots> = \<parallel>y\<parallel>" by simp
146.46 - finally show ?thesis .
146.47 -qed
146.48 -
146.49 -lemma (in seminorm) minus:
146.50 - assumes "vectorspace V"
146.51 - shows "x \<in> V \<Longrightarrow> \<parallel>- x\<parallel> = \<parallel>x\<parallel>"
146.52 -proof -
146.53 - interpret vectorspace V by fact
146.54 - assume x: "x \<in> V"
146.55 - then have "- x = - 1 \<cdot> x" by (simp only: negate_eq1)
146.56 - also from x have "\<parallel>\<dots>\<parallel> = \<bar>- 1\<bar> * \<parallel>x\<parallel>"
146.57 - by (rule abs_homogenous)
146.58 - also have "\<dots> = \<parallel>x\<parallel>" by simp
146.59 - finally show ?thesis .
146.60 -qed
146.61 -
146.62 -
146.63 -subsection {* Norms *}
146.64 -
146.65 -text {*
146.66 - A \emph{norm} @{text "\<parallel>\<cdot>\<parallel>"} is a seminorm that maps only the
146.67 - @{text 0} vector to @{text 0}.
146.68 -*}
146.69 -
146.70 -locale norm = seminorm +
146.71 - assumes zero_iff [iff]: "x \<in> V \<Longrightarrow> (\<parallel>x\<parallel> = 0) = (x = 0)"
146.72 -
146.73 -
146.74 -subsection {* Normed vector spaces *}
146.75 -
146.76 -text {*
146.77 - A vector space together with a norm is called a \emph{normed
146.78 - space}.
146.79 -*}
146.80 -
146.81 -locale normed_vectorspace = vectorspace + norm
146.82 -
146.83 -declare normed_vectorspace.intro [intro?]
146.84 -
146.85 -lemma (in normed_vectorspace) gt_zero [intro?]:
146.86 - "x \<in> V \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> 0 < \<parallel>x\<parallel>"
146.87 -proof -
146.88 - assume x: "x \<in> V" and neq: "x \<noteq> 0"
146.89 - from x have "0 \<le> \<parallel>x\<parallel>" ..
146.90 - also have [symmetric]: "\<dots> \<noteq> 0"
146.91 - proof
146.92 - assume "\<parallel>x\<parallel> = 0"
146.93 - with x have "x = 0" by simp
146.94 - with neq show False by contradiction
146.95 - qed
146.96 - finally show ?thesis .
146.97 -qed
146.98 -
146.99 -text {*
146.100 - Any subspace of a normed vector space is again a normed vectorspace.
146.101 -*}
146.102 -
146.103 -lemma subspace_normed_vs [intro?]:
146.104 - fixes F E norm
146.105 - assumes "subspace F E" "normed_vectorspace E norm"
146.106 - shows "normed_vectorspace F norm"
146.107 -proof -
146.108 - interpret subspace F E by fact
146.109 - interpret normed_vectorspace E norm by fact
146.110 - show ?thesis
146.111 - proof
146.112 - show "vectorspace F" by (rule vectorspace) unfold_locales
146.113 - next
146.114 - have "NormedSpace.norm E norm" ..
146.115 - with subset show "NormedSpace.norm F norm"
146.116 - by (simp add: norm_def seminorm_def norm_axioms_def)
146.117 - qed
146.118 -qed
146.119 -
146.120 -end
147.1 --- a/src/HOL/Real/HahnBanach/README.html Tue Dec 30 08:18:54 2008 +0100
147.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
147.3 @@ -1,38 +0,0 @@
147.4 -<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
147.5 -
147.6 -<!-- $Id$ -->
147.7 -
147.8 -<HTML>
147.9 -
147.10 -<HEAD>
147.11 - <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
147.12 - <TITLE>HOL/Real/HahnBanach/README</TITLE>
147.13 -</HEAD>
147.14 -
147.15 -<BODY>
147.16 -
147.17 -<H3>The Hahn-Banach Theorem for Real Vector Spaces (Isabelle/Isar)</H3>
147.18 -
147.19 -Author: Gertrud Bauer, Technische Universität München<P>
147.20 -
147.21 -This directory contains the proof of the Hahn-Banach theorem for real vectorspaces,
147.22 -following H. Heuser, Funktionalanalysis, p. 228 -232.
147.23 -The Hahn-Banach theorem is one of the fundamental theorems of functioal analysis.
147.24 -It is a conclusion of Zorn's lemma.<P>
147.25 -
147.26 -Two different formaulations of the theorem are presented, one for general real vectorspaces
147.27 -and its application to normed vectorspaces. <P>
147.28 -
147.29 -The theorem says, that every continous linearform, defined on arbitrary subspaces
147.30 -(not only one-dimensional subspaces), can be extended to a continous linearform on
147.31 -the whole vectorspace.
147.32 -
147.33 -
147.34 -<HR>
147.35 -
147.36 -<ADDRESS>
147.37 -<A NAME="bauerg@in.tum.de" HREF="mailto:bauerg@in.tum.de">bauerg@in.tum.de</A>
147.38 -</ADDRESS>
147.39 -
147.40 -</BODY>
147.41 -</HTML>
148.1 --- a/src/HOL/Real/HahnBanach/ROOT.ML Tue Dec 30 08:18:54 2008 +0100
148.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
148.3 @@ -1,8 +0,0 @@
148.4 -(* Title: HOL/Real/HahnBanach/ROOT.ML
148.5 - ID: $Id$
148.6 - Author: Gertrud Bauer, TU Munich
148.7 -
148.8 -The Hahn-Banach theorem for real vector spaces (Isabelle/Isar).
148.9 -*)
148.10 -
148.11 -time_use_thy "HahnBanach";
149.1 --- a/src/HOL/Real/HahnBanach/Subspace.thy Tue Dec 30 08:18:54 2008 +0100
149.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
149.3 @@ -1,513 +0,0 @@
149.4 -(* Title: HOL/Real/HahnBanach/Subspace.thy
149.5 - Author: Gertrud Bauer, TU Munich
149.6 -*)
149.7 -
149.8 -header {* Subspaces *}
149.9 -
149.10 -theory Subspace
149.11 -imports VectorSpace
149.12 -begin
149.13 -
149.14 -subsection {* Definition *}
149.15 -
149.16 -text {*
149.17 - A non-empty subset @{text U} of a vector space @{text V} is a
149.18 - \emph{subspace} of @{text V}, iff @{text U} is closed under addition
149.19 - and scalar multiplication.
149.20 -*}
149.21 -
149.22 -locale subspace =
149.23 - fixes U :: "'a\<Colon>{minus, plus, zero, uminus} set" and V
149.24 - assumes non_empty [iff, intro]: "U \<noteq> {}"
149.25 - and subset [iff]: "U \<subseteq> V"
149.26 - and add_closed [iff]: "x \<in> U \<Longrightarrow> y \<in> U \<Longrightarrow> x + y \<in> U"
149.27 - and mult_closed [iff]: "x \<in> U \<Longrightarrow> a \<cdot> x \<in> U"
149.28 -
149.29 -notation (symbols)
149.30 - subspace (infix "\<unlhd>" 50)
149.31 -
149.32 -declare vectorspace.intro [intro?] subspace.intro [intro?]
149.33 -
149.34 -lemma subspace_subset [elim]: "U \<unlhd> V \<Longrightarrow> U \<subseteq> V"
149.35 - by (rule subspace.subset)
149.36 -
149.37 -lemma (in subspace) subsetD [iff]: "x \<in> U \<Longrightarrow> x \<in> V"
149.38 - using subset by blast
149.39 -
149.40 -lemma subspaceD [elim]: "U \<unlhd> V \<Longrightarrow> x \<in> U \<Longrightarrow> x \<in> V"
149.41 - by (rule subspace.subsetD)
149.42 -
149.43 -lemma rev_subspaceD [elim?]: "x \<in> U \<Longrightarrow> U \<unlhd> V \<Longrightarrow> x \<in> V"
149.44 - by (rule subspace.subsetD)
149.45 -
149.46 -lemma (in subspace) diff_closed [iff]:
149.47 - assumes "vectorspace V"
149.48 - assumes x: "x \<in> U" and y: "y \<in> U"
149.49 - shows "x - y \<in> U"
149.50 -proof -
149.51 - interpret vectorspace V by fact
149.52 - from x y show ?thesis by (simp add: diff_eq1 negate_eq1)
149.53 -qed
149.54 -
149.55 -text {*
149.56 - \medskip Similar as for linear spaces, the existence of the zero
149.57 - element in every subspace follows from the non-emptiness of the
149.58 - carrier set and by vector space laws.
149.59 -*}
149.60 -
149.61 -lemma (in subspace) zero [intro]:
149.62 - assumes "vectorspace V"
149.63 - shows "0 \<in> U"
149.64 -proof -
149.65 - interpret V!: vectorspace V by fact
149.66 - have "U \<noteq> {}" by (rule non_empty)
149.67 - then obtain x where x: "x \<in> U" by blast
149.68 - then have "x \<in> V" .. then have "0 = x - x" by simp
149.69 - also from `vectorspace V` x x have "\<dots> \<in> U" by (rule diff_closed)
149.70 - finally show ?thesis .
149.71 -qed
149.72 -
149.73 -lemma (in subspace) neg_closed [iff]:
149.74 - assumes "vectorspace V"
149.75 - assumes x: "x \<in> U"
149.76 - shows "- x \<in> U"
149.77 -proof -
149.78 - interpret vectorspace V by fact
149.79 - from x show ?thesis by (simp add: negate_eq1)
149.80 -qed
149.81 -
149.82 -text {* \medskip Further derived laws: every subspace is a vector space. *}
149.83 -
149.84 -lemma (in subspace) vectorspace [iff]:
149.85 - assumes "vectorspace V"
149.86 - shows "vectorspace U"
149.87 -proof -
149.88 - interpret vectorspace V by fact
149.89 - show ?thesis
149.90 - proof
149.91 - show "U \<noteq> {}" ..
149.92 - fix x y z assume x: "x \<in> U" and y: "y \<in> U" and z: "z \<in> U"
149.93 - fix a b :: real
149.94 - from x y show "x + y \<in> U" by simp
149.95 - from x show "a \<cdot> x \<in> U" by simp
149.96 - from x y z show "(x + y) + z = x + (y + z)" by (simp add: add_ac)
149.97 - from x y show "x + y = y + x" by (simp add: add_ac)
149.98 - from x show "x - x = 0" by simp
149.99 - from x show "0 + x = x" by simp
149.100 - from x y show "a \<cdot> (x + y) = a \<cdot> x + a \<cdot> y" by (simp add: distrib)
149.101 - from x show "(a + b) \<cdot> x = a \<cdot> x + b \<cdot> x" by (simp add: distrib)
149.102 - from x show "(a * b) \<cdot> x = a \<cdot> b \<cdot> x" by (simp add: mult_assoc)
149.103 - from x show "1 \<cdot> x = x" by simp
149.104 - from x show "- x = - 1 \<cdot> x" by (simp add: negate_eq1)
149.105 - from x y show "x - y = x + - y" by (simp add: diff_eq1)
149.106 - qed
149.107 -qed
149.108 -
149.109 -
149.110 -text {* The subspace relation is reflexive. *}
149.111 -
149.112 -lemma (in vectorspace) subspace_refl [intro]: "V \<unlhd> V"
149.113 -proof
149.114 - show "V \<noteq> {}" ..
149.115 - show "V \<subseteq> V" ..
149.116 - fix x y assume x: "x \<in> V" and y: "y \<in> V"
149.117 - fix a :: real
149.118 - from x y show "x + y \<in> V" by simp
149.119 - from x show "a \<cdot> x \<in> V" by simp
149.120 -qed
149.121 -
149.122 -text {* The subspace relation is transitive. *}
149.123 -
149.124 -lemma (in vectorspace) subspace_trans [trans]:
149.125 - "U \<unlhd> V \<Longrightarrow> V \<unlhd> W \<Longrightarrow> U \<unlhd> W"
149.126 -proof
149.127 - assume uv: "U \<unlhd> V" and vw: "V \<unlhd> W"
149.128 - from uv show "U \<noteq> {}" by (rule subspace.non_empty)
149.129 - show "U \<subseteq> W"
149.130 - proof -
149.131 - from uv have "U \<subseteq> V" by (rule subspace.subset)
149.132 - also from vw have "V \<subseteq> W" by (rule subspace.subset)
149.133 - finally show ?thesis .
149.134 - qed
149.135 - fix x y assume x: "x \<in> U" and y: "y \<in> U"
149.136 - from uv and x y show "x + y \<in> U" by (rule subspace.add_closed)
149.137 - from uv and x show "\<And>a. a \<cdot> x \<in> U" by (rule subspace.mult_closed)
149.138 -qed
149.139 -
149.140 -
149.141 -subsection {* Linear closure *}
149.142 -
149.143 -text {*
149.144 - The \emph{linear closure} of a vector @{text x} is the set of all
149.145 - scalar multiples of @{text x}.
149.146 -*}
149.147 -
149.148 -definition
149.149 - lin :: "('a::{minus, plus, zero}) \<Rightarrow> 'a set" where
149.150 - "lin x = {a \<cdot> x | a. True}"
149.151 -
149.152 -lemma linI [intro]: "y = a \<cdot> x \<Longrightarrow> y \<in> lin x"
149.153 - unfolding lin_def by blast
149.154 -
149.155 -lemma linI' [iff]: "a \<cdot> x \<in> lin x"
149.156 - unfolding lin_def by blast
149.157 -
149.158 -lemma linE [elim]: "x \<in> lin v \<Longrightarrow> (\<And>a::real. x = a \<cdot> v \<Longrightarrow> C) \<Longrightarrow> C"
149.159 - unfolding lin_def by blast
149.160 -
149.161 -
149.162 -text {* Every vector is contained in its linear closure. *}
149.163 -
149.164 -lemma (in vectorspace) x_lin_x [iff]: "x \<in> V \<Longrightarrow> x \<in> lin x"
149.165 -proof -
149.166 - assume "x \<in> V"
149.167 - then have "x = 1 \<cdot> x" by simp
149.168 - also have "\<dots> \<in> lin x" ..
149.169 - finally show ?thesis .
149.170 -qed
149.171 -
149.172 -lemma (in vectorspace) "0_lin_x" [iff]: "x \<in> V \<Longrightarrow> 0 \<in> lin x"
149.173 -proof
149.174 - assume "x \<in> V"
149.175 - then show "0 = 0 \<cdot> x" by simp
149.176 -qed
149.177 -
149.178 -text {* Any linear closure is a subspace. *}
149.179 -
149.180 -lemma (in vectorspace) lin_subspace [intro]:
149.181 - "x \<in> V \<Longrightarrow> lin x \<unlhd> V"
149.182 -proof
149.183 - assume x: "x \<in> V"
149.184 - then show "lin x \<noteq> {}" by (auto simp add: x_lin_x)
149.185 - show "lin x \<subseteq> V"
149.186 - proof
149.187 - fix x' assume "x' \<in> lin x"
149.188 - then obtain a where "x' = a \<cdot> x" ..
149.189 - with x show "x' \<in> V" by simp
149.190 - qed
149.191 - fix x' x'' assume x': "x' \<in> lin x" and x'': "x'' \<in> lin x"
149.192 - show "x' + x'' \<in> lin x"
149.193 - proof -
149.194 - from x' obtain a' where "x' = a' \<cdot> x" ..
149.195 - moreover from x'' obtain a'' where "x'' = a'' \<cdot> x" ..
149.196 - ultimately have "x' + x'' = (a' + a'') \<cdot> x"
149.197 - using x by (simp add: distrib)
149.198 - also have "\<dots> \<in> lin x" ..
149.199 - finally show ?thesis .
149.200 - qed
149.201 - fix a :: real
149.202 - show "a \<cdot> x' \<in> lin x"
149.203 - proof -
149.204 - from x' obtain a' where "x' = a' \<cdot> x" ..
149.205 - with x have "a \<cdot> x' = (a * a') \<cdot> x" by (simp add: mult_assoc)
149.206 - also have "\<dots> \<in> lin x" ..
149.207 - finally show ?thesis .
149.208 - qed
149.209 -qed
149.210 -
149.211 -
149.212 -text {* Any linear closure is a vector space. *}
149.213 -
149.214 -lemma (in vectorspace) lin_vectorspace [intro]:
149.215 - assumes "x \<in> V"
149.216 - shows "vectorspace (lin x)"
149.217 -proof -
149.218 - from `x \<in> V` have "subspace (lin x) V"
149.219 - by (rule lin_subspace)
149.220 - from this and vectorspace_axioms show ?thesis
149.221 - by (rule subspace.vectorspace)
149.222 -qed
149.223 -
149.224 -
149.225 -subsection {* Sum of two vectorspaces *}
149.226 -
149.227 -text {*
149.228 - The \emph{sum} of two vectorspaces @{text U} and @{text V} is the
149.229 - set of all sums of elements from @{text U} and @{text V}.
149.230 -*}
149.231 -
149.232 -instantiation "fun" :: (type, type) plus
149.233 -begin
149.234 -
149.235 -definition
149.236 - sum_def: "plus_fun U V = {u + v | u v. u \<in> U \<and> v \<in> V}" (* FIXME not fully general!? *)
149.237 -
149.238 -instance ..
149.239 -
149.240 -end
149.241 -
149.242 -lemma sumE [elim]:
149.243 - "x \<in> U + V \<Longrightarrow> (\<And>u v. x = u + v \<Longrightarrow> u \<in> U \<Longrightarrow> v \<in> V \<Longrightarrow> C) \<Longrightarrow> C"
149.244 - unfolding sum_def by blast
149.245 -
149.246 -lemma sumI [intro]:
149.247 - "u \<in> U \<Longrightarrow> v \<in> V \<Longrightarrow> x = u + v \<Longrightarrow> x \<in> U + V"
149.248 - unfolding sum_def by blast
149.249 -
149.250 -lemma sumI' [intro]:
149.251 - "u \<in> U \<Longrightarrow> v \<in> V \<Longrightarrow> u + v \<in> U + V"
149.252 - unfolding sum_def by blast
149.253 -
149.254 -text {* @{text U} is a subspace of @{text "U + V"}. *}
149.255 -
149.256 -lemma subspace_sum1 [iff]:
149.257 - assumes "vectorspace U" "vectorspace V"
149.258 - shows "U \<unlhd> U + V"
149.259 -proof -
149.260 - interpret vectorspace U by fact
149.261 - interpret vectorspace V by fact
149.262 - show ?thesis
149.263 - proof
149.264 - show "U \<noteq> {}" ..
149.265 - show "U \<subseteq> U + V"
149.266 - proof
149.267 - fix x assume x: "x \<in> U"
149.268 - moreover have "0 \<in> V" ..
149.269 - ultimately have "x + 0 \<in> U + V" ..
149.270 - with x show "x \<in> U + V" by simp
149.271 - qed
149.272 - fix x y assume x: "x \<in> U" and "y \<in> U"
149.273 - then show "x + y \<in> U" by simp
149.274 - from x show "\<And>a. a \<cdot> x \<in> U" by simp
149.275 - qed
149.276 -qed
149.277 -
149.278 -text {* The sum of two subspaces is again a subspace. *}
149.279 -
149.280 -lemma sum_subspace [intro?]:
149.281 - assumes "subspace U E" "vectorspace E" "subspace V E"
149.282 - shows "U + V \<unlhd> E"
149.283 -proof -
149.284 - interpret subspace U E by fact
149.285 - interpret vectorspace E by fact
149.286 - interpret subspace V E by fact
149.287 - show ?thesis
149.288 - proof
149.289 - have "0 \<in> U + V"
149.290 - proof
149.291 - show "0 \<in> U" using `vectorspace E` ..
149.292 - show "0 \<in> V" using `vectorspace E` ..
149.293 - show "(0::'a) = 0 + 0" by simp
149.294 - qed
149.295 - then show "U + V \<noteq> {}" by blast
149.296 - show "U + V \<subseteq> E"
149.297 - proof
149.298 - fix x assume "x \<in> U + V"
149.299 - then obtain u v where "x = u + v" and
149.300 - "u \<in> U" and "v \<in> V" ..
149.301 - then show "x \<in> E" by simp
149.302 - qed
149.303 - fix x y assume x: "x \<in> U + V" and y: "y \<in> U + V"
149.304 - show "x + y \<in> U + V"
149.305 - proof -
149.306 - from x obtain ux vx where "x = ux + vx" and "ux \<in> U" and "vx \<in> V" ..
149.307 - moreover
149.308 - from y obtain uy vy where "y = uy + vy" and "uy \<in> U" and "vy \<in> V" ..
149.309 - ultimately
149.310 - have "ux + uy \<in> U"
149.311 - and "vx + vy \<in> V"
149.312 - and "x + y = (ux + uy) + (vx + vy)"
149.313 - using x y by (simp_all add: add_ac)
149.314 - then show ?thesis ..
149.315 - qed
149.316 - fix a show "a \<cdot> x \<in> U + V"
149.317 - proof -
149.318 - from x obtain u v where "x = u + v" and "u \<in> U" and "v \<in> V" ..
149.319 - then have "a \<cdot> u \<in> U" and "a \<cdot> v \<in> V"
149.320 - and "a \<cdot> x = (a \<cdot> u) + (a \<cdot> v)" by (simp_all add: distrib)
149.321 - then show ?thesis ..
149.322 - qed
149.323 - qed
149.324 -qed
149.325 -
149.326 -text{* The sum of two subspaces is a vectorspace. *}
149.327 -
149.328 -lemma sum_vs [intro?]:
149.329 - "U \<unlhd> E \<Longrightarrow> V \<unlhd> E \<Longrightarrow> vectorspace E \<Longrightarrow> vectorspace (U + V)"
149.330 - by (rule subspace.vectorspace) (rule sum_subspace)
149.331 -
149.332 -
149.333 -subsection {* Direct sums *}
149.334 -
149.335 -text {*
149.336 - The sum of @{text U} and @{text V} is called \emph{direct}, iff the
149.337 - zero element is the only common element of @{text U} and @{text
149.338 - V}. For every element @{text x} of the direct sum of @{text U} and
149.339 - @{text V} the decomposition in @{text "x = u + v"} with
149.340 - @{text "u \<in> U"} and @{text "v \<in> V"} is unique.
149.341 -*}
149.342 -
149.343 -lemma decomp:
149.344 - assumes "vectorspace E" "subspace U E" "subspace V E"
149.345 - assumes direct: "U \<inter> V = {0}"
149.346 - and u1: "u1 \<in> U" and u2: "u2 \<in> U"
149.347 - and v1: "v1 \<in> V" and v2: "v2 \<in> V"
149.348 - and sum: "u1 + v1 = u2 + v2"
149.349 - shows "u1 = u2 \<and> v1 = v2"
149.350 -proof -
149.351 - interpret vectorspace E by fact
149.352 - interpret subspace U E by fact
149.353 - interpret subspace V E by fact
149.354 - show ?thesis
149.355 - proof
149.356 - have U: "vectorspace U" (* FIXME: use interpret *)
149.357 - using `subspace U E` `vectorspace E` by (rule subspace.vectorspace)
149.358 - have V: "vectorspace V"
149.359 - using `subspace V E` `vectorspace E` by (rule subspace.vectorspace)
149.360 - from u1 u2 v1 v2 and sum have eq: "u1 - u2 = v2 - v1"
149.361 - by (simp add: add_diff_swap)
149.362 - from u1 u2 have u: "u1 - u2 \<in> U"
149.363 - by (rule vectorspace.diff_closed [OF U])
149.364 - with eq have v': "v2 - v1 \<in> U" by (simp only:)
149.365 - from v2 v1 have v: "v2 - v1 \<in> V"
149.366 - by (rule vectorspace.diff_closed [OF V])
149.367 - with eq have u': " u1 - u2 \<in> V" by (simp only:)
149.368 -
149.369 - show "u1 = u2"
149.370 - proof (rule add_minus_eq)
149.371 - from u1 show "u1 \<in> E" ..
149.372 - from u2 show "u2 \<in> E" ..
149.373 - from u u' and direct show "u1 - u2 = 0" by blast
149.374 - qed
149.375 - show "v1 = v2"
149.376 - proof (rule add_minus_eq [symmetric])
149.377 - from v1 show "v1 \<in> E" ..
149.378 - from v2 show "v2 \<in> E" ..
149.379 - from v v' and direct show "v2 - v1 = 0" by blast
149.380 - qed
149.381 - qed
149.382 -qed
149.383 -
149.384 -text {*
149.385 - An application of the previous lemma will be used in the proof of
149.386 - the Hahn-Banach Theorem (see page \pageref{decomp-H-use}): for any
149.387 - element @{text "y + a \<cdot> x\<^sub>0"} of the direct sum of a
149.388 - vectorspace @{text H} and the linear closure of @{text "x\<^sub>0"}
149.389 - the components @{text "y \<in> H"} and @{text a} are uniquely
149.390 - determined.
149.391 -*}
149.392 -
149.393 -lemma decomp_H':
149.394 - assumes "vectorspace E" "subspace H E"
149.395 - assumes y1: "y1 \<in> H" and y2: "y2 \<in> H"
149.396 - and x': "x' \<notin> H" "x' \<in> E" "x' \<noteq> 0"
149.397 - and eq: "y1 + a1 \<cdot> x' = y2 + a2 \<cdot> x'"
149.398 - shows "y1 = y2 \<and> a1 = a2"
149.399 -proof -
149.400 - interpret vectorspace E by fact
149.401 - interpret subspace H E by fact
149.402 - show ?thesis
149.403 - proof
149.404 - have c: "y1 = y2 \<and> a1 \<cdot> x' = a2 \<cdot> x'"
149.405 - proof (rule decomp)
149.406 - show "a1 \<cdot> x' \<in> lin x'" ..
149.407 - show "a2 \<cdot> x' \<in> lin x'" ..
149.408 - show "H \<inter> lin x' = {0}"
149.409 - proof
149.410 - show "H \<inter> lin x' \<subseteq> {0}"
149.411 - proof
149.412 - fix x assume x: "x \<in> H \<inter> lin x'"
149.413 - then obtain a where xx': "x = a \<cdot> x'"
149.414 - by blast
149.415 - have "x = 0"
149.416 - proof cases
149.417 - assume "a = 0"
149.418 - with xx' and x' show ?thesis by simp
149.419 - next
149.420 - assume a: "a \<noteq> 0"
149.421 - from x have "x \<in> H" ..
149.422 - with xx' have "inverse a \<cdot> a \<cdot> x' \<in> H" by simp
149.423 - with a and x' have "x' \<in> H" by (simp add: mult_assoc2)
149.424 - with `x' \<notin> H` show ?thesis by contradiction
149.425 - qed
149.426 - then show "x \<in> {0}" ..
149.427 - qed
149.428 - show "{0} \<subseteq> H \<inter> lin x'"
149.429 - proof -
149.430 - have "0 \<in> H" using `vectorspace E` ..
149.431 - moreover have "0 \<in> lin x'" using `x' \<in> E` ..
149.432 - ultimately show ?thesis by blast
149.433 - qed
149.434 - qed
149.435 - show "lin x' \<unlhd> E" using `x' \<in> E` ..
149.436 - qed (rule `vectorspace E`, rule `subspace H E`, rule y1, rule y2, rule eq)
149.437 - then show "y1 = y2" ..
149.438 - from c have "a1 \<cdot> x' = a2 \<cdot> x'" ..
149.439 - with x' show "a1 = a2" by (simp add: mult_right_cancel)
149.440 - qed
149.441 -qed
149.442 -
149.443 -text {*
149.444 - Since for any element @{text "y + a \<cdot> x'"} of the direct sum of a
149.445 - vectorspace @{text H} and the linear closure of @{text x'} the
149.446 - components @{text "y \<in> H"} and @{text a} are unique, it follows from
149.447 - @{text "y \<in> H"} that @{text "a = 0"}.
149.448 -*}
149.449 -
149.450 -lemma decomp_H'_H:
149.451 - assumes "vectorspace E" "subspace H E"
149.452 - assumes t: "t \<in> H"
149.453 - and x': "x' \<notin> H" "x' \<in> E" "x' \<noteq> 0"
149.454 - shows "(SOME (y, a). t = y + a \<cdot> x' \<and> y \<in> H) = (t, 0)"
149.455 -proof -
149.456 - interpret vectorspace E by fact
149.457 - interpret subspace H E by fact
149.458 - show ?thesis
149.459 - proof (rule, simp_all only: split_paired_all split_conv)
149.460 - from t x' show "t = t + 0 \<cdot> x' \<and> t \<in> H" by simp
149.461 - fix y and a assume ya: "t = y + a \<cdot> x' \<and> y \<in> H"
149.462 - have "y = t \<and> a = 0"
149.463 - proof (rule decomp_H')
149.464 - from ya x' show "y + a \<cdot> x' = t + 0 \<cdot> x'" by simp
149.465 - from ya show "y \<in> H" ..
149.466 - qed (rule `vectorspace E`, rule `subspace H E`, rule t, (rule x')+)
149.467 - with t x' show "(y, a) = (y + a \<cdot> x', 0)" by simp
149.468 - qed
149.469 -qed
149.470 -
149.471 -text {*
149.472 - The components @{text "y \<in> H"} and @{text a} in @{text "y + a \<cdot> x'"}
149.473 - are unique, so the function @{text h'} defined by
149.474 - @{text "h' (y + a \<cdot> x') = h y + a \<cdot> \<xi>"} is definite.
149.475 -*}
149.476 -
149.477 -lemma h'_definite:
149.478 - fixes H
149.479 - assumes h'_def:
149.480 - "h' \<equiv> (\<lambda>x. let (y, a) = SOME (y, a). (x = y + a \<cdot> x' \<and> y \<in> H)
149.481 - in (h y) + a * xi)"
149.482 - and x: "x = y + a \<cdot> x'"
149.483 - assumes "vectorspace E" "subspace H E"
149.484 - assumes y: "y \<in> H"
149.485 - and x': "x' \<notin> H" "x' \<in> E" "x' \<noteq> 0"
149.486 - shows "h' x = h y + a * xi"
149.487 -proof -
149.488 - interpret vectorspace E by fact
149.489 - interpret subspace H E by fact
149.490 - from x y x' have "x \<in> H + lin x'" by auto
149.491 - have "\<exists>!p. (\<lambda>(y, a). x = y + a \<cdot> x' \<and> y \<in> H) p" (is "\<exists>!p. ?P p")
149.492 - proof (rule ex_ex1I)
149.493 - from x y show "\<exists>p. ?P p" by blast
149.494 - fix p q assume p: "?P p" and q: "?P q"
149.495 - show "p = q"
149.496 - proof -
149.497 - from p have xp: "x = fst p + snd p \<cdot> x' \<and> fst p \<in> H"
149.498 - by (cases p) simp
149.499 - from q have xq: "x = fst q + snd q \<cdot> x' \<and> fst q \<in> H"
149.500 - by (cases q) simp
149.501 - have "fst p = fst q \<and> snd p = snd q"
149.502 - proof (rule decomp_H')
149.503 - from xp show "fst p \<in> H" ..
149.504 - from xq show "fst q \<in> H" ..
149.505 - from xp and xq show "fst p + snd p \<cdot> x' = fst q + snd q \<cdot> x'"
149.506 - by simp
149.507 - qed (rule `vectorspace E`, rule `subspace H E`, (rule x')+)
149.508 - then show ?thesis by (cases p, cases q) simp
149.509 - qed
149.510 - qed
149.511 - then have eq: "(SOME (y, a). x = y + a \<cdot> x' \<and> y \<in> H) = (y, a)"
149.512 - by (rule some1_equality) (simp add: x y)
149.513 - with h'_def show "h' x = h y + a * xi" by (simp add: Let_def)
149.514 -qed
149.515 -
149.516 -end
150.1 --- a/src/HOL/Real/HahnBanach/VectorSpace.thy Tue Dec 30 08:18:54 2008 +0100
150.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
150.3 @@ -1,419 +0,0 @@
150.4 -(* Title: HOL/Real/HahnBanach/VectorSpace.thy
150.5 - ID: $Id$
150.6 - Author: Gertrud Bauer, TU Munich
150.7 -*)
150.8 -
150.9 -header {* Vector spaces *}
150.10 -
150.11 -theory VectorSpace
150.12 -imports Real Bounds Zorn
150.13 -begin
150.14 -
150.15 -subsection {* Signature *}
150.16 -
150.17 -text {*
150.18 - For the definition of real vector spaces a type @{typ 'a} of the
150.19 - sort @{text "{plus, minus, zero}"} is considered, on which a real
150.20 - scalar multiplication @{text \<cdot>} is declared.
150.21 -*}
150.22 -
150.23 -consts
150.24 - prod :: "real \<Rightarrow> 'a::{plus, minus, zero} \<Rightarrow> 'a" (infixr "'(*')" 70)
150.25 -
150.26 -notation (xsymbols)
150.27 - prod (infixr "\<cdot>" 70)
150.28 -notation (HTML output)
150.29 - prod (infixr "\<cdot>" 70)
150.30 -
150.31 -
150.32 -subsection {* Vector space laws *}
150.33 -
150.34 -text {*
150.35 - A \emph{vector space} is a non-empty set @{text V} of elements from
150.36 - @{typ 'a} with the following vector space laws: The set @{text V} is
150.37 - closed under addition and scalar multiplication, addition is
150.38 - associative and commutative; @{text "- x"} is the inverse of @{text
150.39 - x} w.~r.~t.~addition and @{text 0} is the neutral element of
150.40 - addition. Addition and multiplication are distributive; scalar
150.41 - multiplication is associative and the real number @{text "1"} is
150.42 - the neutral element of scalar multiplication.
150.43 -*}
150.44 -
150.45 -locale var_V = fixes V
150.46 -
150.47 -locale vectorspace = var_V +
150.48 - assumes non_empty [iff, intro?]: "V \<noteq> {}"
150.49 - and add_closed [iff]: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x + y \<in> V"
150.50 - and mult_closed [iff]: "x \<in> V \<Longrightarrow> a \<cdot> x \<in> V"
150.51 - and add_assoc: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> z \<in> V \<Longrightarrow> (x + y) + z = x + (y + z)"
150.52 - and add_commute: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x + y = y + x"
150.53 - and diff_self [simp]: "x \<in> V \<Longrightarrow> x - x = 0"
150.54 - and add_zero_left [simp]: "x \<in> V \<Longrightarrow> 0 + x = x"
150.55 - and add_mult_distrib1: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> a \<cdot> (x + y) = a \<cdot> x + a \<cdot> y"
150.56 - and add_mult_distrib2: "x \<in> V \<Longrightarrow> (a + b) \<cdot> x = a \<cdot> x + b \<cdot> x"
150.57 - and mult_assoc: "x \<in> V \<Longrightarrow> (a * b) \<cdot> x = a \<cdot> (b \<cdot> x)"
150.58 - and mult_1 [simp]: "x \<in> V \<Longrightarrow> 1 \<cdot> x = x"
150.59 - and negate_eq1: "x \<in> V \<Longrightarrow> - x = (- 1) \<cdot> x"
150.60 - and diff_eq1: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x - y = x + - y"
150.61 -
150.62 -lemma (in vectorspace) negate_eq2: "x \<in> V \<Longrightarrow> (- 1) \<cdot> x = - x"
150.63 - by (rule negate_eq1 [symmetric])
150.64 -
150.65 -lemma (in vectorspace) negate_eq2a: "x \<in> V \<Longrightarrow> -1 \<cdot> x = - x"
150.66 - by (simp add: negate_eq1)
150.67 -
150.68 -lemma (in vectorspace) diff_eq2: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x + - y = x - y"
150.69 - by (rule diff_eq1 [symmetric])
150.70 -
150.71 -lemma (in vectorspace) diff_closed [iff]: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x - y \<in> V"
150.72 - by (simp add: diff_eq1 negate_eq1)
150.73 -
150.74 -lemma (in vectorspace) neg_closed [iff]: "x \<in> V \<Longrightarrow> - x \<in> V"
150.75 - by (simp add: negate_eq1)
150.76 -
150.77 -lemma (in vectorspace) add_left_commute:
150.78 - "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> z \<in> V \<Longrightarrow> x + (y + z) = y + (x + z)"
150.79 -proof -
150.80 - assume xyz: "x \<in> V" "y \<in> V" "z \<in> V"
150.81 - then have "x + (y + z) = (x + y) + z"
150.82 - by (simp only: add_assoc)
150.83 - also from xyz have "\<dots> = (y + x) + z" by (simp only: add_commute)
150.84 - also from xyz have "\<dots> = y + (x + z)" by (simp only: add_assoc)
150.85 - finally show ?thesis .
150.86 -qed
150.87 -
150.88 -theorems (in vectorspace) add_ac =
150.89 - add_assoc add_commute add_left_commute
150.90 -
150.91 -
150.92 -text {* The existence of the zero element of a vector space
150.93 - follows from the non-emptiness of carrier set. *}
150.94 -
150.95 -lemma (in vectorspace) zero [iff]: "0 \<in> V"
150.96 -proof -
150.97 - from non_empty obtain x where x: "x \<in> V" by blast
150.98 - then have "0 = x - x" by (rule diff_self [symmetric])
150.99 - also from x x have "\<dots> \<in> V" by (rule diff_closed)
150.100 - finally show ?thesis .
150.101 -qed
150.102 -
150.103 -lemma (in vectorspace) add_zero_right [simp]:
150.104 - "x \<in> V \<Longrightarrow> x + 0 = x"
150.105 -proof -
150.106 - assume x: "x \<in> V"
150.107 - from this and zero have "x + 0 = 0 + x" by (rule add_commute)
150.108 - also from x have "\<dots> = x" by (rule add_zero_left)
150.109 - finally show ?thesis .
150.110 -qed
150.111 -
150.112 -lemma (in vectorspace) mult_assoc2:
150.113 - "x \<in> V \<Longrightarrow> a \<cdot> b \<cdot> x = (a * b) \<cdot> x"
150.114 - by (simp only: mult_assoc)
150.115 -
150.116 -lemma (in vectorspace) diff_mult_distrib1:
150.117 - "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> a \<cdot> (x - y) = a \<cdot> x - a \<cdot> y"
150.118 - by (simp add: diff_eq1 negate_eq1 add_mult_distrib1 mult_assoc2)
150.119 -
150.120 -lemma (in vectorspace) diff_mult_distrib2:
150.121 - "x \<in> V \<Longrightarrow> (a - b) \<cdot> x = a \<cdot> x - (b \<cdot> x)"
150.122 -proof -
150.123 - assume x: "x \<in> V"
150.124 - have " (a - b) \<cdot> x = (a + - b) \<cdot> x"
150.125 - by (simp add: real_diff_def)
150.126 - also from x have "\<dots> = a \<cdot> x + (- b) \<cdot> x"
150.127 - by (rule add_mult_distrib2)
150.128 - also from x have "\<dots> = a \<cdot> x + - (b \<cdot> x)"
150.129 - by (simp add: negate_eq1 mult_assoc2)
150.130 - also from x have "\<dots> = a \<cdot> x - (b \<cdot> x)"
150.131 - by (simp add: diff_eq1)
150.132 - finally show ?thesis .
150.133 -qed
150.134 -
150.135 -lemmas (in vectorspace) distrib =
150.136 - add_mult_distrib1 add_mult_distrib2
150.137 - diff_mult_distrib1 diff_mult_distrib2
150.138 -
150.139 -
150.140 -text {* \medskip Further derived laws: *}
150.141 -
150.142 -lemma (in vectorspace) mult_zero_left [simp]:
150.143 - "x \<in> V \<Longrightarrow> 0 \<cdot> x = 0"
150.144 -proof -
150.145 - assume x: "x \<in> V"
150.146 - have "0 \<cdot> x = (1 - 1) \<cdot> x" by simp
150.147 - also have "\<dots> = (1 + - 1) \<cdot> x" by simp
150.148 - also from x have "\<dots> = 1 \<cdot> x + (- 1) \<cdot> x"
150.149 - by (rule add_mult_distrib2)
150.150 - also from x have "\<dots> = x + (- 1) \<cdot> x" by simp
150.151 - also from x have "\<dots> = x + - x" by (simp add: negate_eq2a)
150.152 - also from x have "\<dots> = x - x" by (simp add: diff_eq2)
150.153 - also from x have "\<dots> = 0" by simp
150.154 - finally show ?thesis .
150.155 -qed
150.156 -
150.157 -lemma (in vectorspace) mult_zero_right [simp]:
150.158 - "a \<cdot> 0 = (0::'a)"
150.159 -proof -
150.160 - have "a \<cdot> 0 = a \<cdot> (0 - (0::'a))" by simp
150.161 - also have "\<dots> = a \<cdot> 0 - a \<cdot> 0"
150.162 - by (rule diff_mult_distrib1) simp_all
150.163 - also have "\<dots> = 0" by simp
150.164 - finally show ?thesis .
150.165 -qed
150.166 -
150.167 -lemma (in vectorspace) minus_mult_cancel [simp]:
150.168 - "x \<in> V \<Longrightarrow> (- a) \<cdot> - x = a \<cdot> x"
150.169 - by (simp add: negate_eq1 mult_assoc2)
150.170 -
150.171 -lemma (in vectorspace) add_minus_left_eq_diff:
150.172 - "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> - x + y = y - x"
150.173 -proof -
150.174 - assume xy: "x \<in> V" "y \<in> V"
150.175 - then have "- x + y = y + - x" by (simp add: add_commute)
150.176 - also from xy have "\<dots> = y - x" by (simp add: diff_eq1)
150.177 - finally show ?thesis .
150.178 -qed
150.179 -
150.180 -lemma (in vectorspace) add_minus [simp]:
150.181 - "x \<in> V \<Longrightarrow> x + - x = 0"
150.182 - by (simp add: diff_eq2)
150.183 -
150.184 -lemma (in vectorspace) add_minus_left [simp]:
150.185 - "x \<in> V \<Longrightarrow> - x + x = 0"
150.186 - by (simp add: diff_eq2 add_commute)
150.187 -
150.188 -lemma (in vectorspace) minus_minus [simp]:
150.189 - "x \<in> V \<Longrightarrow> - (- x) = x"
150.190 - by (simp add: negate_eq1 mult_assoc2)
150.191 -
150.192 -lemma (in vectorspace) minus_zero [simp]:
150.193 - "- (0::'a) = 0"
150.194 - by (simp add: negate_eq1)
150.195 -
150.196 -lemma (in vectorspace) minus_zero_iff [simp]:
150.197 - "x \<in> V \<Longrightarrow> (- x = 0) = (x = 0)"
150.198 -proof
150.199 - assume x: "x \<in> V"
150.200 - {
150.201 - from x have "x = - (- x)" by (simp add: minus_minus)
150.202 - also assume "- x = 0"
150.203 - also have "- \<dots> = 0" by (rule minus_zero)
150.204 - finally show "x = 0" .
150.205 - next
150.206 - assume "x = 0"
150.207 - then show "- x = 0" by simp
150.208 - }
150.209 -qed
150.210 -
150.211 -lemma (in vectorspace) add_minus_cancel [simp]:
150.212 - "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x + (- x + y) = y"
150.213 - by (simp add: add_assoc [symmetric] del: add_commute)
150.214 -
150.215 -lemma (in vectorspace) minus_add_cancel [simp]:
150.216 - "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> - x + (x + y) = y"
150.217 - by (simp add: add_assoc [symmetric] del: add_commute)
150.218 -
150.219 -lemma (in vectorspace) minus_add_distrib [simp]:
150.220 - "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> - (x + y) = - x + - y"
150.221 - by (simp add: negate_eq1 add_mult_distrib1)
150.222 -
150.223 -lemma (in vectorspace) diff_zero [simp]:
150.224 - "x \<in> V \<Longrightarrow> x - 0 = x"
150.225 - by (simp add: diff_eq1)
150.226 -
150.227 -lemma (in vectorspace) diff_zero_right [simp]:
150.228 - "x \<in> V \<Longrightarrow> 0 - x = - x"
150.229 - by (simp add: diff_eq1)
150.230 -
150.231 -lemma (in vectorspace) add_left_cancel:
150.232 - "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> z \<in> V \<Longrightarrow> (x + y = x + z) = (y = z)"
150.233 -proof
150.234 - assume x: "x \<in> V" and y: "y \<in> V" and z: "z \<in> V"
150.235 - {
150.236 - from y have "y = 0 + y" by simp
150.237 - also from x y have "\<dots> = (- x + x) + y" by simp
150.238 - also from x y have "\<dots> = - x + (x + y)"
150.239 - by (simp add: add_assoc neg_closed)
150.240 - also assume "x + y = x + z"
150.241 - also from x z have "- x + (x + z) = - x + x + z"
150.242 - by (simp add: add_assoc [symmetric] neg_closed)
150.243 - also from x z have "\<dots> = z" by simp
150.244 - finally show "y = z" .
150.245 - next
150.246 - assume "y = z"
150.247 - then show "x + y = x + z" by (simp only:)
150.248 - }
150.249 -qed
150.250 -
150.251 -lemma (in vectorspace) add_right_cancel:
150.252 - "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> z \<in> V \<Longrightarrow> (y + x = z + x) = (y = z)"
150.253 - by (simp only: add_commute add_left_cancel)
150.254 -
150.255 -lemma (in vectorspace) add_assoc_cong:
150.256 - "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x' \<in> V \<Longrightarrow> y' \<in> V \<Longrightarrow> z \<in> V
150.257 - \<Longrightarrow> x + y = x' + y' \<Longrightarrow> x + (y + z) = x' + (y' + z)"
150.258 - by (simp only: add_assoc [symmetric])
150.259 -
150.260 -lemma (in vectorspace) mult_left_commute:
150.261 - "x \<in> V \<Longrightarrow> a \<cdot> b \<cdot> x = b \<cdot> a \<cdot> x"
150.262 - by (simp add: real_mult_commute mult_assoc2)
150.263 -
150.264 -lemma (in vectorspace) mult_zero_uniq:
150.265 - "x \<in> V \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> a \<cdot> x = 0 \<Longrightarrow> a = 0"
150.266 -proof (rule classical)
150.267 - assume a: "a \<noteq> 0"
150.268 - assume x: "x \<in> V" "x \<noteq> 0" and ax: "a \<cdot> x = 0"
150.269 - from x a have "x = (inverse a * a) \<cdot> x" by simp
150.270 - also from `x \<in> V` have "\<dots> = inverse a \<cdot> (a \<cdot> x)" by (rule mult_assoc)
150.271 - also from ax have "\<dots> = inverse a \<cdot> 0" by simp
150.272 - also have "\<dots> = 0" by simp
150.273 - finally have "x = 0" .
150.274 - with `x \<noteq> 0` show "a = 0" by contradiction
150.275 -qed
150.276 -
150.277 -lemma (in vectorspace) mult_left_cancel:
150.278 - "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> a \<noteq> 0 \<Longrightarrow> (a \<cdot> x = a \<cdot> y) = (x = y)"
150.279 -proof
150.280 - assume x: "x \<in> V" and y: "y \<in> V" and a: "a \<noteq> 0"
150.281 - from x have "x = 1 \<cdot> x" by simp
150.282 - also from a have "\<dots> = (inverse a * a) \<cdot> x" by simp
150.283 - also from x have "\<dots> = inverse a \<cdot> (a \<cdot> x)"
150.284 - by (simp only: mult_assoc)
150.285 - also assume "a \<cdot> x = a \<cdot> y"
150.286 - also from a y have "inverse a \<cdot> \<dots> = y"
150.287 - by (simp add: mult_assoc2)
150.288 - finally show "x = y" .
150.289 -next
150.290 - assume "x = y"
150.291 - then show "a \<cdot> x = a \<cdot> y" by (simp only:)
150.292 -qed
150.293 -
150.294 -lemma (in vectorspace) mult_right_cancel:
150.295 - "x \<in> V \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> (a \<cdot> x = b \<cdot> x) = (a = b)"
150.296 -proof
150.297 - assume x: "x \<in> V" and neq: "x \<noteq> 0"
150.298 - {
150.299 - from x have "(a - b) \<cdot> x = a \<cdot> x - b \<cdot> x"
150.300 - by (simp add: diff_mult_distrib2)
150.301 - also assume "a \<cdot> x = b \<cdot> x"
150.302 - with x have "a \<cdot> x - b \<cdot> x = 0" by simp
150.303 - finally have "(a - b) \<cdot> x = 0" .
150.304 - with x neq have "a - b = 0" by (rule mult_zero_uniq)
150.305 - then show "a = b" by simp
150.306 - next
150.307 - assume "a = b"
150.308 - then show "a \<cdot> x = b \<cdot> x" by (simp only:)
150.309 - }
150.310 -qed
150.311 -
150.312 -lemma (in vectorspace) eq_diff_eq:
150.313 - "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> z \<in> V \<Longrightarrow> (x = z - y) = (x + y = z)"
150.314 -proof
150.315 - assume x: "x \<in> V" and y: "y \<in> V" and z: "z \<in> V"
150.316 - {
150.317 - assume "x = z - y"
150.318 - then have "x + y = z - y + y" by simp
150.319 - also from y z have "\<dots> = z + - y + y"
150.320 - by (simp add: diff_eq1)
150.321 - also have "\<dots> = z + (- y + y)"
150.322 - by (rule add_assoc) (simp_all add: y z)
150.323 - also from y z have "\<dots> = z + 0"
150.324 - by (simp only: add_minus_left)
150.325 - also from z have "\<dots> = z"
150.326 - by (simp only: add_zero_right)
150.327 - finally show "x + y = z" .
150.328 - next
150.329 - assume "x + y = z"
150.330 - then have "z - y = (x + y) - y" by simp
150.331 - also from x y have "\<dots> = x + y + - y"
150.332 - by (simp add: diff_eq1)
150.333 - also have "\<dots> = x + (y + - y)"
150.334 - by (rule add_assoc) (simp_all add: x y)
150.335 - also from x y have "\<dots> = x" by simp
150.336 - finally show "x = z - y" ..
150.337 - }
150.338 -qed
150.339 -
150.340 -lemma (in vectorspace) add_minus_eq_minus:
150.341 - "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x + y = 0 \<Longrightarrow> x = - y"
150.342 -proof -
150.343 - assume x: "x \<in> V" and y: "y \<in> V"
150.344 - from x y have "x = (- y + y) + x" by simp
150.345 - also from x y have "\<dots> = - y + (x + y)" by (simp add: add_ac)
150.346 - also assume "x + y = 0"
150.347 - also from y have "- y + 0 = - y" by simp
150.348 - finally show "x = - y" .
150.349 -qed
150.350 -
150.351 -lemma (in vectorspace) add_minus_eq:
150.352 - "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x - y = 0 \<Longrightarrow> x = y"
150.353 -proof -
150.354 - assume x: "x \<in> V" and y: "y \<in> V"
150.355 - assume "x - y = 0"
150.356 - with x y have eq: "x + - y = 0" by (simp add: diff_eq1)
150.357 - with _ _ have "x = - (- y)"
150.358 - by (rule add_minus_eq_minus) (simp_all add: x y)
150.359 - with x y show "x = y" by simp
150.360 -qed
150.361 -
150.362 -lemma (in vectorspace) add_diff_swap:
150.363 - "a \<in> V \<Longrightarrow> b \<in> V \<Longrightarrow> c \<in> V \<Longrightarrow> d \<in> V \<Longrightarrow> a + b = c + d
150.364 - \<Longrightarrow> a - c = d - b"
150.365 -proof -
150.366 - assume vs: "a \<in> V" "b \<in> V" "c \<in> V" "d \<in> V"
150.367 - and eq: "a + b = c + d"
150.368 - then have "- c + (a + b) = - c + (c + d)"
150.369 - by (simp add: add_left_cancel)
150.370 - also have "\<dots> = d" using `c \<in> V` `d \<in> V` by (rule minus_add_cancel)
150.371 - finally have eq: "- c + (a + b) = d" .
150.372 - from vs have "a - c = (- c + (a + b)) + - b"
150.373 - by (simp add: add_ac diff_eq1)
150.374 - also from vs eq have "\<dots> = d + - b"
150.375 - by (simp add: add_right_cancel)
150.376 - also from vs have "\<dots> = d - b" by (simp add: diff_eq2)
150.377 - finally show "a - c = d - b" .
150.378 -qed
150.379 -
150.380 -lemma (in vectorspace) vs_add_cancel_21:
150.381 - "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> z \<in> V \<Longrightarrow> u \<in> V
150.382 - \<Longrightarrow> (x + (y + z) = y + u) = (x + z = u)"
150.383 -proof
150.384 - assume vs: "x \<in> V" "y \<in> V" "z \<in> V" "u \<in> V"
150.385 - {
150.386 - from vs have "x + z = - y + y + (x + z)" by simp
150.387 - also have "\<dots> = - y + (y + (x + z))"
150.388 - by (rule add_assoc) (simp_all add: vs)
150.389 - also from vs have "y + (x + z) = x + (y + z)"
150.390 - by (simp add: add_ac)
150.391 - also assume "x + (y + z) = y + u"
150.392 - also from vs have "- y + (y + u) = u" by simp
150.393 - finally show "x + z = u" .
150.394 - next
150.395 - assume "x + z = u"
150.396 - with vs show "x + (y + z) = y + u"
150.397 - by (simp only: add_left_commute [of x])
150.398 - }
150.399 -qed
150.400 -
150.401 -lemma (in vectorspace) add_cancel_end:
150.402 - "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> z \<in> V \<Longrightarrow> (x + (y + z) = y) = (x = - z)"
150.403 -proof
150.404 - assume vs: "x \<in> V" "y \<in> V" "z \<in> V"
150.405 - {
150.406 - assume "x + (y + z) = y"
150.407 - with vs have "(x + z) + y = 0 + y"
150.408 - by (simp add: add_ac)
150.409 - with vs have "x + z = 0"
150.410 - by (simp only: add_right_cancel add_closed zero)
150.411 - with vs show "x = - z" by (simp add: add_minus_eq_minus)
150.412 - next
150.413 - assume eq: "x = - z"
150.414 - then have "x + (y + z) = - z + (y + z)" by simp
150.415 - also have "\<dots> = y + (- z + z)"
150.416 - by (rule add_left_commute) (simp_all add: vs)
150.417 - also from vs have "\<dots> = y" by simp
150.418 - finally show "x + (y + z) = y" .
150.419 - }
150.420 -qed
150.421 -
150.422 -end
151.1 --- a/src/HOL/Real/HahnBanach/ZornLemma.thy Tue Dec 30 08:18:54 2008 +0100
151.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
151.3 @@ -1,57 +0,0 @@
151.4 -(* Title: HOL/Real/HahnBanach/ZornLemma.thy
151.5 - Author: Gertrud Bauer, TU Munich
151.6 -*)
151.7 -
151.8 -header {* Zorn's Lemma *}
151.9 -
151.10 -theory ZornLemma
151.11 -imports Zorn
151.12 -begin
151.13 -
151.14 -text {*
151.15 - Zorn's Lemmas states: if every linear ordered subset of an ordered
151.16 - set @{text S} has an upper bound in @{text S}, then there exists a
151.17 - maximal element in @{text S}. In our application, @{text S} is a
151.18 - set of sets ordered by set inclusion. Since the union of a chain of
151.19 - sets is an upper bound for all elements of the chain, the conditions
151.20 - of Zorn's lemma can be modified: if @{text S} is non-empty, it
151.21 - suffices to show that for every non-empty chain @{text c} in @{text
151.22 - S} the union of @{text c} also lies in @{text S}.
151.23 -*}
151.24 -
151.25 -theorem Zorn's_Lemma:
151.26 - assumes r: "\<And>c. c \<in> chain S \<Longrightarrow> \<exists>x. x \<in> c \<Longrightarrow> \<Union>c \<in> S"
151.27 - and aS: "a \<in> S"
151.28 - shows "\<exists>y \<in> S. \<forall>z \<in> S. y \<subseteq> z \<longrightarrow> y = z"
151.29 -proof (rule Zorn_Lemma2)
151.30 - show "\<forall>c \<in> chain S. \<exists>y \<in> S. \<forall>z \<in> c. z \<subseteq> y"
151.31 - proof
151.32 - fix c assume "c \<in> chain S"
151.33 - show "\<exists>y \<in> S. \<forall>z \<in> c. z \<subseteq> y"
151.34 - proof cases
151.35 -
151.36 - txt {* If @{text c} is an empty chain, then every element in
151.37 - @{text S} is an upper bound of @{text c}. *}
151.38 -
151.39 - assume "c = {}"
151.40 - with aS show ?thesis by fast
151.41 -
151.42 - txt {* If @{text c} is non-empty, then @{text "\<Union>c"} is an upper
151.43 - bound of @{text c}, lying in @{text S}. *}
151.44 -
151.45 - next
151.46 - assume "c \<noteq> {}"
151.47 - show ?thesis
151.48 - proof
151.49 - show "\<forall>z \<in> c. z \<subseteq> \<Union>c" by fast
151.50 - show "\<Union>c \<in> S"
151.51 - proof (rule r)
151.52 - from `c \<noteq> {}` show "\<exists>x. x \<in> c" by fast
151.53 - show "c \<in> chain S" by fact
151.54 - qed
151.55 - qed
151.56 - qed
151.57 - qed
151.58 -qed
151.59 -
151.60 -end
152.1 --- a/src/HOL/Real/HahnBanach/document/root.bib Tue Dec 30 08:18:54 2008 +0100
152.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
152.3 @@ -1,27 +0,0 @@
152.4 -
152.5 -@Book{Heuser:1986,
152.6 - author = {H. Heuser},
152.7 - title = {Funktionalanalysis: Theorie und Anwendung},
152.8 - publisher = {Teubner},
152.9 - year = 1986
152.10 -}
152.11 -
152.12 -@InCollection{Narici:1996,
152.13 - author = {L. Narici and E. Beckenstein},
152.14 - title = {The {Hahn-Banach Theorem}: The Life and Times},
152.15 - booktitle = {Topology Atlas},
152.16 - publisher = {York University, Toronto, Ontario, Canada},
152.17 - year = 1996,
152.18 - note = {\url{http://at.yorku.ca/topology/preprint.htm} and
152.19 - \url{http://at.yorku.ca/p/a/a/a/16.htm}}
152.20 -}
152.21 -
152.22 -@Article{Nowak:1993,
152.23 - author = {B. Nowak and A. Trybulec},
152.24 - title = {{Hahn-Banach} Theorem},
152.25 - journal = {Journal of Formalized Mathematics},
152.26 - year = {1993},
152.27 - volume = {5},
152.28 - institution = {University of Bialystok},
152.29 - note = {\url{http://mizar.uwb.edu.pl/JFM/Vol5/hahnban.html}}
152.30 -}
153.1 --- a/src/HOL/Real/HahnBanach/document/root.tex Tue Dec 30 08:18:54 2008 +0100
153.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
153.3 @@ -1,83 +0,0 @@
153.4 -\documentclass[10pt,a4paper,twoside]{article}
153.5 -\usepackage{graphicx}
153.6 -\usepackage{latexsym,theorem}
153.7 -\usepackage{isabelle,isabellesym}
153.8 -\usepackage{pdfsetup} %last one!
153.9 -
153.10 -\isabellestyle{it}
153.11 -\urlstyle{rm}
153.12 -
153.13 -\newcommand{\isasymsup}{\isamath{\sup\,}}
153.14 -\newcommand{\skp}{\smallskip}
153.15 -
153.16 -
153.17 -\begin{document}
153.18 -
153.19 -\pagestyle{headings}
153.20 -\pagenumbering{arabic}
153.21 -
153.22 -\title{The Hahn-Banach Theorem \\ for Real Vector Spaces}
153.23 -\author{Gertrud Bauer \\ \url{http://www.in.tum.de/~bauerg/}}
153.24 -\maketitle
153.25 -
153.26 -\begin{abstract}
153.27 - The Hahn-Banach Theorem is one of the most fundamental results in functional
153.28 - analysis. We present a fully formal proof of two versions of the theorem,
153.29 - one for general linear spaces and another for normed spaces. This
153.30 - development is based on simply-typed classical set-theory, as provided by
153.31 - Isabelle/HOL.
153.32 -\end{abstract}
153.33 -
153.34 -
153.35 -\tableofcontents
153.36 -\parindent 0pt \parskip 0.5ex
153.37 -
153.38 -\clearpage
153.39 -\section{Preface}
153.40 -
153.41 -This is a fully formal proof of the Hahn-Banach Theorem. It closely follows
153.42 -the informal presentation given in Heuser's textbook \cite[{\S} 36]{Heuser:1986}.
153.43 -Another formal proof of the same theorem has been done in Mizar
153.44 -\cite{Nowak:1993}. A general overview of the relevance and history of the
153.45 -Hahn-Banach Theorem is given by Narici and Beckenstein \cite{Narici:1996}.
153.46 -
153.47 -\medskip The document is structured as follows. The first part contains
153.48 -definitions of basic notions of linear algebra: vector spaces, subspaces,
153.49 -normed spaces, continuous linear-forms, norm of functions and an order on
153.50 -functions by domain extension. The second part contains some lemmas about the
153.51 -supremum (w.r.t.\ the function order) and extension of non-maximal functions.
153.52 -With these preliminaries, the main proof of the theorem (in its two versions)
153.53 -is conducted in the third part. The dependencies of individual theories are
153.54 -as follows.
153.55 -
153.56 -\begin{center}
153.57 - \includegraphics[scale=0.5]{session_graph}
153.58 -\end{center}
153.59 -
153.60 -\clearpage
153.61 -\part {Basic Notions}
153.62 -
153.63 -\input{Bounds}
153.64 -\input{VectorSpace}
153.65 -\input{Subspace}
153.66 -\input{NormedSpace}
153.67 -\input{Linearform}
153.68 -\input{FunctionOrder}
153.69 -\input{FunctionNorm}
153.70 -\input{ZornLemma}
153.71 -
153.72 -\clearpage
153.73 -\part {Lemmas for the Proof}
153.74 -
153.75 -\input{HahnBanachSupLemmas}
153.76 -\input{HahnBanachExtLemmas}
153.77 -\input{HahnBanachLemmas}
153.78 -
153.79 -\clearpage
153.80 -\part {The Main Proof}
153.81 -
153.82 -\input{HahnBanach}
153.83 -\bibliographystyle{abbrv}
153.84 -\bibliography{root}
153.85 -
153.86 -\end{document}
154.1 --- a/src/HOL/Real/RealVector.thy Tue Dec 30 08:18:54 2008 +0100
154.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
154.3 @@ -1,841 +0,0 @@
154.4 -(* Title: HOL/Real/RealVector.thy
154.5 - Author: Brian Huffman
154.6 -*)
154.7 -
154.8 -header {* Vector Spaces and Algebras over the Reals *}
154.9 -
154.10 -theory RealVector
154.11 -imports "~~/src/HOL/RealPow"
154.12 -begin
154.13 -
154.14 -subsection {* Locale for additive functions *}
154.15 -
154.16 -locale additive =
154.17 - fixes f :: "'a::ab_group_add \<Rightarrow> 'b::ab_group_add"
154.18 - assumes add: "f (x + y) = f x + f y"
154.19 -begin
154.20 -
154.21 -lemma zero: "f 0 = 0"
154.22 -proof -
154.23 - have "f 0 = f (0 + 0)" by simp
154.24 - also have "\<dots> = f 0 + f 0" by (rule add)
154.25 - finally show "f 0 = 0" by simp
154.26 -qed
154.27 -
154.28 -lemma minus: "f (- x) = - f x"
154.29 -proof -
154.30 - have "f (- x) + f x = f (- x + x)" by (rule add [symmetric])
154.31 - also have "\<dots> = - f x + f x" by (simp add: zero)
154.32 - finally show "f (- x) = - f x" by (rule add_right_imp_eq)
154.33 -qed
154.34 -
154.35 -lemma diff: "f (x - y) = f x - f y"
154.36 -by (simp add: diff_def add minus)
154.37 -
154.38 -lemma setsum: "f (setsum g A) = (\<Sum>x\<in>A. f (g x))"
154.39 -apply (cases "finite A")
154.40 -apply (induct set: finite)
154.41 -apply (simp add: zero)
154.42 -apply (simp add: add)
154.43 -apply (simp add: zero)
154.44 -done
154.45 -
154.46 -end
154.47 -
154.48 -subsection {* Vector spaces *}
154.49 -
154.50 -locale vector_space =
154.51 - fixes scale :: "'a::field \<Rightarrow> 'b::ab_group_add \<Rightarrow> 'b"
154.52 - assumes scale_right_distrib: "scale a (x + y) = scale a x + scale a y"
154.53 - and scale_left_distrib: "scale (a + b) x = scale a x + scale b x"
154.54 - and scale_scale [simp]: "scale a (scale b x) = scale (a * b) x"
154.55 - and scale_one [simp]: "scale 1 x = x"
154.56 -begin
154.57 -
154.58 -lemma scale_left_commute:
154.59 - "scale a (scale b x) = scale b (scale a x)"
154.60 -by (simp add: mult_commute)
154.61 -
154.62 -lemma scale_zero_left [simp]: "scale 0 x = 0"
154.63 - and scale_minus_left [simp]: "scale (- a) x = - (scale a x)"
154.64 - and scale_left_diff_distrib: "scale (a - b) x = scale a x - scale b x"
154.65 -proof -
154.66 - interpret s: additive "\<lambda>a. scale a x"
154.67 - proof qed (rule scale_left_distrib)
154.68 - show "scale 0 x = 0" by (rule s.zero)
154.69 - show "scale (- a) x = - (scale a x)" by (rule s.minus)
154.70 - show "scale (a - b) x = scale a x - scale b x" by (rule s.diff)
154.71 -qed
154.72 -
154.73 -lemma scale_zero_right [simp]: "scale a 0 = 0"
154.74 - and scale_minus_right [simp]: "scale a (- x) = - (scale a x)"
154.75 - and scale_right_diff_distrib: "scale a (x - y) = scale a x - scale a y"
154.76 -proof -
154.77 - interpret s: additive "\<lambda>x. scale a x"
154.78 - proof qed (rule scale_right_distrib)
154.79 - show "scale a 0 = 0" by (rule s.zero)
154.80 - show "scale a (- x) = - (scale a x)" by (rule s.minus)
154.81 - show "scale a (x - y) = scale a x - scale a y" by (rule s.diff)
154.82 -qed
154.83 -
154.84 -lemma scale_eq_0_iff [simp]:
154.85 - "scale a x = 0 \<longleftrightarrow> a = 0 \<or> x = 0"
154.86 -proof cases
154.87 - assume "a = 0" thus ?thesis by simp
154.88 -next
154.89 - assume anz [simp]: "a \<noteq> 0"
154.90 - { assume "scale a x = 0"
154.91 - hence "scale (inverse a) (scale a x) = 0" by simp
154.92 - hence "x = 0" by simp }
154.93 - thus ?thesis by force
154.94 -qed
154.95 -
154.96 -lemma scale_left_imp_eq:
154.97 - "\<lbrakk>a \<noteq> 0; scale a x = scale a y\<rbrakk> \<Longrightarrow> x = y"
154.98 -proof -
154.99 - assume nonzero: "a \<noteq> 0"
154.100 - assume "scale a x = scale a y"
154.101 - hence "scale a (x - y) = 0"
154.102 - by (simp add: scale_right_diff_distrib)
154.103 - hence "x - y = 0" by (simp add: nonzero)
154.104 - thus "x = y" by (simp only: right_minus_eq)
154.105 -qed
154.106 -
154.107 -lemma scale_right_imp_eq:
154.108 - "\<lbrakk>x \<noteq> 0; scale a x = scale b x\<rbrakk> \<Longrightarrow> a = b"
154.109 -proof -
154.110 - assume nonzero: "x \<noteq> 0"
154.111 - assume "scale a x = scale b x"
154.112 - hence "scale (a - b) x = 0"
154.113 - by (simp add: scale_left_diff_distrib)
154.114 - hence "a - b = 0" by (simp add: nonzero)
154.115 - thus "a = b" by (simp only: right_minus_eq)
154.116 -qed
154.117 -
154.118 -lemma scale_cancel_left:
154.119 - "scale a x = scale a y \<longleftrightarrow> x = y \<or> a = 0"
154.120 -by (auto intro: scale_left_imp_eq)
154.121 -
154.122 -lemma scale_cancel_right:
154.123 - "scale a x = scale b x \<longleftrightarrow> a = b \<or> x = 0"
154.124 -by (auto intro: scale_right_imp_eq)
154.125 -
154.126 -end
154.127 -
154.128 -subsection {* Real vector spaces *}
154.129 -
154.130 -class scaleR = type +
154.131 - fixes scaleR :: "real \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "*\<^sub>R" 75)
154.132 -begin
154.133 -
154.134 -abbreviation
154.135 - divideR :: "'a \<Rightarrow> real \<Rightarrow> 'a" (infixl "'/\<^sub>R" 70)
154.136 -where
154.137 - "x /\<^sub>R r == scaleR (inverse r) x"
154.138 -
154.139 -end
154.140 -
154.141 -instantiation real :: scaleR
154.142 -begin
154.143 -
154.144 -definition
154.145 - real_scaleR_def [simp]: "scaleR a x = a * x"
154.146 -
154.147 -instance ..
154.148 -
154.149 -end
154.150 -
154.151 -class real_vector = scaleR + ab_group_add +
154.152 - assumes scaleR_right_distrib: "scaleR a (x + y) = scaleR a x + scaleR a y"
154.153 - and scaleR_left_distrib: "scaleR (a + b) x = scaleR a x + scaleR b x"
154.154 - and scaleR_scaleR [simp]: "scaleR a (scaleR b x) = scaleR (a * b) x"
154.155 - and scaleR_one [simp]: "scaleR 1 x = x"
154.156 -
154.157 -interpretation real_vector!:
154.158 - vector_space "scaleR :: real \<Rightarrow> 'a \<Rightarrow> 'a::real_vector"
154.159 -apply unfold_locales
154.160 -apply (rule scaleR_right_distrib)
154.161 -apply (rule scaleR_left_distrib)
154.162 -apply (rule scaleR_scaleR)
154.163 -apply (rule scaleR_one)
154.164 -done
154.165 -
154.166 -text {* Recover original theorem names *}
154.167 -
154.168 -lemmas scaleR_left_commute = real_vector.scale_left_commute
154.169 -lemmas scaleR_zero_left = real_vector.scale_zero_left
154.170 -lemmas scaleR_minus_left = real_vector.scale_minus_left
154.171 -lemmas scaleR_left_diff_distrib = real_vector.scale_left_diff_distrib
154.172 -lemmas scaleR_zero_right = real_vector.scale_zero_right
154.173 -lemmas scaleR_minus_right = real_vector.scale_minus_right
154.174 -lemmas scaleR_right_diff_distrib = real_vector.scale_right_diff_distrib
154.175 -lemmas scaleR_eq_0_iff = real_vector.scale_eq_0_iff
154.176 -lemmas scaleR_left_imp_eq = real_vector.scale_left_imp_eq
154.177 -lemmas scaleR_right_imp_eq = real_vector.scale_right_imp_eq
154.178 -lemmas scaleR_cancel_left = real_vector.scale_cancel_left
154.179 -lemmas scaleR_cancel_right = real_vector.scale_cancel_right
154.180 -
154.181 -class real_algebra = real_vector + ring +
154.182 - assumes mult_scaleR_left [simp]: "scaleR a x * y = scaleR a (x * y)"
154.183 - and mult_scaleR_right [simp]: "x * scaleR a y = scaleR a (x * y)"
154.184 -
154.185 -class real_algebra_1 = real_algebra + ring_1
154.186 -
154.187 -class real_div_algebra = real_algebra_1 + division_ring
154.188 -
154.189 -class real_field = real_div_algebra + field
154.190 -
154.191 -instance real :: real_field
154.192 -apply (intro_classes, unfold real_scaleR_def)
154.193 -apply (rule right_distrib)
154.194 -apply (rule left_distrib)
154.195 -apply (rule mult_assoc [symmetric])
154.196 -apply (rule mult_1_left)
154.197 -apply (rule mult_assoc)
154.198 -apply (rule mult_left_commute)
154.199 -done
154.200 -
154.201 -interpretation scaleR_left!: additive "(\<lambda>a. scaleR a x::'a::real_vector)"
154.202 -proof qed (rule scaleR_left_distrib)
154.203 -
154.204 -interpretation scaleR_right!: additive "(\<lambda>x. scaleR a x::'a::real_vector)"
154.205 -proof qed (rule scaleR_right_distrib)
154.206 -
154.207 -lemma nonzero_inverse_scaleR_distrib:
154.208 - fixes x :: "'a::real_div_algebra" shows
154.209 - "\<lbrakk>a \<noteq> 0; x \<noteq> 0\<rbrakk> \<Longrightarrow> inverse (scaleR a x) = scaleR (inverse a) (inverse x)"
154.210 -by (rule inverse_unique, simp)
154.211 -
154.212 -lemma inverse_scaleR_distrib:
154.213 - fixes x :: "'a::{real_div_algebra,division_by_zero}"
154.214 - shows "inverse (scaleR a x) = scaleR (inverse a) (inverse x)"
154.215 -apply (case_tac "a = 0", simp)
154.216 -apply (case_tac "x = 0", simp)
154.217 -apply (erule (1) nonzero_inverse_scaleR_distrib)
154.218 -done
154.219 -
154.220 -
154.221 -subsection {* Embedding of the Reals into any @{text real_algebra_1}:
154.222 -@{term of_real} *}
154.223 -
154.224 -definition
154.225 - of_real :: "real \<Rightarrow> 'a::real_algebra_1" where
154.226 - "of_real r = scaleR r 1"
154.227 -
154.228 -lemma scaleR_conv_of_real: "scaleR r x = of_real r * x"
154.229 -by (simp add: of_real_def)
154.230 -
154.231 -lemma of_real_0 [simp]: "of_real 0 = 0"
154.232 -by (simp add: of_real_def)
154.233 -
154.234 -lemma of_real_1 [simp]: "of_real 1 = 1"
154.235 -by (simp add: of_real_def)
154.236 -
154.237 -lemma of_real_add [simp]: "of_real (x + y) = of_real x + of_real y"
154.238 -by (simp add: of_real_def scaleR_left_distrib)
154.239 -
154.240 -lemma of_real_minus [simp]: "of_real (- x) = - of_real x"
154.241 -by (simp add: of_real_def)
154.242 -
154.243 -lemma of_real_diff [simp]: "of_real (x - y) = of_real x - of_real y"
154.244 -by (simp add: of_real_def scaleR_left_diff_distrib)
154.245 -
154.246 -lemma of_real_mult [simp]: "of_real (x * y) = of_real x * of_real y"
154.247 -by (simp add: of_real_def mult_commute)
154.248 -
154.249 -lemma nonzero_of_real_inverse:
154.250 - "x \<noteq> 0 \<Longrightarrow> of_real (inverse x) =
154.251 - inverse (of_real x :: 'a::real_div_algebra)"
154.252 -by (simp add: of_real_def nonzero_inverse_scaleR_distrib)
154.253 -
154.254 -lemma of_real_inverse [simp]:
154.255 - "of_real (inverse x) =
154.256 - inverse (of_real x :: 'a::{real_div_algebra,division_by_zero})"
154.257 -by (simp add: of_real_def inverse_scaleR_distrib)
154.258 -
154.259 -lemma nonzero_of_real_divide:
154.260 - "y \<noteq> 0 \<Longrightarrow> of_real (x / y) =
154.261 - (of_real x / of_real y :: 'a::real_field)"
154.262 -by (simp add: divide_inverse nonzero_of_real_inverse)
154.263 -
154.264 -lemma of_real_divide [simp]:
154.265 - "of_real (x / y) =
154.266 - (of_real x / of_real y :: 'a::{real_field,division_by_zero})"
154.267 -by (simp add: divide_inverse)
154.268 -
154.269 -lemma of_real_power [simp]:
154.270 - "of_real (x ^ n) = (of_real x :: 'a::{real_algebra_1,recpower}) ^ n"
154.271 -by (induct n) (simp_all add: power_Suc)
154.272 -
154.273 -lemma of_real_eq_iff [simp]: "(of_real x = of_real y) = (x = y)"
154.274 -by (simp add: of_real_def scaleR_cancel_right)
154.275 -
154.276 -lemmas of_real_eq_0_iff [simp] = of_real_eq_iff [of _ 0, simplified]
154.277 -
154.278 -lemma of_real_eq_id [simp]: "of_real = (id :: real \<Rightarrow> real)"
154.279 -proof
154.280 - fix r
154.281 - show "of_real r = id r"
154.282 - by (simp add: of_real_def)
154.283 -qed
154.284 -
154.285 -text{*Collapse nested embeddings*}
154.286 -lemma of_real_of_nat_eq [simp]: "of_real (of_nat n) = of_nat n"
154.287 -by (induct n) auto
154.288 -
154.289 -lemma of_real_of_int_eq [simp]: "of_real (of_int z) = of_int z"
154.290 -by (cases z rule: int_diff_cases, simp)
154.291 -
154.292 -lemma of_real_number_of_eq:
154.293 - "of_real (number_of w) = (number_of w :: 'a::{number_ring,real_algebra_1})"
154.294 -by (simp add: number_of_eq)
154.295 -
154.296 -text{*Every real algebra has characteristic zero*}
154.297 -instance real_algebra_1 < ring_char_0
154.298 -proof
154.299 - fix m n :: nat
154.300 - have "(of_real (of_nat m) = (of_real (of_nat n)::'a)) = (m = n)"
154.301 - by (simp only: of_real_eq_iff of_nat_eq_iff)
154.302 - thus "(of_nat m = (of_nat n::'a)) = (m = n)"
154.303 - by (simp only: of_real_of_nat_eq)
154.304 -qed
154.305 -
154.306 -instance real_field < field_char_0 ..
154.307 -
154.308 -
154.309 -subsection {* The Set of Real Numbers *}
154.310 -
154.311 -definition
154.312 - Reals :: "'a::real_algebra_1 set" where
154.313 - [code del]: "Reals \<equiv> range of_real"
154.314 -
154.315 -notation (xsymbols)
154.316 - Reals ("\<real>")
154.317 -
154.318 -lemma Reals_of_real [simp]: "of_real r \<in> Reals"
154.319 -by (simp add: Reals_def)
154.320 -
154.321 -lemma Reals_of_int [simp]: "of_int z \<in> Reals"
154.322 -by (subst of_real_of_int_eq [symmetric], rule Reals_of_real)
154.323 -
154.324 -lemma Reals_of_nat [simp]: "of_nat n \<in> Reals"
154.325 -by (subst of_real_of_nat_eq [symmetric], rule Reals_of_real)
154.326 -
154.327 -lemma Reals_number_of [simp]:
154.328 - "(number_of w::'a::{number_ring,real_algebra_1}) \<in> Reals"
154.329 -by (subst of_real_number_of_eq [symmetric], rule Reals_of_real)
154.330 -
154.331 -lemma Reals_0 [simp]: "0 \<in> Reals"
154.332 -apply (unfold Reals_def)
154.333 -apply (rule range_eqI)
154.334 -apply (rule of_real_0 [symmetric])
154.335 -done
154.336 -
154.337 -lemma Reals_1 [simp]: "1 \<in> Reals"
154.338 -apply (unfold Reals_def)
154.339 -apply (rule range_eqI)
154.340 -apply (rule of_real_1 [symmetric])
154.341 -done
154.342 -
154.343 -lemma Reals_add [simp]: "\<lbrakk>a \<in> Reals; b \<in> Reals\<rbrakk> \<Longrightarrow> a + b \<in> Reals"
154.344 -apply (auto simp add: Reals_def)
154.345 -apply (rule range_eqI)
154.346 -apply (rule of_real_add [symmetric])
154.347 -done
154.348 -
154.349 -lemma Reals_minus [simp]: "a \<in> Reals \<Longrightarrow> - a \<in> Reals"
154.350 -apply (auto simp add: Reals_def)
154.351 -apply (rule range_eqI)
154.352 -apply (rule of_real_minus [symmetric])
154.353 -done
154.354 -
154.355 -lemma Reals_diff [simp]: "\<lbrakk>a \<in> Reals; b \<in> Reals\<rbrakk> \<Longrightarrow> a - b \<in> Reals"
154.356 -apply (auto simp add: Reals_def)
154.357 -apply (rule range_eqI)
154.358 -apply (rule of_real_diff [symmetric])
154.359 -done
154.360 -
154.361 -lemma Reals_mult [simp]: "\<lbrakk>a \<in> Reals; b \<in> Reals\<rbrakk> \<Longrightarrow> a * b \<in> Reals"
154.362 -apply (auto simp add: Reals_def)
154.363 -apply (rule range_eqI)
154.364 -apply (rule of_real_mult [symmetric])
154.365 -done
154.366 -
154.367 -lemma nonzero_Reals_inverse:
154.368 - fixes a :: "'a::real_div_algebra"
154.369 - shows "\<lbrakk>a \<in> Reals; a \<noteq> 0\<rbrakk> \<Longrightarrow> inverse a \<in> Reals"
154.370 -apply (auto simp add: Reals_def)
154.371 -apply (rule range_eqI)
154.372 -apply (erule nonzero_of_real_inverse [symmetric])
154.373 -done
154.374 -
154.375 -lemma Reals_inverse [simp]:
154.376 - fixes a :: "'a::{real_div_algebra,division_by_zero}"
154.377 - shows "a \<in> Reals \<Longrightarrow> inverse a \<in> Reals"
154.378 -apply (auto simp add: Reals_def)
154.379 -apply (rule range_eqI)
154.380 -apply (rule of_real_inverse [symmetric])
154.381 -done
154.382 -
154.383 -lemma nonzero_Reals_divide:
154.384 - fixes a b :: "'a::real_field"
154.385 - shows "\<lbrakk>a \<in> Reals; b \<in> Reals; b \<noteq> 0\<rbrakk> \<Longrightarrow> a / b \<in> Reals"
154.386 -apply (auto simp add: Reals_def)
154.387 -apply (rule range_eqI)
154.388 -apply (erule nonzero_of_real_divide [symmetric])
154.389 -done
154.390 -
154.391 -lemma Reals_divide [simp]:
154.392 - fixes a b :: "'a::{real_field,division_by_zero}"
154.393 - shows "\<lbrakk>a \<in> Reals; b \<in> Reals\<rbrakk> \<Longrightarrow> a / b \<in> Reals"
154.394 -apply (auto simp add: Reals_def)
154.395 -apply (rule range_eqI)
154.396 -apply (rule of_real_divide [symmetric])
154.397 -done
154.398 -
154.399 -lemma Reals_power [simp]:
154.400 - fixes a :: "'a::{real_algebra_1,recpower}"
154.401 - shows "a \<in> Reals \<Longrightarrow> a ^ n \<in> Reals"
154.402 -apply (auto simp add: Reals_def)
154.403 -apply (rule range_eqI)
154.404 -apply (rule of_real_power [symmetric])
154.405 -done
154.406 -
154.407 -lemma Reals_cases [cases set: Reals]:
154.408 - assumes "q \<in> \<real>"
154.409 - obtains (of_real) r where "q = of_real r"
154.410 - unfolding Reals_def
154.411 -proof -
154.412 - from `q \<in> \<real>` have "q \<in> range of_real" unfolding Reals_def .
154.413 - then obtain r where "q = of_real r" ..
154.414 - then show thesis ..
154.415 -qed
154.416 -
154.417 -lemma Reals_induct [case_names of_real, induct set: Reals]:
154.418 - "q \<in> \<real> \<Longrightarrow> (\<And>r. P (of_real r)) \<Longrightarrow> P q"
154.419 - by (rule Reals_cases) auto
154.420 -
154.421 -
154.422 -subsection {* Real normed vector spaces *}
154.423 -
154.424 -class norm = type +
154.425 - fixes norm :: "'a \<Rightarrow> real"
154.426 -
154.427 -instantiation real :: norm
154.428 -begin
154.429 -
154.430 -definition
154.431 - real_norm_def [simp]: "norm r \<equiv> \<bar>r\<bar>"
154.432 -
154.433 -instance ..
154.434 -
154.435 -end
154.436 -
154.437 -class sgn_div_norm = scaleR + norm + sgn +
154.438 - assumes sgn_div_norm: "sgn x = x /\<^sub>R norm x"
154.439 -
154.440 -class real_normed_vector = real_vector + sgn_div_norm +
154.441 - assumes norm_ge_zero [simp]: "0 \<le> norm x"
154.442 - and norm_eq_zero [simp]: "norm x = 0 \<longleftrightarrow> x = 0"
154.443 - and norm_triangle_ineq: "norm (x + y) \<le> norm x + norm y"
154.444 - and norm_scaleR: "norm (scaleR a x) = \<bar>a\<bar> * norm x"
154.445 -
154.446 -class real_normed_algebra = real_algebra + real_normed_vector +
154.447 - assumes norm_mult_ineq: "norm (x * y) \<le> norm x * norm y"
154.448 -
154.449 -class real_normed_algebra_1 = real_algebra_1 + real_normed_algebra +
154.450 - assumes norm_one [simp]: "norm 1 = 1"
154.451 -
154.452 -class real_normed_div_algebra = real_div_algebra + real_normed_vector +
154.453 - assumes norm_mult: "norm (x * y) = norm x * norm y"
154.454 -
154.455 -class real_normed_field = real_field + real_normed_div_algebra
154.456 -
154.457 -instance real_normed_div_algebra < real_normed_algebra_1
154.458 -proof
154.459 - fix x y :: 'a
154.460 - show "norm (x * y) \<le> norm x * norm y"
154.461 - by (simp add: norm_mult)
154.462 -next
154.463 - have "norm (1 * 1::'a) = norm (1::'a) * norm (1::'a)"
154.464 - by (rule norm_mult)
154.465 - thus "norm (1::'a) = 1" by simp
154.466 -qed
154.467 -
154.468 -instance real :: real_normed_field
154.469 -apply (intro_classes, unfold real_norm_def real_scaleR_def)
154.470 -apply (simp add: real_sgn_def)
154.471 -apply (rule abs_ge_zero)
154.472 -apply (rule abs_eq_0)
154.473 -apply (rule abs_triangle_ineq)
154.474 -apply (rule abs_mult)
154.475 -apply (rule abs_mult)
154.476 -done
154.477 -
154.478 -lemma norm_zero [simp]: "norm (0::'a::real_normed_vector) = 0"
154.479 -by simp
154.480 -
154.481 -lemma zero_less_norm_iff [simp]:
154.482 - fixes x :: "'a::real_normed_vector"
154.483 - shows "(0 < norm x) = (x \<noteq> 0)"
154.484 -by (simp add: order_less_le)
154.485 -
154.486 -lemma norm_not_less_zero [simp]:
154.487 - fixes x :: "'a::real_normed_vector"
154.488 - shows "\<not> norm x < 0"
154.489 -by (simp add: linorder_not_less)
154.490 -
154.491 -lemma norm_le_zero_iff [simp]:
154.492 - fixes x :: "'a::real_normed_vector"
154.493 - shows "(norm x \<le> 0) = (x = 0)"
154.494 -by (simp add: order_le_less)
154.495 -
154.496 -lemma norm_minus_cancel [simp]:
154.497 - fixes x :: "'a::real_normed_vector"
154.498 - shows "norm (- x) = norm x"
154.499 -proof -
154.500 - have "norm (- x) = norm (scaleR (- 1) x)"
154.501 - by (simp only: scaleR_minus_left scaleR_one)
154.502 - also have "\<dots> = \<bar>- 1\<bar> * norm x"
154.503 - by (rule norm_scaleR)
154.504 - finally show ?thesis by simp
154.505 -qed
154.506 -
154.507 -lemma norm_minus_commute:
154.508 - fixes a b :: "'a::real_normed_vector"
154.509 - shows "norm (a - b) = norm (b - a)"
154.510 -proof -
154.511 - have "norm (- (b - a)) = norm (b - a)"
154.512 - by (rule norm_minus_cancel)
154.513 - thus ?thesis by simp
154.514 -qed
154.515 -
154.516 -lemma norm_triangle_ineq2:
154.517 - fixes a b :: "'a::real_normed_vector"
154.518 - shows "norm a - norm b \<le> norm (a - b)"
154.519 -proof -
154.520 - have "norm (a - b + b) \<le> norm (a - b) + norm b"
154.521 - by (rule norm_triangle_ineq)
154.522 - thus ?thesis by simp
154.523 -qed
154.524 -
154.525 -lemma norm_triangle_ineq3:
154.526 - fixes a b :: "'a::real_normed_vector"
154.527 - shows "\<bar>norm a - norm b\<bar> \<le> norm (a - b)"
154.528 -apply (subst abs_le_iff)
154.529 -apply auto
154.530 -apply (rule norm_triangle_ineq2)
154.531 -apply (subst norm_minus_commute)
154.532 -apply (rule norm_triangle_ineq2)
154.533 -done
154.534 -
154.535 -lemma norm_triangle_ineq4:
154.536 - fixes a b :: "'a::real_normed_vector"
154.537 - shows "norm (a - b) \<le> norm a + norm b"
154.538 -proof -
154.539 - have "norm (a + - b) \<le> norm a + norm (- b)"
154.540 - by (rule norm_triangle_ineq)
154.541 - thus ?thesis
154.542 - by (simp only: diff_minus norm_minus_cancel)
154.543 -qed
154.544 -
154.545 -lemma norm_diff_ineq:
154.546 - fixes a b :: "'a::real_normed_vector"
154.547 - shows "norm a - norm b \<le> norm (a + b)"
154.548 -proof -
154.549 - have "norm a - norm (- b) \<le> norm (a - - b)"
154.550 - by (rule norm_triangle_ineq2)
154.551 - thus ?thesis by simp
154.552 -qed
154.553 -
154.554 -lemma norm_diff_triangle_ineq:
154.555 - fixes a b c d :: "'a::real_normed_vector"
154.556 - shows "norm ((a + b) - (c + d)) \<le> norm (a - c) + norm (b - d)"
154.557 -proof -
154.558 - have "norm ((a + b) - (c + d)) = norm ((a - c) + (b - d))"
154.559 - by (simp add: diff_minus add_ac)
154.560 - also have "\<dots> \<le> norm (a - c) + norm (b - d)"
154.561 - by (rule norm_triangle_ineq)
154.562 - finally show ?thesis .
154.563 -qed
154.564 -
154.565 -lemma abs_norm_cancel [simp]:
154.566 - fixes a :: "'a::real_normed_vector"
154.567 - shows "\<bar>norm a\<bar> = norm a"
154.568 -by (rule abs_of_nonneg [OF norm_ge_zero])
154.569 -
154.570 -lemma norm_add_less:
154.571 - fixes x y :: "'a::real_normed_vector"
154.572 - shows "\<lbrakk>norm x < r; norm y < s\<rbrakk> \<Longrightarrow> norm (x + y) < r + s"
154.573 -by (rule order_le_less_trans [OF norm_triangle_ineq add_strict_mono])
154.574 -
154.575 -lemma norm_mult_less:
154.576 - fixes x y :: "'a::real_normed_algebra"
154.577 - shows "\<lbrakk>norm x < r; norm y < s\<rbrakk> \<Longrightarrow> norm (x * y) < r * s"
154.578 -apply (rule order_le_less_trans [OF norm_mult_ineq])
154.579 -apply (simp add: mult_strict_mono')
154.580 -done
154.581 -
154.582 -lemma norm_of_real [simp]:
154.583 - "norm (of_real r :: 'a::real_normed_algebra_1) = \<bar>r\<bar>"
154.584 -unfolding of_real_def by (simp add: norm_scaleR)
154.585 -
154.586 -lemma norm_number_of [simp]:
154.587 - "norm (number_of w::'a::{number_ring,real_normed_algebra_1})
154.588 - = \<bar>number_of w\<bar>"
154.589 -by (subst of_real_number_of_eq [symmetric], rule norm_of_real)
154.590 -
154.591 -lemma norm_of_int [simp]:
154.592 - "norm (of_int z::'a::real_normed_algebra_1) = \<bar>of_int z\<bar>"
154.593 -by (subst of_real_of_int_eq [symmetric], rule norm_of_real)
154.594 -
154.595 -lemma norm_of_nat [simp]:
154.596 - "norm (of_nat n::'a::real_normed_algebra_1) = of_nat n"
154.597 -apply (subst of_real_of_nat_eq [symmetric])
154.598 -apply (subst norm_of_real, simp)
154.599 -done
154.600 -
154.601 -lemma nonzero_norm_inverse:
154.602 - fixes a :: "'a::real_normed_div_algebra"
154.603 - shows "a \<noteq> 0 \<Longrightarrow> norm (inverse a) = inverse (norm a)"
154.604 -apply (rule inverse_unique [symmetric])
154.605 -apply (simp add: norm_mult [symmetric])
154.606 -done
154.607 -
154.608 -lemma norm_inverse:
154.609 - fixes a :: "'a::{real_normed_div_algebra,division_by_zero}"
154.610 - shows "norm (inverse a) = inverse (norm a)"
154.611 -apply (case_tac "a = 0", simp)
154.612 -apply (erule nonzero_norm_inverse)
154.613 -done
154.614 -
154.615 -lemma nonzero_norm_divide:
154.616 - fixes a b :: "'a::real_normed_field"
154.617 - shows "b \<noteq> 0 \<Longrightarrow> norm (a / b) = norm a / norm b"
154.618 -by (simp add: divide_inverse norm_mult nonzero_norm_inverse)
154.619 -
154.620 -lemma norm_divide:
154.621 - fixes a b :: "'a::{real_normed_field,division_by_zero}"
154.622 - shows "norm (a / b) = norm a / norm b"
154.623 -by (simp add: divide_inverse norm_mult norm_inverse)
154.624 -
154.625 -lemma norm_power_ineq:
154.626 - fixes x :: "'a::{real_normed_algebra_1,recpower}"
154.627 - shows "norm (x ^ n) \<le> norm x ^ n"
154.628 -proof (induct n)
154.629 - case 0 show "norm (x ^ 0) \<le> norm x ^ 0" by simp
154.630 -next
154.631 - case (Suc n)
154.632 - have "norm (x * x ^ n) \<le> norm x * norm (x ^ n)"
154.633 - by (rule norm_mult_ineq)
154.634 - also from Suc have "\<dots> \<le> norm x * norm x ^ n"
154.635 - using norm_ge_zero by (rule mult_left_mono)
154.636 - finally show "norm (x ^ Suc n) \<le> norm x ^ Suc n"
154.637 - by (simp add: power_Suc)
154.638 -qed
154.639 -
154.640 -lemma norm_power:
154.641 - fixes x :: "'a::{real_normed_div_algebra,recpower}"
154.642 - shows "norm (x ^ n) = norm x ^ n"
154.643 -by (induct n) (simp_all add: power_Suc norm_mult)
154.644 -
154.645 -
154.646 -subsection {* Sign function *}
154.647 -
154.648 -lemma norm_sgn:
154.649 - "norm (sgn(x::'a::real_normed_vector)) = (if x = 0 then 0 else 1)"
154.650 -by (simp add: sgn_div_norm norm_scaleR)
154.651 -
154.652 -lemma sgn_zero [simp]: "sgn(0::'a::real_normed_vector) = 0"
154.653 -by (simp add: sgn_div_norm)
154.654 -
154.655 -lemma sgn_zero_iff: "(sgn(x::'a::real_normed_vector) = 0) = (x = 0)"
154.656 -by (simp add: sgn_div_norm)
154.657 -
154.658 -lemma sgn_minus: "sgn (- x) = - sgn(x::'a::real_normed_vector)"
154.659 -by (simp add: sgn_div_norm)
154.660 -
154.661 -lemma sgn_scaleR:
154.662 - "sgn (scaleR r x) = scaleR (sgn r) (sgn(x::'a::real_normed_vector))"
154.663 -by (simp add: sgn_div_norm norm_scaleR mult_ac)
154.664 -
154.665 -lemma sgn_one [simp]: "sgn (1::'a::real_normed_algebra_1) = 1"
154.666 -by (simp add: sgn_div_norm)
154.667 -
154.668 -lemma sgn_of_real:
154.669 - "sgn (of_real r::'a::real_normed_algebra_1) = of_real (sgn r)"
154.670 -unfolding of_real_def by (simp only: sgn_scaleR sgn_one)
154.671 -
154.672 -lemma sgn_mult:
154.673 - fixes x y :: "'a::real_normed_div_algebra"
154.674 - shows "sgn (x * y) = sgn x * sgn y"
154.675 -by (simp add: sgn_div_norm norm_mult mult_commute)
154.676 -
154.677 -lemma real_sgn_eq: "sgn (x::real) = x / \<bar>x\<bar>"
154.678 -by (simp add: sgn_div_norm divide_inverse)
154.679 -
154.680 -lemma real_sgn_pos: "0 < (x::real) \<Longrightarrow> sgn x = 1"
154.681 -unfolding real_sgn_eq by simp
154.682 -
154.683 -lemma real_sgn_neg: "(x::real) < 0 \<Longrightarrow> sgn x = -1"
154.684 -unfolding real_sgn_eq by simp
154.685 -
154.686 -
154.687 -subsection {* Bounded Linear and Bilinear Operators *}
154.688 -
154.689 -locale bounded_linear = additive +
154.690 - constrains f :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
154.691 - assumes scaleR: "f (scaleR r x) = scaleR r (f x)"
154.692 - assumes bounded: "\<exists>K. \<forall>x. norm (f x) \<le> norm x * K"
154.693 -begin
154.694 -
154.695 -lemma pos_bounded:
154.696 - "\<exists>K>0. \<forall>x. norm (f x) \<le> norm x * K"
154.697 -proof -
154.698 - obtain K where K: "\<And>x. norm (f x) \<le> norm x * K"
154.699 - using bounded by fast
154.700 - show ?thesis
154.701 - proof (intro exI impI conjI allI)
154.702 - show "0 < max 1 K"
154.703 - by (rule order_less_le_trans [OF zero_less_one le_maxI1])
154.704 - next
154.705 - fix x
154.706 - have "norm (f x) \<le> norm x * K" using K .
154.707 - also have "\<dots> \<le> norm x * max 1 K"
154.708 - by (rule mult_left_mono [OF le_maxI2 norm_ge_zero])
154.709 - finally show "norm (f x) \<le> norm x * max 1 K" .
154.710 - qed
154.711 -qed
154.712 -
154.713 -lemma nonneg_bounded:
154.714 - "\<exists>K\<ge>0. \<forall>x. norm (f x) \<le> norm x * K"
154.715 -proof -
154.716 - from pos_bounded
154.717 - show ?thesis by (auto intro: order_less_imp_le)
154.718 -qed
154.719 -
154.720 -end
154.721 -
154.722 -locale bounded_bilinear =
154.723 - fixes prod :: "['a::real_normed_vector, 'b::real_normed_vector]
154.724 - \<Rightarrow> 'c::real_normed_vector"
154.725 - (infixl "**" 70)
154.726 - assumes add_left: "prod (a + a') b = prod a b + prod a' b"
154.727 - assumes add_right: "prod a (b + b') = prod a b + prod a b'"
154.728 - assumes scaleR_left: "prod (scaleR r a) b = scaleR r (prod a b)"
154.729 - assumes scaleR_right: "prod a (scaleR r b) = scaleR r (prod a b)"
154.730 - assumes bounded: "\<exists>K. \<forall>a b. norm (prod a b) \<le> norm a * norm b * K"
154.731 -begin
154.732 -
154.733 -lemma pos_bounded:
154.734 - "\<exists>K>0. \<forall>a b. norm (a ** b) \<le> norm a * norm b * K"
154.735 -apply (cut_tac bounded, erule exE)
154.736 -apply (rule_tac x="max 1 K" in exI, safe)
154.737 -apply (rule order_less_le_trans [OF zero_less_one le_maxI1])
154.738 -apply (drule spec, drule spec, erule order_trans)
154.739 -apply (rule mult_left_mono [OF le_maxI2])
154.740 -apply (intro mult_nonneg_nonneg norm_ge_zero)
154.741 -done
154.742 -
154.743 -lemma nonneg_bounded:
154.744 - "\<exists>K\<ge>0. \<forall>a b. norm (a ** b) \<le> norm a * norm b * K"
154.745 -proof -
154.746 - from pos_bounded
154.747 - show ?thesis by (auto intro: order_less_imp_le)
154.748 -qed
154.749 -
154.750 -lemma additive_right: "additive (\<lambda>b. prod a b)"
154.751 -by (rule additive.intro, rule add_right)
154.752 -
154.753 -lemma additive_left: "additive (\<lambda>a. prod a b)"
154.754 -by (rule additive.intro, rule add_left)
154.755 -
154.756 -lemma zero_left: "prod 0 b = 0"
154.757 -by (rule additive.zero [OF additive_left])
154.758 -
154.759 -lemma zero_right: "prod a 0 = 0"
154.760 -by (rule additive.zero [OF additive_right])
154.761 -
154.762 -lemma minus_left: "prod (- a) b = - prod a b"
154.763 -by (rule additive.minus [OF additive_left])
154.764 -
154.765 -lemma minus_right: "prod a (- b) = - prod a b"
154.766 -by (rule additive.minus [OF additive_right])
154.767 -
154.768 -lemma diff_left:
154.769 - "prod (a - a') b = prod a b - prod a' b"
154.770 -by (rule additive.diff [OF additive_left])
154.771 -
154.772 -lemma diff_right:
154.773 - "prod a (b - b') = prod a b - prod a b'"
154.774 -by (rule additive.diff [OF additive_right])
154.775 -
154.776 -lemma bounded_linear_left:
154.777 - "bounded_linear (\<lambda>a. a ** b)"
154.778 -apply (unfold_locales)
154.779 -apply (rule add_left)
154.780 -apply (rule scaleR_left)
154.781 -apply (cut_tac bounded, safe)
154.782 -apply (rule_tac x="norm b * K" in exI)
154.783 -apply (simp add: mult_ac)
154.784 -done
154.785 -
154.786 -lemma bounded_linear_right:
154.787 - "bounded_linear (\<lambda>b. a ** b)"
154.788 -apply (unfold_locales)
154.789 -apply (rule add_right)
154.790 -apply (rule scaleR_right)
154.791 -apply (cut_tac bounded, safe)
154.792 -apply (rule_tac x="norm a * K" in exI)
154.793 -apply (simp add: mult_ac)
154.794 -done
154.795 -
154.796 -lemma prod_diff_prod:
154.797 - "(x ** y - a ** b) = (x - a) ** (y - b) + (x - a) ** b + a ** (y - b)"
154.798 -by (simp add: diff_left diff_right)
154.799 -
154.800 -end
154.801 -
154.802 -interpretation mult!:
154.803 - bounded_bilinear "op * :: 'a \<Rightarrow> 'a \<Rightarrow> 'a::real_normed_algebra"
154.804 -apply (rule bounded_bilinear.intro)
154.805 -apply (rule left_distrib)
154.806 -apply (rule right_distrib)
154.807 -apply (rule mult_scaleR_left)
154.808 -apply (rule mult_scaleR_right)
154.809 -apply (rule_tac x="1" in exI)
154.810 -apply (simp add: norm_mult_ineq)
154.811 -done
154.812 -
154.813 -interpretation mult_left!:
154.814 - bounded_linear "(\<lambda>x::'a::real_normed_algebra. x * y)"
154.815 -by (rule mult.bounded_linear_left)
154.816 -
154.817 -interpretation mult_right!:
154.818 - bounded_linear "(\<lambda>y::'a::real_normed_algebra. x * y)"
154.819 -by (rule mult.bounded_linear_right)
154.820 -
154.821 -interpretation divide!:
154.822 - bounded_linear "(\<lambda>x::'a::real_normed_field. x / y)"
154.823 -unfolding divide_inverse by (rule mult.bounded_linear_left)
154.824 -
154.825 -interpretation scaleR!: bounded_bilinear "scaleR"
154.826 -apply (rule bounded_bilinear.intro)
154.827 -apply (rule scaleR_left_distrib)
154.828 -apply (rule scaleR_right_distrib)
154.829 -apply simp
154.830 -apply (rule scaleR_left_commute)
154.831 -apply (rule_tac x="1" in exI)
154.832 -apply (simp add: norm_scaleR)
154.833 -done
154.834 -
154.835 -interpretation scaleR_left!: bounded_linear "\<lambda>r. scaleR r x"
154.836 -by (rule scaleR.bounded_linear_left)
154.837 -
154.838 -interpretation scaleR_right!: bounded_linear "\<lambda>x. scaleR r x"
154.839 -by (rule scaleR.bounded_linear_right)
154.840 -
154.841 -interpretation of_real!: bounded_linear "\<lambda>r. of_real r"
154.842 -unfolding of_real_def by (rule scaleR.bounded_linear_left)
154.843 -
154.844 -end
155.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
155.2 +++ b/src/HOL/RealVector.thy Tue Dec 30 11:10:01 2008 +0100
155.3 @@ -0,0 +1,841 @@
155.4 +(* Title: HOL/RealVector.thy
155.5 + Author: Brian Huffman
155.6 +*)
155.7 +
155.8 +header {* Vector Spaces and Algebras over the Reals *}
155.9 +
155.10 +theory RealVector
155.11 +imports RealPow
155.12 +begin
155.13 +
155.14 +subsection {* Locale for additive functions *}
155.15 +
155.16 +locale additive =
155.17 + fixes f :: "'a::ab_group_add \<Rightarrow> 'b::ab_group_add"
155.18 + assumes add: "f (x + y) = f x + f y"
155.19 +begin
155.20 +
155.21 +lemma zero: "f 0 = 0"
155.22 +proof -
155.23 + have "f 0 = f (0 + 0)" by simp
155.24 + also have "\<dots> = f 0 + f 0" by (rule add)
155.25 + finally show "f 0 = 0" by simp
155.26 +qed
155.27 +
155.28 +lemma minus: "f (- x) = - f x"
155.29 +proof -
155.30 + have "f (- x) + f x = f (- x + x)" by (rule add [symmetric])
155.31 + also have "\<dots> = - f x + f x" by (simp add: zero)
155.32 + finally show "f (- x) = - f x" by (rule add_right_imp_eq)
155.33 +qed
155.34 +
155.35 +lemma diff: "f (x - y) = f x - f y"
155.36 +by (simp add: diff_def add minus)
155.37 +
155.38 +lemma setsum: "f (setsum g A) = (\<Sum>x\<in>A. f (g x))"
155.39 +apply (cases "finite A")
155.40 +apply (induct set: finite)
155.41 +apply (simp add: zero)
155.42 +apply (simp add: add)
155.43 +apply (simp add: zero)
155.44 +done
155.45 +
155.46 +end
155.47 +
155.48 +subsection {* Vector spaces *}
155.49 +
155.50 +locale vector_space =
155.51 + fixes scale :: "'a::field \<Rightarrow> 'b::ab_group_add \<Rightarrow> 'b"
155.52 + assumes scale_right_distrib: "scale a (x + y) = scale a x + scale a y"
155.53 + and scale_left_distrib: "scale (a + b) x = scale a x + scale b x"
155.54 + and scale_scale [simp]: "scale a (scale b x) = scale (a * b) x"
155.55 + and scale_one [simp]: "scale 1 x = x"
155.56 +begin
155.57 +
155.58 +lemma scale_left_commute:
155.59 + "scale a (scale b x) = scale b (scale a x)"
155.60 +by (simp add: mult_commute)
155.61 +
155.62 +lemma scale_zero_left [simp]: "scale 0 x = 0"
155.63 + and scale_minus_left [simp]: "scale (- a) x = - (scale a x)"
155.64 + and scale_left_diff_distrib: "scale (a - b) x = scale a x - scale b x"
155.65 +proof -
155.66 + interpret s: additive "\<lambda>a. scale a x"
155.67 + proof qed (rule scale_left_distrib)
155.68 + show "scale 0 x = 0" by (rule s.zero)
155.69 + show "scale (- a) x = - (scale a x)" by (rule s.minus)
155.70 + show "scale (a - b) x = scale a x - scale b x" by (rule s.diff)
155.71 +qed
155.72 +
155.73 +lemma scale_zero_right [simp]: "scale a 0 = 0"
155.74 + and scale_minus_right [simp]: "scale a (- x) = - (scale a x)"
155.75 + and scale_right_diff_distrib: "scale a (x - y) = scale a x - scale a y"
155.76 +proof -
155.77 + interpret s: additive "\<lambda>x. scale a x"
155.78 + proof qed (rule scale_right_distrib)
155.79 + show "scale a 0 = 0" by (rule s.zero)
155.80 + show "scale a (- x) = - (scale a x)" by (rule s.minus)
155.81 + show "scale a (x - y) = scale a x - scale a y" by (rule s.diff)
155.82 +qed
155.83 +
155.84 +lemma scale_eq_0_iff [simp]:
155.85 + "scale a x = 0 \<longleftrightarrow> a = 0 \<or> x = 0"
155.86 +proof cases
155.87 + assume "a = 0" thus ?thesis by simp
155.88 +next
155.89 + assume anz [simp]: "a \<noteq> 0"
155.90 + { assume "scale a x = 0"
155.91 + hence "scale (inverse a) (scale a x) = 0" by simp
155.92 + hence "x = 0" by simp }
155.93 + thus ?thesis by force
155.94 +qed
155.95 +
155.96 +lemma scale_left_imp_eq:
155.97 + "\<lbrakk>a \<noteq> 0; scale a x = scale a y\<rbrakk> \<Longrightarrow> x = y"
155.98 +proof -
155.99 + assume nonzero: "a \<noteq> 0"
155.100 + assume "scale a x = scale a y"
155.101 + hence "scale a (x - y) = 0"
155.102 + by (simp add: scale_right_diff_distrib)
155.103 + hence "x - y = 0" by (simp add: nonzero)
155.104 + thus "x = y" by (simp only: right_minus_eq)
155.105 +qed
155.106 +
155.107 +lemma scale_right_imp_eq:
155.108 + "\<lbrakk>x \<noteq> 0; scale a x = scale b x\<rbrakk> \<Longrightarrow> a = b"
155.109 +proof -
155.110 + assume nonzero: "x \<noteq> 0"
155.111 + assume "scale a x = scale b x"
155.112 + hence "scale (a - b) x = 0"
155.113 + by (simp add: scale_left_diff_distrib)
155.114 + hence "a - b = 0" by (simp add: nonzero)
155.115 + thus "a = b" by (simp only: right_minus_eq)
155.116 +qed
155.117 +
155.118 +lemma scale_cancel_left:
155.119 + "scale a x = scale a y \<longleftrightarrow> x = y \<or> a = 0"
155.120 +by (auto intro: scale_left_imp_eq)
155.121 +
155.122 +lemma scale_cancel_right:
155.123 + "scale a x = scale b x \<longleftrightarrow> a = b \<or> x = 0"
155.124 +by (auto intro: scale_right_imp_eq)
155.125 +
155.126 +end
155.127 +
155.128 +subsection {* Real vector spaces *}
155.129 +
155.130 +class scaleR = type +
155.131 + fixes scaleR :: "real \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "*\<^sub>R" 75)
155.132 +begin
155.133 +
155.134 +abbreviation
155.135 + divideR :: "'a \<Rightarrow> real \<Rightarrow> 'a" (infixl "'/\<^sub>R" 70)
155.136 +where
155.137 + "x /\<^sub>R r == scaleR (inverse r) x"
155.138 +
155.139 +end
155.140 +
155.141 +instantiation real :: scaleR
155.142 +begin
155.143 +
155.144 +definition
155.145 + real_scaleR_def [simp]: "scaleR a x = a * x"
155.146 +
155.147 +instance ..
155.148 +
155.149 +end
155.150 +
155.151 +class real_vector = scaleR + ab_group_add +
155.152 + assumes scaleR_right_distrib: "scaleR a (x + y) = scaleR a x + scaleR a y"
155.153 + and scaleR_left_distrib: "scaleR (a + b) x = scaleR a x + scaleR b x"
155.154 + and scaleR_scaleR [simp]: "scaleR a (scaleR b x) = scaleR (a * b) x"
155.155 + and scaleR_one [simp]: "scaleR 1 x = x"
155.156 +
155.157 +interpretation real_vector!:
155.158 + vector_space "scaleR :: real \<Rightarrow> 'a \<Rightarrow> 'a::real_vector"
155.159 +apply unfold_locales
155.160 +apply (rule scaleR_right_distrib)
155.161 +apply (rule scaleR_left_distrib)
155.162 +apply (rule scaleR_scaleR)
155.163 +apply (rule scaleR_one)
155.164 +done
155.165 +
155.166 +text {* Recover original theorem names *}
155.167 +
155.168 +lemmas scaleR_left_commute = real_vector.scale_left_commute
155.169 +lemmas scaleR_zero_left = real_vector.scale_zero_left
155.170 +lemmas scaleR_minus_left = real_vector.scale_minus_left
155.171 +lemmas scaleR_left_diff_distrib = real_vector.scale_left_diff_distrib
155.172 +lemmas scaleR_zero_right = real_vector.scale_zero_right
155.173 +lemmas scaleR_minus_right = real_vector.scale_minus_right
155.174 +lemmas scaleR_right_diff_distrib = real_vector.scale_right_diff_distrib
155.175 +lemmas scaleR_eq_0_iff = real_vector.scale_eq_0_iff
155.176 +lemmas scaleR_left_imp_eq = real_vector.scale_left_imp_eq
155.177 +lemmas scaleR_right_imp_eq = real_vector.scale_right_imp_eq
155.178 +lemmas scaleR_cancel_left = real_vector.scale_cancel_left
155.179 +lemmas scaleR_cancel_right = real_vector.scale_cancel_right
155.180 +
155.181 +class real_algebra = real_vector + ring +
155.182 + assumes mult_scaleR_left [simp]: "scaleR a x * y = scaleR a (x * y)"
155.183 + and mult_scaleR_right [simp]: "x * scaleR a y = scaleR a (x * y)"
155.184 +
155.185 +class real_algebra_1 = real_algebra + ring_1
155.186 +
155.187 +class real_div_algebra = real_algebra_1 + division_ring
155.188 +
155.189 +class real_field = real_div_algebra + field
155.190 +
155.191 +instance real :: real_field
155.192 +apply (intro_classes, unfold real_scaleR_def)
155.193 +apply (rule right_distrib)
155.194 +apply (rule left_distrib)
155.195 +apply (rule mult_assoc [symmetric])
155.196 +apply (rule mult_1_left)
155.197 +apply (rule mult_assoc)
155.198 +apply (rule mult_left_commute)
155.199 +done
155.200 +
155.201 +interpretation scaleR_left!: additive "(\<lambda>a. scaleR a x::'a::real_vector)"
155.202 +proof qed (rule scaleR_left_distrib)
155.203 +
155.204 +interpretation scaleR_right!: additive "(\<lambda>x. scaleR a x::'a::real_vector)"
155.205 +proof qed (rule scaleR_right_distrib)
155.206 +
155.207 +lemma nonzero_inverse_scaleR_distrib:
155.208 + fixes x :: "'a::real_div_algebra" shows
155.209 + "\<lbrakk>a \<noteq> 0; x \<noteq> 0\<rbrakk> \<Longrightarrow> inverse (scaleR a x) = scaleR (inverse a) (inverse x)"
155.210 +by (rule inverse_unique, simp)
155.211 +
155.212 +lemma inverse_scaleR_distrib:
155.213 + fixes x :: "'a::{real_div_algebra,division_by_zero}"
155.214 + shows "inverse (scaleR a x) = scaleR (inverse a) (inverse x)"
155.215 +apply (case_tac "a = 0", simp)
155.216 +apply (case_tac "x = 0", simp)
155.217 +apply (erule (1) nonzero_inverse_scaleR_distrib)
155.218 +done
155.219 +
155.220 +
155.221 +subsection {* Embedding of the Reals into any @{text real_algebra_1}:
155.222 +@{term of_real} *}
155.223 +
155.224 +definition
155.225 + of_real :: "real \<Rightarrow> 'a::real_algebra_1" where
155.226 + "of_real r = scaleR r 1"
155.227 +
155.228 +lemma scaleR_conv_of_real: "scaleR r x = of_real r * x"
155.229 +by (simp add: of_real_def)
155.230 +
155.231 +lemma of_real_0 [simp]: "of_real 0 = 0"
155.232 +by (simp add: of_real_def)
155.233 +
155.234 +lemma of_real_1 [simp]: "of_real 1 = 1"
155.235 +by (simp add: of_real_def)
155.236 +
155.237 +lemma of_real_add [simp]: "of_real (x + y) = of_real x + of_real y"
155.238 +by (simp add: of_real_def scaleR_left_distrib)
155.239 +
155.240 +lemma of_real_minus [simp]: "of_real (- x) = - of_real x"
155.241 +by (simp add: of_real_def)
155.242 +
155.243 +lemma of_real_diff [simp]: "of_real (x - y) = of_real x - of_real y"
155.244 +by (simp add: of_real_def scaleR_left_diff_distrib)
155.245 +
155.246 +lemma of_real_mult [simp]: "of_real (x * y) = of_real x * of_real y"
155.247 +by (simp add: of_real_def mult_commute)
155.248 +
155.249 +lemma nonzero_of_real_inverse:
155.250 + "x \<noteq> 0 \<Longrightarrow> of_real (inverse x) =
155.251 + inverse (of_real x :: 'a::real_div_algebra)"
155.252 +by (simp add: of_real_def nonzero_inverse_scaleR_distrib)
155.253 +
155.254 +lemma of_real_inverse [simp]:
155.255 + "of_real (inverse x) =
155.256 + inverse (of_real x :: 'a::{real_div_algebra,division_by_zero})"
155.257 +by (simp add: of_real_def inverse_scaleR_distrib)
155.258 +
155.259 +lemma nonzero_of_real_divide:
155.260 + "y \<noteq> 0 \<Longrightarrow> of_real (x / y) =
155.261 + (of_real x / of_real y :: 'a::real_field)"
155.262 +by (simp add: divide_inverse nonzero_of_real_inverse)
155.263 +
155.264 +lemma of_real_divide [simp]:
155.265 + "of_real (x / y) =
155.266 + (of_real x / of_real y :: 'a::{real_field,division_by_zero})"
155.267 +by (simp add: divide_inverse)
155.268 +
155.269 +lemma of_real_power [simp]:
155.270 + "of_real (x ^ n) = (of_real x :: 'a::{real_algebra_1,recpower}) ^ n"
155.271 +by (induct n) (simp_all add: power_Suc)
155.272 +
155.273 +lemma of_real_eq_iff [simp]: "(of_real x = of_real y) = (x = y)"
155.274 +by (simp add: of_real_def scaleR_cancel_right)
155.275 +
155.276 +lemmas of_real_eq_0_iff [simp] = of_real_eq_iff [of _ 0, simplified]
155.277 +
155.278 +lemma of_real_eq_id [simp]: "of_real = (id :: real \<Rightarrow> real)"
155.279 +proof
155.280 + fix r
155.281 + show "of_real r = id r"
155.282 + by (simp add: of_real_def)
155.283 +qed
155.284 +
155.285 +text{*Collapse nested embeddings*}
155.286 +lemma of_real_of_nat_eq [simp]: "of_real (of_nat n) = of_nat n"
155.287 +by (induct n) auto
155.288 +
155.289 +lemma of_real_of_int_eq [simp]: "of_real (of_int z) = of_int z"
155.290 +by (cases z rule: int_diff_cases, simp)
155.291 +
155.292 +lemma of_real_number_of_eq:
155.293 + "of_real (number_of w) = (number_of w :: 'a::{number_ring,real_algebra_1})"
155.294 +by (simp add: number_of_eq)
155.295 +
155.296 +text{*Every real algebra has characteristic zero*}
155.297 +instance real_algebra_1 < ring_char_0
155.298 +proof
155.299 + fix m n :: nat
155.300 + have "(of_real (of_nat m) = (of_real (of_nat n)::'a)) = (m = n)"
155.301 + by (simp only: of_real_eq_iff of_nat_eq_iff)
155.302 + thus "(of_nat m = (of_nat n::'a)) = (m = n)"
155.303 + by (simp only: of_real_of_nat_eq)
155.304 +qed
155.305 +
155.306 +instance real_field < field_char_0 ..
155.307 +
155.308 +
155.309 +subsection {* The Set of Real Numbers *}
155.310 +
155.311 +definition
155.312 + Reals :: "'a::real_algebra_1 set" where
155.313 + [code del]: "Reals \<equiv> range of_real"
155.314 +
155.315 +notation (xsymbols)
155.316 + Reals ("\<real>")
155.317 +
155.318 +lemma Reals_of_real [simp]: "of_real r \<in> Reals"
155.319 +by (simp add: Reals_def)
155.320 +
155.321 +lemma Reals_of_int [simp]: "of_int z \<in> Reals"
155.322 +by (subst of_real_of_int_eq [symmetric], rule Reals_of_real)
155.323 +
155.324 +lemma Reals_of_nat [simp]: "of_nat n \<in> Reals"
155.325 +by (subst of_real_of_nat_eq [symmetric], rule Reals_of_real)
155.326 +
155.327 +lemma Reals_number_of [simp]:
155.328 + "(number_of w::'a::{number_ring,real_algebra_1}) \<in> Reals"
155.329 +by (subst of_real_number_of_eq [symmetric], rule Reals_of_real)
155.330 +
155.331 +lemma Reals_0 [simp]: "0 \<in> Reals"
155.332 +apply (unfold Reals_def)
155.333 +apply (rule range_eqI)
155.334 +apply (rule of_real_0 [symmetric])
155.335 +done
155.336 +
155.337 +lemma Reals_1 [simp]: "1 \<in> Reals"
155.338 +apply (unfold Reals_def)
155.339 +apply (rule range_eqI)
155.340 +apply (rule of_real_1 [symmetric])
155.341 +done
155.342 +
155.343 +lemma Reals_add [simp]: "\<lbrakk>a \<in> Reals; b \<in> Reals\<rbrakk> \<Longrightarrow> a + b \<in> Reals"
155.344 +apply (auto simp add: Reals_def)
155.345 +apply (rule range_eqI)
155.346 +apply (rule of_real_add [symmetric])
155.347 +done
155.348 +
155.349 +lemma Reals_minus [simp]: "a \<in> Reals \<Longrightarrow> - a \<in> Reals"
155.350 +apply (auto simp add: Reals_def)
155.351 +apply (rule range_eqI)
155.352 +apply (rule of_real_minus [symmetric])
155.353 +done
155.354 +
155.355 +lemma Reals_diff [simp]: "\<lbrakk>a \<in> Reals; b \<in> Reals\<rbrakk> \<Longrightarrow> a - b \<in> Reals"
155.356 +apply (auto simp add: Reals_def)
155.357 +apply (rule range_eqI)
155.358 +apply (rule of_real_diff [symmetric])
155.359 +done
155.360 +
155.361 +lemma Reals_mult [simp]: "\<lbrakk>a \<in> Reals; b \<in> Reals\<rbrakk> \<Longrightarrow> a * b \<in> Reals"
155.362 +apply (auto simp add: Reals_def)
155.363 +apply (rule range_eqI)
155.364 +apply (rule of_real_mult [symmetric])
155.365 +done
155.366 +
155.367 +lemma nonzero_Reals_inverse:
155.368 + fixes a :: "'a::real_div_algebra"
155.369 + shows "\<lbrakk>a \<in> Reals; a \<noteq> 0\<rbrakk> \<Longrightarrow> inverse a \<in> Reals"
155.370 +apply (auto simp add: Reals_def)
155.371 +apply (rule range_eqI)
155.372 +apply (erule nonzero_of_real_inverse [symmetric])
155.373 +done
155.374 +
155.375 +lemma Reals_inverse [simp]:
155.376 + fixes a :: "'a::{real_div_algebra,division_by_zero}"
155.377 + shows "a \<in> Reals \<Longrightarrow> inverse a \<in> Reals"
155.378 +apply (auto simp add: Reals_def)
155.379 +apply (rule range_eqI)
155.380 +apply (rule of_real_inverse [symmetric])
155.381 +done
155.382 +
155.383 +lemma nonzero_Reals_divide:
155.384 + fixes a b :: "'a::real_field"
155.385 + shows "\<lbrakk>a \<in> Reals; b \<in> Reals; b \<noteq> 0\<rbrakk> \<Longrightarrow> a / b \<in> Reals"
155.386 +apply (auto simp add: Reals_def)
155.387 +apply (rule range_eqI)
155.388 +apply (erule nonzero_of_real_divide [symmetric])
155.389 +done
155.390 +
155.391 +lemma Reals_divide [simp]:
155.392 + fixes a b :: "'a::{real_field,division_by_zero}"
155.393 + shows "\<lbrakk>a \<in> Reals; b \<in> Reals\<rbrakk> \<Longrightarrow> a / b \<in> Reals"
155.394 +apply (auto simp add: Reals_def)
155.395 +apply (rule range_eqI)
155.396 +apply (rule of_real_divide [symmetric])
155.397 +done
155.398 +
155.399 +lemma Reals_power [simp]:
155.400 + fixes a :: "'a::{real_algebra_1,recpower}"
155.401 + shows "a \<in> Reals \<Longrightarrow> a ^ n \<in> Reals"
155.402 +apply (auto simp add: Reals_def)
155.403 +apply (rule range_eqI)
155.404 +apply (rule of_real_power [symmetric])
155.405 +done
155.406 +
155.407 +lemma Reals_cases [cases set: Reals]:
155.408 + assumes "q \<in> \<real>"
155.409 + obtains (of_real) r where "q = of_real r"
155.410 + unfolding Reals_def
155.411 +proof -
155.412 + from `q \<in> \<real>` have "q \<in> range of_real" unfolding Reals_def .
155.413 + then obtain r where "q = of_real r" ..
155.414 + then show thesis ..
155.415 +qed
155.416 +
155.417 +lemma Reals_induct [case_names of_real, induct set: Reals]:
155.418 + "q \<in> \<real> \<Longrightarrow> (\<And>r. P (of_real r)) \<Longrightarrow> P q"
155.419 + by (rule Reals_cases) auto
155.420 +
155.421 +
155.422 +subsection {* Real normed vector spaces *}
155.423 +
155.424 +class norm = type +
155.425 + fixes norm :: "'a \<Rightarrow> real"
155.426 +
155.427 +instantiation real :: norm
155.428 +begin
155.429 +
155.430 +definition
155.431 + real_norm_def [simp]: "norm r \<equiv> \<bar>r\<bar>"
155.432 +
155.433 +instance ..
155.434 +
155.435 +end
155.436 +
155.437 +class sgn_div_norm = scaleR + norm + sgn +
155.438 + assumes sgn_div_norm: "sgn x = x /\<^sub>R norm x"
155.439 +
155.440 +class real_normed_vector = real_vector + sgn_div_norm +
155.441 + assumes norm_ge_zero [simp]: "0 \<le> norm x"
155.442 + and norm_eq_zero [simp]: "norm x = 0 \<longleftrightarrow> x = 0"
155.443 + and norm_triangle_ineq: "norm (x + y) \<le> norm x + norm y"
155.444 + and norm_scaleR: "norm (scaleR a x) = \<bar>a\<bar> * norm x"
155.445 +
155.446 +class real_normed_algebra = real_algebra + real_normed_vector +
155.447 + assumes norm_mult_ineq: "norm (x * y) \<le> norm x * norm y"
155.448 +
155.449 +class real_normed_algebra_1 = real_algebra_1 + real_normed_algebra +
155.450 + assumes norm_one [simp]: "norm 1 = 1"
155.451 +
155.452 +class real_normed_div_algebra = real_div_algebra + real_normed_vector +
155.453 + assumes norm_mult: "norm (x * y) = norm x * norm y"
155.454 +
155.455 +class real_normed_field = real_field + real_normed_div_algebra
155.456 +
155.457 +instance real_normed_div_algebra < real_normed_algebra_1
155.458 +proof
155.459 + fix x y :: 'a
155.460 + show "norm (x * y) \<le> norm x * norm y"
155.461 + by (simp add: norm_mult)
155.462 +next
155.463 + have "norm (1 * 1::'a) = norm (1::'a) * norm (1::'a)"
155.464 + by (rule norm_mult)
155.465 + thus "norm (1::'a) = 1" by simp
155.466 +qed
155.467 +
155.468 +instance real :: real_normed_field
155.469 +apply (intro_classes, unfold real_norm_def real_scaleR_def)
155.470 +apply (simp add: real_sgn_def)
155.471 +apply (rule abs_ge_zero)
155.472 +apply (rule abs_eq_0)
155.473 +apply (rule abs_triangle_ineq)
155.474 +apply (rule abs_mult)
155.475 +apply (rule abs_mult)
155.476 +done
155.477 +
155.478 +lemma norm_zero [simp]: "norm (0::'a::real_normed_vector) = 0"
155.479 +by simp
155.480 +
155.481 +lemma zero_less_norm_iff [simp]:
155.482 + fixes x :: "'a::real_normed_vector"
155.483 + shows "(0 < norm x) = (x \<noteq> 0)"
155.484 +by (simp add: order_less_le)
155.485 +
155.486 +lemma norm_not_less_zero [simp]:
155.487 + fixes x :: "'a::real_normed_vector"
155.488 + shows "\<not> norm x < 0"
155.489 +by (simp add: linorder_not_less)
155.490 +
155.491 +lemma norm_le_zero_iff [simp]:
155.492 + fixes x :: "'a::real_normed_vector"
155.493 + shows "(norm x \<le> 0) = (x = 0)"
155.494 +by (simp add: order_le_less)
155.495 +
155.496 +lemma norm_minus_cancel [simp]:
155.497 + fixes x :: "'a::real_normed_vector"
155.498 + shows "norm (- x) = norm x"
155.499 +proof -
155.500 + have "norm (- x) = norm (scaleR (- 1) x)"
155.501 + by (simp only: scaleR_minus_left scaleR_one)
155.502 + also have "\<dots> = \<bar>- 1\<bar> * norm x"
155.503 + by (rule norm_scaleR)
155.504 + finally show ?thesis by simp
155.505 +qed
155.506 +
155.507 +lemma norm_minus_commute:
155.508 + fixes a b :: "'a::real_normed_vector"
155.509 + shows "norm (a - b) = norm (b - a)"
155.510 +proof -
155.511 + have "norm (- (b - a)) = norm (b - a)"
155.512 + by (rule norm_minus_cancel)
155.513 + thus ?thesis by simp
155.514 +qed
155.515 +
155.516 +lemma norm_triangle_ineq2:
155.517 + fixes a b :: "'a::real_normed_vector"
155.518 + shows "norm a - norm b \<le> norm (a - b)"
155.519 +proof -
155.520 + have "norm (a - b + b) \<le> norm (a - b) + norm b"
155.521 + by (rule norm_triangle_ineq)
155.522 + thus ?thesis by simp
155.523 +qed
155.524 +
155.525 +lemma norm_triangle_ineq3:
155.526 + fixes a b :: "'a::real_normed_vector"
155.527 + shows "\<bar>norm a - norm b\<bar> \<le> norm (a - b)"
155.528 +apply (subst abs_le_iff)
155.529 +apply auto
155.530 +apply (rule norm_triangle_ineq2)
155.531 +apply (subst norm_minus_commute)
155.532 +apply (rule norm_triangle_ineq2)
155.533 +done
155.534 +
155.535 +lemma norm_triangle_ineq4:
155.536 + fixes a b :: "'a::real_normed_vector"
155.537 + shows "norm (a - b) \<le> norm a + norm b"
155.538 +proof -
155.539 + have "norm (a + - b) \<le> norm a + norm (- b)"
155.540 + by (rule norm_triangle_ineq)
155.541 + thus ?thesis
155.542 + by (simp only: diff_minus norm_minus_cancel)
155.543 +qed
155.544 +
155.545 +lemma norm_diff_ineq:
155.546 + fixes a b :: "'a::real_normed_vector"
155.547 + shows "norm a - norm b \<le> norm (a + b)"
155.548 +proof -
155.549 + have "norm a - norm (- b) \<le> norm (a - - b)"
155.550 + by (rule norm_triangle_ineq2)
155.551 + thus ?thesis by simp
155.552 +qed
155.553 +
155.554 +lemma norm_diff_triangle_ineq:
155.555 + fixes a b c d :: "'a::real_normed_vector"
155.556 + shows "norm ((a + b) - (c + d)) \<le> norm (a - c) + norm (b - d)"
155.557 +proof -
155.558 + have "norm ((a + b) - (c + d)) = norm ((a - c) + (b - d))"
155.559 + by (simp add: diff_minus add_ac)
155.560 + also have "\<dots> \<le> norm (a - c) + norm (b - d)"
155.561 + by (rule norm_triangle_ineq)
155.562 + finally show ?thesis .
155.563 +qed
155.564 +
155.565 +lemma abs_norm_cancel [simp]:
155.566 + fixes a :: "'a::real_normed_vector"
155.567 + shows "\<bar>norm a\<bar> = norm a"
155.568 +by (rule abs_of_nonneg [OF norm_ge_zero])
155.569 +
155.570 +lemma norm_add_less:
155.571 + fixes x y :: "'a::real_normed_vector"
155.572 + shows "\<lbrakk>norm x < r; norm y < s\<rbrakk> \<Longrightarrow> norm (x + y) < r + s"
155.573 +by (rule order_le_less_trans [OF norm_triangle_ineq add_strict_mono])
155.574 +
155.575 +lemma norm_mult_less:
155.576 + fixes x y :: "'a::real_normed_algebra"
155.577 + shows "\<lbrakk>norm x < r; norm y < s\<rbrakk> \<Longrightarrow> norm (x * y) < r * s"
155.578 +apply (rule order_le_less_trans [OF norm_mult_ineq])
155.579 +apply (simp add: mult_strict_mono')
155.580 +done
155.581 +
155.582 +lemma norm_of_real [simp]:
155.583 + "norm (of_real r :: 'a::real_normed_algebra_1) = \<bar>r\<bar>"
155.584 +unfolding of_real_def by (simp add: norm_scaleR)
155.585 +
155.586 +lemma norm_number_of [simp]:
155.587 + "norm (number_of w::'a::{number_ring,real_normed_algebra_1})
155.588 + = \<bar>number_of w\<bar>"
155.589 +by (subst of_real_number_of_eq [symmetric], rule norm_of_real)
155.590 +
155.591 +lemma norm_of_int [simp]:
155.592 + "norm (of_int z::'a::real_normed_algebra_1) = \<bar>of_int z\<bar>"
155.593 +by (subst of_real_of_int_eq [symmetric], rule norm_of_real)
155.594 +
155.595 +lemma norm_of_nat [simp]:
155.596 + "norm (of_nat n::'a::real_normed_algebra_1) = of_nat n"
155.597 +apply (subst of_real_of_nat_eq [symmetric])
155.598 +apply (subst norm_of_real, simp)
155.599 +done
155.600 +
155.601 +lemma nonzero_norm_inverse:
155.602 + fixes a :: "'a::real_normed_div_algebra"
155.603 + shows "a \<noteq> 0 \<Longrightarrow> norm (inverse a) = inverse (norm a)"
155.604 +apply (rule inverse_unique [symmetric])
155.605 +apply (simp add: norm_mult [symmetric])
155.606 +done
155.607 +
155.608 +lemma norm_inverse:
155.609 + fixes a :: "'a::{real_normed_div_algebra,division_by_zero}"
155.610 + shows "norm (inverse a) = inverse (norm a)"
155.611 +apply (case_tac "a = 0", simp)
155.612 +apply (erule nonzero_norm_inverse)
155.613 +done
155.614 +
155.615 +lemma nonzero_norm_divide:
155.616 + fixes a b :: "'a::real_normed_field"
155.617 + shows "b \<noteq> 0 \<Longrightarrow> norm (a / b) = norm a / norm b"
155.618 +by (simp add: divide_inverse norm_mult nonzero_norm_inverse)
155.619 +
155.620 +lemma norm_divide:
155.621 + fixes a b :: "'a::{real_normed_field,division_by_zero}"
155.622 + shows "norm (a / b) = norm a / norm b"
155.623 +by (simp add: divide_inverse norm_mult norm_inverse)
155.624 +
155.625 +lemma norm_power_ineq:
155.626 + fixes x :: "'a::{real_normed_algebra_1,recpower}"
155.627 + shows "norm (x ^ n) \<le> norm x ^ n"
155.628 +proof (induct n)
155.629 + case 0 show "norm (x ^ 0) \<le> norm x ^ 0" by simp
155.630 +next
155.631 + case (Suc n)
155.632 + have "norm (x * x ^ n) \<le> norm x * norm (x ^ n)"
155.633 + by (rule norm_mult_ineq)
155.634 + also from Suc have "\<dots> \<le> norm x * norm x ^ n"
155.635 + using norm_ge_zero by (rule mult_left_mono)
155.636 + finally show "norm (x ^ Suc n) \<le> norm x ^ Suc n"
155.637 + by (simp add: power_Suc)
155.638 +qed
155.639 +
155.640 +lemma norm_power:
155.641 + fixes x :: "'a::{real_normed_div_algebra,recpower}"
155.642 + shows "norm (x ^ n) = norm x ^ n"
155.643 +by (induct n) (simp_all add: power_Suc norm_mult)
155.644 +
155.645 +
155.646 +subsection {* Sign function *}
155.647 +
155.648 +lemma norm_sgn:
155.649 + "norm (sgn(x::'a::real_normed_vector)) = (if x = 0 then 0 else 1)"
155.650 +by (simp add: sgn_div_norm norm_scaleR)
155.651 +
155.652 +lemma sgn_zero [simp]: "sgn(0::'a::real_normed_vector) = 0"
155.653 +by (simp add: sgn_div_norm)
155.654 +
155.655 +lemma sgn_zero_iff: "(sgn(x::'a::real_normed_vector) = 0) = (x = 0)"
155.656 +by (simp add: sgn_div_norm)
155.657 +
155.658 +lemma sgn_minus: "sgn (- x) = - sgn(x::'a::real_normed_vector)"
155.659 +by (simp add: sgn_div_norm)
155.660 +
155.661 +lemma sgn_scaleR:
155.662 + "sgn (scaleR r x) = scaleR (sgn r) (sgn(x::'a::real_normed_vector))"
155.663 +by (simp add: sgn_div_norm norm_scaleR mult_ac)
155.664 +
155.665 +lemma sgn_one [simp]: "sgn (1::'a::real_normed_algebra_1) = 1"
155.666 +by (simp add: sgn_div_norm)
155.667 +
155.668 +lemma sgn_of_real:
155.669 + "sgn (of_real r::'a::real_normed_algebra_1) = of_real (sgn r)"
155.670 +unfolding of_real_def by (simp only: sgn_scaleR sgn_one)
155.671 +
155.672 +lemma sgn_mult:
155.673 + fixes x y :: "'a::real_normed_div_algebra"
155.674 + shows "sgn (x * y) = sgn x * sgn y"
155.675 +by (simp add: sgn_div_norm norm_mult mult_commute)
155.676 +
155.677 +lemma real_sgn_eq: "sgn (x::real) = x / \<bar>x\<bar>"
155.678 +by (simp add: sgn_div_norm divide_inverse)
155.679 +
155.680 +lemma real_sgn_pos: "0 < (x::real) \<Longrightarrow> sgn x = 1"
155.681 +unfolding real_sgn_eq by simp
155.682 +
155.683 +lemma real_sgn_neg: "(x::real) < 0 \<Longrightarrow> sgn x = -1"
155.684 +unfolding real_sgn_eq by simp
155.685 +
155.686 +
155.687 +subsection {* Bounded Linear and Bilinear Operators *}
155.688 +
155.689 +locale bounded_linear = additive +
155.690 + constrains f :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
155.691 + assumes scaleR: "f (scaleR r x) = scaleR r (f x)"
155.692 + assumes bounded: "\<exists>K. \<forall>x. norm (f x) \<le> norm x * K"
155.693 +begin
155.694 +
155.695 +lemma pos_bounded:
155.696 + "\<exists>K>0. \<forall>x. norm (f x) \<le> norm x * K"
155.697 +proof -
155.698 + obtain K where K: "\<And>x. norm (f x) \<le> norm x * K"
155.699 + using bounded by fast
155.700 + show ?thesis
155.701 + proof (intro exI impI conjI allI)
155.702 + show "0 < max 1 K"
155.703 + by (rule order_less_le_trans [OF zero_less_one le_maxI1])
155.704 + next
155.705 + fix x
155.706 + have "norm (f x) \<le> norm x * K" using K .
155.707 + also have "\<dots> \<le> norm x * max 1 K"
155.708 + by (rule mult_left_mono [OF le_maxI2 norm_ge_zero])
155.709 + finally show "norm (f x) \<le> norm x * max 1 K" .
155.710 + qed
155.711 +qed
155.712 +
155.713 +lemma nonneg_bounded:
155.714 + "\<exists>K\<ge>0. \<forall>x. norm (f x) \<le> norm x * K"
155.715 +proof -
155.716 + from pos_bounded
155.717 + show ?thesis by (auto intro: order_less_imp_le)
155.718 +qed
155.719 +
155.720 +end
155.721 +
155.722 +locale bounded_bilinear =
155.723 + fixes prod :: "['a::real_normed_vector, 'b::real_normed_vector]
155.724 + \<Rightarrow> 'c::real_normed_vector"
155.725 + (infixl "**" 70)
155.726 + assumes add_left: "prod (a + a') b = prod a b + prod a' b"
155.727 + assumes add_right: "prod a (b + b') = prod a b + prod a b'"
155.728 + assumes scaleR_left: "prod (scaleR r a) b = scaleR r (prod a b)"
155.729 + assumes scaleR_right: "prod a (scaleR r b) = scaleR r (prod a b)"
155.730 + assumes bounded: "\<exists>K. \<forall>a b. norm (prod a b) \<le> norm a * norm b * K"
155.731 +begin
155.732 +
155.733 +lemma pos_bounded:
155.734 + "\<exists>K>0. \<forall>a b. norm (a ** b) \<le> norm a * norm b * K"
155.735 +apply (cut_tac bounded, erule exE)
155.736 +apply (rule_tac x="max 1 K" in exI, safe)
155.737 +apply (rule order_less_le_trans [OF zero_less_one le_maxI1])
155.738 +apply (drule spec, drule spec, erule order_trans)
155.739 +apply (rule mult_left_mono [OF le_maxI2])
155.740 +apply (intro mult_nonneg_nonneg norm_ge_zero)
155.741 +done
155.742 +
155.743 +lemma nonneg_bounded:
155.744 + "\<exists>K\<ge>0. \<forall>a b. norm (a ** b) \<le> norm a * norm b * K"
155.745 +proof -
155.746 + from pos_bounded
155.747 + show ?thesis by (auto intro: order_less_imp_le)
155.748 +qed
155.749 +
155.750 +lemma additive_right: "additive (\<lambda>b. prod a b)"
155.751 +by (rule additive.intro, rule add_right)
155.752 +
155.753 +lemma additive_left: "additive (\<lambda>a. prod a b)"
155.754 +by (rule additive.intro, rule add_left)
155.755 +
155.756 +lemma zero_left: "prod 0 b = 0"
155.757 +by (rule additive.zero [OF additive_left])
155.758 +
155.759 +lemma zero_right: "prod a 0 = 0"
155.760 +by (rule additive.zero [OF additive_right])
155.761 +
155.762 +lemma minus_left: "prod (- a) b = - prod a b"
155.763 +by (rule additive.minus [OF additive_left])
155.764 +
155.765 +lemma minus_right: "prod a (- b) = - prod a b"
155.766 +by (rule additive.minus [OF additive_right])
155.767 +
155.768 +lemma diff_left:
155.769 + "prod (a - a') b = prod a b - prod a' b"
155.770 +by (rule additive.diff [OF additive_left])
155.771 +
155.772 +lemma diff_right:
155.773 + "prod a (b - b') = prod a b - prod a b'"
155.774 +by (rule additive.diff [OF additive_right])
155.775 +
155.776 +lemma bounded_linear_left:
155.777 + "bounded_linear (\<lambda>a. a ** b)"
155.778 +apply (unfold_locales)
155.779 +apply (rule add_left)
155.780 +apply (rule scaleR_left)
155.781 +apply (cut_tac bounded, safe)
155.782 +apply (rule_tac x="norm b * K" in exI)
155.783 +apply (simp add: mult_ac)
155.784 +done
155.785 +
155.786 +lemma bounded_linear_right:
155.787 + "bounded_linear (\<lambda>b. a ** b)"
155.788 +apply (unfold_locales)
155.789 +apply (rule add_right)
155.790 +apply (rule scaleR_right)
155.791 +apply (cut_tac bounded, safe)
155.792 +apply (rule_tac x="norm a * K" in exI)
155.793 +apply (simp add: mult_ac)
155.794 +done
155.795 +
155.796 +lemma prod_diff_prod:
155.797 + "(x ** y - a ** b) = (x - a) ** (y - b) + (x - a) ** b + a ** (y - b)"
155.798 +by (simp add: diff_left diff_right)
155.799 +
155.800 +end
155.801 +
155.802 +interpretation mult!:
155.803 + bounded_bilinear "op * :: 'a \<Rightarrow> 'a \<Rightarrow> 'a::real_normed_algebra"
155.804 +apply (rule bounded_bilinear.intro)
155.805 +apply (rule left_distrib)
155.806 +apply (rule right_distrib)
155.807 +apply (rule mult_scaleR_left)
155.808 +apply (rule mult_scaleR_right)
155.809 +apply (rule_tac x="1" in exI)
155.810 +apply (simp add: norm_mult_ineq)
155.811 +done
155.812 +
155.813 +interpretation mult_left!:
155.814 + bounded_linear "(\<lambda>x::'a::real_normed_algebra. x * y)"
155.815 +by (rule mult.bounded_linear_left)
155.816 +
155.817 +interpretation mult_right!:
155.818 + bounded_linear "(\<lambda>y::'a::real_normed_algebra. x * y)"
155.819 +by (rule mult.bounded_linear_right)
155.820 +
155.821 +interpretation divide!:
155.822 + bounded_linear "(\<lambda>x::'a::real_normed_field. x / y)"
155.823 +unfolding divide_inverse by (rule mult.bounded_linear_left)
155.824 +
155.825 +interpretation scaleR!: bounded_bilinear "scaleR"
155.826 +apply (rule bounded_bilinear.intro)
155.827 +apply (rule scaleR_left_distrib)
155.828 +apply (rule scaleR_right_distrib)
155.829 +apply simp
155.830 +apply (rule scaleR_left_commute)
155.831 +apply (rule_tac x="1" in exI)
155.832 +apply (simp add: norm_scaleR)
155.833 +done
155.834 +
155.835 +interpretation scaleR_left!: bounded_linear "\<lambda>r. scaleR r x"
155.836 +by (rule scaleR.bounded_linear_left)
155.837 +
155.838 +interpretation scaleR_right!: bounded_linear "\<lambda>x. scaleR r x"
155.839 +by (rule scaleR.bounded_linear_right)
155.840 +
155.841 +interpretation of_real!: bounded_linear "\<lambda>r. of_real r"
155.842 +unfolding of_real_def by (rule scaleR.bounded_linear_left)
155.843 +
155.844 +end
156.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
156.2 +++ b/src/HOL/SEQ.thy Tue Dec 30 11:10:01 2008 +0100
156.3 @@ -0,0 +1,1136 @@
156.4 +(* Title : SEQ.thy
156.5 + Author : Jacques D. Fleuriot
156.6 + Copyright : 1998 University of Cambridge
156.7 + Description : Convergence of sequences and series
156.8 + Conversion to Isar and new proofs by Lawrence C Paulson, 2004
156.9 + Additional contributions by Jeremy Avigad and Brian Huffman
156.10 +*)
156.11 +
156.12 +header {* Sequences and Convergence *}
156.13 +
156.14 +theory SEQ
156.15 +imports RealVector RComplete
156.16 +begin
156.17 +
156.18 +definition
156.19 + Zseq :: "[nat \<Rightarrow> 'a::real_normed_vector] \<Rightarrow> bool" where
156.20 + --{*Standard definition of sequence converging to zero*}
156.21 + [code del]: "Zseq X = (\<forall>r>0. \<exists>no. \<forall>n\<ge>no. norm (X n) < r)"
156.22 +
156.23 +definition
156.24 + LIMSEQ :: "[nat => 'a::real_normed_vector, 'a] => bool"
156.25 + ("((_)/ ----> (_))" [60, 60] 60) where
156.26 + --{*Standard definition of convergence of sequence*}
156.27 + [code del]: "X ----> L = (\<forall>r. 0 < r --> (\<exists>no. \<forall>n. no \<le> n --> norm (X n - L) < r))"
156.28 +
156.29 +definition
156.30 + lim :: "(nat => 'a::real_normed_vector) => 'a" where
156.31 + --{*Standard definition of limit using choice operator*}
156.32 + "lim X = (THE L. X ----> L)"
156.33 +
156.34 +definition
156.35 + convergent :: "(nat => 'a::real_normed_vector) => bool" where
156.36 + --{*Standard definition of convergence*}
156.37 + "convergent X = (\<exists>L. X ----> L)"
156.38 +
156.39 +definition
156.40 + Bseq :: "(nat => 'a::real_normed_vector) => bool" where
156.41 + --{*Standard definition for bounded sequence*}
156.42 + [code del]: "Bseq X = (\<exists>K>0.\<forall>n. norm (X n) \<le> K)"
156.43 +
156.44 +definition
156.45 + monoseq :: "(nat=>real)=>bool" where
156.46 + --{*Definition for monotonicity*}
156.47 + [code del]: "monoseq X = ((\<forall>m. \<forall>n\<ge>m. X m \<le> X n) | (\<forall>m. \<forall>n\<ge>m. X n \<le> X m))"
156.48 +
156.49 +definition
156.50 + subseq :: "(nat => nat) => bool" where
156.51 + --{*Definition of subsequence*}
156.52 + [code del]: "subseq f = (\<forall>m. \<forall>n>m. (f m) < (f n))"
156.53 +
156.54 +definition
156.55 + Cauchy :: "(nat => 'a::real_normed_vector) => bool" where
156.56 + --{*Standard definition of the Cauchy condition*}
156.57 + [code del]: "Cauchy X = (\<forall>e>0. \<exists>M. \<forall>m \<ge> M. \<forall>n \<ge> M. norm (X m - X n) < e)"
156.58 +
156.59 +
156.60 +subsection {* Bounded Sequences *}
156.61 +
156.62 +lemma BseqI': assumes K: "\<And>n. norm (X n) \<le> K" shows "Bseq X"
156.63 +unfolding Bseq_def
156.64 +proof (intro exI conjI allI)
156.65 + show "0 < max K 1" by simp
156.66 +next
156.67 + fix n::nat
156.68 + have "norm (X n) \<le> K" by (rule K)
156.69 + thus "norm (X n) \<le> max K 1" by simp
156.70 +qed
156.71 +
156.72 +lemma BseqE: "\<lbrakk>Bseq X; \<And>K. \<lbrakk>0 < K; \<forall>n. norm (X n) \<le> K\<rbrakk> \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
156.73 +unfolding Bseq_def by auto
156.74 +
156.75 +lemma BseqI2': assumes K: "\<forall>n\<ge>N. norm (X n) \<le> K" shows "Bseq X"
156.76 +proof (rule BseqI')
156.77 + let ?A = "norm ` X ` {..N}"
156.78 + have 1: "finite ?A" by simp
156.79 + fix n::nat
156.80 + show "norm (X n) \<le> max K (Max ?A)"
156.81 + proof (cases rule: linorder_le_cases)
156.82 + assume "n \<ge> N"
156.83 + hence "norm (X n) \<le> K" using K by simp
156.84 + thus "norm (X n) \<le> max K (Max ?A)" by simp
156.85 + next
156.86 + assume "n \<le> N"
156.87 + hence "norm (X n) \<in> ?A" by simp
156.88 + with 1 have "norm (X n) \<le> Max ?A" by (rule Max_ge)
156.89 + thus "norm (X n) \<le> max K (Max ?A)" by simp
156.90 + qed
156.91 +qed
156.92 +
156.93 +lemma Bseq_ignore_initial_segment: "Bseq X \<Longrightarrow> Bseq (\<lambda>n. X (n + k))"
156.94 +unfolding Bseq_def by auto
156.95 +
156.96 +lemma Bseq_offset: "Bseq (\<lambda>n. X (n + k)) \<Longrightarrow> Bseq X"
156.97 +apply (erule BseqE)
156.98 +apply (rule_tac N="k" and K="K" in BseqI2')
156.99 +apply clarify
156.100 +apply (drule_tac x="n - k" in spec, simp)
156.101 +done
156.102 +
156.103 +
156.104 +subsection {* Sequences That Converge to Zero *}
156.105 +
156.106 +lemma ZseqI:
156.107 + "(\<And>r. 0 < r \<Longrightarrow> \<exists>no. \<forall>n\<ge>no. norm (X n) < r) \<Longrightarrow> Zseq X"
156.108 +unfolding Zseq_def by simp
156.109 +
156.110 +lemma ZseqD:
156.111 + "\<lbrakk>Zseq X; 0 < r\<rbrakk> \<Longrightarrow> \<exists>no. \<forall>n\<ge>no. norm (X n) < r"
156.112 +unfolding Zseq_def by simp
156.113 +
156.114 +lemma Zseq_zero: "Zseq (\<lambda>n. 0)"
156.115 +unfolding Zseq_def by simp
156.116 +
156.117 +lemma Zseq_const_iff: "Zseq (\<lambda>n. k) = (k = 0)"
156.118 +unfolding Zseq_def by force
156.119 +
156.120 +lemma Zseq_norm_iff: "Zseq (\<lambda>n. norm (X n)) = Zseq (\<lambda>n. X n)"
156.121 +unfolding Zseq_def by simp
156.122 +
156.123 +lemma Zseq_imp_Zseq:
156.124 + assumes X: "Zseq X"
156.125 + assumes Y: "\<And>n. norm (Y n) \<le> norm (X n) * K"
156.126 + shows "Zseq (\<lambda>n. Y n)"
156.127 +proof (cases)
156.128 + assume K: "0 < K"
156.129 + show ?thesis
156.130 + proof (rule ZseqI)
156.131 + fix r::real assume "0 < r"
156.132 + hence "0 < r / K"
156.133 + using K by (rule divide_pos_pos)
156.134 + then obtain N where "\<forall>n\<ge>N. norm (X n) < r / K"
156.135 + using ZseqD [OF X] by fast
156.136 + hence "\<forall>n\<ge>N. norm (X n) * K < r"
156.137 + by (simp add: pos_less_divide_eq K)
156.138 + hence "\<forall>n\<ge>N. norm (Y n) < r"
156.139 + by (simp add: order_le_less_trans [OF Y])
156.140 + thus "\<exists>N. \<forall>n\<ge>N. norm (Y n) < r" ..
156.141 + qed
156.142 +next
156.143 + assume "\<not> 0 < K"
156.144 + hence K: "K \<le> 0" by (simp only: linorder_not_less)
156.145 + {
156.146 + fix n::nat
156.147 + have "norm (Y n) \<le> norm (X n) * K" by (rule Y)
156.148 + also have "\<dots> \<le> norm (X n) * 0"
156.149 + using K norm_ge_zero by (rule mult_left_mono)
156.150 + finally have "norm (Y n) = 0" by simp
156.151 + }
156.152 + thus ?thesis by (simp add: Zseq_zero)
156.153 +qed
156.154 +
156.155 +lemma Zseq_le: "\<lbrakk>Zseq Y; \<forall>n. norm (X n) \<le> norm (Y n)\<rbrakk> \<Longrightarrow> Zseq X"
156.156 +by (erule_tac K="1" in Zseq_imp_Zseq, simp)
156.157 +
156.158 +lemma Zseq_add:
156.159 + assumes X: "Zseq X"
156.160 + assumes Y: "Zseq Y"
156.161 + shows "Zseq (\<lambda>n. X n + Y n)"
156.162 +proof (rule ZseqI)
156.163 + fix r::real assume "0 < r"
156.164 + hence r: "0 < r / 2" by simp
156.165 + obtain M where M: "\<forall>n\<ge>M. norm (X n) < r/2"
156.166 + using ZseqD [OF X r] by fast
156.167 + obtain N where N: "\<forall>n\<ge>N. norm (Y n) < r/2"
156.168 + using ZseqD [OF Y r] by fast
156.169 + show "\<exists>N. \<forall>n\<ge>N. norm (X n + Y n) < r"
156.170 + proof (intro exI allI impI)
156.171 + fix n assume n: "max M N \<le> n"
156.172 + have "norm (X n + Y n) \<le> norm (X n) + norm (Y n)"
156.173 + by (rule norm_triangle_ineq)
156.174 + also have "\<dots> < r/2 + r/2"
156.175 + proof (rule add_strict_mono)
156.176 + from M n show "norm (X n) < r/2" by simp
156.177 + from N n show "norm (Y n) < r/2" by simp
156.178 + qed
156.179 + finally show "norm (X n + Y n) < r" by simp
156.180 + qed
156.181 +qed
156.182 +
156.183 +lemma Zseq_minus: "Zseq X \<Longrightarrow> Zseq (\<lambda>n. - X n)"
156.184 +unfolding Zseq_def by simp
156.185 +
156.186 +lemma Zseq_diff: "\<lbrakk>Zseq X; Zseq Y\<rbrakk> \<Longrightarrow> Zseq (\<lambda>n. X n - Y n)"
156.187 +by (simp only: diff_minus Zseq_add Zseq_minus)
156.188 +
156.189 +lemma (in bounded_linear) Zseq:
156.190 + assumes X: "Zseq X"
156.191 + shows "Zseq (\<lambda>n. f (X n))"
156.192 +proof -
156.193 + obtain K where "\<And>x. norm (f x) \<le> norm x * K"
156.194 + using bounded by fast
156.195 + with X show ?thesis
156.196 + by (rule Zseq_imp_Zseq)
156.197 +qed
156.198 +
156.199 +lemma (in bounded_bilinear) Zseq:
156.200 + assumes X: "Zseq X"
156.201 + assumes Y: "Zseq Y"
156.202 + shows "Zseq (\<lambda>n. X n ** Y n)"
156.203 +proof (rule ZseqI)
156.204 + fix r::real assume r: "0 < r"
156.205 + obtain K where K: "0 < K"
156.206 + and norm_le: "\<And>x y. norm (x ** y) \<le> norm x * norm y * K"
156.207 + using pos_bounded by fast
156.208 + from K have K': "0 < inverse K"
156.209 + by (rule positive_imp_inverse_positive)
156.210 + obtain M where M: "\<forall>n\<ge>M. norm (X n) < r"
156.211 + using ZseqD [OF X r] by fast
156.212 + obtain N where N: "\<forall>n\<ge>N. norm (Y n) < inverse K"
156.213 + using ZseqD [OF Y K'] by fast
156.214 + show "\<exists>N. \<forall>n\<ge>N. norm (X n ** Y n) < r"
156.215 + proof (intro exI allI impI)
156.216 + fix n assume n: "max M N \<le> n"
156.217 + have "norm (X n ** Y n) \<le> norm (X n) * norm (Y n) * K"
156.218 + by (rule norm_le)
156.219 + also have "norm (X n) * norm (Y n) * K < r * inverse K * K"
156.220 + proof (intro mult_strict_right_mono mult_strict_mono' norm_ge_zero K)
156.221 + from M n show Xn: "norm (X n) < r" by simp
156.222 + from N n show Yn: "norm (Y n) < inverse K" by simp
156.223 + qed
156.224 + also from K have "r * inverse K * K = r" by simp
156.225 + finally show "norm (X n ** Y n) < r" .
156.226 + qed
156.227 +qed
156.228 +
156.229 +lemma (in bounded_bilinear) Zseq_prod_Bseq:
156.230 + assumes X: "Zseq X"
156.231 + assumes Y: "Bseq Y"
156.232 + shows "Zseq (\<lambda>n. X n ** Y n)"
156.233 +proof -
156.234 + obtain K where K: "0 \<le> K"
156.235 + and norm_le: "\<And>x y. norm (x ** y) \<le> norm x * norm y * K"
156.236 + using nonneg_bounded by fast
156.237 + obtain B where B: "0 < B"
156.238 + and norm_Y: "\<And>n. norm (Y n) \<le> B"
156.239 + using Y [unfolded Bseq_def] by fast
156.240 + from X show ?thesis
156.241 + proof (rule Zseq_imp_Zseq)
156.242 + fix n::nat
156.243 + have "norm (X n ** Y n) \<le> norm (X n) * norm (Y n) * K"
156.244 + by (rule norm_le)
156.245 + also have "\<dots> \<le> norm (X n) * B * K"
156.246 + by (intro mult_mono' order_refl norm_Y norm_ge_zero
156.247 + mult_nonneg_nonneg K)
156.248 + also have "\<dots> = norm (X n) * (B * K)"
156.249 + by (rule mult_assoc)
156.250 + finally show "norm (X n ** Y n) \<le> norm (X n) * (B * K)" .
156.251 + qed
156.252 +qed
156.253 +
156.254 +lemma (in bounded_bilinear) Bseq_prod_Zseq:
156.255 + assumes X: "Bseq X"
156.256 + assumes Y: "Zseq Y"
156.257 + shows "Zseq (\<lambda>n. X n ** Y n)"
156.258 +proof -
156.259 + obtain K where K: "0 \<le> K"
156.260 + and norm_le: "\<And>x y. norm (x ** y) \<le> norm x * norm y * K"
156.261 + using nonneg_bounded by fast
156.262 + obtain B where B: "0 < B"
156.263 + and norm_X: "\<And>n. norm (X n) \<le> B"
156.264 + using X [unfolded Bseq_def] by fast
156.265 + from Y show ?thesis
156.266 + proof (rule Zseq_imp_Zseq)
156.267 + fix n::nat
156.268 + have "norm (X n ** Y n) \<le> norm (X n) * norm (Y n) * K"
156.269 + by (rule norm_le)
156.270 + also have "\<dots> \<le> B * norm (Y n) * K"
156.271 + by (intro mult_mono' order_refl norm_X norm_ge_zero
156.272 + mult_nonneg_nonneg K)
156.273 + also have "\<dots> = norm (Y n) * (B * K)"
156.274 + by (simp only: mult_ac)
156.275 + finally show "norm (X n ** Y n) \<le> norm (Y n) * (B * K)" .
156.276 + qed
156.277 +qed
156.278 +
156.279 +lemma (in bounded_bilinear) Zseq_left:
156.280 + "Zseq X \<Longrightarrow> Zseq (\<lambda>n. X n ** a)"
156.281 +by (rule bounded_linear_left [THEN bounded_linear.Zseq])
156.282 +
156.283 +lemma (in bounded_bilinear) Zseq_right:
156.284 + "Zseq X \<Longrightarrow> Zseq (\<lambda>n. a ** X n)"
156.285 +by (rule bounded_linear_right [THEN bounded_linear.Zseq])
156.286 +
156.287 +lemmas Zseq_mult = mult.Zseq
156.288 +lemmas Zseq_mult_right = mult.Zseq_right
156.289 +lemmas Zseq_mult_left = mult.Zseq_left
156.290 +
156.291 +
156.292 +subsection {* Limits of Sequences *}
156.293 +
156.294 +lemma LIMSEQ_iff:
156.295 + "(X ----> L) = (\<forall>r>0. \<exists>no. \<forall>n \<ge> no. norm (X n - L) < r)"
156.296 +by (rule LIMSEQ_def)
156.297 +
156.298 +lemma LIMSEQ_Zseq_iff: "((\<lambda>n. X n) ----> L) = Zseq (\<lambda>n. X n - L)"
156.299 +by (simp only: LIMSEQ_def Zseq_def)
156.300 +
156.301 +lemma LIMSEQ_I:
156.302 + "(\<And>r. 0 < r \<Longrightarrow> \<exists>no. \<forall>n\<ge>no. norm (X n - L) < r) \<Longrightarrow> X ----> L"
156.303 +by (simp add: LIMSEQ_def)
156.304 +
156.305 +lemma LIMSEQ_D:
156.306 + "\<lbrakk>X ----> L; 0 < r\<rbrakk> \<Longrightarrow> \<exists>no. \<forall>n\<ge>no. norm (X n - L) < r"
156.307 +by (simp add: LIMSEQ_def)
156.308 +
156.309 +lemma LIMSEQ_const: "(\<lambda>n. k) ----> k"
156.310 +by (simp add: LIMSEQ_def)
156.311 +
156.312 +lemma LIMSEQ_const_iff: "(\<lambda>n. k) ----> l = (k = l)"
156.313 +by (simp add: LIMSEQ_Zseq_iff Zseq_const_iff)
156.314 +
156.315 +lemma LIMSEQ_norm: "X ----> a \<Longrightarrow> (\<lambda>n. norm (X n)) ----> norm a"
156.316 +apply (simp add: LIMSEQ_def, safe)
156.317 +apply (drule_tac x="r" in spec, safe)
156.318 +apply (rule_tac x="no" in exI, safe)
156.319 +apply (drule_tac x="n" in spec, safe)
156.320 +apply (erule order_le_less_trans [OF norm_triangle_ineq3])
156.321 +done
156.322 +
156.323 +lemma LIMSEQ_ignore_initial_segment:
156.324 + "f ----> a \<Longrightarrow> (\<lambda>n. f (n + k)) ----> a"
156.325 +apply (rule LIMSEQ_I)
156.326 +apply (drule (1) LIMSEQ_D)
156.327 +apply (erule exE, rename_tac N)
156.328 +apply (rule_tac x=N in exI)
156.329 +apply simp
156.330 +done
156.331 +
156.332 +lemma LIMSEQ_offset:
156.333 + "(\<lambda>n. f (n + k)) ----> a \<Longrightarrow> f ----> a"
156.334 +apply (rule LIMSEQ_I)
156.335 +apply (drule (1) LIMSEQ_D)
156.336 +apply (erule exE, rename_tac N)
156.337 +apply (rule_tac x="N + k" in exI)
156.338 +apply clarify
156.339 +apply (drule_tac x="n - k" in spec)
156.340 +apply (simp add: le_diff_conv2)
156.341 +done
156.342 +
156.343 +lemma LIMSEQ_Suc: "f ----> l \<Longrightarrow> (\<lambda>n. f (Suc n)) ----> l"
156.344 +by (drule_tac k="1" in LIMSEQ_ignore_initial_segment, simp)
156.345 +
156.346 +lemma LIMSEQ_imp_Suc: "(\<lambda>n. f (Suc n)) ----> l \<Longrightarrow> f ----> l"
156.347 +by (rule_tac k="1" in LIMSEQ_offset, simp)
156.348 +
156.349 +lemma LIMSEQ_Suc_iff: "(\<lambda>n. f (Suc n)) ----> l = f ----> l"
156.350 +by (blast intro: LIMSEQ_imp_Suc LIMSEQ_Suc)
156.351 +
156.352 +lemma add_diff_add:
156.353 + fixes a b c d :: "'a::ab_group_add"
156.354 + shows "(a + c) - (b + d) = (a - b) + (c - d)"
156.355 +by simp
156.356 +
156.357 +lemma minus_diff_minus:
156.358 + fixes a b :: "'a::ab_group_add"
156.359 + shows "(- a) - (- b) = - (a - b)"
156.360 +by simp
156.361 +
156.362 +lemma LIMSEQ_add: "\<lbrakk>X ----> a; Y ----> b\<rbrakk> \<Longrightarrow> (\<lambda>n. X n + Y n) ----> a + b"
156.363 +by (simp only: LIMSEQ_Zseq_iff add_diff_add Zseq_add)
156.364 +
156.365 +lemma LIMSEQ_minus: "X ----> a \<Longrightarrow> (\<lambda>n. - X n) ----> - a"
156.366 +by (simp only: LIMSEQ_Zseq_iff minus_diff_minus Zseq_minus)
156.367 +
156.368 +lemma LIMSEQ_minus_cancel: "(\<lambda>n. - X n) ----> - a \<Longrightarrow> X ----> a"
156.369 +by (drule LIMSEQ_minus, simp)
156.370 +
156.371 +lemma LIMSEQ_diff: "\<lbrakk>X ----> a; Y ----> b\<rbrakk> \<Longrightarrow> (\<lambda>n. X n - Y n) ----> a - b"
156.372 +by (simp add: diff_minus LIMSEQ_add LIMSEQ_minus)
156.373 +
156.374 +lemma LIMSEQ_unique: "\<lbrakk>X ----> a; X ----> b\<rbrakk> \<Longrightarrow> a = b"
156.375 +by (drule (1) LIMSEQ_diff, simp add: LIMSEQ_const_iff)
156.376 +
156.377 +lemma (in bounded_linear) LIMSEQ:
156.378 + "X ----> a \<Longrightarrow> (\<lambda>n. f (X n)) ----> f a"
156.379 +by (simp only: LIMSEQ_Zseq_iff diff [symmetric] Zseq)
156.380 +
156.381 +lemma (in bounded_bilinear) LIMSEQ:
156.382 + "\<lbrakk>X ----> a; Y ----> b\<rbrakk> \<Longrightarrow> (\<lambda>n. X n ** Y n) ----> a ** b"
156.383 +by (simp only: LIMSEQ_Zseq_iff prod_diff_prod
156.384 + Zseq_add Zseq Zseq_left Zseq_right)
156.385 +
156.386 +lemma LIMSEQ_mult:
156.387 + fixes a b :: "'a::real_normed_algebra"
156.388 + shows "[| X ----> a; Y ----> b |] ==> (%n. X n * Y n) ----> a * b"
156.389 +by (rule mult.LIMSEQ)
156.390 +
156.391 +lemma inverse_diff_inverse:
156.392 + "\<lbrakk>(a::'a::division_ring) \<noteq> 0; b \<noteq> 0\<rbrakk>
156.393 + \<Longrightarrow> inverse a - inverse b = - (inverse a * (a - b) * inverse b)"
156.394 +by (simp add: ring_simps)
156.395 +
156.396 +lemma Bseq_inverse_lemma:
156.397 + fixes x :: "'a::real_normed_div_algebra"
156.398 + shows "\<lbrakk>r \<le> norm x; 0 < r\<rbrakk> \<Longrightarrow> norm (inverse x) \<le> inverse r"
156.399 +apply (subst nonzero_norm_inverse, clarsimp)
156.400 +apply (erule (1) le_imp_inverse_le)
156.401 +done
156.402 +
156.403 +lemma Bseq_inverse:
156.404 + fixes a :: "'a::real_normed_div_algebra"
156.405 + assumes X: "X ----> a"
156.406 + assumes a: "a \<noteq> 0"
156.407 + shows "Bseq (\<lambda>n. inverse (X n))"
156.408 +proof -
156.409 + from a have "0 < norm a" by simp
156.410 + hence "\<exists>r>0. r < norm a" by (rule dense)
156.411 + then obtain r where r1: "0 < r" and r2: "r < norm a" by fast
156.412 + obtain N where N: "\<And>n. N \<le> n \<Longrightarrow> norm (X n - a) < r"
156.413 + using LIMSEQ_D [OF X r1] by fast
156.414 + show ?thesis
156.415 + proof (rule BseqI2' [rule_format])
156.416 + fix n assume n: "N \<le> n"
156.417 + hence 1: "norm (X n - a) < r" by (rule N)
156.418 + hence 2: "X n \<noteq> 0" using r2 by auto
156.419 + hence "norm (inverse (X n)) = inverse (norm (X n))"
156.420 + by (rule nonzero_norm_inverse)
156.421 + also have "\<dots> \<le> inverse (norm a - r)"
156.422 + proof (rule le_imp_inverse_le)
156.423 + show "0 < norm a - r" using r2 by simp
156.424 + next
156.425 + have "norm a - norm (X n) \<le> norm (a - X n)"
156.426 + by (rule norm_triangle_ineq2)
156.427 + also have "\<dots> = norm (X n - a)"
156.428 + by (rule norm_minus_commute)
156.429 + also have "\<dots> < r" using 1 .
156.430 + finally show "norm a - r \<le> norm (X n)" by simp
156.431 + qed
156.432 + finally show "norm (inverse (X n)) \<le> inverse (norm a - r)" .
156.433 + qed
156.434 +qed
156.435 +
156.436 +lemma LIMSEQ_inverse_lemma:
156.437 + fixes a :: "'a::real_normed_div_algebra"
156.438 + shows "\<lbrakk>X ----> a; a \<noteq> 0; \<forall>n. X n \<noteq> 0\<rbrakk>
156.439 + \<Longrightarrow> (\<lambda>n. inverse (X n)) ----> inverse a"
156.440 +apply (subst LIMSEQ_Zseq_iff)
156.441 +apply (simp add: inverse_diff_inverse nonzero_imp_inverse_nonzero)
156.442 +apply (rule Zseq_minus)
156.443 +apply (rule Zseq_mult_left)
156.444 +apply (rule mult.Bseq_prod_Zseq)
156.445 +apply (erule (1) Bseq_inverse)
156.446 +apply (simp add: LIMSEQ_Zseq_iff)
156.447 +done
156.448 +
156.449 +lemma LIMSEQ_inverse:
156.450 + fixes a :: "'a::real_normed_div_algebra"
156.451 + assumes X: "X ----> a"
156.452 + assumes a: "a \<noteq> 0"
156.453 + shows "(\<lambda>n. inverse (X n)) ----> inverse a"
156.454 +proof -
156.455 + from a have "0 < norm a" by simp
156.456 + then obtain k where "\<forall>n\<ge>k. norm (X n - a) < norm a"
156.457 + using LIMSEQ_D [OF X] by fast
156.458 + hence "\<forall>n\<ge>k. X n \<noteq> 0" by auto
156.459 + hence k: "\<forall>n. X (n + k) \<noteq> 0" by simp
156.460 +
156.461 + from X have "(\<lambda>n. X (n + k)) ----> a"
156.462 + by (rule LIMSEQ_ignore_initial_segment)
156.463 + hence "(\<lambda>n. inverse (X (n + k))) ----> inverse a"
156.464 + using a k by (rule LIMSEQ_inverse_lemma)
156.465 + thus "(\<lambda>n. inverse (X n)) ----> inverse a"
156.466 + by (rule LIMSEQ_offset)
156.467 +qed
156.468 +
156.469 +lemma LIMSEQ_divide:
156.470 + fixes a b :: "'a::real_normed_field"
156.471 + shows "\<lbrakk>X ----> a; Y ----> b; b \<noteq> 0\<rbrakk> \<Longrightarrow> (\<lambda>n. X n / Y n) ----> a / b"
156.472 +by (simp add: LIMSEQ_mult LIMSEQ_inverse divide_inverse)
156.473 +
156.474 +lemma LIMSEQ_pow:
156.475 + fixes a :: "'a::{real_normed_algebra,recpower}"
156.476 + shows "X ----> a \<Longrightarrow> (\<lambda>n. (X n) ^ m) ----> a ^ m"
156.477 +by (induct m) (simp_all add: power_Suc LIMSEQ_const LIMSEQ_mult)
156.478 +
156.479 +lemma LIMSEQ_setsum:
156.480 + assumes n: "\<And>n. n \<in> S \<Longrightarrow> X n ----> L n"
156.481 + shows "(\<lambda>m. \<Sum>n\<in>S. X n m) ----> (\<Sum>n\<in>S. L n)"
156.482 +proof (cases "finite S")
156.483 + case True
156.484 + thus ?thesis using n
156.485 + proof (induct)
156.486 + case empty
156.487 + show ?case
156.488 + by (simp add: LIMSEQ_const)
156.489 + next
156.490 + case insert
156.491 + thus ?case
156.492 + by (simp add: LIMSEQ_add)
156.493 + qed
156.494 +next
156.495 + case False
156.496 + thus ?thesis
156.497 + by (simp add: LIMSEQ_const)
156.498 +qed
156.499 +
156.500 +lemma LIMSEQ_setprod:
156.501 + fixes L :: "'a \<Rightarrow> 'b::{real_normed_algebra,comm_ring_1}"
156.502 + assumes n: "\<And>n. n \<in> S \<Longrightarrow> X n ----> L n"
156.503 + shows "(\<lambda>m. \<Prod>n\<in>S. X n m) ----> (\<Prod>n\<in>S. L n)"
156.504 +proof (cases "finite S")
156.505 + case True
156.506 + thus ?thesis using n
156.507 + proof (induct)
156.508 + case empty
156.509 + show ?case
156.510 + by (simp add: LIMSEQ_const)
156.511 + next
156.512 + case insert
156.513 + thus ?case
156.514 + by (simp add: LIMSEQ_mult)
156.515 + qed
156.516 +next
156.517 + case False
156.518 + thus ?thesis
156.519 + by (simp add: setprod_def LIMSEQ_const)
156.520 +qed
156.521 +
156.522 +lemma LIMSEQ_add_const: "f ----> a ==> (%n.(f n + b)) ----> a + b"
156.523 +by (simp add: LIMSEQ_add LIMSEQ_const)
156.524 +
156.525 +(* FIXME: delete *)
156.526 +lemma LIMSEQ_add_minus:
156.527 + "[| X ----> a; Y ----> b |] ==> (%n. X n + -Y n) ----> a + -b"
156.528 +by (simp only: LIMSEQ_add LIMSEQ_minus)
156.529 +
156.530 +lemma LIMSEQ_diff_const: "f ----> a ==> (%n.(f n - b)) ----> a - b"
156.531 +by (simp add: LIMSEQ_diff LIMSEQ_const)
156.532 +
156.533 +lemma LIMSEQ_diff_approach_zero:
156.534 + "g ----> L ==> (%x. f x - g x) ----> 0 ==>
156.535 + f ----> L"
156.536 + apply (drule LIMSEQ_add)
156.537 + apply assumption
156.538 + apply simp
156.539 +done
156.540 +
156.541 +lemma LIMSEQ_diff_approach_zero2:
156.542 + "f ----> L ==> (%x. f x - g x) ----> 0 ==>
156.543 + g ----> L";
156.544 + apply (drule LIMSEQ_diff)
156.545 + apply assumption
156.546 + apply simp
156.547 +done
156.548 +
156.549 +text{*A sequence tends to zero iff its abs does*}
156.550 +lemma LIMSEQ_norm_zero: "((\<lambda>n. norm (X n)) ----> 0) = (X ----> 0)"
156.551 +by (simp add: LIMSEQ_def)
156.552 +
156.553 +lemma LIMSEQ_rabs_zero: "((%n. \<bar>f n\<bar>) ----> 0) = (f ----> (0::real))"
156.554 +by (simp add: LIMSEQ_def)
156.555 +
156.556 +lemma LIMSEQ_imp_rabs: "f ----> (l::real) ==> (%n. \<bar>f n\<bar>) ----> \<bar>l\<bar>"
156.557 +by (drule LIMSEQ_norm, simp)
156.558 +
156.559 +text{*An unbounded sequence's inverse tends to 0*}
156.560 +
156.561 +lemma LIMSEQ_inverse_zero:
156.562 + "\<forall>r::real. \<exists>N. \<forall>n\<ge>N. r < X n \<Longrightarrow> (\<lambda>n. inverse (X n)) ----> 0"
156.563 +apply (rule LIMSEQ_I)
156.564 +apply (drule_tac x="inverse r" in spec, safe)
156.565 +apply (rule_tac x="N" in exI, safe)
156.566 +apply (drule_tac x="n" in spec, safe)
156.567 +apply (frule positive_imp_inverse_positive)
156.568 +apply (frule (1) less_imp_inverse_less)
156.569 +apply (subgoal_tac "0 < X n", simp)
156.570 +apply (erule (1) order_less_trans)
156.571 +done
156.572 +
156.573 +text{*The sequence @{term "1/n"} tends to 0 as @{term n} tends to infinity*}
156.574 +
156.575 +lemma LIMSEQ_inverse_real_of_nat: "(%n. inverse(real(Suc n))) ----> 0"
156.576 +apply (rule LIMSEQ_inverse_zero, safe)
156.577 +apply (cut_tac x = r in reals_Archimedean2)
156.578 +apply (safe, rule_tac x = n in exI)
156.579 +apply (auto simp add: real_of_nat_Suc)
156.580 +done
156.581 +
156.582 +text{*The sequence @{term "r + 1/n"} tends to @{term r} as @{term n} tends to
156.583 +infinity is now easily proved*}
156.584 +
156.585 +lemma LIMSEQ_inverse_real_of_nat_add:
156.586 + "(%n. r + inverse(real(Suc n))) ----> r"
156.587 +by (cut_tac LIMSEQ_add [OF LIMSEQ_const LIMSEQ_inverse_real_of_nat], auto)
156.588 +
156.589 +lemma LIMSEQ_inverse_real_of_nat_add_minus:
156.590 + "(%n. r + -inverse(real(Suc n))) ----> r"
156.591 +by (cut_tac LIMSEQ_add_minus [OF LIMSEQ_const LIMSEQ_inverse_real_of_nat], auto)
156.592 +
156.593 +lemma LIMSEQ_inverse_real_of_nat_add_minus_mult:
156.594 + "(%n. r*( 1 + -inverse(real(Suc n)))) ----> r"
156.595 +by (cut_tac b=1 in
156.596 + LIMSEQ_mult [OF LIMSEQ_const LIMSEQ_inverse_real_of_nat_add_minus], auto)
156.597 +
156.598 +lemma LIMSEQ_le_const:
156.599 + "\<lbrakk>X ----> (x::real); \<exists>N. \<forall>n\<ge>N. a \<le> X n\<rbrakk> \<Longrightarrow> a \<le> x"
156.600 +apply (rule ccontr, simp only: linorder_not_le)
156.601 +apply (drule_tac r="a - x" in LIMSEQ_D, simp)
156.602 +apply clarsimp
156.603 +apply (drule_tac x="max N no" in spec, drule mp, rule le_maxI1)
156.604 +apply (drule_tac x="max N no" in spec, drule mp, rule le_maxI2)
156.605 +apply simp
156.606 +done
156.607 +
156.608 +lemma LIMSEQ_le_const2:
156.609 + "\<lbrakk>X ----> (x::real); \<exists>N. \<forall>n\<ge>N. X n \<le> a\<rbrakk> \<Longrightarrow> x \<le> a"
156.610 +apply (subgoal_tac "- a \<le> - x", simp)
156.611 +apply (rule LIMSEQ_le_const)
156.612 +apply (erule LIMSEQ_minus)
156.613 +apply simp
156.614 +done
156.615 +
156.616 +lemma LIMSEQ_le:
156.617 + "\<lbrakk>X ----> x; Y ----> y; \<exists>N. \<forall>n\<ge>N. X n \<le> Y n\<rbrakk> \<Longrightarrow> x \<le> (y::real)"
156.618 +apply (subgoal_tac "0 \<le> y - x", simp)
156.619 +apply (rule LIMSEQ_le_const)
156.620 +apply (erule (1) LIMSEQ_diff)
156.621 +apply (simp add: le_diff_eq)
156.622 +done
156.623 +
156.624 +
156.625 +subsection {* Convergence *}
156.626 +
156.627 +lemma limI: "X ----> L ==> lim X = L"
156.628 +apply (simp add: lim_def)
156.629 +apply (blast intro: LIMSEQ_unique)
156.630 +done
156.631 +
156.632 +lemma convergentD: "convergent X ==> \<exists>L. (X ----> L)"
156.633 +by (simp add: convergent_def)
156.634 +
156.635 +lemma convergentI: "(X ----> L) ==> convergent X"
156.636 +by (auto simp add: convergent_def)
156.637 +
156.638 +lemma convergent_LIMSEQ_iff: "convergent X = (X ----> lim X)"
156.639 +by (auto intro: theI LIMSEQ_unique simp add: convergent_def lim_def)
156.640 +
156.641 +lemma convergent_minus_iff: "(convergent X) = (convergent (%n. -(X n)))"
156.642 +apply (simp add: convergent_def)
156.643 +apply (auto dest: LIMSEQ_minus)
156.644 +apply (drule LIMSEQ_minus, auto)
156.645 +done
156.646 +
156.647 +
156.648 +subsection {* Bounded Monotonic Sequences *}
156.649 +
156.650 +text{*Subsequence (alternative definition, (e.g. Hoskins)*}
156.651 +
156.652 +lemma subseq_Suc_iff: "subseq f = (\<forall>n. (f n) < (f (Suc n)))"
156.653 +apply (simp add: subseq_def)
156.654 +apply (auto dest!: less_imp_Suc_add)
156.655 +apply (induct_tac k)
156.656 +apply (auto intro: less_trans)
156.657 +done
156.658 +
156.659 +lemma monoseq_Suc:
156.660 + "monoseq X = ((\<forall>n. X n \<le> X (Suc n))
156.661 + | (\<forall>n. X (Suc n) \<le> X n))"
156.662 +apply (simp add: monoseq_def)
156.663 +apply (auto dest!: le_imp_less_or_eq)
156.664 +apply (auto intro!: lessI [THEN less_imp_le] dest!: less_imp_Suc_add)
156.665 +apply (induct_tac "ka")
156.666 +apply (auto intro: order_trans)
156.667 +apply (erule contrapos_np)
156.668 +apply (induct_tac "k")
156.669 +apply (auto intro: order_trans)
156.670 +done
156.671 +
156.672 +lemma monoI1: "\<forall>m. \<forall> n \<ge> m. X m \<le> X n ==> monoseq X"
156.673 +by (simp add: monoseq_def)
156.674 +
156.675 +lemma monoI2: "\<forall>m. \<forall> n \<ge> m. X n \<le> X m ==> monoseq X"
156.676 +by (simp add: monoseq_def)
156.677 +
156.678 +lemma mono_SucI1: "\<forall>n. X n \<le> X (Suc n) ==> monoseq X"
156.679 +by (simp add: monoseq_Suc)
156.680 +
156.681 +lemma mono_SucI2: "\<forall>n. X (Suc n) \<le> X n ==> monoseq X"
156.682 +by (simp add: monoseq_Suc)
156.683 +
156.684 +text{*Bounded Sequence*}
156.685 +
156.686 +lemma BseqD: "Bseq X ==> \<exists>K. 0 < K & (\<forall>n. norm (X n) \<le> K)"
156.687 +by (simp add: Bseq_def)
156.688 +
156.689 +lemma BseqI: "[| 0 < K; \<forall>n. norm (X n) \<le> K |] ==> Bseq X"
156.690 +by (auto simp add: Bseq_def)
156.691 +
156.692 +lemma lemma_NBseq_def:
156.693 + "(\<exists>K > 0. \<forall>n. norm (X n) \<le> K) =
156.694 + (\<exists>N. \<forall>n. norm (X n) \<le> real(Suc N))"
156.695 +apply auto
156.696 + prefer 2 apply force
156.697 +apply (cut_tac x = K in reals_Archimedean2, clarify)
156.698 +apply (rule_tac x = n in exI, clarify)
156.699 +apply (drule_tac x = na in spec)
156.700 +apply (auto simp add: real_of_nat_Suc)
156.701 +done
156.702 +
156.703 +text{* alternative definition for Bseq *}
156.704 +lemma Bseq_iff: "Bseq X = (\<exists>N. \<forall>n. norm (X n) \<le> real(Suc N))"
156.705 +apply (simp add: Bseq_def)
156.706 +apply (simp (no_asm) add: lemma_NBseq_def)
156.707 +done
156.708 +
156.709 +lemma lemma_NBseq_def2:
156.710 + "(\<exists>K > 0. \<forall>n. norm (X n) \<le> K) = (\<exists>N. \<forall>n. norm (X n) < real(Suc N))"
156.711 +apply (subst lemma_NBseq_def, auto)
156.712 +apply (rule_tac x = "Suc N" in exI)
156.713 +apply (rule_tac [2] x = N in exI)
156.714 +apply (auto simp add: real_of_nat_Suc)
156.715 + prefer 2 apply (blast intro: order_less_imp_le)
156.716 +apply (drule_tac x = n in spec, simp)
156.717 +done
156.718 +
156.719 +(* yet another definition for Bseq *)
156.720 +lemma Bseq_iff1a: "Bseq X = (\<exists>N. \<forall>n. norm (X n) < real(Suc N))"
156.721 +by (simp add: Bseq_def lemma_NBseq_def2)
156.722 +
156.723 +subsubsection{*Upper Bounds and Lubs of Bounded Sequences*}
156.724 +
156.725 +lemma Bseq_isUb:
156.726 + "!!(X::nat=>real). Bseq X ==> \<exists>U. isUb (UNIV::real set) {x. \<exists>n. X n = x} U"
156.727 +by (auto intro: isUbI setleI simp add: Bseq_def abs_le_iff)
156.728 +
156.729 +
156.730 +text{* Use completeness of reals (supremum property)
156.731 + to show that any bounded sequence has a least upper bound*}
156.732 +
156.733 +lemma Bseq_isLub:
156.734 + "!!(X::nat=>real). Bseq X ==>
156.735 + \<exists>U. isLub (UNIV::real set) {x. \<exists>n. X n = x} U"
156.736 +by (blast intro: reals_complete Bseq_isUb)
156.737 +
156.738 +subsubsection{*A Bounded and Monotonic Sequence Converges*}
156.739 +
156.740 +lemma lemma_converg1:
156.741 + "!!(X::nat=>real). [| \<forall>m. \<forall> n \<ge> m. X m \<le> X n;
156.742 + isLub (UNIV::real set) {x. \<exists>n. X n = x} (X ma)
156.743 + |] ==> \<forall>n \<ge> ma. X n = X ma"
156.744 +apply safe
156.745 +apply (drule_tac y = "X n" in isLubD2)
156.746 +apply (blast dest: order_antisym)+
156.747 +done
156.748 +
156.749 +text{* The best of both worlds: Easier to prove this result as a standard
156.750 + theorem and then use equivalence to "transfer" it into the
156.751 + equivalent nonstandard form if needed!*}
156.752 +
156.753 +lemma Bmonoseq_LIMSEQ: "\<forall>n. m \<le> n --> X n = X m ==> \<exists>L. (X ----> L)"
156.754 +apply (simp add: LIMSEQ_def)
156.755 +apply (rule_tac x = "X m" in exI, safe)
156.756 +apply (rule_tac x = m in exI, safe)
156.757 +apply (drule spec, erule impE, auto)
156.758 +done
156.759 +
156.760 +lemma lemma_converg2:
156.761 + "!!(X::nat=>real).
156.762 + [| \<forall>m. X m ~= U; isLub UNIV {x. \<exists>n. X n = x} U |] ==> \<forall>m. X m < U"
156.763 +apply safe
156.764 +apply (drule_tac y = "X m" in isLubD2)
156.765 +apply (auto dest!: order_le_imp_less_or_eq)
156.766 +done
156.767 +
156.768 +lemma lemma_converg3: "!!(X ::nat=>real). \<forall>m. X m \<le> U ==> isUb UNIV {x. \<exists>n. X n = x} U"
156.769 +by (rule setleI [THEN isUbI], auto)
156.770 +
156.771 +text{* FIXME: @{term "U - T < U"} is redundant *}
156.772 +lemma lemma_converg4: "!!(X::nat=> real).
156.773 + [| \<forall>m. X m ~= U;
156.774 + isLub UNIV {x. \<exists>n. X n = x} U;
156.775 + 0 < T;
156.776 + U + - T < U
156.777 + |] ==> \<exists>m. U + -T < X m & X m < U"
156.778 +apply (drule lemma_converg2, assumption)
156.779 +apply (rule ccontr, simp)
156.780 +apply (simp add: linorder_not_less)
156.781 +apply (drule lemma_converg3)
156.782 +apply (drule isLub_le_isUb, assumption)
156.783 +apply (auto dest: order_less_le_trans)
156.784 +done
156.785 +
156.786 +text{*A standard proof of the theorem for monotone increasing sequence*}
156.787 +
156.788 +lemma Bseq_mono_convergent:
156.789 + "[| Bseq X; \<forall>m. \<forall>n \<ge> m. X m \<le> X n |] ==> convergent (X::nat=>real)"
156.790 +apply (simp add: convergent_def)
156.791 +apply (frule Bseq_isLub, safe)
156.792 +apply (case_tac "\<exists>m. X m = U", auto)
156.793 +apply (blast dest: lemma_converg1 Bmonoseq_LIMSEQ)
156.794 +(* second case *)
156.795 +apply (rule_tac x = U in exI)
156.796 +apply (subst LIMSEQ_iff, safe)
156.797 +apply (frule lemma_converg2, assumption)
156.798 +apply (drule lemma_converg4, auto)
156.799 +apply (rule_tac x = m in exI, safe)
156.800 +apply (subgoal_tac "X m \<le> X n")
156.801 + prefer 2 apply blast
156.802 +apply (drule_tac x=n and P="%m. X m < U" in spec, arith)
156.803 +done
156.804 +
156.805 +lemma Bseq_minus_iff: "Bseq (%n. -(X n)) = Bseq X"
156.806 +by (simp add: Bseq_def)
156.807 +
156.808 +text{*Main monotonicity theorem*}
156.809 +lemma Bseq_monoseq_convergent: "[| Bseq X; monoseq X |] ==> convergent X"
156.810 +apply (simp add: monoseq_def, safe)
156.811 +apply (rule_tac [2] convergent_minus_iff [THEN ssubst])
156.812 +apply (drule_tac [2] Bseq_minus_iff [THEN ssubst])
156.813 +apply (auto intro!: Bseq_mono_convergent)
156.814 +done
156.815 +
156.816 +subsubsection{*A Few More Equivalence Theorems for Boundedness*}
156.817 +
156.818 +text{*alternative formulation for boundedness*}
156.819 +lemma Bseq_iff2: "Bseq X = (\<exists>k > 0. \<exists>x. \<forall>n. norm (X(n) + -x) \<le> k)"
156.820 +apply (unfold Bseq_def, safe)
156.821 +apply (rule_tac [2] x = "k + norm x" in exI)
156.822 +apply (rule_tac x = K in exI, simp)
156.823 +apply (rule exI [where x = 0], auto)
156.824 +apply (erule order_less_le_trans, simp)
156.825 +apply (drule_tac x=n in spec, fold diff_def)
156.826 +apply (drule order_trans [OF norm_triangle_ineq2])
156.827 +apply simp
156.828 +done
156.829 +
156.830 +text{*alternative formulation for boundedness*}
156.831 +lemma Bseq_iff3: "Bseq X = (\<exists>k > 0. \<exists>N. \<forall>n. norm(X(n) + -X(N)) \<le> k)"
156.832 +apply safe
156.833 +apply (simp add: Bseq_def, safe)
156.834 +apply (rule_tac x = "K + norm (X N)" in exI)
156.835 +apply auto
156.836 +apply (erule order_less_le_trans, simp)
156.837 +apply (rule_tac x = N in exI, safe)
156.838 +apply (drule_tac x = n in spec)
156.839 +apply (rule order_trans [OF norm_triangle_ineq], simp)
156.840 +apply (auto simp add: Bseq_iff2)
156.841 +done
156.842 +
156.843 +lemma BseqI2: "(\<forall>n. k \<le> f n & f n \<le> (K::real)) ==> Bseq f"
156.844 +apply (simp add: Bseq_def)
156.845 +apply (rule_tac x = " (\<bar>k\<bar> + \<bar>K\<bar>) + 1" in exI, auto)
156.846 +apply (drule_tac x = n in spec, arith)
156.847 +done
156.848 +
156.849 +
156.850 +subsection {* Cauchy Sequences *}
156.851 +
156.852 +lemma CauchyI:
156.853 + "(\<And>e. 0 < e \<Longrightarrow> \<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. norm (X m - X n) < e) \<Longrightarrow> Cauchy X"
156.854 +by (simp add: Cauchy_def)
156.855 +
156.856 +lemma CauchyD:
156.857 + "\<lbrakk>Cauchy X; 0 < e\<rbrakk> \<Longrightarrow> \<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. norm (X m - X n) < e"
156.858 +by (simp add: Cauchy_def)
156.859 +
156.860 +subsubsection {* Cauchy Sequences are Bounded *}
156.861 +
156.862 +text{*A Cauchy sequence is bounded -- this is the standard
156.863 + proof mechanization rather than the nonstandard proof*}
156.864 +
156.865 +lemma lemmaCauchy: "\<forall>n \<ge> M. norm (X M - X n) < (1::real)
156.866 + ==> \<forall>n \<ge> M. norm (X n :: 'a::real_normed_vector) < 1 + norm (X M)"
156.867 +apply (clarify, drule spec, drule (1) mp)
156.868 +apply (simp only: norm_minus_commute)
156.869 +apply (drule order_le_less_trans [OF norm_triangle_ineq2])
156.870 +apply simp
156.871 +done
156.872 +
156.873 +lemma Cauchy_Bseq: "Cauchy X ==> Bseq X"
156.874 +apply (simp add: Cauchy_def)
156.875 +apply (drule spec, drule mp, rule zero_less_one, safe)
156.876 +apply (drule_tac x="M" in spec, simp)
156.877 +apply (drule lemmaCauchy)
156.878 +apply (rule_tac k="M" in Bseq_offset)
156.879 +apply (simp add: Bseq_def)
156.880 +apply (rule_tac x="1 + norm (X M)" in exI)
156.881 +apply (rule conjI, rule order_less_le_trans [OF zero_less_one], simp)
156.882 +apply (simp add: order_less_imp_le)
156.883 +done
156.884 +
156.885 +subsubsection {* Cauchy Sequences are Convergent *}
156.886 +
156.887 +axclass banach \<subseteq> real_normed_vector
156.888 + Cauchy_convergent: "Cauchy X \<Longrightarrow> convergent X"
156.889 +
156.890 +theorem LIMSEQ_imp_Cauchy:
156.891 + assumes X: "X ----> a" shows "Cauchy X"
156.892 +proof (rule CauchyI)
156.893 + fix e::real assume "0 < e"
156.894 + hence "0 < e/2" by simp
156.895 + with X have "\<exists>N. \<forall>n\<ge>N. norm (X n - a) < e/2" by (rule LIMSEQ_D)
156.896 + then obtain N where N: "\<forall>n\<ge>N. norm (X n - a) < e/2" ..
156.897 + show "\<exists>N. \<forall>m\<ge>N. \<forall>n\<ge>N. norm (X m - X n) < e"
156.898 + proof (intro exI allI impI)
156.899 + fix m assume "N \<le> m"
156.900 + hence m: "norm (X m - a) < e/2" using N by fast
156.901 + fix n assume "N \<le> n"
156.902 + hence n: "norm (X n - a) < e/2" using N by fast
156.903 + have "norm (X m - X n) = norm ((X m - a) - (X n - a))" by simp
156.904 + also have "\<dots> \<le> norm (X m - a) + norm (X n - a)"
156.905 + by (rule norm_triangle_ineq4)
156.906 + also from m n have "\<dots> < e" by(simp add:field_simps)
156.907 + finally show "norm (X m - X n) < e" .
156.908 + qed
156.909 +qed
156.910 +
156.911 +lemma convergent_Cauchy: "convergent X \<Longrightarrow> Cauchy X"
156.912 +unfolding convergent_def
156.913 +by (erule exE, erule LIMSEQ_imp_Cauchy)
156.914 +
156.915 +text {*
156.916 +Proof that Cauchy sequences converge based on the one from
156.917 +http://pirate.shu.edu/~wachsmut/ira/numseq/proofs/cauconv.html
156.918 +*}
156.919 +
156.920 +text {*
156.921 + If sequence @{term "X"} is Cauchy, then its limit is the lub of
156.922 + @{term "{r::real. \<exists>N. \<forall>n\<ge>N. r < X n}"}
156.923 +*}
156.924 +
156.925 +lemma isUb_UNIV_I: "(\<And>y. y \<in> S \<Longrightarrow> y \<le> u) \<Longrightarrow> isUb UNIV S u"
156.926 +by (simp add: isUbI setleI)
156.927 +
156.928 +lemma real_abs_diff_less_iff:
156.929 + "(\<bar>x - a\<bar> < (r::real)) = (a - r < x \<and> x < a + r)"
156.930 +by auto
156.931 +
156.932 +locale real_Cauchy =
156.933 + fixes X :: "nat \<Rightarrow> real"
156.934 + assumes X: "Cauchy X"
156.935 + fixes S :: "real set"
156.936 + defines S_def: "S \<equiv> {x::real. \<exists>N. \<forall>n\<ge>N. x < X n}"
156.937 +
156.938 +lemma real_CauchyI:
156.939 + assumes "Cauchy X"
156.940 + shows "real_Cauchy X"
156.941 + proof qed (fact assms)
156.942 +
156.943 +lemma (in real_Cauchy) mem_S: "\<forall>n\<ge>N. x < X n \<Longrightarrow> x \<in> S"
156.944 +by (unfold S_def, auto)
156.945 +
156.946 +lemma (in real_Cauchy) bound_isUb:
156.947 + assumes N: "\<forall>n\<ge>N. X n < x"
156.948 + shows "isUb UNIV S x"
156.949 +proof (rule isUb_UNIV_I)
156.950 + fix y::real assume "y \<in> S"
156.951 + hence "\<exists>M. \<forall>n\<ge>M. y < X n"
156.952 + by (simp add: S_def)
156.953 + then obtain M where "\<forall>n\<ge>M. y < X n" ..
156.954 + hence "y < X (max M N)" by simp
156.955 + also have "\<dots> < x" using N by simp
156.956 + finally show "y \<le> x"
156.957 + by (rule order_less_imp_le)
156.958 +qed
156.959 +
156.960 +lemma (in real_Cauchy) isLub_ex: "\<exists>u. isLub UNIV S u"
156.961 +proof (rule reals_complete)
156.962 + obtain N where "\<forall>m\<ge>N. \<forall>n\<ge>N. norm (X m - X n) < 1"
156.963 + using CauchyD [OF X zero_less_one] by fast
156.964 + hence N: "\<forall>n\<ge>N. norm (X n - X N) < 1" by simp
156.965 + show "\<exists>x. x \<in> S"
156.966 + proof
156.967 + from N have "\<forall>n\<ge>N. X N - 1 < X n"
156.968 + by (simp add: real_abs_diff_less_iff)
156.969 + thus "X N - 1 \<in> S" by (rule mem_S)
156.970 + qed
156.971 + show "\<exists>u. isUb UNIV S u"
156.972 + proof
156.973 + from N have "\<forall>n\<ge>N. X n < X N + 1"
156.974 + by (simp add: real_abs_diff_less_iff)
156.975 + thus "isUb UNIV S (X N + 1)"
156.976 + by (rule bound_isUb)
156.977 + qed
156.978 +qed
156.979 +
156.980 +lemma (in real_Cauchy) isLub_imp_LIMSEQ:
156.981 + assumes x: "isLub UNIV S x"
156.982 + shows "X ----> x"
156.983 +proof (rule LIMSEQ_I)
156.984 + fix r::real assume "0 < r"
156.985 + hence r: "0 < r/2" by simp
156.986 + obtain N where "\<forall>n\<ge>N. \<forall>m\<ge>N. norm (X n - X m) < r/2"
156.987 + using CauchyD [OF X r] by fast
156.988 + hence "\<forall>n\<ge>N. norm (X n - X N) < r/2" by simp
156.989 + hence N: "\<forall>n\<ge>N. X N - r/2 < X n \<and> X n < X N + r/2"
156.990 + by (simp only: real_norm_def real_abs_diff_less_iff)
156.991 +
156.992 + from N have "\<forall>n\<ge>N. X N - r/2 < X n" by fast
156.993 + hence "X N - r/2 \<in> S" by (rule mem_S)
156.994 + hence 1: "X N - r/2 \<le> x" using x isLub_isUb isUbD by fast
156.995 +
156.996 + from N have "\<forall>n\<ge>N. X n < X N + r/2" by fast
156.997 + hence "isUb UNIV S (X N + r/2)" by (rule bound_isUb)
156.998 + hence 2: "x \<le> X N + r/2" using x isLub_le_isUb by fast
156.999 +
156.1000 + show "\<exists>N. \<forall>n\<ge>N. norm (X n - x) < r"
156.1001 + proof (intro exI allI impI)
156.1002 + fix n assume n: "N \<le> n"
156.1003 + from N n have "X n < X N + r/2" and "X N - r/2 < X n" by simp+
156.1004 + thus "norm (X n - x) < r" using 1 2
156.1005 + by (simp add: real_abs_diff_less_iff)
156.1006 + qed
156.1007 +qed
156.1008 +
156.1009 +lemma (in real_Cauchy) LIMSEQ_ex: "\<exists>x. X ----> x"
156.1010 +proof -
156.1011 + obtain x where "isLub UNIV S x"
156.1012 + using isLub_ex by fast
156.1013 + hence "X ----> x"
156.1014 + by (rule isLub_imp_LIMSEQ)
156.1015 + thus ?thesis ..
156.1016 +qed
156.1017 +
156.1018 +lemma real_Cauchy_convergent:
156.1019 + fixes X :: "nat \<Rightarrow> real"
156.1020 + shows "Cauchy X \<Longrightarrow> convergent X"
156.1021 +unfolding convergent_def
156.1022 +by (rule real_Cauchy.LIMSEQ_ex)
156.1023 + (rule real_CauchyI)
156.1024 +
156.1025 +instance real :: banach
156.1026 +by intro_classes (rule real_Cauchy_convergent)
156.1027 +
156.1028 +lemma Cauchy_convergent_iff:
156.1029 + fixes X :: "nat \<Rightarrow> 'a::banach"
156.1030 + shows "Cauchy X = convergent X"
156.1031 +by (fast intro: Cauchy_convergent convergent_Cauchy)
156.1032 +
156.1033 +
156.1034 +subsection {* Power Sequences *}
156.1035 +
156.1036 +text{*The sequence @{term "x^n"} tends to 0 if @{term "0\<le>x"} and @{term
156.1037 +"x<1"}. Proof will use (NS) Cauchy equivalence for convergence and
156.1038 + also fact that bounded and monotonic sequence converges.*}
156.1039 +
156.1040 +lemma Bseq_realpow: "[| 0 \<le> (x::real); x \<le> 1 |] ==> Bseq (%n. x ^ n)"
156.1041 +apply (simp add: Bseq_def)
156.1042 +apply (rule_tac x = 1 in exI)
156.1043 +apply (simp add: power_abs)
156.1044 +apply (auto dest: power_mono)
156.1045 +done
156.1046 +
156.1047 +lemma monoseq_realpow: "[| 0 \<le> x; x \<le> 1 |] ==> monoseq (%n. x ^ n)"
156.1048 +apply (clarify intro!: mono_SucI2)
156.1049 +apply (cut_tac n = n and N = "Suc n" and a = x in power_decreasing, auto)
156.1050 +done
156.1051 +
156.1052 +lemma convergent_realpow:
156.1053 + "[| 0 \<le> (x::real); x \<le> 1 |] ==> convergent (%n. x ^ n)"
156.1054 +by (blast intro!: Bseq_monoseq_convergent Bseq_realpow monoseq_realpow)
156.1055 +
156.1056 +lemma LIMSEQ_inverse_realpow_zero_lemma:
156.1057 + fixes x :: real
156.1058 + assumes x: "0 \<le> x"
156.1059 + shows "real n * x + 1 \<le> (x + 1) ^ n"
156.1060 +apply (induct n)
156.1061 +apply simp
156.1062 +apply simp
156.1063 +apply (rule order_trans)
156.1064 +prefer 2
156.1065 +apply (erule mult_left_mono)
156.1066 +apply (rule add_increasing [OF x], simp)
156.1067 +apply (simp add: real_of_nat_Suc)
156.1068 +apply (simp add: ring_distribs)
156.1069 +apply (simp add: mult_nonneg_nonneg x)
156.1070 +done
156.1071 +
156.1072 +lemma LIMSEQ_inverse_realpow_zero:
156.1073 + "1 < (x::real) \<Longrightarrow> (\<lambda>n. inverse (x ^ n)) ----> 0"
156.1074 +proof (rule LIMSEQ_inverse_zero [rule_format])
156.1075 + fix y :: real
156.1076 + assume x: "1 < x"
156.1077 + hence "0 < x - 1" by simp
156.1078 + hence "\<forall>y. \<exists>N::nat. y < real N * (x - 1)"
156.1079 + by (rule reals_Archimedean3)
156.1080 + hence "\<exists>N::nat. y < real N * (x - 1)" ..
156.1081 + then obtain N::nat where "y < real N * (x - 1)" ..
156.1082 + also have "\<dots> \<le> real N * (x - 1) + 1" by simp
156.1083 + also have "\<dots> \<le> (x - 1 + 1) ^ N"
156.1084 + by (rule LIMSEQ_inverse_realpow_zero_lemma, cut_tac x, simp)
156.1085 + also have "\<dots> = x ^ N" by simp
156.1086 + finally have "y < x ^ N" .
156.1087 + hence "\<forall>n\<ge>N. y < x ^ n"
156.1088 + apply clarify
156.1089 + apply (erule order_less_le_trans)
156.1090 + apply (erule power_increasing)
156.1091 + apply (rule order_less_imp_le [OF x])
156.1092 + done
156.1093 + thus "\<exists>N. \<forall>n\<ge>N. y < x ^ n" ..
156.1094 +qed
156.1095 +
156.1096 +lemma LIMSEQ_realpow_zero:
156.1097 + "\<lbrakk>0 \<le> (x::real); x < 1\<rbrakk> \<Longrightarrow> (\<lambda>n. x ^ n) ----> 0"
156.1098 +proof (cases)
156.1099 + assume "x = 0"
156.1100 + hence "(\<lambda>n. x ^ Suc n) ----> 0" by (simp add: LIMSEQ_const)
156.1101 + thus ?thesis by (rule LIMSEQ_imp_Suc)
156.1102 +next
156.1103 + assume "0 \<le> x" and "x \<noteq> 0"
156.1104 + hence x0: "0 < x" by simp
156.1105 + assume x1: "x < 1"
156.1106 + from x0 x1 have "1 < inverse x"
156.1107 + by (rule real_inverse_gt_one)
156.1108 + hence "(\<lambda>n. inverse (inverse x ^ n)) ----> 0"
156.1109 + by (rule LIMSEQ_inverse_realpow_zero)
156.1110 + thus ?thesis by (simp add: power_inverse)
156.1111 +qed
156.1112 +
156.1113 +lemma LIMSEQ_power_zero:
156.1114 + fixes x :: "'a::{real_normed_algebra_1,recpower}"
156.1115 + shows "norm x < 1 \<Longrightarrow> (\<lambda>n. x ^ n) ----> 0"
156.1116 +apply (drule LIMSEQ_realpow_zero [OF norm_ge_zero])
156.1117 +apply (simp only: LIMSEQ_Zseq_iff, erule Zseq_le)
156.1118 +apply (simp add: power_abs norm_power_ineq)
156.1119 +done
156.1120 +
156.1121 +lemma LIMSEQ_divide_realpow_zero:
156.1122 + "1 < (x::real) ==> (%n. a / (x ^ n)) ----> 0"
156.1123 +apply (cut_tac a = a and x1 = "inverse x" in
156.1124 + LIMSEQ_mult [OF LIMSEQ_const LIMSEQ_realpow_zero])
156.1125 +apply (auto simp add: divide_inverse power_inverse)
156.1126 +apply (simp add: inverse_eq_divide pos_divide_less_eq)
156.1127 +done
156.1128 +
156.1129 +text{*Limit of @{term "c^n"} for @{term"\<bar>c\<bar> < 1"}*}
156.1130 +
156.1131 +lemma LIMSEQ_rabs_realpow_zero: "\<bar>c\<bar> < (1::real) ==> (%n. \<bar>c\<bar> ^ n) ----> 0"
156.1132 +by (rule LIMSEQ_realpow_zero [OF abs_ge_zero])
156.1133 +
156.1134 +lemma LIMSEQ_rabs_realpow_zero2: "\<bar>c\<bar> < (1::real) ==> (%n. c ^ n) ----> 0"
156.1135 +apply (rule LIMSEQ_rabs_zero [THEN iffD1])
156.1136 +apply (auto intro: LIMSEQ_rabs_realpow_zero simp add: power_abs)
156.1137 +done
156.1138 +
156.1139 +end
157.1 --- a/src/HOL/Series.thy Tue Dec 30 08:18:54 2008 +0100
157.2 +++ b/src/HOL/Series.thy Tue Dec 30 11:10:01 2008 +0100
157.3 @@ -10,7 +10,7 @@
157.4 header{*Finite Summation and Infinite Series*}
157.5
157.6 theory Series
157.7 -imports "~~/src/HOL/Hyperreal/SEQ"
157.8 +imports SEQ
157.9 begin
157.10
157.11 definition
158.1 --- a/src/HOL/Sum_Type.thy Tue Dec 30 08:18:54 2008 +0100
158.2 +++ b/src/HOL/Sum_Type.thy Tue Dec 30 11:10:01 2008 +0100
158.3 @@ -120,29 +120,6 @@
158.4 by (blast dest!: Inr_inject)
158.5
158.6
158.7 -subsection {* Projections *}
158.8 -
158.9 -definition
158.10 - "sum_case f g x =
158.11 - (if (\<exists>!y. x = Inl y)
158.12 - then f (THE y. x = Inl y)
158.13 - else g (THE y. x = Inr y))"
158.14 -definition "Projl x = sum_case id undefined x"
158.15 -definition "Projr x = sum_case undefined id x"
158.16 -
158.17 -lemma sum_cases[simp]:
158.18 - "sum_case f g (Inl x) = f x"
158.19 - "sum_case f g (Inr y) = g y"
158.20 - unfolding sum_case_def
158.21 - by auto
158.22 -
158.23 -lemma Projl_Inl[simp]: "Projl (Inl x) = x"
158.24 - unfolding Projl_def by simp
158.25 -
158.26 -lemma Projr_Inr[simp]: "Projr (Inr x) = x"
158.27 - unfolding Projr_def by simp
158.28 -
158.29 -
158.30 subsection{*The Disjoint Sum of Sets*}
158.31
158.32 (** Introduction rules for the injections **)
159.1 --- a/src/HOL/Tools/atp_manager.ML Tue Dec 30 08:18:54 2008 +0100
159.2 +++ b/src/HOL/Tools/atp_manager.ML Tue Dec 30 11:10:01 2008 +0100
159.3 @@ -1,5 +1,4 @@
159.4 (* Title: HOL/Tools/atp_manager.ML
159.5 - ID: $Id$
159.6 Author: Fabian Immler, TU Muenchen
159.7
159.8 ATP threads are registered here.
159.9 @@ -19,6 +18,7 @@
159.10 val set_timeout: int -> unit
159.11 val kill: unit -> unit
159.12 val info: unit -> unit
159.13 + val messages: int option -> unit
159.14 type prover = int -> Proof.state -> bool * string
159.15 val add_prover: string -> prover -> theory -> theory
159.16 val print_provers: theory -> unit
159.17 @@ -30,6 +30,9 @@
159.18
159.19 (** preferences **)
159.20
159.21 +val message_store_limit = 20;
159.22 +val message_display_limit = 5;
159.23 +
159.24 local
159.25
159.26 val atps = ref "e";
159.27 @@ -85,13 +88,14 @@
159.28 {timeout_heap: ThreadHeap.T,
159.29 oldest_heap: ThreadHeap.T,
159.30 active: (Thread.thread * (Time.time * Time.time * string)) list,
159.31 - cancelling: (Thread.thread * (Time.time * Time.time * string)) list};
159.32 + cancelling: (Thread.thread * (Time.time * Time.time * string)) list,
159.33 + messages: string list};
159.34
159.35 -fun make_state timeout_heap oldest_heap active cancelling =
159.36 +fun make_state timeout_heap oldest_heap active cancelling messages =
159.37 State {timeout_heap = timeout_heap, oldest_heap = oldest_heap,
159.38 - active = active, cancelling = cancelling};
159.39 + active = active, cancelling = cancelling, messages = messages};
159.40
159.41 -val state = Synchronized.var "atp_manager" (make_state ThreadHeap.empty ThreadHeap.empty [] []);
159.42 +val state = Synchronized.var "atp_manager" (make_state ThreadHeap.empty ThreadHeap.empty [] [] []);
159.43
159.44
159.45 (* the managing thread *)
159.46 @@ -100,34 +104,31 @@
159.47 val managing_thread = ref (NONE: Thread.thread option);
159.48
159.49
159.50 -(* unregister thread from thread manager -- move to cancelling *)
159.51 +(* unregister thread *)
159.52
159.53 fun unregister (success, message) thread = Synchronized.change_result state
159.54 - (fn State {timeout_heap, oldest_heap, active, cancelling} =>
159.55 - let
159.56 - val info = lookup_thread active thread
159.57 + (fn state as State {timeout_heap, oldest_heap, active, cancelling, messages} =>
159.58 + (case lookup_thread active thread of
159.59 + SOME (birthtime, _, description) =>
159.60 + let
159.61 + val (group, active') =
159.62 + if success then List.partition (fn (_, (tb, _, _)) => tb = birthtime) active
159.63 + else List.partition (fn (th, _) => Thread.equal (th, thread)) active
159.64 + val others = delete_thread thread group
159.65
159.66 - (* get birthtime of unregistering thread if successful - for group-killing*)
159.67 - val birthtime = case info of NONE => Time.zeroTime
159.68 - | SOME (tb, _, _) => if success then tb else Time.zeroTime
159.69 + val now = Time.now ()
159.70 + val cancelling' =
159.71 + fold (fn (th, (tb, _, desc)) => update_thread (th, (tb, now, desc))) others cancelling
159.72
159.73 - (* move unregistering thread to cancelling *)
159.74 - val active' = delete_thread thread active
159.75 - val cancelling' = case info of NONE => cancelling
159.76 - | SOME (tb, _, desc) => update_thread (thread, (tb, Time.now (), desc)) cancelling
159.77 -
159.78 - (* move all threads of the same group to cancelling *)
159.79 - val group_threads = active |> map_filter (fn (th, (tb, _, desc)) =>
159.80 - if tb = birthtime then SOME (th, (tb, Time.now (), desc)) else NONE)
159.81 - val active'' = filter_out (fn (_, (tb, _, _)) => tb = birthtime) active'
159.82 - val cancelling'' = append group_threads cancelling'
159.83 -
159.84 - (* message for user *)
159.85 - val message' = case info of NONE => ""
159.86 - | SOME (_, _, desc) => "Sledgehammer: " ^ desc ^ "\n" ^ message ^
159.87 - (if null group_threads then ""
159.88 - else "\nInterrupted " ^ string_of_int (length group_threads - 1) ^ " other group members")
159.89 - in (message', make_state timeout_heap oldest_heap active'' cancelling'') end);
159.90 + val msg = description ^ "\n" ^ message
159.91 + val message' = "Sledgehammer: " ^ msg ^
159.92 + (if null others then ""
159.93 + else "\nInterrupted " ^ string_of_int (length others) ^ " other group members")
159.94 + val messages' = msg ::
159.95 + (if length messages <= message_store_limit then messages
159.96 + else #1 (chop message_store_limit messages))
159.97 + in (message', make_state timeout_heap oldest_heap active' cancelling' messages') end
159.98 + | NONE => ("", state)));
159.99
159.100
159.101 (* kill excessive atp threads *)
159.102 @@ -140,12 +141,13 @@
159.103
159.104 fun kill_oldest () =
159.105 let exception Unchanged in
159.106 - Synchronized.change_result state (fn State {timeout_heap, oldest_heap, active, cancelling} =>
159.107 + Synchronized.change_result state
159.108 + (fn State {timeout_heap, oldest_heap, active, cancelling, messages} =>
159.109 if ThreadHeap.is_empty oldest_heap orelse not (excessive_atps active)
159.110 then raise Unchanged
159.111 else
159.112 let val ((_, oldest_thread), oldest_heap') = ThreadHeap.min_elem oldest_heap
159.113 - in (oldest_thread, make_state timeout_heap oldest_heap' active cancelling) end)
159.114 + in (oldest_thread, make_state timeout_heap oldest_heap' active cancelling messages) end)
159.115 |> (priority o unregister (false, "Interrupted (maximum number of ATPs exceeded)"))
159.116 handle Unchanged => ()
159.117 end;
159.118 @@ -175,7 +177,7 @@
159.119 | SOME (time, _) => SOME time)
159.120
159.121 (* action: cancel find threads whose timeout is reached, and interrupt cancelling threads *)
159.122 - fun action (State {timeout_heap, oldest_heap, active, cancelling}) =
159.123 + fun action (State {timeout_heap, oldest_heap, active, cancelling, messages}) =
159.124 let val (timeout_threads, timeout_heap') =
159.125 ThreadHeap.upto (Time.now (), Thread.self ()) timeout_heap
159.126 in
159.127 @@ -185,7 +187,7 @@
159.128 let
159.129 val _ = List.app (SimpleThread.interrupt o #1) cancelling
159.130 val cancelling' = filter (Thread.isActive o #1) cancelling
159.131 - val state' = make_state timeout_heap' oldest_heap active cancelling'
159.132 + val state' = make_state timeout_heap' oldest_heap active cancelling' messages
159.133 in SOME (map #2 timeout_threads, state') end
159.134 end
159.135 in
159.136 @@ -203,12 +205,13 @@
159.137
159.138 fun register birthtime deadtime (thread, desc) =
159.139 (check_thread_manager ();
159.140 - Synchronized.change state (fn State {timeout_heap, oldest_heap, active, cancelling} =>
159.141 - let
159.142 - val timeout_heap' = ThreadHeap.insert (deadtime, thread) timeout_heap
159.143 - val oldest_heap' = ThreadHeap.insert (birthtime, thread) oldest_heap
159.144 - val active' = update_thread (thread, (birthtime, deadtime, desc)) active
159.145 - in make_state timeout_heap' oldest_heap' active' cancelling end));
159.146 + Synchronized.change state
159.147 + (fn State {timeout_heap, oldest_heap, active, cancelling, messages} =>
159.148 + let
159.149 + val timeout_heap' = ThreadHeap.insert (deadtime, thread) timeout_heap
159.150 + val oldest_heap' = ThreadHeap.insert (birthtime, thread) oldest_heap
159.151 + val active' = update_thread (thread, (birthtime, deadtime, desc)) active
159.152 + in make_state timeout_heap' oldest_heap' active' cancelling messages end));
159.153
159.154
159.155
159.156 @@ -217,16 +220,17 @@
159.157 (* kill: move all threads to cancelling *)
159.158
159.159 fun kill () = Synchronized.change state
159.160 - (fn State {timeout_heap, oldest_heap, active, cancelling} =>
159.161 + (fn State {timeout_heap, oldest_heap, active, cancelling, messages} =>
159.162 let val formerly_active = map (fn (th, (tb, _, desc)) => (th, (tb, Time.now (), desc))) active
159.163 - in make_state timeout_heap oldest_heap [] (formerly_active @ cancelling) end);
159.164 + in make_state timeout_heap oldest_heap [] (formerly_active @ cancelling) messages end);
159.165
159.166
159.167 -(* info: information on running threads *)
159.168 +(* ATP info *)
159.169
159.170 fun info () =
159.171 let
159.172 - val State {timeout_heap, oldest_heap, active, cancelling} = Synchronized.value state
159.173 + val State {active, cancelling, ...} = Synchronized.value state
159.174 +
159.175 fun running_info (_, (birth_time, dead_time, desc)) = "Running: "
159.176 ^ (string_of_int o Time.toSeconds) (Time.- (Time.now (), birth_time))
159.177 ^ " s -- "
159.178 @@ -235,6 +239,7 @@
159.179 fun cancelling_info (_, (_, dead_time, desc)) = "Trying to interrupt thread since "
159.180 ^ (string_of_int o Time.toSeconds) (Time.- (Time.now (), dead_time))
159.181 ^ " s:\n" ^ desc
159.182 +
159.183 val running =
159.184 if null active then "No ATPs running."
159.185 else space_implode "\n\n" ("Running ATPs:" :: map running_info active)
159.186 @@ -242,8 +247,17 @@
159.187 if null cancelling then ""
159.188 else space_implode "\n\n"
159.189 ("Trying to interrupt the following ATPs:" :: map cancelling_info cancelling)
159.190 +
159.191 in writeln (running ^ "\n" ^ interrupting) end;
159.192
159.193 +fun messages opt_limit =
159.194 + let
159.195 + val limit = the_default message_display_limit opt_limit;
159.196 + val State {messages = msgs, ...} = Synchronized.value state
159.197 + val header = "Recent ATP messages" ^
159.198 + (if length msgs <= limit then ":" else " (" ^ string_of_int limit ^ " displayed):");
159.199 + in writeln (space_implode "\n\n" (header :: #1 (chop limit msgs))) end;
159.200 +
159.201
159.202
159.203 (** The Sledgehammer **)
159.204 @@ -322,6 +336,11 @@
159.205 (Scan.succeed (Toplevel.no_timing o Toplevel.imperative info));
159.206
159.207 val _ =
159.208 + OuterSyntax.improper_command "atp_messages" "print recent messages issued by managed provers" K.diag
159.209 + (Scan.option (P.$$$ "(" |-- P.nat --| P.$$$ ")") >>
159.210 + (fn limit => Toplevel.no_timing o Toplevel.imperative (fn () => messages limit)));
159.211 +
159.212 +val _ =
159.213 OuterSyntax.improper_command "print_atps" "print external provers" K.diag
159.214 (Scan.succeed (Toplevel.no_timing o Toplevel.unknown_theory o
159.215 Toplevel.keep (print_provers o Toplevel.theory_of)));
159.216 @@ -329,7 +348,7 @@
159.217 val _ =
159.218 OuterSyntax.command "sledgehammer" "call all automatic theorem provers" K.diag
159.219 (Scan.repeat P.xname >> (fn names => Toplevel.no_timing o Toplevel.unknown_proof o
159.220 - Toplevel.keep ((sledgehammer names) o Toplevel.proof_of)));
159.221 + Toplevel.keep ((sledgehammer names) o Toplevel.proof_of)));
159.222
159.223 end;
159.224
160.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
160.2 +++ b/src/HOL/Tools/function_package/decompose.ML Tue Dec 30 11:10:01 2008 +0100
160.3 @@ -0,0 +1,105 @@
160.4 +(* Title: HOL/Tools/function_package/decompose.ML
160.5 + Author: Alexander Krauss, TU Muenchen
160.6 +
160.7 +Graph decomposition using "Shallow Dependency Pairs".
160.8 +*)
160.9 +
160.10 +signature DECOMPOSE =
160.11 +sig
160.12 +
160.13 + val derive_chains : Proof.context -> tactic
160.14 + -> (Termination.data -> int -> tactic)
160.15 + -> Termination.data -> int -> tactic
160.16 +
160.17 + val decompose_tac : Proof.context -> tactic
160.18 + -> Termination.ttac
160.19 +
160.20 +end
160.21 +
160.22 +structure Decompose : DECOMPOSE =
160.23 +struct
160.24 +
160.25 +structure TermGraph = GraphFun(type key = term val ord = Term.fast_term_ord);
160.26 +
160.27 +
160.28 +fun derive_chains ctxt chain_tac cont D = Termination.CALLS (fn (cs, i) =>
160.29 + let
160.30 + val thy = ProofContext.theory_of ctxt
160.31 +
160.32 + fun prove_chain c1 c2 D =
160.33 + if is_some (Termination.get_chain D c1 c2) then D else
160.34 + let
160.35 + val goal = HOLogic.mk_eq (HOLogic.mk_binop @{const_name "Relation.rel_comp"} (c1, c2),
160.36 + Const (@{const_name "{}"}, fastype_of c1))
160.37 + |> HOLogic.mk_Trueprop (* "C1 O C2 = {}" *)
160.38 +
160.39 + val chain = case FundefLib.try_proof (cterm_of thy goal) chain_tac of
160.40 + FundefLib.Solved thm => SOME thm
160.41 + | _ => NONE
160.42 + in
160.43 + Termination.note_chain c1 c2 chain D
160.44 + end
160.45 + in
160.46 + cont (fold_product prove_chain cs cs D) i
160.47 + end)
160.48 +
160.49 +
160.50 +fun mk_dgraph D cs =
160.51 + TermGraph.empty
160.52 + |> fold (fn c => TermGraph.new_node (c,())) cs
160.53 + |> fold_product (fn c1 => fn c2 =>
160.54 + if is_none (Termination.get_chain D c1 c2 |> the_default NONE)
160.55 + then TermGraph.add_edge (c1, c2) else I)
160.56 + cs cs
160.57 +
160.58 +
160.59 +fun ucomp_empty_tac T =
160.60 + REPEAT_ALL_NEW (rtac @{thm union_comp_emptyR}
160.61 + ORELSE' rtac @{thm union_comp_emptyL}
160.62 + ORELSE' SUBGOAL (fn (_ $ (_ $ (_ $ c1 $ c2) $ _), i) => rtac (T c1 c2) i))
160.63 +
160.64 +fun regroup_calls_tac cs = Termination.CALLS (fn (cs', i) =>
160.65 + let
160.66 + val is = map (fn c => find_index (curry op aconv c) cs') cs
160.67 + in
160.68 + CONVERSION (Conv.arg_conv (Conv.arg_conv (FundefLib.regroup_union_conv is))) i
160.69 + end)
160.70 +
160.71 +
160.72 +fun solve_trivial_tac D = Termination.CALLS
160.73 +(fn ([c], i) =>
160.74 + (case Termination.get_chain D c c of
160.75 + SOME (SOME thm) => rtac @{thm wf_no_loop} i
160.76 + THEN rtac thm i
160.77 + | _ => no_tac)
160.78 + | _ => no_tac)
160.79 +
160.80 +fun decompose_tac' ctxt cont err_cont D = Termination.CALLS (fn (cs, i) =>
160.81 + let
160.82 + val G = mk_dgraph D cs
160.83 + val sccs = TermGraph.strong_conn G
160.84 +
160.85 + fun split [SCC] i = (solve_trivial_tac D i ORELSE cont D i)
160.86 + | split (SCC::rest) i =
160.87 + regroup_calls_tac SCC i
160.88 + THEN rtac @{thm wf_union_compatible} i
160.89 + THEN rtac @{thm less_by_empty} (i + 2)
160.90 + THEN ucomp_empty_tac (the o the oo Termination.get_chain D) (i + 2)
160.91 + THEN split rest (i + 1)
160.92 + THEN (solve_trivial_tac D i ORELSE cont D i)
160.93 + in
160.94 + if length sccs > 1 then split sccs i
160.95 + else solve_trivial_tac D i ORELSE err_cont D i
160.96 + end)
160.97 +
160.98 +fun decompose_tac ctxt chain_tac cont err_cont =
160.99 + derive_chains ctxt chain_tac
160.100 + (decompose_tac' ctxt cont err_cont)
160.101 +
160.102 +fun auto_decompose_tac ctxt =
160.103 + Termination.TERMINATION ctxt
160.104 + (decompose_tac ctxt (auto_tac (local_clasimpset_of ctxt))
160.105 + (K (K all_tac)) (K (K no_tac)))
160.106 +
160.107 +
160.108 +end
161.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
161.2 +++ b/src/HOL/Tools/function_package/descent.ML Tue Dec 30 11:10:01 2008 +0100
161.3 @@ -0,0 +1,44 @@
161.4 +(* Title: HOL/Tools/function_package/descent.ML
161.5 + Author: Alexander Krauss, TU Muenchen
161.6 +
161.7 +Descent proofs for termination
161.8 +*)
161.9 +
161.10 +
161.11 +signature DESCENT =
161.12 +sig
161.13 +
161.14 + val derive_diag : Proof.context -> tactic -> (Termination.data -> int -> tactic)
161.15 + -> Termination.data -> int -> tactic
161.16 +
161.17 + val derive_all : Proof.context -> tactic -> (Termination.data -> int -> tactic)
161.18 + -> Termination.data -> int -> tactic
161.19 +
161.20 +end
161.21 +
161.22 +
161.23 +structure Descent : DESCENT =
161.24 +struct
161.25 +
161.26 +fun gen_descent diag ctxt tac cont D = Termination.CALLS (fn (cs, i) =>
161.27 + let
161.28 + val thy = ProofContext.theory_of ctxt
161.29 + val measures_of = Termination.get_measures D
161.30 +
161.31 + fun derive c D =
161.32 + let
161.33 + val (_, p, _, q, _, _) = Termination.dest_call D c
161.34 + in
161.35 + if diag andalso p = q
161.36 + then fold (fn m => Termination.derive_descent thy tac c m m) (measures_of p) D
161.37 + else fold_product (Termination.derive_descent thy tac c)
161.38 + (measures_of p) (measures_of q) D
161.39 + end
161.40 + in
161.41 + cont (FundefCommon.PROFILE "deriving descents" (fold derive cs) D) i
161.42 + end)
161.43 +
161.44 +val derive_diag = gen_descent true
161.45 +val derive_all = gen_descent false
161.46 +
161.47 +end
162.1 --- a/src/HOL/Tools/function_package/fundef_lib.ML Tue Dec 30 08:18:54 2008 +0100
162.2 +++ b/src/HOL/Tools/function_package/fundef_lib.ML Tue Dec 30 11:10:01 2008 +0100
162.3 @@ -130,4 +130,50 @@
162.4 | SOME st => if Thm.no_prems st then Solved (Goal.finish st) else Stuck st
162.5
162.6
162.7 +fun dest_binop_list cn (t as (Const (n, _) $ a $ b)) =
162.8 + if cn = n then dest_binop_list cn a @ dest_binop_list cn b else [ t ]
162.9 + | dest_binop_list _ t = [ t ]
162.10 +
162.11 +
162.12 +(* separate two parts in a +-expression:
162.13 + "a + b + c + d + e" --> "(a + b + d) + (c + e)"
162.14 +
162.15 + Here, + can be any binary operation that is AC.
162.16 +
162.17 + cn - The name of the binop-constructor (e.g. @{const_name "op Un"})
162.18 + ac - the AC rewrite rules for cn
162.19 + is - the list of indices of the expressions that should become the first part
162.20 + (e.g. [0,1,3] in the above example)
162.21 +*)
162.22 +
162.23 +fun regroup_conv neu cn ac is ct =
162.24 + let
162.25 + val mk = HOLogic.mk_binop cn
162.26 + val t = term_of ct
162.27 + val xs = dest_binop_list cn t
162.28 + val js = 0 upto (length xs) - 1 \\ is
162.29 + val ty = fastype_of t
162.30 + val thy = theory_of_cterm ct
162.31 + in
162.32 + Goal.prove_internal []
162.33 + (cterm_of thy
162.34 + (Logic.mk_equals (t,
162.35 + if is = []
162.36 + then mk (Const (neu, ty), foldr1 mk (map (nth xs) js))
162.37 + else if js = []
162.38 + then mk (foldr1 mk (map (nth xs) is), Const (neu, ty))
162.39 + else mk (foldr1 mk (map (nth xs) is), foldr1 mk (map (nth xs) js)))))
162.40 + (K (MetaSimplifier.rewrite_goals_tac ac
162.41 + THEN rtac Drule.reflexive_thm 1))
162.42 + end
162.43 +
162.44 +(* instance for unions *)
162.45 +fun regroup_union_conv t =
162.46 + regroup_conv (@{const_name "{}"})
162.47 + @{const_name "op Un"}
162.48 + (map (fn t => t RS eq_reflection) (@{thms "Un_ac"} @
162.49 + @{thms "Un_empty_right"} @
162.50 + @{thms "Un_empty_left"})) t
162.51 +
162.52 +
162.53 end
163.1 --- a/src/HOL/Tools/function_package/induction_scheme.ML Tue Dec 30 08:18:54 2008 +0100
163.2 +++ b/src/HOL/Tools/function_package/induction_scheme.ML Tue Dec 30 11:10:01 2008 +0100
163.3 @@ -55,7 +55,7 @@
163.4 fun meta thm = thm RS eq_reflection
163.5
163.6 val sum_prod_conv = MetaSimplifier.rewrite true
163.7 - (map meta (@{thm split_conv} :: @{thms sum_cases}))
163.8 + (map meta (@{thm split_conv} :: @{thms sum.cases}))
163.9
163.10 fun term_conv thy cv t =
163.11 cv (cterm_of thy t)
163.12 @@ -320,7 +320,7 @@
163.13
163.14 val Pxs = cert (HOLogic.mk_Trueprop (P_comp $ x))
163.15 |> Goal.init
163.16 - |> (MetaSimplifier.rewrite_goals_tac (map meta (branch_hyp :: @{thm split_conv} :: @{thms sum_cases}))
163.17 + |> (MetaSimplifier.rewrite_goals_tac (map meta (branch_hyp :: @{thm split_conv} :: @{thms sum.cases}))
163.18 THEN CONVERSION ind_rulify 1)
163.19 |> Seq.hd
163.20 |> Thm.elim_implies (Conv.fconv_rule Drule.beta_eta_conversion bstep)
164.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
164.2 +++ b/src/HOL/Tools/function_package/scnp_reconstruct.ML Tue Dec 30 11:10:01 2008 +0100
164.3 @@ -0,0 +1,426 @@
164.4 +(* Title: HOL/Tools/function_package/scnp_reconstruct.ML
164.5 + Author: Armin Heller, TU Muenchen
164.6 + Author: Alexander Krauss, TU Muenchen
164.7 +
164.8 +Proof reconstruction for SCNP
164.9 +*)
164.10 +
164.11 +signature SCNP_RECONSTRUCT =
164.12 +sig
164.13 +
164.14 + val decomp_scnp : ScnpSolve.label list -> Proof.context -> method
164.15 +
164.16 + val setup : theory -> theory
164.17 +
164.18 + datatype multiset_setup =
164.19 + Multiset of
164.20 + {
164.21 + msetT : typ -> typ,
164.22 + mk_mset : typ -> term list -> term,
164.23 + mset_regroup_conv : int list -> conv,
164.24 + mset_member_tac : int -> int -> tactic,
164.25 + mset_nonempty_tac : int -> tactic,
164.26 + mset_pwleq_tac : int -> tactic,
164.27 + set_of_simps : thm list,
164.28 + smsI' : thm,
164.29 + wmsI2'' : thm,
164.30 + wmsI1 : thm,
164.31 + reduction_pair : thm
164.32 + }
164.33 +
164.34 +
164.35 + val multiset_setup : multiset_setup -> theory -> theory
164.36 +
164.37 +end
164.38 +
164.39 +structure ScnpReconstruct : SCNP_RECONSTRUCT =
164.40 +struct
164.41 +
164.42 +val PROFILE = FundefCommon.PROFILE
164.43 +fun TRACE x = if ! FundefCommon.profile then Output.tracing x else ()
164.44 +
164.45 +open ScnpSolve
164.46 +
164.47 +val natT = HOLogic.natT
164.48 +val nat_pairT = HOLogic.mk_prodT (natT, natT)
164.49 +
164.50 +(* Theory dependencies *)
164.51 +
164.52 +datatype multiset_setup =
164.53 + Multiset of
164.54 + {
164.55 + msetT : typ -> typ,
164.56 + mk_mset : typ -> term list -> term,
164.57 + mset_regroup_conv : int list -> conv,
164.58 + mset_member_tac : int -> int -> tactic,
164.59 + mset_nonempty_tac : int -> tactic,
164.60 + mset_pwleq_tac : int -> tactic,
164.61 + set_of_simps : thm list,
164.62 + smsI' : thm,
164.63 + wmsI2'' : thm,
164.64 + wmsI1 : thm,
164.65 + reduction_pair : thm
164.66 + }
164.67 +
164.68 +structure MultisetSetup = TheoryDataFun
164.69 +(
164.70 + type T = multiset_setup option
164.71 + val empty = NONE
164.72 + val copy = I;
164.73 + val extend = I;
164.74 + fun merge _ (v1, v2) = if is_some v2 then v2 else v1
164.75 +)
164.76 +
164.77 +val multiset_setup = MultisetSetup.put o SOME
164.78 +
164.79 +fun undef x = error "undef"
164.80 +fun get_multiset_setup thy = MultisetSetup.get thy
164.81 + |> the_default (Multiset
164.82 +{ msetT = undef, mk_mset=undef,
164.83 + mset_regroup_conv=undef, mset_member_tac = undef,
164.84 + mset_nonempty_tac = undef, mset_pwleq_tac = undef,
164.85 + set_of_simps = [],reduction_pair = refl,
164.86 + smsI'=refl, wmsI2''=refl, wmsI1=refl })
164.87 +
164.88 +fun order_rpair _ MAX = @{thm max_rpair_set}
164.89 + | order_rpair msrp MS = msrp
164.90 + | order_rpair _ MIN = @{thm min_rpair_set}
164.91 +
164.92 +fun ord_intros_max true =
164.93 + (@{thm smax_emptyI}, @{thm smax_insertI})
164.94 + | ord_intros_max false =
164.95 + (@{thm wmax_emptyI}, @{thm wmax_insertI})
164.96 +fun ord_intros_min true =
164.97 + (@{thm smin_emptyI}, @{thm smin_insertI})
164.98 + | ord_intros_min false =
164.99 + (@{thm wmin_emptyI}, @{thm wmin_insertI})
164.100 +
164.101 +fun gen_probl D cs =
164.102 + let
164.103 + val n = Termination.get_num_points D
164.104 + val arity = length o Termination.get_measures D
164.105 + fun measure p i = nth (Termination.get_measures D p) i
164.106 +
164.107 + fun mk_graph c =
164.108 + let
164.109 + val (_, p, _, q, _, _) = Termination.dest_call D c
164.110 +
164.111 + fun add_edge i j =
164.112 + case Termination.get_descent D c (measure p i) (measure q j)
164.113 + of SOME (Termination.Less _) => cons (i, GTR, j)
164.114 + | SOME (Termination.LessEq _) => cons (i, GEQ, j)
164.115 + | _ => I
164.116 +
164.117 + val edges =
164.118 + fold_product add_edge (0 upto arity p - 1) (0 upto arity q - 1) []
164.119 + in
164.120 + G (p, q, edges)
164.121 + end
164.122 + in
164.123 + GP (map arity (0 upto n - 1), map mk_graph cs)
164.124 + end
164.125 +
164.126 +(* General reduction pair application *)
164.127 +fun rem_inv_img ctxt =
164.128 + let
164.129 + val unfold_tac = LocalDefs.unfold_tac ctxt
164.130 + in
164.131 + rtac @{thm subsetI} 1
164.132 + THEN etac @{thm CollectE} 1
164.133 + THEN REPEAT (etac @{thm exE} 1)
164.134 + THEN unfold_tac @{thms inv_image_def}
164.135 + THEN rtac @{thm CollectI} 1
164.136 + THEN etac @{thm conjE} 1
164.137 + THEN etac @{thm ssubst} 1
164.138 + THEN unfold_tac (@{thms split_conv} @ @{thms triv_forall_equality}
164.139 + @ @{thms sum.cases})
164.140 + end
164.141 +
164.142 +(* Sets *)
164.143 +
164.144 +val setT = HOLogic.mk_setT
164.145 +
164.146 +fun mk_set T [] = Const (@{const_name "{}"}, setT T)
164.147 + | mk_set T (x :: xs) =
164.148 + Const (@{const_name insert}, T --> setT T --> setT T) $
164.149 + x $ mk_set T xs
164.150 +
164.151 +fun set_member_tac m i =
164.152 + if m = 0 then rtac @{thm insertI1} i
164.153 + else rtac @{thm insertI2} i THEN set_member_tac (m - 1) i
164.154 +
164.155 +val set_nonempty_tac = rtac @{thm insert_not_empty}
164.156 +
164.157 +fun set_finite_tac i =
164.158 + rtac @{thm finite.emptyI} i
164.159 + ORELSE (rtac @{thm finite.insertI} i THEN (fn st => set_finite_tac i st))
164.160 +
164.161 +
164.162 +(* Reconstruction *)
164.163 +
164.164 +fun reconstruct_tac ctxt D cs (gp as GP (_, gs)) certificate =
164.165 + let
164.166 + val thy = ProofContext.theory_of ctxt
164.167 + val Multiset
164.168 + { msetT, mk_mset,
164.169 + mset_regroup_conv, mset_member_tac,
164.170 + mset_nonempty_tac, mset_pwleq_tac, set_of_simps,
164.171 + smsI', wmsI2'', wmsI1, reduction_pair=ms_rp }
164.172 + = get_multiset_setup thy
164.173 +
164.174 + fun measure_fn p = nth (Termination.get_measures D p)
164.175 +
164.176 + fun get_desc_thm cidx m1 m2 bStrict =
164.177 + case Termination.get_descent D (nth cs cidx) m1 m2
164.178 + of SOME (Termination.Less thm) =>
164.179 + if bStrict then thm
164.180 + else (thm COMP (Thm.lift_rule (cprop_of thm) @{thm less_imp_le}))
164.181 + | SOME (Termination.LessEq (thm, _)) =>
164.182 + if not bStrict then thm
164.183 + else sys_error "get_desc_thm"
164.184 + | _ => sys_error "get_desc_thm"
164.185 +
164.186 + val (label, lev, sl, covering) = certificate
164.187 +
164.188 + fun prove_lev strict g =
164.189 + let
164.190 + val G (p, q, el) = nth gs g
164.191 +
164.192 + fun less_proof strict (j, b) (i, a) =
164.193 + let
164.194 + val tag_flag = b < a orelse (not strict andalso b <= a)
164.195 +
164.196 + val stored_thm =
164.197 + get_desc_thm g (measure_fn p i) (measure_fn q j)
164.198 + (not tag_flag)
164.199 + |> Conv.fconv_rule (Thm.beta_conversion true)
164.200 +
164.201 + val rule = if strict
164.202 + then if b < a then @{thm pair_lessI2} else @{thm pair_lessI1}
164.203 + else if b <= a then @{thm pair_leqI2} else @{thm pair_leqI1}
164.204 + in
164.205 + rtac rule 1 THEN PRIMITIVE (Thm.elim_implies stored_thm)
164.206 + THEN (if tag_flag then arith_tac ctxt 1 else all_tac)
164.207 + end
164.208 +
164.209 + fun steps_tac MAX strict lq lp =
164.210 + let
164.211 + val (empty, step) = ord_intros_max strict
164.212 + in
164.213 + if length lq = 0
164.214 + then rtac empty 1 THEN set_finite_tac 1
164.215 + THEN (if strict then set_nonempty_tac 1 else all_tac)
164.216 + else
164.217 + let
164.218 + val (j, b) :: rest = lq
164.219 + val (i, a) = the (covering g strict j)
164.220 + fun choose xs = set_member_tac (Library.find_index (curry op = (i, a)) xs) 1
164.221 + val solve_tac = choose lp THEN less_proof strict (j, b) (i, a)
164.222 + in
164.223 + rtac step 1 THEN solve_tac THEN steps_tac MAX strict rest lp
164.224 + end
164.225 + end
164.226 + | steps_tac MIN strict lq lp =
164.227 + let
164.228 + val (empty, step) = ord_intros_min strict
164.229 + in
164.230 + if length lp = 0
164.231 + then rtac empty 1
164.232 + THEN (if strict then set_nonempty_tac 1 else all_tac)
164.233 + else
164.234 + let
164.235 + val (i, a) :: rest = lp
164.236 + val (j, b) = the (covering g strict i)
164.237 + fun choose xs = set_member_tac (Library.find_index (curry op = (j, b)) xs) 1
164.238 + val solve_tac = choose lq THEN less_proof strict (j, b) (i, a)
164.239 + in
164.240 + rtac step 1 THEN solve_tac THEN steps_tac MIN strict lq rest
164.241 + end
164.242 + end
164.243 + | steps_tac MS strict lq lp =
164.244 + let
164.245 + fun get_str_cover (j, b) =
164.246 + if is_some (covering g true j) then SOME (j, b) else NONE
164.247 + fun get_wk_cover (j, b) = the (covering g false j)
164.248 +
164.249 + val qs = lq \\ map_filter get_str_cover lq
164.250 + val ps = map get_wk_cover qs
164.251 +
164.252 + fun indices xs ys = map (fn y => Library.find_index (curry op = y) xs) ys
164.253 + val iqs = indices lq qs
164.254 + val ips = indices lp ps
164.255 +
164.256 + local open Conv in
164.257 + fun t_conv a C =
164.258 + params_conv ~1 (K ((concl_conv ~1 o arg_conv o arg1_conv o a) C)) ctxt
164.259 + val goal_rewrite =
164.260 + t_conv arg1_conv (mset_regroup_conv iqs)
164.261 + then_conv t_conv arg_conv (mset_regroup_conv ips)
164.262 + end
164.263 + in
164.264 + CONVERSION goal_rewrite 1
164.265 + THEN (if strict then rtac smsI' 1
164.266 + else if qs = lq then rtac wmsI2'' 1
164.267 + else rtac wmsI1 1)
164.268 + THEN mset_pwleq_tac 1
164.269 + THEN EVERY (map2 (less_proof false) qs ps)
164.270 + THEN (if strict orelse qs <> lq
164.271 + then LocalDefs.unfold_tac ctxt set_of_simps
164.272 + THEN steps_tac MAX true (lq \\ qs) (lp \\ ps)
164.273 + else all_tac)
164.274 + end
164.275 + in
164.276 + rem_inv_img ctxt
164.277 + THEN steps_tac label strict (nth lev q) (nth lev p)
164.278 + end
164.279 +
164.280 + val (mk_set, setT) = if label = MS then (mk_mset, msetT) else (mk_set, setT)
164.281 +
164.282 + fun tag_pair p (i, tag) =
164.283 + HOLogic.pair_const natT natT $
164.284 + (measure_fn p i $ Bound 0) $ HOLogic.mk_number natT tag
164.285 +
164.286 + fun pt_lev (p, lm) = Abs ("x", Termination.get_types D p,
164.287 + mk_set nat_pairT (map (tag_pair p) lm))
164.288 +
164.289 + val level_mapping =
164.290 + map_index pt_lev lev
164.291 + |> Termination.mk_sumcases D (setT nat_pairT)
164.292 + |> cterm_of thy
164.293 + in
164.294 + PROFILE "Proof Reconstruction"
164.295 + (CONVERSION (Conv.arg_conv (Conv.arg_conv (FundefLib.regroup_union_conv sl))) 1
164.296 + THEN (rtac @{thm reduction_pair_lemma} 1)
164.297 + THEN (rtac @{thm rp_inv_image_rp} 1)
164.298 + THEN (rtac (order_rpair ms_rp label) 1)
164.299 + THEN PRIMITIVE (instantiate' [] [SOME level_mapping])
164.300 + THEN unfold_tac @{thms rp_inv_image_def} (simpset_of thy)
164.301 + THEN LocalDefs.unfold_tac ctxt
164.302 + (@{thms split_conv} @ @{thms fst_conv} @ @{thms snd_conv})
164.303 + THEN REPEAT (SOMEGOAL (resolve_tac [@{thm Un_least}, @{thm empty_subsetI}]))
164.304 + THEN EVERY (map (prove_lev true) sl)
164.305 + THEN EVERY (map (prove_lev false) ((0 upto length cs - 1) \\ sl)))
164.306 + end
164.307 +
164.308 +
164.309 +
164.310 +local open Termination in
164.311 +fun print_cell (SOME (Less _)) = "<"
164.312 + | print_cell (SOME (LessEq _)) = "\<le>"
164.313 + | print_cell (SOME (None _)) = "-"
164.314 + | print_cell (SOME (False _)) = "-"
164.315 + | print_cell (NONE) = "?"
164.316 +
164.317 +fun print_error ctxt D = CALLS (fn (cs, i) =>
164.318 + let
164.319 + val np = get_num_points D
164.320 + val ms = map (get_measures D) (0 upto np - 1)
164.321 + val tys = map (get_types D) (0 upto np - 1)
164.322 + fun index xs = (1 upto length xs) ~~ xs
164.323 + fun outp s t f xs = map (fn (x, y) => s ^ Int.toString x ^ t ^ f y ^ "\n") xs
164.324 + val ims = index (map index ms)
164.325 + val _ = Output.tracing (concat (outp "fn #" ":\n" (concat o outp "\tmeasure #" ": " (Syntax.string_of_term ctxt)) ims))
164.326 + fun print_call (k, c) =
164.327 + let
164.328 + val (_, p, _, q, _, _) = dest_call D c
164.329 + val _ = Output.tracing ("call table for call #" ^ Int.toString k ^ ": fn " ^
164.330 + Int.toString (p + 1) ^ " ~> fn " ^ Int.toString (q + 1))
164.331 + val caller_ms = nth ms p
164.332 + val callee_ms = nth ms q
164.333 + val entries = map (fn x => map (pair x) (callee_ms)) (caller_ms)
164.334 + fun print_ln (i : int, l) = concat (Int.toString i :: " " :: map (enclose " " " " o print_cell o (uncurry (get_descent D c))) l)
164.335 + val _ = Output.tracing (concat (Int.toString (p + 1) ^ "|" ^ Int.toString (q + 1) ^
164.336 + " " :: map (enclose " " " " o Int.toString) (1 upto length callee_ms)) ^ "\n"
164.337 + ^ cat_lines (map print_ln ((1 upto (length entries)) ~~ entries)))
164.338 + in
164.339 + true
164.340 + end
164.341 + fun list_call (k, c) =
164.342 + let
164.343 + val (_, p, _, q, _, _) = dest_call D c
164.344 + val _ = Output.tracing ("call #" ^ (Int.toString k) ^ ": fn " ^
164.345 + Int.toString (p + 1) ^ " ~> fn " ^ Int.toString (q + 1) ^ "\n" ^
164.346 + (Syntax.string_of_term ctxt c))
164.347 + in true end
164.348 + val _ = forall list_call ((1 upto length cs) ~~ cs)
164.349 + val _ = forall print_call ((1 upto length cs) ~~ cs)
164.350 + in
164.351 + all_tac
164.352 + end)
164.353 +end
164.354 +
164.355 +
164.356 +fun single_scnp_tac use_tags orders ctxt cont err_cont D = Termination.CALLS (fn (cs, i) =>
164.357 + let
164.358 + val gp = gen_probl D cs
164.359 +(* val _ = TRACE ("SCNP instance: " ^ makestring gp)*)
164.360 + val certificate = generate_certificate use_tags orders gp
164.361 +(* val _ = TRACE ("Certificate: " ^ makestring certificate)*)
164.362 +
164.363 + val ms_configured = is_some (MultisetSetup.get (ProofContext.theory_of ctxt))
164.364 + in
164.365 + case certificate
164.366 + of NONE => err_cont D i
164.367 + | SOME cert =>
164.368 + if not ms_configured andalso #1 cert = MS
164.369 + then err_cont D i
164.370 + else SELECT_GOAL (reconstruct_tac ctxt D cs gp cert) i
164.371 + THEN (rtac @{thm wf_empty} i ORELSE cont D i)
164.372 + end)
164.373 +
164.374 +fun decomp_scnp_tac orders autom_tac ctxt err_cont =
164.375 + let
164.376 + open Termination
164.377 + val derive_diag = Descent.derive_diag ctxt autom_tac
164.378 + val derive_all = Descent.derive_all ctxt autom_tac
164.379 + val decompose = Decompose.decompose_tac ctxt autom_tac
164.380 + val scnp_no_tags = single_scnp_tac false orders ctxt
164.381 + val scnp_full = single_scnp_tac true orders ctxt
164.382 +
164.383 + fun first_round c e =
164.384 + derive_diag (REPEAT scnp_no_tags c e)
164.385 +
164.386 + val second_round =
164.387 + REPEAT (fn c => fn e => decompose (scnp_no_tags c c) e)
164.388 +
164.389 + val third_round =
164.390 + derive_all oo
164.391 + REPEAT (fn c => fn e =>
164.392 + scnp_full (decompose c c) e)
164.393 +
164.394 + fun Then s1 s2 c e = s1 (s2 c c) (s2 c e)
164.395 +
164.396 + val strategy = Then (Then first_round second_round) third_round
164.397 +
164.398 + in
164.399 + TERMINATION ctxt (strategy err_cont err_cont)
164.400 + end
164.401 +
164.402 +fun decomp_scnp orders ctxt =
164.403 + let
164.404 + val extra_simps = FundefCommon.TerminationSimps.get ctxt
164.405 + val autom_tac = auto_tac (local_clasimpset_of ctxt addsimps2 extra_simps)
164.406 + in
164.407 + Method.SIMPLE_METHOD
164.408 + (TRY (FundefCommon.apply_termination_rule ctxt 1)
164.409 + THEN TRY Termination.wf_union_tac
164.410 + THEN
164.411 + (rtac @{thm wf_empty} 1
164.412 + ORELSE decomp_scnp_tac orders autom_tac ctxt (print_error ctxt) 1))
164.413 + end
164.414 +
164.415 +
164.416 +(* Method setup *)
164.417 +
164.418 +val orders =
164.419 + (Scan.repeat1
164.420 + ((Args.$$$ "max" >> K MAX) ||
164.421 + (Args.$$$ "min" >> K MIN) ||
164.422 + (Args.$$$ "ms" >> K MS))
164.423 + || Scan.succeed [MAX, MS, MIN])
164.424 +
164.425 +val setup = Method.add_method
164.426 + ("sizechange", Method.sectioned_args (Scan.lift orders) clasimp_modifiers decomp_scnp,
164.427 + "termination prover with graph decomposition and the NP subset of size change termination")
164.428 +
164.429 +end
165.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
165.2 +++ b/src/HOL/Tools/function_package/scnp_solve.ML Tue Dec 30 11:10:01 2008 +0100
165.3 @@ -0,0 +1,257 @@
165.4 +(* Title: HOL/Tools/function_package/scnp_solve.ML
165.5 + Author: Armin Heller, TU Muenchen
165.6 + Author: Alexander Krauss, TU Muenchen
165.7 +
165.8 +Generate certificates for SCNP using a SAT solver
165.9 +*)
165.10 +
165.11 +
165.12 +signature SCNP_SOLVE =
165.13 +sig
165.14 +
165.15 + datatype edge = GTR | GEQ
165.16 + datatype graph = G of int * int * (int * edge * int) list
165.17 + datatype graph_problem = GP of int list * graph list
165.18 +
165.19 + datatype label = MIN | MAX | MS
165.20 +
165.21 + type certificate =
165.22 + label (* which order *)
165.23 + * (int * int) list list (* (multi)sets *)
165.24 + * int list (* strictly ordered calls *)
165.25 + * (int -> bool -> int -> (int * int) option) (* covering function *)
165.26 +
165.27 + val generate_certificate : bool -> label list -> graph_problem -> certificate option
165.28 +
165.29 + val solver : string ref
165.30 +end
165.31 +
165.32 +structure ScnpSolve : SCNP_SOLVE =
165.33 +struct
165.34 +
165.35 +(** Graph problems **)
165.36 +
165.37 +datatype edge = GTR | GEQ ;
165.38 +datatype graph = G of int * int * (int * edge * int) list ;
165.39 +datatype graph_problem = GP of int list * graph list ;
165.40 +
165.41 +datatype label = MIN | MAX | MS ;
165.42 +type certificate =
165.43 + label
165.44 + * (int * int) list list
165.45 + * int list
165.46 + * (int -> bool -> int -> (int * int) option)
165.47 +
165.48 +fun graph_at (GP (_, gs), i) = nth gs i ;
165.49 +fun num_prog_pts (GP (arities, _)) = length arities ;
165.50 +fun num_graphs (GP (_, gs)) = length gs ;
165.51 +fun arity (GP (arities, gl)) i = nth arities i ;
165.52 +fun ndigits (GP (arities, _)) = IntInf.log2 (foldl (op +) 0 arities) + 1
165.53 +
165.54 +
165.55 +(** Propositional formulas **)
165.56 +
165.57 +val Not = PropLogic.Not and And = PropLogic.And and Or = PropLogic.Or
165.58 +val BoolVar = PropLogic.BoolVar
165.59 +fun Implies (p, q) = Or (Not p, q)
165.60 +fun Equiv (p, q) = And (Implies (p, q), Implies (q, p))
165.61 +val all = PropLogic.all
165.62 +
165.63 +(* finite indexed quantifiers:
165.64 +
165.65 +iforall n f <==> /\
165.66 + / \ f i
165.67 + 0<=i<n
165.68 + *)
165.69 +fun iforall n f = all (map f (0 upto n - 1))
165.70 +fun iexists n f = PropLogic.exists (map f (0 upto n - 1))
165.71 +fun iforall2 n m f = all (map_product f (0 upto n - 1) (0 upto m - 1))
165.72 +
165.73 +fun the_one var n x = all (var x :: map (Not o var) ((0 upto n - 1) \\ [x]))
165.74 +fun exactly_one n f = iexists n (the_one f n)
165.75 +
165.76 +(* SAT solving *)
165.77 +val solver = ref "auto";
165.78 +fun sat_solver x =
165.79 + FundefCommon.PROFILE "sat_solving..." (SatSolver.invoke_solver (!solver)) x
165.80 +
165.81 +(* "Virtual constructors" for various propositional variables *)
165.82 +fun var_constrs (gp as GP (arities, gl)) =
165.83 + let
165.84 + val n = Int.max (num_graphs gp, num_prog_pts gp)
165.85 + val k = foldl Int.max 1 arities
165.86 +
165.87 + (* Injective, provided a < 8, x < n, and i < k. *)
165.88 + fun prod a x i j = ((j * k + i) * n + x) * 8 + a + 1
165.89 +
165.90 + fun ES (g, i, j) = BoolVar (prod 0 g i j)
165.91 + fun EW (g, i, j) = BoolVar (prod 1 g i j)
165.92 + fun WEAK g = BoolVar (prod 2 g 0 0)
165.93 + fun STRICT g = BoolVar (prod 3 g 0 0)
165.94 + fun P (p, i) = BoolVar (prod 4 p i 0)
165.95 + fun GAM (g, i, j)= BoolVar (prod 5 g i j)
165.96 + fun EPS (g, i) = BoolVar (prod 6 g i 0)
165.97 + fun TAG (p, i) b = BoolVar (prod 7 p i b)
165.98 + in
165.99 + (ES,EW,WEAK,STRICT,P,GAM,EPS,TAG)
165.100 + end
165.101 +
165.102 +
165.103 +fun graph_info gp g =
165.104 + let
165.105 + val G (p, q, edgs) = graph_at (gp, g)
165.106 + in
165.107 + (g, p, q, arity gp p, arity gp q, edgs)
165.108 + end
165.109 +
165.110 +
165.111 +(* Order-independent part of encoding *)
165.112 +
165.113 +fun encode_graphs bits gp =
165.114 + let
165.115 + val ng = num_graphs gp
165.116 + val (ES,EW,_,_,_,_,_,TAG) = var_constrs gp
165.117 +
165.118 + fun encode_constraint_strict 0 (x, y) = PropLogic.False
165.119 + | encode_constraint_strict k (x, y) =
165.120 + Or (And (TAG x (k - 1), Not (TAG y (k - 1))),
165.121 + And (Equiv (TAG x (k - 1), TAG y (k - 1)),
165.122 + encode_constraint_strict (k - 1) (x, y)))
165.123 +
165.124 + fun encode_constraint_weak k (x, y) =
165.125 + Or (encode_constraint_strict k (x, y),
165.126 + iforall k (fn i => Equiv (TAG x i, TAG y i)))
165.127 +
165.128 + fun encode_graph (g, p, q, n, m, edges) =
165.129 + let
165.130 + fun encode_edge i j =
165.131 + if exists (fn x => x = (i, GTR, j)) edges then
165.132 + And (ES (g, i, j), EW (g, i, j))
165.133 + else if not (exists (fn x => x = (i, GEQ, j)) edges) then
165.134 + And (Not (ES (g, i, j)), Not (EW (g, i, j)))
165.135 + else
165.136 + And (
165.137 + Equiv (ES (g, i, j),
165.138 + encode_constraint_strict bits ((p, i), (q, j))),
165.139 + Equiv (EW (g, i, j),
165.140 + encode_constraint_weak bits ((p, i), (q, j))))
165.141 + in
165.142 + iforall2 n m encode_edge
165.143 + end
165.144 + in
165.145 + iforall ng (encode_graph o graph_info gp)
165.146 + end
165.147 +
165.148 +
165.149 +(* Order-specific part of encoding *)
165.150 +
165.151 +fun encode bits gp mu =
165.152 + let
165.153 + val ng = num_graphs gp
165.154 + val (ES,EW,WEAK,STRICT,P,GAM,EPS,_) = var_constrs gp
165.155 +
165.156 + fun encode_graph MAX (g, p, q, n, m, _) =
165.157 + all [
165.158 + Equiv (WEAK g,
165.159 + iforall m (fn j =>
165.160 + Implies (P (q, j),
165.161 + iexists n (fn i =>
165.162 + And (P (p, i), EW (g, i, j)))))),
165.163 + Equiv (STRICT g,
165.164 + iforall m (fn j =>
165.165 + Implies (P (q, j),
165.166 + iexists n (fn i =>
165.167 + And (P (p, i), ES (g, i, j)))))),
165.168 + iexists n (fn i => P (p, i))
165.169 + ]
165.170 + | encode_graph MIN (g, p, q, n, m, _) =
165.171 + all [
165.172 + Equiv (WEAK g,
165.173 + iforall n (fn i =>
165.174 + Implies (P (p, i),
165.175 + iexists m (fn j =>
165.176 + And (P (q, j), EW (g, i, j)))))),
165.177 + Equiv (STRICT g,
165.178 + iforall n (fn i =>
165.179 + Implies (P (p, i),
165.180 + iexists m (fn j =>
165.181 + And (P (q, j), ES (g, i, j)))))),
165.182 + iexists m (fn j => P (q, j))
165.183 + ]
165.184 + | encode_graph MS (g, p, q, n, m, _) =
165.185 + all [
165.186 + Equiv (WEAK g,
165.187 + iforall m (fn j =>
165.188 + Implies (P (q, j),
165.189 + iexists n (fn i => GAM (g, i, j))))),
165.190 + Equiv (STRICT g,
165.191 + iexists n (fn i =>
165.192 + And (P (p, i), Not (EPS (g, i))))),
165.193 + iforall2 n m (fn i => fn j =>
165.194 + Implies (GAM (g, i, j),
165.195 + all [
165.196 + P (p, i),
165.197 + P (q, j),
165.198 + EW (g, i, j),
165.199 + Equiv (Not (EPS (g, i)), ES (g, i, j))])),
165.200 + iforall n (fn i =>
165.201 + Implies (And (P (p, i), EPS (g, i)),
165.202 + exactly_one m (fn j => GAM (g, i, j))))
165.203 + ]
165.204 + in
165.205 + all [
165.206 + encode_graphs bits gp,
165.207 + iforall ng (encode_graph mu o graph_info gp),
165.208 + iforall ng (fn x => WEAK x),
165.209 + iexists ng (fn x => STRICT x)
165.210 + ]
165.211 + end
165.212 +
165.213 +
165.214 +(*Generieren des level-mapping und diverser output*)
165.215 +fun mk_certificate bits label gp f =
165.216 + let
165.217 + val (ES,EW,WEAK,STRICT,P,GAM,EPS,TAG) = var_constrs gp
165.218 + fun assign (PropLogic.BoolVar v) = the_default false (f v)
165.219 + fun assignTag i j =
165.220 + (fold (fn x => fn y => 2 * y + (if assign (TAG (i, j) x) then 1 else 0))
165.221 + (bits - 1 downto 0) 0)
165.222 +
165.223 + val level_mapping =
165.224 + let fun prog_pt_mapping p =
165.225 + map_filter (fn x => if assign (P(p, x)) then SOME (x, assignTag p x) else NONE)
165.226 + (0 upto (arity gp p) - 1)
165.227 + in map prog_pt_mapping (0 upto num_prog_pts gp - 1) end
165.228 +
165.229 + val strict_list = filter (assign o STRICT) (0 upto num_graphs gp - 1)
165.230 +
165.231 + fun covering_pair g bStrict j =
165.232 + let
165.233 + val (_, p, q, n, m, _) = graph_info gp g
165.234 +
165.235 + fun cover MAX j = find_index (fn i => assign (P (p, i)) andalso assign (EW (g, i, j))) (0 upto n - 1)
165.236 + | cover MS k = find_index (fn i => assign (GAM (g, i, k))) (0 upto n - 1)
165.237 + | cover MIN i = find_index (fn j => assign (P (q, j)) andalso assign (EW (g, i, j))) (0 upto m - 1)
165.238 + fun cover_strict MAX j = find_index (fn i => assign (P (p, i)) andalso assign (ES (g, i, j))) (0 upto n - 1)
165.239 + | cover_strict MS k = find_index (fn i => assign (GAM (g, i, k)) andalso not (assign (EPS (g, i) ))) (0 upto n - 1)
165.240 + | cover_strict MIN i = find_index (fn j => assign (P (q, j)) andalso assign (ES (g, i, j))) (0 upto m - 1)
165.241 + val i = if bStrict then cover_strict label j else cover label j
165.242 + in
165.243 + find_first (fn x => fst x = i) (nth level_mapping (if label = MIN then q else p))
165.244 + end
165.245 + in
165.246 + (label, level_mapping, strict_list, covering_pair)
165.247 + end
165.248 +
165.249 +(*interface for the proof reconstruction*)
165.250 +fun generate_certificate use_tags labels gp =
165.251 + let
165.252 + val bits = if use_tags then ndigits gp else 0
165.253 + in
165.254 + get_first
165.255 + (fn l => case sat_solver (encode bits gp l) of
165.256 + SatSolver.SATISFIABLE f => SOME (mk_certificate bits l gp f)
165.257 + | _ => NONE)
165.258 + labels
165.259 + end
165.260 +end
166.1 --- a/src/HOL/Tools/function_package/sum_tree.ML Tue Dec 30 08:18:54 2008 +0100
166.2 +++ b/src/HOL/Tools/function_package/sum_tree.ML Tue Dec 30 11:10:01 2008 +0100
166.3 @@ -9,8 +9,8 @@
166.4 struct
166.5
166.6 (* Theory dependencies *)
166.7 -val proj_in_rules = [thm "Sum_Type.Projl_Inl", thm "Sum_Type.Projr_Inr"]
166.8 -val sumcase_split_ss = HOL_basic_ss addsimps (@{thm "Product_Type.split"} :: @{thms "Sum_Type.sum_cases"})
166.9 +val proj_in_rules = [@{thm "Datatype.Projl_Inl"}, @{thm "Datatype.Projr_Inr"}]
166.10 +val sumcase_split_ss = HOL_basic_ss addsimps (@{thm "Product_Type.split"} :: @{thms "sum.cases"})
166.11
166.12 (* top-down access in balanced tree *)
166.13 fun access_top_down {left, right, init} len i =
166.14 @@ -18,7 +18,7 @@
166.15
166.16 (* Sum types *)
166.17 fun mk_sumT LT RT = Type ("+", [LT, RT])
166.18 -fun mk_sumcase TL TR T l r = Const (@{const_name "Sum_Type.sum_case"}, (TL --> T) --> (TR --> T) --> mk_sumT TL TR --> T) $ l $ r
166.19 +fun mk_sumcase TL TR T l r = Const (@{const_name "sum.sum_case"}, (TL --> T) --> (TR --> T) --> mk_sumT TL TR --> T) $ l $ r
166.20
166.21 val App = curry op $
166.22
166.23 @@ -32,8 +32,8 @@
166.24 fun mk_proj ST n i =
166.25 access_top_down
166.26 { init = (ST, I : term -> term),
166.27 - left = (fn (T as Type ("+", [LT, RT]), proj) => (LT, App (Const (@{const_name "Projl"}, T --> LT)) o proj)),
166.28 - right =(fn (T as Type ("+", [LT, RT]), proj) => (RT, App (Const (@{const_name "Projr"}, T --> RT)) o proj))} n i
166.29 + left = (fn (T as Type ("+", [LT, RT]), proj) => (LT, App (Const (@{const_name "Datatype.Projl"}, T --> LT)) o proj)),
166.30 + right =(fn (T as Type ("+", [LT, RT]), proj) => (RT, App (Const (@{const_name "Datatype.Projr"}, T --> RT)) o proj))} n i
166.31 |> snd
166.32
166.33 fun mk_sumcases T fs =
167.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
167.2 +++ b/src/HOL/Tools/function_package/termination.ML Tue Dec 30 11:10:01 2008 +0100
167.3 @@ -0,0 +1,324 @@
167.4 +(* Title: HOL/Tools/function_package/termination_data.ML
167.5 + Author: Alexander Krauss, TU Muenchen
167.6 +
167.7 +Context data for termination proofs
167.8 +*)
167.9 +
167.10 +
167.11 +signature TERMINATION =
167.12 +sig
167.13 +
167.14 + type data
167.15 + datatype cell = Less of thm | LessEq of (thm * thm) | None of (thm * thm) | False of thm
167.16 +
167.17 + val mk_sumcases : data -> typ -> term list -> term
167.18 +
167.19 + val note_measure : int -> term -> data -> data
167.20 + val note_chain : term -> term -> thm option -> data -> data
167.21 + val note_descent : term -> term -> term -> cell -> data -> data
167.22 +
167.23 + val get_num_points : data -> int
167.24 + val get_types : data -> int -> typ
167.25 + val get_measures : data -> int -> term list
167.26 +
167.27 + (* read from cache *)
167.28 + val get_chain : data -> term -> term -> thm option option
167.29 + val get_descent : data -> term -> term -> term -> cell option
167.30 +
167.31 + (* writes *)
167.32 + val derive_descent : theory -> tactic -> term -> term -> term -> data -> data
167.33 + val derive_descents : theory -> tactic -> term -> data -> data
167.34 +
167.35 + val dest_call : data -> term -> ((string * typ) list * int * term * int * term * term)
167.36 +
167.37 + val CALLS : (term list * int -> tactic) -> int -> tactic
167.38 +
167.39 + (* Termination tactics. Sequential composition via continuations. (2nd argument is the error continuation) *)
167.40 + type ttac = (data -> int -> tactic) -> (data -> int -> tactic) -> data -> int -> tactic
167.41 +
167.42 + val TERMINATION : Proof.context -> (data -> int -> tactic) -> int -> tactic
167.43 +
167.44 + val REPEAT : ttac -> ttac
167.45 +
167.46 + val wf_union_tac : tactic
167.47 +end
167.48 +
167.49 +
167.50 +
167.51 +structure Termination : TERMINATION =
167.52 +struct
167.53 +
167.54 +open FundefLib
167.55 +
167.56 +val term2_ord = prod_ord Term.fast_term_ord Term.fast_term_ord
167.57 +structure Term2tab = TableFun(type key = term * term val ord = term2_ord);
167.58 +structure Term3tab = TableFun(type key = term * (term * term) val ord = prod_ord Term.fast_term_ord term2_ord);
167.59 +
167.60 +(** Analyzing binary trees **)
167.61 +
167.62 +(* Skeleton of a tree structure *)
167.63 +
167.64 +datatype skel =
167.65 + SLeaf of int (* index *)
167.66 +| SBranch of (skel * skel)
167.67 +
167.68 +
167.69 +(* abstract make and dest functions *)
167.70 +fun mk_tree leaf branch =
167.71 + let fun mk (SLeaf i) = leaf i
167.72 + | mk (SBranch (s, t)) = branch (mk s, mk t)
167.73 + in mk end
167.74 +
167.75 +
167.76 +fun dest_tree split =
167.77 + let fun dest (SLeaf i) x = [(i, x)]
167.78 + | dest (SBranch (s, t)) x =
167.79 + let val (l, r) = split x
167.80 + in dest s l @ dest t r end
167.81 + in dest end
167.82 +
167.83 +
167.84 +(* concrete versions for sum types *)
167.85 +fun is_inj (Const ("Sum_Type.Inl", _) $ _) = true
167.86 + | is_inj (Const ("Sum_Type.Inr", _) $ _) = true
167.87 + | is_inj _ = false
167.88 +
167.89 +fun dest_inl (Const ("Sum_Type.Inl", _) $ t) = SOME t
167.90 + | dest_inl _ = NONE
167.91 +
167.92 +fun dest_inr (Const ("Sum_Type.Inr", _) $ t) = SOME t
167.93 + | dest_inr _ = NONE
167.94 +
167.95 +
167.96 +fun mk_skel ps =
167.97 + let
167.98 + fun skel i ps =
167.99 + if forall is_inj ps andalso not (null ps)
167.100 + then let
167.101 + val (j, s) = skel i (map_filter dest_inl ps)
167.102 + val (k, t) = skel j (map_filter dest_inr ps)
167.103 + in (k, SBranch (s, t)) end
167.104 + else (i + 1, SLeaf i)
167.105 + in
167.106 + snd (skel 0 ps)
167.107 + end
167.108 +
167.109 +(* compute list of types for nodes *)
167.110 +fun node_types sk T = dest_tree (fn Type ("+", [LT, RT]) => (LT, RT)) sk T |> map snd
167.111 +
167.112 +(* find index and raw term *)
167.113 +fun dest_inj (SLeaf i) trm = (i, trm)
167.114 + | dest_inj (SBranch (s, t)) trm =
167.115 + case dest_inl trm of
167.116 + SOME trm' => dest_inj s trm'
167.117 + | _ => dest_inj t (the (dest_inr trm))
167.118 +
167.119 +
167.120 +
167.121 +(** Matrix cell datatype **)
167.122 +
167.123 +datatype cell = Less of thm | LessEq of (thm * thm) | None of (thm * thm) | False of thm;
167.124 +
167.125 +
167.126 +type data =
167.127 + skel (* structure of the sum type encoding "program points" *)
167.128 + * (int -> typ) (* types of program points *)
167.129 + * (term list Inttab.table) (* measures for program points *)
167.130 + * (thm option Term2tab.table) (* which calls form chains? *)
167.131 + * (cell Term3tab.table) (* local descents *)
167.132 +
167.133 +
167.134 +fun map_measures f (p, T, M, C, D) = (p, T, f M, C, D)
167.135 +fun map_chains f (p, T, M, C, D) = (p, T, M, f C, D)
167.136 +fun map_descent f (p, T, M, C, D) = (p, T, M, C, f D)
167.137 +
167.138 +fun note_measure p m = map_measures (Inttab.insert_list (op aconv) (p, m))
167.139 +fun note_chain c1 c2 res = map_chains (Term2tab.update ((c1, c2), res))
167.140 +fun note_descent c m1 m2 res = map_descent (Term3tab.update ((c,(m1, m2)), res))
167.141 +
167.142 +(* Build case expression *)
167.143 +fun mk_sumcases (sk, _, _, _, _) T fs =
167.144 + mk_tree (fn i => (nth fs i, domain_type (fastype_of (nth fs i))))
167.145 + (fn ((f, fT), (g, gT)) => (SumTree.mk_sumcase fT gT T f g, SumTree.mk_sumT fT gT))
167.146 + sk
167.147 + |> fst
167.148 +
167.149 +fun mk_sum_skel rel =
167.150 + let
167.151 + val cs = FundefLib.dest_binop_list @{const_name "op Un"} rel
167.152 + fun collect_pats (Const ("Collect", _) $ Abs (_, _, c)) =
167.153 + let
167.154 + val (Const ("op &", _) $ (Const ("op =", _) $ _ $ (Const ("Pair", _) $ r $ l)) $ Gam)
167.155 + = Term.strip_qnt_body "Ex" c
167.156 + in cons r o cons l end
167.157 + in
167.158 + mk_skel (fold collect_pats cs [])
167.159 + end
167.160 +
167.161 +fun create ctxt T rel =
167.162 + let
167.163 + val sk = mk_sum_skel rel
167.164 + val Ts = node_types sk T
167.165 + val M = Inttab.make (map_index (apsnd (MeasureFunctions.get_measure_functions ctxt)) Ts)
167.166 + in
167.167 + (sk, nth Ts, M, Term2tab.empty, Term3tab.empty)
167.168 + end
167.169 +
167.170 +fun get_num_points (sk, _, _, _, _) =
167.171 + let
167.172 + fun num (SLeaf i) = i + 1
167.173 + | num (SBranch (s, t)) = num t
167.174 + in num sk end
167.175 +
167.176 +fun get_types (_, T, _, _, _) = T
167.177 +fun get_measures (_, _, M, _, _) = Inttab.lookup_list M
167.178 +
167.179 +fun get_chain (_, _, _, C, _) c1 c2 =
167.180 + Term2tab.lookup C (c1, c2)
167.181 +
167.182 +fun get_descent (_, _, _, _, D) c m1 m2 =
167.183 + Term3tab.lookup D (c, (m1, m2))
167.184 +
167.185 +fun dest_call D (Const ("Collect", _) $ Abs (_, _, c)) =
167.186 + let
167.187 + val n = get_num_points D
167.188 + val (sk, _, _, _, _) = D
167.189 + val vs = Term.strip_qnt_vars "Ex" c
167.190 +
167.191 + (* FIXME: throw error "dest_call" for malformed terms *)
167.192 + val (Const ("op &", _) $ (Const ("op =", _) $ _ $ (Const ("Pair", _) $ r $ l)) $ Gam)
167.193 + = Term.strip_qnt_body "Ex" c
167.194 + val (p, l') = dest_inj sk l
167.195 + val (q, r') = dest_inj sk r
167.196 + in
167.197 + (vs, p, l', q, r', Gam)
167.198 + end
167.199 + | dest_call D t = error "dest_call"
167.200 +
167.201 +
167.202 +fun derive_desc_aux thy tac c (vs, p, l', q, r', Gam) m1 m2 D =
167.203 + case get_descent D c m1 m2 of
167.204 + SOME _ => D
167.205 + | NONE => let
167.206 + fun cgoal rel =
167.207 + Term.list_all (vs,
167.208 + Logic.mk_implies (HOLogic.mk_Trueprop Gam,
167.209 + HOLogic.mk_Trueprop (Const (rel, @{typ "nat => nat => bool"})
167.210 + $ (m2 $ r') $ (m1 $ l'))))
167.211 + |> cterm_of thy
167.212 + in
167.213 + note_descent c m1 m2
167.214 + (case try_proof (cgoal @{const_name HOL.less}) tac of
167.215 + Solved thm => Less thm
167.216 + | Stuck thm =>
167.217 + (case try_proof (cgoal @{const_name HOL.less_eq}) tac of
167.218 + Solved thm2 => LessEq (thm2, thm)
167.219 + | Stuck thm2 =>
167.220 + if prems_of thm2 = [HOLogic.Trueprop $ HOLogic.false_const]
167.221 + then False thm2 else None (thm2, thm)
167.222 + | _ => raise Match) (* FIXME *)
167.223 + | _ => raise Match) D
167.224 + end
167.225 +
167.226 +fun derive_descent thy tac c m1 m2 D =
167.227 + derive_desc_aux thy tac c (dest_call D c) m1 m2 D
167.228 +
167.229 +(* all descents in one go *)
167.230 +fun derive_descents thy tac c D =
167.231 + let val cdesc as (vs, p, l', q, r', Gam) = dest_call D c
167.232 + in fold_product (derive_desc_aux thy tac c cdesc)
167.233 + (get_measures D p) (get_measures D q) D
167.234 + end
167.235 +
167.236 +fun CALLS tac i st =
167.237 + if Thm.no_prems st then all_tac st
167.238 + else case Thm.term_of (Thm.cprem_of st i) of
167.239 + (_ $ (_ $ rel)) => tac (FundefLib.dest_binop_list @{const_name "op Un"} rel, i) st
167.240 + |_ => no_tac st
167.241 +
167.242 +type ttac = (data -> int -> tactic) -> (data -> int -> tactic) -> data -> int -> tactic
167.243 +
167.244 +fun TERMINATION ctxt tac =
167.245 + SUBGOAL (fn (_ $ (Const (@{const_name "wf"}, wfT) $ rel), i) =>
167.246 + let
167.247 + val (T, _) = HOLogic.dest_prodT (HOLogic.dest_setT (domain_type wfT))
167.248 + in
167.249 + tac (create ctxt T rel) i
167.250 + end)
167.251 +
167.252 +
167.253 +(* A tactic to convert open to closed termination goals *)
167.254 +local
167.255 +fun dest_term (t : term) = (* FIXME, cf. Lexicographic order *)
167.256 + let
167.257 + val (vars, prop) = FundefLib.dest_all_all t
167.258 + val (prems, concl) = Logic.strip_horn prop
167.259 + val (lhs, rhs) = concl
167.260 + |> HOLogic.dest_Trueprop
167.261 + |> HOLogic.dest_mem |> fst
167.262 + |> HOLogic.dest_prod
167.263 + in
167.264 + (vars, prems, lhs, rhs)
167.265 + end
167.266 +
167.267 +fun mk_pair_compr (T, qs, l, r, conds) =
167.268 + let
167.269 + val pT = HOLogic.mk_prodT (T, T)
167.270 + val n = length qs
167.271 + val peq = HOLogic.eq_const pT $ Bound n $ (HOLogic.pair_const T T $ l $ r)
167.272 + val conds' = if null conds then [HOLogic.true_const] else conds
167.273 + in
167.274 + HOLogic.Collect_const pT $
167.275 + Abs ("uu_", pT,
167.276 + (foldr1 HOLogic.mk_conj (peq :: conds')
167.277 + |> fold_rev (fn v => fn t => HOLogic.exists_const (fastype_of v) $ lambda v t) qs))
167.278 + end
167.279 +
167.280 +in
167.281 +
167.282 +fun wf_union_tac st =
167.283 + let
167.284 + val thy = theory_of_thm st
167.285 + val cert = cterm_of (theory_of_thm st)
167.286 + val ((trueprop $ (wf $ rel)) :: ineqs) = prems_of st
167.287 +
167.288 + fun mk_compr ineq =
167.289 + let
167.290 + val (vars, prems, lhs, rhs) = dest_term ineq
167.291 + in
167.292 + mk_pair_compr (fastype_of lhs, vars, lhs, rhs, map (ObjectLogic.atomize_term thy) prems)
167.293 + end
167.294 +
167.295 + val relation =
167.296 + if null ineqs then
167.297 + Const (@{const_name "{}"}, fastype_of rel)
167.298 + else
167.299 + foldr1 (HOLogic.mk_binop @{const_name "op Un"}) (map mk_compr ineqs)
167.300 +
167.301 + fun solve_membership_tac i =
167.302 + (EVERY' (replicate (i - 2) (rtac @{thm UnI2})) (* pick the right component of the union *)
167.303 + THEN' (fn j => TRY (rtac @{thm UnI1} j))
167.304 + THEN' (rtac @{thm CollectI}) (* unfold comprehension *)
167.305 + THEN' (fn i => REPEAT (rtac @{thm exI} i)) (* Turn existentials into schematic Vars *)
167.306 + THEN' ((rtac @{thm refl}) (* unification instantiates all Vars *)
167.307 + ORELSE' ((rtac @{thm conjI})
167.308 + THEN' (rtac @{thm refl})
167.309 + THEN' (CLASET' blast_tac))) (* Solve rest of context... not very elegant *)
167.310 + ) i
167.311 + in
167.312 + ((PRIMITIVE (Drule.cterm_instantiate [(cert rel, cert relation)])
167.313 + THEN ALLGOALS (fn i => if i = 1 then all_tac else solve_membership_tac i))) st
167.314 + end
167.315 +
167.316 +
167.317 +end
167.318 +
167.319 +
167.320 +(* continuation passing repeat combinator *)
167.321 +fun REPEAT ttac cont err_cont =
167.322 + ttac (fn D => fn i => (REPEAT ttac cont cont D i)) err_cont
167.323 +
167.324 +
167.325 +
167.326 +
167.327 +end
168.1 --- a/src/HOL/Transcendental.thy Tue Dec 30 08:18:54 2008 +0100
168.2 +++ b/src/HOL/Transcendental.thy Tue Dec 30 11:10:01 2008 +0100
168.3 @@ -11,7 +11,7 @@
168.4 imports Fact Series Deriv NthRoot
168.5 begin
168.6
168.7 -subsection{*Properties of Power Series*}
168.8 +subsection {* Properties of Power Series *}
168.9
168.10 lemma lemma_realpow_diff:
168.11 fixes y :: "'a::recpower"
168.12 @@ -26,8 +26,8 @@
168.13 fixes y :: "'a::{recpower,comm_semiring_0}" shows
168.14 "(\<Sum>p=0..<Suc n. (x ^ p) * y ^ (Suc n - p)) =
168.15 y * (\<Sum>p=0..<Suc n. (x ^ p) * y ^ (n - p))"
168.16 -by (auto simp add: setsum_right_distrib lemma_realpow_diff mult_ac
168.17 - simp del: setsum_op_ivl_Suc cong: strong_setsum_cong)
168.18 +by (simp add: setsum_right_distrib lemma_realpow_diff mult_ac
168.19 + del: setsum_op_ivl_Suc cong: strong_setsum_cong)
168.20
168.21 lemma lemma_realpow_diff_sumr2:
168.22 fixes y :: "'a::{recpower,comm_ring}" shows
168.23 @@ -114,7 +114,7 @@
168.24 by (rule powser_insidea [THEN summable_norm_cancel])
168.25
168.26
168.27 -subsection{*Term-by-Term Differentiability of Power Series*}
168.28 +subsection {* Term-by-Term Differentiability of Power Series *}
168.29
168.30 definition
168.31 diffs :: "(nat => 'a::ring_1) => nat => 'a" where
168.32 @@ -124,33 +124,22 @@
168.33 lemma diffs_minus: "diffs (%n. - c n) = (%n. - diffs c n)"
168.34 by (simp add: diffs_def)
168.35
168.36 -text{*Show that we can shift the terms down one*}
168.37 -lemma lemma_diffs:
168.38 - "(\<Sum>n=0..<n. (diffs c)(n) * (x ^ n)) =
168.39 - (\<Sum>n=0..<n. of_nat n * c(n) * (x ^ (n - Suc 0))) +
168.40 - (of_nat n * c(n) * x ^ (n - Suc 0))"
168.41 -apply (induct "n")
168.42 -apply (auto simp add: mult_assoc add_assoc [symmetric] diffs_def)
168.43 +lemma sums_Suc_imp:
168.44 + assumes f: "f 0 = 0"
168.45 + shows "(\<lambda>n. f (Suc n)) sums s \<Longrightarrow> (\<lambda>n. f n) sums s"
168.46 +unfolding sums_def
168.47 +apply (rule LIMSEQ_imp_Suc)
168.48 +apply (subst setsum_shift_lb_Suc0_0_upt [where f=f, OF f, symmetric])
168.49 +apply (simp only: setsum_shift_bounds_Suc_ivl)
168.50 done
168.51
168.52 -lemma lemma_diffs2:
168.53 - "(\<Sum>n=0..<n. of_nat n * c(n) * (x ^ (n - Suc 0))) =
168.54 - (\<Sum>n=0..<n. (diffs c)(n) * (x ^ n)) -
168.55 - (of_nat n * c(n) * x ^ (n - Suc 0))"
168.56 -by (auto simp add: lemma_diffs)
168.57 -
168.58 -
168.59 lemma diffs_equiv:
168.60 "summable (%n. (diffs c)(n) * (x ^ n)) ==>
168.61 (%n. of_nat n * c(n) * (x ^ (n - Suc 0))) sums
168.62 (\<Sum>n. (diffs c)(n) * (x ^ n))"
168.63 -apply (subgoal_tac " (%n. of_nat n * c (n) * (x ^ (n - Suc 0))) ----> 0")
168.64 -apply (rule_tac [2] LIMSEQ_imp_Suc)
168.65 -apply (drule summable_sums)
168.66 -apply (auto simp add: sums_def)
168.67 -apply (drule_tac X="(\<lambda>n. \<Sum>n = 0..<n. diffs c n * x ^ n)" in LIMSEQ_diff)
168.68 -apply (auto simp add: lemma_diffs2 [symmetric] diffs_def [symmetric])
168.69 -apply (simp add: diffs_def summable_LIMSEQ_zero)
168.70 +unfolding diffs_def
168.71 +apply (drule summable_sums)
168.72 +apply (rule sums_Suc_imp, simp_all)
168.73 done
168.74
168.75 lemma lemma_termdiff1:
168.76 @@ -160,12 +149,6 @@
168.77 by (auto simp add: right_distrib diff_minus power_add [symmetric] mult_ac
168.78 cong: strong_setsum_cong)
168.79
168.80 -lemma less_add_one: "m < n ==> (\<exists>d. n = m + d + Suc 0)"
168.81 -by (simp add: less_iff_Suc_add)
168.82 -
168.83 -lemma sumdiff: "a + b - (c + d) = a - c + b - (d::real)"
168.84 -by arith
168.85 -
168.86 lemma sumr_diff_mult_const2:
168.87 "setsum f {0..<n} - of_nat n * (r::'a::ring_1) = (\<Sum>i = 0..<n. f i - r)"
168.88 by (simp add: setsum_subtractf)
168.89 @@ -252,15 +235,15 @@
168.90 assumes k: "0 < (k::real)"
168.91 assumes le: "\<And>h. \<lbrakk>h \<noteq> 0; norm h < k\<rbrakk> \<Longrightarrow> norm (f h) \<le> K * norm h"
168.92 shows "f -- 0 --> 0"
168.93 -proof (simp add: LIM_def, safe)
168.94 +unfolding LIM_def diff_0_right
168.95 +proof (safe)
168.96 + let ?h = "of_real (k / 2)::'a"
168.97 + have "?h \<noteq> 0" and "norm ?h < k" using k by simp_all
168.98 + hence "norm (f ?h) \<le> K * norm ?h" by (rule le)
168.99 + hence "0 \<le> K * norm ?h" by (rule order_trans [OF norm_ge_zero])
168.100 + hence zero_le_K: "0 \<le> K" using k by (simp add: zero_le_mult_iff)
168.101 +
168.102 fix r::real assume r: "0 < r"
168.103 - have zero_le_K: "0 \<le> K"
168.104 - apply (cut_tac k)
168.105 - apply (cut_tac h="of_real (k/2)" in le, simp)
168.106 - apply (simp del: of_real_divide)
168.107 - apply (drule order_trans [OF norm_ge_zero])
168.108 - apply (simp add: zero_le_mult_iff)
168.109 - done
168.110 show "\<exists>s. 0 < s \<and> (\<forall>x. x \<noteq> 0 \<and> norm x < s \<longrightarrow> norm (f x) < r)"
168.111 proof (cases)
168.112 assume "K = 0"
168.113 @@ -392,11 +375,12 @@
168.114 assumes 3: "summable (\<lambda>n. (diffs (diffs c)) n * K ^ n)"
168.115 assumes 4: "norm x < norm K"
168.116 shows "DERIV (\<lambda>x. \<Sum>n. c n * x ^ n) x :> (\<Sum>n. (diffs c) n * x ^ n)"
168.117 -proof (simp add: deriv_def, rule LIM_zero_cancel)
168.118 +unfolding deriv_def
168.119 +proof (rule LIM_zero_cancel)
168.120 show "(\<lambda>h. (suminf (\<lambda>n. c n * (x + h) ^ n) - suminf (\<lambda>n. c n * x ^ n)) / h
168.121 - suminf (\<lambda>n. diffs c n * x ^ n)) -- 0 --> 0"
168.122 proof (rule LIM_equal2)
168.123 - show "0 < norm K - norm x" by (simp add: less_diff_eq 4)
168.124 + show "0 < norm K - norm x" using 4 by (simp add: less_diff_eq)
168.125 next
168.126 fix h :: 'a
168.127 assume "h \<noteq> 0"
168.128 @@ -421,8 +405,7 @@
168.129 apply (rule summable_divide)
168.130 apply (rule summable_diff [OF B A])
168.131 apply (rule sums_summable [OF diffs_equiv [OF C]])
168.132 - apply (rule_tac f="suminf" in arg_cong)
168.133 - apply (rule ext)
168.134 + apply (rule arg_cong [where f="suminf"], rule ext)
168.135 apply (simp add: ring_simps)
168.136 done
168.137 next
168.138 @@ -433,22 +416,12 @@
168.139 qed
168.140
168.141
168.142 -subsection{*Exponential Function*}
168.143 +subsection {* Exponential Function *}
168.144
168.145 definition
168.146 exp :: "'a \<Rightarrow> 'a::{recpower,real_normed_field,banach}" where
168.147 "exp x = (\<Sum>n. x ^ n /\<^sub>R real (fact n))"
168.148
168.149 -definition
168.150 - sin :: "real => real" where
168.151 - "sin x = (\<Sum>n. (if even(n) then 0 else
168.152 - (-1 ^ ((n - Suc 0) div 2))/(real (fact n))) * x ^ n)"
168.153 -
168.154 -definition
168.155 - cos :: "real => real" where
168.156 - "cos x = (\<Sum>n. (if even(n) then (-1 ^ (n div 2))/(real (fact n))
168.157 - else 0) * x ^ n)"
168.158 -
168.159 lemma summable_exp_generic:
168.160 fixes x :: "'a::{real_normed_algebra_1,recpower,banach}"
168.161 defines S_def: "S \<equiv> \<lambda>n. x ^ n /\<^sub>R real (fact n)"
168.162 @@ -493,66 +466,9 @@
168.163 lemma summable_exp: "summable (%n. inverse (real (fact n)) * x ^ n)"
168.164 by (insert summable_exp_generic [where x=x], simp)
168.165
168.166 -lemma summable_sin:
168.167 - "summable (%n.
168.168 - (if even n then 0
168.169 - else -1 ^ ((n - Suc 0) div 2)/(real (fact n))) *
168.170 - x ^ n)"
168.171 -apply (rule_tac g = "(%n. inverse (real (fact n)) * \<bar>x\<bar> ^ n)" in summable_comparison_test)
168.172 -apply (rule_tac [2] summable_exp)
168.173 -apply (rule_tac x = 0 in exI)
168.174 -apply (auto simp add: divide_inverse abs_mult power_abs [symmetric] zero_le_mult_iff)
168.175 -done
168.176 -
168.177 -lemma summable_cos:
168.178 - "summable (%n.
168.179 - (if even n then
168.180 - -1 ^ (n div 2)/(real (fact n)) else 0) * x ^ n)"
168.181 -apply (rule_tac g = "(%n. inverse (real (fact n)) * \<bar>x\<bar> ^ n)" in summable_comparison_test)
168.182 -apply (rule_tac [2] summable_exp)
168.183 -apply (rule_tac x = 0 in exI)
168.184 -apply (auto simp add: divide_inverse abs_mult power_abs [symmetric] zero_le_mult_iff)
168.185 -done
168.186 -
168.187 -lemma lemma_STAR_sin:
168.188 - "(if even n then 0
168.189 - else -1 ^ ((n - Suc 0) div 2)/(real (fact n))) * 0 ^ n = 0"
168.190 -by (induct "n", auto)
168.191 -
168.192 -lemma lemma_STAR_cos:
168.193 - "0 < n -->
168.194 - -1 ^ (n div 2)/(real (fact n)) * 0 ^ n = 0"
168.195 -by (induct "n", auto)
168.196 -
168.197 -lemma lemma_STAR_cos1:
168.198 - "0 < n -->
168.199 - (-1) ^ (n div 2)/(real (fact n)) * 0 ^ n = 0"
168.200 -by (induct "n", auto)
168.201 -
168.202 -lemma lemma_STAR_cos2:
168.203 - "(\<Sum>n=1..<n. if even n then -1 ^ (n div 2)/(real (fact n)) * 0 ^ n
168.204 - else 0) = 0"
168.205 -apply (induct "n")
168.206 -apply (case_tac [2] "n", auto)
168.207 -done
168.208 -
168.209 lemma exp_converges: "(\<lambda>n. x ^ n /\<^sub>R real (fact n)) sums exp x"
168.210 unfolding exp_def by (rule summable_exp_generic [THEN summable_sums])
168.211
168.212 -lemma sin_converges:
168.213 - "(%n. (if even n then 0
168.214 - else -1 ^ ((n - Suc 0) div 2)/(real (fact n))) *
168.215 - x ^ n) sums sin(x)"
168.216 -unfolding sin_def by (rule summable_sin [THEN summable_sums])
168.217 -
168.218 -lemma cos_converges:
168.219 - "(%n. (if even n then
168.220 - -1 ^ (n div 2)/(real (fact n))
168.221 - else 0) * x ^ n) sums cos(x)"
168.222 -unfolding cos_def by (rule summable_cos [THEN summable_sums])
168.223 -
168.224 -
168.225 -subsection{*Formal Derivatives of Exp, Sin, and Cos Series*}
168.226
168.227 lemma exp_fdiffs:
168.228 "diffs (%n. inverse(real (fact n))) = (%n. inverse(real (fact n)))"
168.229 @@ -562,48 +478,6 @@
168.230 lemma diffs_of_real: "diffs (\<lambda>n. of_real (f n)) = (\<lambda>n. of_real (diffs f n))"
168.231 by (simp add: diffs_def)
168.232
168.233 -lemma sin_fdiffs:
168.234 - "diffs(%n. if even n then 0
168.235 - else -1 ^ ((n - Suc 0) div 2)/(real (fact n)))
168.236 - = (%n. if even n then
168.237 - -1 ^ (n div 2)/(real (fact n))
168.238 - else 0)"
168.239 -by (auto intro!: ext
168.240 - simp add: diffs_def divide_inverse real_of_nat_def of_nat_mult
168.241 - simp del: mult_Suc of_nat_Suc)
168.242 -
168.243 -lemma sin_fdiffs2:
168.244 - "diffs(%n. if even n then 0
168.245 - else -1 ^ ((n - Suc 0) div 2)/(real (fact n))) n
168.246 - = (if even n then
168.247 - -1 ^ (n div 2)/(real (fact n))
168.248 - else 0)"
168.249 -by (simp only: sin_fdiffs)
168.250 -
168.251 -lemma cos_fdiffs:
168.252 - "diffs(%n. if even n then
168.253 - -1 ^ (n div 2)/(real (fact n)) else 0)
168.254 - = (%n. - (if even n then 0
168.255 - else -1 ^ ((n - Suc 0)div 2)/(real (fact n))))"
168.256 -by (auto intro!: ext
168.257 - simp add: diffs_def divide_inverse odd_Suc_mult_two_ex real_of_nat_def of_nat_mult
168.258 - simp del: mult_Suc of_nat_Suc)
168.259 -
168.260 -
168.261 -lemma cos_fdiffs2:
168.262 - "diffs(%n. if even n then
168.263 - -1 ^ (n div 2)/(real (fact n)) else 0) n
168.264 - = - (if even n then 0
168.265 - else -1 ^ ((n - Suc 0)div 2)/(real (fact n)))"
168.266 -by (simp only: cos_fdiffs)
168.267 -
168.268 -text{*Now at last we can get the derivatives of exp, sin and cos*}
168.269 -
168.270 -lemma lemma_sin_minus:
168.271 - "- sin x = (\<Sum>n. - ((if even n then 0
168.272 - else -1 ^ ((n - Suc 0) div 2)/(real (fact n))) * x ^ n))"
168.273 -by (auto intro!: sums_unique sums_minus sin_converges)
168.274 -
168.275 lemma lemma_exp_ext: "exp = (\<lambda>x. \<Sum>n. x ^ n /\<^sub>R real (fact n))"
168.276 by (auto intro!: ext simp add: exp_def)
168.277
168.278 @@ -617,45 +491,11 @@
168.279 apply (simp del: of_real_add)
168.280 done
168.281
168.282 -lemma lemma_sin_ext:
168.283 - "sin = (%x. \<Sum>n.
168.284 - (if even n then 0
168.285 - else -1 ^ ((n - Suc 0) div 2)/(real (fact n))) *
168.286 - x ^ n)"
168.287 -by (auto intro!: ext simp add: sin_def)
168.288 -
168.289 -lemma lemma_cos_ext:
168.290 - "cos = (%x. \<Sum>n.
168.291 - (if even n then -1 ^ (n div 2)/(real (fact n)) else 0) *
168.292 - x ^ n)"
168.293 -by (auto intro!: ext simp add: cos_def)
168.294 -
168.295 -lemma DERIV_sin [simp]: "DERIV sin x :> cos(x)"
168.296 -apply (simp add: cos_def)
168.297 -apply (subst lemma_sin_ext)
168.298 -apply (auto simp add: sin_fdiffs2 [symmetric])
168.299 -apply (rule_tac K = "1 + \<bar>x\<bar>" in termdiffs)
168.300 -apply (auto intro: sin_converges cos_converges sums_summable intro!: sums_minus [THEN sums_summable] simp add: cos_fdiffs sin_fdiffs)
168.301 -done
168.302 -
168.303 -lemma DERIV_cos [simp]: "DERIV cos x :> -sin(x)"
168.304 -apply (subst lemma_cos_ext)
168.305 -apply (auto simp add: lemma_sin_minus cos_fdiffs2 [symmetric] minus_mult_left)
168.306 -apply (rule_tac K = "1 + \<bar>x\<bar>" in termdiffs)
168.307 -apply (auto intro: sin_converges cos_converges sums_summable intro!: sums_minus [THEN sums_summable] simp add: cos_fdiffs sin_fdiffs diffs_minus)
168.308 -done
168.309 -
168.310 lemma isCont_exp [simp]: "isCont exp x"
168.311 by (rule DERIV_exp [THEN DERIV_isCont])
168.312
168.313 -lemma isCont_sin [simp]: "isCont sin x"
168.314 -by (rule DERIV_sin [THEN DERIV_isCont])
168.315
168.316 -lemma isCont_cos [simp]: "isCont cos x"
168.317 -by (rule DERIV_cos [THEN DERIV_isCont])
168.318 -
168.319 -
168.320 -subsection{*Properties of the Exponential Function*}
168.321 +subsubsection {* Properties of the Exponential Function *}
168.322
168.323 lemma powser_zero:
168.324 fixes f :: "nat \<Rightarrow> 'a::{real_normed_algebra_1,recpower}"
168.325 @@ -724,6 +564,9 @@
168.326 unfolding exp_def
168.327 by (simp only: Cauchy_product summable_norm_exp exp_series_add)
168.328
168.329 +lemma mult_exp_exp: "exp x * exp y = exp (x + y)"
168.330 +by (rule exp_add [symmetric])
168.331 +
168.332 lemma exp_of_real: "exp (of_real x) = of_real (exp x)"
168.333 unfolding exp_def
168.334 apply (subst of_real.suminf)
168.335 @@ -731,6 +574,51 @@
168.336 apply (simp add: scaleR_conv_of_real)
168.337 done
168.338
168.339 +lemma exp_not_eq_zero [simp]: "exp x \<noteq> 0"
168.340 +proof
168.341 + have "exp x * exp (- x) = 1" by (simp add: mult_exp_exp)
168.342 + also assume "exp x = 0"
168.343 + finally show "False" by simp
168.344 +qed
168.345 +
168.346 +lemma exp_minus: "exp (- x) = inverse (exp x)"
168.347 +by (rule inverse_unique [symmetric], simp add: mult_exp_exp)
168.348 +
168.349 +lemma exp_diff: "exp (x - y) = exp x / exp y"
168.350 + unfolding diff_minus divide_inverse
168.351 + by (simp add: exp_add exp_minus)
168.352 +
168.353 +
168.354 +subsubsection {* Properties of the Exponential Function on Reals *}
168.355 +
168.356 +text {* Comparisons of @{term "exp x"} with zero. *}
168.357 +
168.358 +text{*Proof: because every exponential can be seen as a square.*}
168.359 +lemma exp_ge_zero [simp]: "0 \<le> exp (x::real)"
168.360 +proof -
168.361 + have "0 \<le> exp (x/2) * exp (x/2)" by simp
168.362 + thus ?thesis by (simp add: exp_add [symmetric])
168.363 +qed
168.364 +
168.365 +lemma exp_gt_zero [simp]: "0 < exp (x::real)"
168.366 +by (simp add: order_less_le)
168.367 +
168.368 +lemma not_exp_less_zero [simp]: "\<not> exp (x::real) < 0"
168.369 +by (simp add: not_less)
168.370 +
168.371 +lemma not_exp_le_zero [simp]: "\<not> exp (x::real) \<le> 0"
168.372 +by (simp add: not_le)
168.373 +
168.374 +lemma abs_exp_cancel [simp]: "\<bar>exp x::real\<bar> = exp x"
168.375 +by simp
168.376 +
168.377 +lemma exp_real_of_nat_mult: "exp(real n * x) = exp(x) ^ n"
168.378 +apply (induct "n")
168.379 +apply (auto simp add: real_of_nat_Suc right_distrib exp_add mult_commute)
168.380 +done
168.381 +
168.382 +text {* Strict monotonicity of exponential. *}
168.383 +
168.384 lemma exp_ge_add_one_self_aux: "0 \<le> (x::real) ==> (1 + x) \<le> exp(x)"
168.385 apply (drule order_le_imp_less_or_eq, auto)
168.386 apply (simp add: exp_def)
168.387 @@ -739,114 +627,61 @@
168.388 apply (auto intro: summable_exp simp add: numeral_2_eq_2 zero_le_mult_iff)
168.389 done
168.390
168.391 -lemma exp_gt_one [simp]: "0 < (x::real) ==> 1 < exp x"
168.392 -apply (rule order_less_le_trans)
168.393 -apply (rule_tac [2] exp_ge_add_one_self_aux, auto)
168.394 -done
168.395 -
168.396 -lemma DERIV_exp_add_const: "DERIV (%x. exp (x + y)) x :> exp(x + y)"
168.397 +lemma exp_gt_one: "0 < (x::real) \<Longrightarrow> 1 < exp x"
168.398 proof -
168.399 - have "DERIV (exp \<circ> (\<lambda>x. x + y)) x :> exp (x + y) * (1+0)"
168.400 - by (fast intro: DERIV_chain DERIV_add DERIV_exp DERIV_ident DERIV_const)
168.401 - thus ?thesis by (simp add: o_def)
168.402 + assume x: "0 < x"
168.403 + hence "1 < 1 + x" by simp
168.404 + also from x have "1 + x \<le> exp x"
168.405 + by (simp add: exp_ge_add_one_self_aux)
168.406 + finally show ?thesis .
168.407 qed
168.408
168.409 -lemma DERIV_exp_minus [simp]: "DERIV (%x. exp (-x)) x :> - exp(-x)"
168.410 -proof -
168.411 - have "DERIV (exp \<circ> uminus) x :> exp (- x) * - 1"
168.412 - by (fast intro: DERIV_chain DERIV_minus DERIV_exp DERIV_ident)
168.413 - thus ?thesis by (simp add: o_def)
168.414 -qed
168.415 -
168.416 -lemma DERIV_exp_exp_zero [simp]: "DERIV (%x. exp (x + y) * exp (- x)) x :> 0"
168.417 -proof -
168.418 - have "DERIV (\<lambda>x. exp (x + y) * exp (- x)) x
168.419 - :> exp (x + y) * exp (- x) + - exp (- x) * exp (x + y)"
168.420 - by (fast intro: DERIV_exp_add_const DERIV_exp_minus DERIV_mult)
168.421 - thus ?thesis by (simp add: mult_commute)
168.422 -qed
168.423 -
168.424 -lemma exp_add_mult_minus [simp]: "exp(x + y)*exp(-x) = exp(y::real)"
168.425 -proof -
168.426 - have "\<forall>x. DERIV (%x. exp (x + y) * exp (- x)) x :> 0" by simp
168.427 - hence "exp (x + y) * exp (- x) = exp (0 + y) * exp (- 0)"
168.428 - by (rule DERIV_isconst_all)
168.429 - thus ?thesis by simp
168.430 -qed
168.431 -
168.432 -lemma exp_mult_minus [simp]: "exp x * exp(-x) = 1"
168.433 -by (simp add: exp_add [symmetric])
168.434 -
168.435 -lemma exp_mult_minus2 [simp]: "exp(-x)*exp(x) = 1"
168.436 -by (simp add: mult_commute)
168.437 -
168.438 -
168.439 -lemma exp_minus: "exp(-x) = inverse(exp(x))"
168.440 -by (auto intro: inverse_unique [symmetric])
168.441 -
168.442 -text{*Proof: because every exponential can be seen as a square.*}
168.443 -lemma exp_ge_zero [simp]: "0 \<le> exp (x::real)"
168.444 -apply (rule_tac t = x in real_sum_of_halves [THEN subst])
168.445 -apply (subst exp_add, auto)
168.446 -done
168.447 -
168.448 -lemma exp_not_eq_zero [simp]: "exp x \<noteq> 0"
168.449 -apply (cut_tac x = x in exp_mult_minus2)
168.450 -apply (auto simp del: exp_mult_minus2)
168.451 -done
168.452 -
168.453 -lemma exp_gt_zero [simp]: "0 < exp (x::real)"
168.454 -by (simp add: order_less_le)
168.455 -
168.456 -lemma inv_exp_gt_zero [simp]: "0 < inverse(exp x::real)"
168.457 -by (auto intro: positive_imp_inverse_positive)
168.458 -
168.459 -lemma abs_exp_cancel [simp]: "\<bar>exp x::real\<bar> = exp x"
168.460 -by auto
168.461 -
168.462 -lemma exp_real_of_nat_mult: "exp(real n * x) = exp(x) ^ n"
168.463 -apply (induct "n")
168.464 -apply (auto simp add: real_of_nat_Suc right_distrib exp_add mult_commute)
168.465 -done
168.466 -
168.467 -lemma exp_diff: "exp(x - y) = exp(x)/(exp y)"
168.468 -apply (simp add: diff_minus divide_inverse)
168.469 -apply (simp (no_asm) add: exp_add exp_minus)
168.470 -done
168.471 -
168.472 -
168.473 lemma exp_less_mono:
168.474 fixes x y :: real
168.475 - assumes xy: "x < y" shows "exp x < exp y"
168.476 + assumes "x < y" shows "exp x < exp y"
168.477 proof -
168.478 - from xy have "1 < exp (y + - x)"
168.479 - by (rule real_less_sum_gt_zero [THEN exp_gt_one])
168.480 - hence "exp x * inverse (exp x) < exp y * inverse (exp x)"
168.481 - by (auto simp add: exp_add exp_minus)
168.482 - thus ?thesis
168.483 - by (simp add: divide_inverse [symmetric] pos_less_divide_eq
168.484 - del: divide_self_if)
168.485 + from `x < y` have "0 < y - x" by simp
168.486 + hence "1 < exp (y - x)" by (rule exp_gt_one)
168.487 + hence "1 < exp y / exp x" by (simp only: exp_diff)
168.488 + thus "exp x < exp y" by simp
168.489 qed
168.490
168.491 lemma exp_less_cancel: "exp (x::real) < exp y ==> x < y"
168.492 -apply (simp add: linorder_not_le [symmetric])
168.493 -apply (auto simp add: order_le_less exp_less_mono)
168.494 +apply (simp add: linorder_not_le [symmetric])
168.495 +apply (auto simp add: order_le_less exp_less_mono)
168.496 done
168.497
168.498 -lemma exp_less_cancel_iff [iff]: "(exp(x::real) < exp(y)) = (x < y)"
168.499 +lemma exp_less_cancel_iff [iff]: "exp (x::real) < exp y \<longleftrightarrow> x < y"
168.500 by (auto intro: exp_less_mono exp_less_cancel)
168.501
168.502 -lemma exp_le_cancel_iff [iff]: "(exp(x::real) \<le> exp(y)) = (x \<le> y)"
168.503 +lemma exp_le_cancel_iff [iff]: "exp (x::real) \<le> exp y \<longleftrightarrow> x \<le> y"
168.504 by (auto simp add: linorder_not_less [symmetric])
168.505
168.506 -lemma exp_inj_iff [iff]: "(exp (x::real) = exp y) = (x = y)"
168.507 +lemma exp_inj_iff [iff]: "exp (x::real) = exp y \<longleftrightarrow> x = y"
168.508 by (simp add: order_eq_iff)
168.509
168.510 +text {* Comparisons of @{term "exp x"} with one. *}
168.511 +
168.512 +lemma one_less_exp_iff [simp]: "1 < exp (x::real) \<longleftrightarrow> 0 < x"
168.513 + using exp_less_cancel_iff [where x=0 and y=x] by simp
168.514 +
168.515 +lemma exp_less_one_iff [simp]: "exp (x::real) < 1 \<longleftrightarrow> x < 0"
168.516 + using exp_less_cancel_iff [where x=x and y=0] by simp
168.517 +
168.518 +lemma one_le_exp_iff [simp]: "1 \<le> exp (x::real) \<longleftrightarrow> 0 \<le> x"
168.519 + using exp_le_cancel_iff [where x=0 and y=x] by simp
168.520 +
168.521 +lemma exp_le_one_iff [simp]: "exp (x::real) \<le> 1 \<longleftrightarrow> x \<le> 0"
168.522 + using exp_le_cancel_iff [where x=x and y=0] by simp
168.523 +
168.524 +lemma exp_eq_one_iff [simp]: "exp (x::real) = 1 \<longleftrightarrow> x = 0"
168.525 + using exp_inj_iff [where x=x and y=0] by simp
168.526 +
168.527 lemma lemma_exp_total: "1 \<le> y ==> \<exists>x. 0 \<le> x & x \<le> y - 1 & exp(x::real) = y"
168.528 apply (rule IVT)
168.529 apply (auto intro: isCont_exp simp add: le_diff_eq)
168.530 apply (subgoal_tac "1 + (y - 1) \<le> exp (y - 1)")
168.531 -apply simp
168.532 +apply simp
168.533 apply (rule exp_ge_add_one_self_aux, simp)
168.534 done
168.535
168.536 @@ -861,7 +696,7 @@
168.537 done
168.538
168.539
168.540 -subsection{*Properties of the Logarithmic Function*}
168.541 +subsection {* Natural Logarithm *}
168.542
168.543 definition
168.544 ln :: "real => real" where
168.545 @@ -873,59 +708,46 @@
168.546 lemma exp_ln [simp]: "0 < x \<Longrightarrow> exp (ln x) = x"
168.547 by (auto dest: exp_total)
168.548
168.549 -lemma exp_ln_iff [simp]: "(exp (ln x) = x) = (0 < x)"
168.550 -apply (auto dest: exp_total)
168.551 -apply (erule subst, simp)
168.552 +lemma exp_ln_iff [simp]: "exp (ln x) = x \<longleftrightarrow> 0 < x"
168.553 +apply (rule iffI)
168.554 +apply (erule subst, rule exp_gt_zero)
168.555 +apply (erule exp_ln)
168.556 done
168.557
168.558 -lemma ln_mult: "[| 0 < x; 0 < y |] ==> ln(x * y) = ln(x) + ln(y)"
168.559 -apply (rule exp_inj_iff [THEN iffD1])
168.560 -apply (simp add: exp_add exp_ln mult_pos_pos)
168.561 +lemma ln_unique: "exp y = x \<Longrightarrow> ln x = y"
168.562 +by (erule subst, rule ln_exp)
168.563 +
168.564 +lemma ln_one [simp]: "ln 1 = 0"
168.565 +by (rule ln_unique, simp)
168.566 +
168.567 +lemma ln_mult: "\<lbrakk>0 < x; 0 < y\<rbrakk> \<Longrightarrow> ln (x * y) = ln x + ln y"
168.568 +by (rule ln_unique, simp add: exp_add)
168.569 +
168.570 +lemma ln_inverse: "0 < x \<Longrightarrow> ln (inverse x) = - ln x"
168.571 +by (rule ln_unique, simp add: exp_minus)
168.572 +
168.573 +lemma ln_div: "\<lbrakk>0 < x; 0 < y\<rbrakk> \<Longrightarrow> ln (x / y) = ln x - ln y"
168.574 +by (rule ln_unique, simp add: exp_diff)
168.575 +
168.576 +lemma ln_realpow: "0 < x \<Longrightarrow> ln (x ^ n) = real n * ln x"
168.577 +by (rule ln_unique, simp add: exp_real_of_nat_mult)
168.578 +
168.579 +lemma ln_less_cancel_iff [simp]: "\<lbrakk>0 < x; 0 < y\<rbrakk> \<Longrightarrow> ln x < ln y \<longleftrightarrow> x < y"
168.580 +by (subst exp_less_cancel_iff [symmetric], simp)
168.581 +
168.582 +lemma ln_le_cancel_iff [simp]: "\<lbrakk>0 < x; 0 < y\<rbrakk> \<Longrightarrow> ln x \<le> ln y \<longleftrightarrow> x \<le> y"
168.583 +by (simp add: linorder_not_less [symmetric])
168.584 +
168.585 +lemma ln_inj_iff [simp]: "\<lbrakk>0 < x; 0 < y\<rbrakk> \<Longrightarrow> ln x = ln y \<longleftrightarrow> x = y"
168.586 +by (simp add: order_eq_iff)
168.587 +
168.588 +lemma ln_add_one_self_le_self [simp]: "0 \<le> x \<Longrightarrow> ln (1 + x) \<le> x"
168.589 +apply (rule exp_le_cancel_iff [THEN iffD1])
168.590 +apply (simp add: exp_ge_add_one_self_aux)
168.591 done
168.592
168.593 -lemma ln_inj_iff[simp]: "[| 0 < x; 0 < y |] ==> (ln x = ln y) = (x = y)"
168.594 -apply (simp only: exp_ln_iff [symmetric])
168.595 -apply (erule subst)+
168.596 -apply simp
168.597 -done
168.598 -
168.599 -lemma ln_one[simp]: "ln 1 = 0"
168.600 -by (rule exp_inj_iff [THEN iffD1], auto)
168.601 -
168.602 -lemma ln_inverse: "0 < x ==> ln(inverse x) = - ln x"
168.603 -apply (rule_tac a1 = "ln x" in add_left_cancel [THEN iffD1])
168.604 -apply (auto simp add: positive_imp_inverse_positive ln_mult [symmetric])
168.605 -done
168.606 -
168.607 -lemma ln_div:
168.608 - "[|0 < x; 0 < y|] ==> ln(x/y) = ln x - ln y"
168.609 -apply (simp add: divide_inverse)
168.610 -apply (auto simp add: positive_imp_inverse_positive ln_mult ln_inverse)
168.611 -done
168.612 -
168.613 -lemma ln_less_cancel_iff[simp]: "[| 0 < x; 0 < y|] ==> (ln x < ln y) = (x < y)"
168.614 -apply (simp only: exp_ln_iff [symmetric])
168.615 -apply (erule subst)+
168.616 -apply simp
168.617 -done
168.618 -
168.619 -lemma ln_le_cancel_iff[simp]: "[| 0 < x; 0 < y|] ==> (ln x \<le> ln y) = (x \<le> y)"
168.620 -by (auto simp add: linorder_not_less [symmetric])
168.621 -
168.622 -lemma ln_realpow: "0 < x ==> ln(x ^ n) = real n * ln(x)"
168.623 -by (auto dest!: exp_total simp add: exp_real_of_nat_mult [symmetric])
168.624 -
168.625 -lemma ln_add_one_self_le_self [simp]: "0 \<le> x ==> ln(1 + x) \<le> x"
168.626 -apply (rule ln_exp [THEN subst])
168.627 -apply (rule ln_le_cancel_iff [THEN iffD2])
168.628 -apply (auto simp add: exp_ge_add_one_self_aux)
168.629 -done
168.630 -
168.631 -lemma ln_less_self [simp]: "0 < x ==> ln x < x"
168.632 -apply (rule order_less_le_trans)
168.633 -apply (rule_tac [2] ln_add_one_self_le_self)
168.634 -apply (rule ln_less_cancel_iff [THEN iffD2], auto)
168.635 -done
168.636 +lemma ln_less_self [simp]: "0 < x \<Longrightarrow> ln x < x"
168.637 +by (rule order_less_le_trans [where y="ln (1 + x)"]) simp_all
168.638
168.639 lemma ln_ge_zero [simp]:
168.640 assumes x: "1 \<le> x" shows "0 \<le> ln x"
168.641 @@ -992,7 +814,151 @@
168.642 done
168.643
168.644
168.645 -subsection{*Basic Properties of the Trigonometric Functions*}
168.646 +subsection {* Sine and Cosine *}
168.647 +
168.648 +definition
168.649 + sin :: "real => real" where
168.650 + "sin x = (\<Sum>n. (if even(n) then 0 else
168.651 + (-1 ^ ((n - Suc 0) div 2))/(real (fact n))) * x ^ n)"
168.652 +
168.653 +definition
168.654 + cos :: "real => real" where
168.655 + "cos x = (\<Sum>n. (if even(n) then (-1 ^ (n div 2))/(real (fact n))
168.656 + else 0) * x ^ n)"
168.657 +
168.658 +lemma summable_sin:
168.659 + "summable (%n.
168.660 + (if even n then 0
168.661 + else -1 ^ ((n - Suc 0) div 2)/(real (fact n))) *
168.662 + x ^ n)"
168.663 +apply (rule_tac g = "(%n. inverse (real (fact n)) * \<bar>x\<bar> ^ n)" in summable_comparison_test)
168.664 +apply (rule_tac [2] summable_exp)
168.665 +apply (rule_tac x = 0 in exI)
168.666 +apply (auto simp add: divide_inverse abs_mult power_abs [symmetric] zero_le_mult_iff)
168.667 +done
168.668 +
168.669 +lemma summable_cos:
168.670 + "summable (%n.
168.671 + (if even n then
168.672 + -1 ^ (n div 2)/(real (fact n)) else 0) * x ^ n)"
168.673 +apply (rule_tac g = "(%n. inverse (real (fact n)) * \<bar>x\<bar> ^ n)" in summable_comparison_test)
168.674 +apply (rule_tac [2] summable_exp)
168.675 +apply (rule_tac x = 0 in exI)
168.676 +apply (auto simp add: divide_inverse abs_mult power_abs [symmetric] zero_le_mult_iff)
168.677 +done
168.678 +
168.679 +lemma lemma_STAR_sin:
168.680 + "(if even n then 0
168.681 + else -1 ^ ((n - Suc 0) div 2)/(real (fact n))) * 0 ^ n = 0"
168.682 +by (induct "n", auto)
168.683 +
168.684 +lemma lemma_STAR_cos:
168.685 + "0 < n -->
168.686 + -1 ^ (n div 2)/(real (fact n)) * 0 ^ n = 0"
168.687 +by (induct "n", auto)
168.688 +
168.689 +lemma lemma_STAR_cos1:
168.690 + "0 < n -->
168.691 + (-1) ^ (n div 2)/(real (fact n)) * 0 ^ n = 0"
168.692 +by (induct "n", auto)
168.693 +
168.694 +lemma lemma_STAR_cos2:
168.695 + "(\<Sum>n=1..<n. if even n then -1 ^ (n div 2)/(real (fact n)) * 0 ^ n
168.696 + else 0) = 0"
168.697 +apply (induct "n")
168.698 +apply (case_tac [2] "n", auto)
168.699 +done
168.700 +
168.701 +lemma sin_converges:
168.702 + "(%n. (if even n then 0
168.703 + else -1 ^ ((n - Suc 0) div 2)/(real (fact n))) *
168.704 + x ^ n) sums sin(x)"
168.705 +unfolding sin_def by (rule summable_sin [THEN summable_sums])
168.706 +
168.707 +lemma cos_converges:
168.708 + "(%n. (if even n then
168.709 + -1 ^ (n div 2)/(real (fact n))
168.710 + else 0) * x ^ n) sums cos(x)"
168.711 +unfolding cos_def by (rule summable_cos [THEN summable_sums])
168.712 +
168.713 +lemma sin_fdiffs:
168.714 + "diffs(%n. if even n then 0
168.715 + else -1 ^ ((n - Suc 0) div 2)/(real (fact n)))
168.716 + = (%n. if even n then
168.717 + -1 ^ (n div 2)/(real (fact n))
168.718 + else 0)"
168.719 +by (auto intro!: ext
168.720 + simp add: diffs_def divide_inverse real_of_nat_def of_nat_mult
168.721 + simp del: mult_Suc of_nat_Suc)
168.722 +
168.723 +lemma sin_fdiffs2:
168.724 + "diffs(%n. if even n then 0
168.725 + else -1 ^ ((n - Suc 0) div 2)/(real (fact n))) n
168.726 + = (if even n then
168.727 + -1 ^ (n div 2)/(real (fact n))
168.728 + else 0)"
168.729 +by (simp only: sin_fdiffs)
168.730 +
168.731 +lemma cos_fdiffs:
168.732 + "diffs(%n. if even n then
168.733 + -1 ^ (n div 2)/(real (fact n)) else 0)
168.734 + = (%n. - (if even n then 0
168.735 + else -1 ^ ((n - Suc 0)div 2)/(real (fact n))))"
168.736 +by (auto intro!: ext
168.737 + simp add: diffs_def divide_inverse odd_Suc_mult_two_ex real_of_nat_def of_nat_mult
168.738 + simp del: mult_Suc of_nat_Suc)
168.739 +
168.740 +
168.741 +lemma cos_fdiffs2:
168.742 + "diffs(%n. if even n then
168.743 + -1 ^ (n div 2)/(real (fact n)) else 0) n
168.744 + = - (if even n then 0
168.745 + else -1 ^ ((n - Suc 0)div 2)/(real (fact n)))"
168.746 +by (simp only: cos_fdiffs)
168.747 +
168.748 +text{*Now at last we can get the derivatives of exp, sin and cos*}
168.749 +
168.750 +lemma lemma_sin_minus:
168.751 + "- sin x = (\<Sum>n. - ((if even n then 0
168.752 + else -1 ^ ((n - Suc 0) div 2)/(real (fact n))) * x ^ n))"
168.753 +by (auto intro!: sums_unique sums_minus sin_converges)
168.754 +
168.755 +lemma lemma_sin_ext:
168.756 + "sin = (%x. \<Sum>n.
168.757 + (if even n then 0
168.758 + else -1 ^ ((n - Suc 0) div 2)/(real (fact n))) *
168.759 + x ^ n)"
168.760 +by (auto intro!: ext simp add: sin_def)
168.761 +
168.762 +lemma lemma_cos_ext:
168.763 + "cos = (%x. \<Sum>n.
168.764 + (if even n then -1 ^ (n div 2)/(real (fact n)) else 0) *
168.765 + x ^ n)"
168.766 +by (auto intro!: ext simp add: cos_def)
168.767 +
168.768 +lemma DERIV_sin [simp]: "DERIV sin x :> cos(x)"
168.769 +apply (simp add: cos_def)
168.770 +apply (subst lemma_sin_ext)
168.771 +apply (auto simp add: sin_fdiffs2 [symmetric])
168.772 +apply (rule_tac K = "1 + \<bar>x\<bar>" in termdiffs)
168.773 +apply (auto intro: sin_converges cos_converges sums_summable intro!: sums_minus [THEN sums_summable] simp add: cos_fdiffs sin_fdiffs)
168.774 +done
168.775 +
168.776 +lemma DERIV_cos [simp]: "DERIV cos x :> -sin(x)"
168.777 +apply (subst lemma_cos_ext)
168.778 +apply (auto simp add: lemma_sin_minus cos_fdiffs2 [symmetric] minus_mult_left)
168.779 +apply (rule_tac K = "1 + \<bar>x\<bar>" in termdiffs)
168.780 +apply (auto intro: sin_converges cos_converges sums_summable intro!: sums_minus [THEN sums_summable] simp add: cos_fdiffs sin_fdiffs diffs_minus)
168.781 +done
168.782 +
168.783 +lemma isCont_sin [simp]: "isCont sin x"
168.784 +by (rule DERIV_sin [THEN DERIV_isCont])
168.785 +
168.786 +lemma isCont_cos [simp]: "isCont cos x"
168.787 +by (rule DERIV_cos [THEN DERIV_isCont])
168.788 +
168.789 +
168.790 +subsection {* Properties of Sine and Cosine *}
168.791
168.792 lemma sin_zero [simp]: "sin 0 = 0"
168.793 unfolding sin_def by (simp add: powser_zero)
168.794 @@ -1088,9 +1054,6 @@
168.795 apply (simp del: realpow_Suc)
168.796 done
168.797
168.798 -lemma real_gt_one_ge_zero_add_less: "[| 1 < x; 0 \<le> y |] ==> 1 < x + (y::real)"
168.799 -by arith
168.800 -
168.801 lemma abs_sin_le_one [simp]: "\<bar>sin x\<bar> \<le> 1"
168.802 by (rule power2_le_imp_le, simp_all add: sin_squared_eq)
168.803
168.804 @@ -1187,7 +1150,7 @@
168.805 apply (auto simp add: diff_minus left_distrib right_distrib mult_ac add_ac)
168.806 done
168.807
168.808 -lemma sin_cos_minus [simp]:
168.809 +lemma sin_cos_minus:
168.810 "(sin(-x) + (sin x)) ^ 2 + (cos(-x) - (cos x)) ^ 2 = 0"
168.811 apply (cut_tac y = 0 and x = x
168.812 in lemma_DERIV_sin_cos_minus [THEN DERIV_isconst_all])
168.813 @@ -1195,14 +1158,10 @@
168.814 done
168.815
168.816 lemma sin_minus [simp]: "sin (-x) = -sin(x)"
168.817 -apply (cut_tac x = x in sin_cos_minus)
168.818 -apply (simp del: sin_cos_minus)
168.819 -done
168.820 + using sin_cos_minus [where x=x] by simp
168.821
168.822 lemma cos_minus [simp]: "cos (-x) = cos(x)"
168.823 -apply (cut_tac x = x in sin_cos_minus)
168.824 -apply (simp del: sin_cos_minus)
168.825 -done
168.826 + using sin_cos_minus [where x=x] by simp
168.827
168.828 lemma sin_diff: "sin (x - y) = sin x * cos y - cos x * sin y"
168.829 by (simp add: diff_minus sin_add)
168.830 @@ -1217,16 +1176,14 @@
168.831 by (simp add: cos_diff mult_commute)
168.832
168.833 lemma sin_double [simp]: "sin(2 * x) = 2* sin x * cos x"
168.834 -by (cut_tac x = x and y = x in sin_add, auto)
168.835 -
168.836 + using sin_add [where x=x and y=x] by simp
168.837
168.838 lemma cos_double: "cos(2* x) = ((cos x)\<twosuperior>) - ((sin x)\<twosuperior>)"
168.839 -apply (cut_tac x = x and y = x in cos_add)
168.840 -apply (simp add: power2_eq_square)
168.841 -done
168.842 + using cos_add [where x=x and y=x]
168.843 + by (simp add: power2_eq_square)
168.844
168.845
168.846 -subsection{*The Constant Pi*}
168.847 +subsection {* The Constant Pi *}
168.848
168.849 definition
168.850 pi :: "real" where
168.851 @@ -1401,8 +1358,8 @@
168.852 lemma pi_not_less_zero [simp]: "\<not> pi < 0"
168.853 by (simp add: linorder_not_less)
168.854
168.855 -lemma minus_pi_half_less_zero [simp]: "-(pi/2) < 0"
168.856 -by auto
168.857 +lemma minus_pi_half_less_zero: "-(pi/2) < 0"
168.858 +by simp
168.859
168.860 lemma sin_pi_half [simp]: "sin(pi/2) = 1"
168.861 apply (cut_tac x = "pi/2" in sin_cos_squared_add2)
168.862 @@ -1614,7 +1571,7 @@
168.863 done
168.864
168.865
168.866 -subsection{*Tangent*}
168.867 +subsection {* Tangent *}
168.868
168.869 definition
168.870 tan :: "real => real" where
168.871 @@ -2139,11 +2096,6 @@
168.872 lemma sin_zero_abs_cos_one: "sin x = 0 ==> \<bar>cos x\<bar> = 1"
168.873 by (auto simp add: sin_zero_iff even_mult_two_ex)
168.874
168.875 -lemma exp_eq_one_iff [simp]: "(exp (x::real) = 1) = (x = 0)"
168.876 -apply auto
168.877 -apply (drule_tac f = ln in arg_cong, auto)
168.878 -done
168.879 -
168.880 lemma cos_one_sin_zero: "cos x = 1 ==> sin x = 0"
168.881 by (cut_tac x = x in sin_cos_squared_add3, auto)
168.882
168.883 @@ -2190,60 +2142,4 @@
168.884 apply (erule polar_ex2)
168.885 done
168.886
168.887 -
168.888 -subsection {* Theorems about Limits *}
168.889 -
168.890 -(* need to rename second isCont_inverse *)
168.891 -
168.892 -lemma isCont_inv_fun:
168.893 - fixes f g :: "real \<Rightarrow> real"
168.894 - shows "[| 0 < d; \<forall>z. \<bar>z - x\<bar> \<le> d --> g(f(z)) = z;
168.895 - \<forall>z. \<bar>z - x\<bar> \<le> d --> isCont f z |]
168.896 - ==> isCont g (f x)"
168.897 -by (rule isCont_inverse_function)
168.898 -
168.899 -lemma isCont_inv_fun_inv:
168.900 - fixes f g :: "real \<Rightarrow> real"
168.901 - shows "[| 0 < d;
168.902 - \<forall>z. \<bar>z - x\<bar> \<le> d --> g(f(z)) = z;
168.903 - \<forall>z. \<bar>z - x\<bar> \<le> d --> isCont f z |]
168.904 - ==> \<exists>e. 0 < e &
168.905 - (\<forall>y. 0 < \<bar>y - f(x)\<bar> & \<bar>y - f(x)\<bar> < e --> f(g(y)) = y)"
168.906 -apply (drule isCont_inj_range)
168.907 -prefer 2 apply (assumption, assumption, auto)
168.908 -apply (rule_tac x = e in exI, auto)
168.909 -apply (rotate_tac 2)
168.910 -apply (drule_tac x = y in spec, auto)
168.911 -done
168.912 -
168.913 -
168.914 -text{*Bartle/Sherbert: Introduction to Real Analysis, Theorem 4.2.9, p. 110*}
168.915 -lemma LIM_fun_gt_zero:
168.916 - "[| f -- c --> (l::real); 0 < l |]
168.917 - ==> \<exists>r. 0 < r & (\<forall>x::real. x \<noteq> c & \<bar>c - x\<bar> < r --> 0 < f x)"
168.918 -apply (auto simp add: LIM_def)
168.919 -apply (drule_tac x = "l/2" in spec, safe, force)
168.920 -apply (rule_tac x = s in exI)
168.921 -apply (auto simp only: abs_less_iff)
168.922 -done
168.923 -
168.924 -lemma LIM_fun_less_zero:
168.925 - "[| f -- c --> (l::real); l < 0 |]
168.926 - ==> \<exists>r. 0 < r & (\<forall>x::real. x \<noteq> c & \<bar>c - x\<bar> < r --> f x < 0)"
168.927 -apply (auto simp add: LIM_def)
168.928 -apply (drule_tac x = "-l/2" in spec, safe, force)
168.929 -apply (rule_tac x = s in exI)
168.930 -apply (auto simp only: abs_less_iff)
168.931 -done
168.932 -
168.933 -
168.934 -lemma LIM_fun_not_zero:
168.935 - "[| f -- c --> (l::real); l \<noteq> 0 |]
168.936 - ==> \<exists>r. 0 < r & (\<forall>x::real. x \<noteq> c & \<bar>c - x\<bar> < r --> f x \<noteq> 0)"
168.937 -apply (cut_tac x = l and y = 0 in linorder_less_linear, auto)
168.938 -apply (drule LIM_fun_less_zero)
168.939 -apply (drule_tac [3] LIM_fun_gt_zero)
168.940 -apply force+
168.941 -done
168.942 -
168.943 end
169.1 --- a/src/HOL/Wellfounded.thy Tue Dec 30 08:18:54 2008 +0100
169.2 +++ b/src/HOL/Wellfounded.thy Tue Dec 30 11:10:01 2008 +0100
169.3 @@ -842,6 +842,11 @@
169.4 qed
169.5 qed
169.6
169.7 +lemma max_ext_additive:
169.8 + "(A, B) \<in> max_ext R \<Longrightarrow> (C, D) \<in> max_ext R \<Longrightarrow>
169.9 + (A \<union> C, B \<union> D) \<in> max_ext R"
169.10 +by (force elim!: max_ext.cases)
169.11 +
169.12
169.13 definition
169.14 min_ext :: "('a \<times> 'a) set \<Rightarrow> ('a set \<times> 'a set) set"
170.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
170.2 +++ b/src/HOL/ex/CodegenSML_Test.thy Tue Dec 30 11:10:01 2008 +0100
170.3 @@ -0,0 +1,54 @@
170.4 +(* Title: Test file for Stefan Berghofer's SML code generator
170.5 + Author: Tobias Nipkow, TU Muenchen
170.6 +*)
170.7 +
170.8 +theory CodegenSML_Test
170.9 +imports Executable_Set
170.10 +begin
170.11 +
170.12 +lemma "True : {False, True} & False ~: {True}"
170.13 +by evaluation
170.14 +
170.15 +lemma
170.16 +"eq_set ({1::nat,2,3,2} \<union> {3,1,2,1}) {2,2,3,1} &
170.17 + eq_set ({1::nat,2,3,2} \<union> {4,1,5,1}) {4,4,5,1,2,3}"
170.18 +by evaluation
170.19 +
170.20 +lemma
170.21 +"eq_set ({1::nat,2,3,2} \<inter> {3,1,2,1}) {2,2,3,1} &
170.22 + eq_set ({1::nat,2,3,2} \<inter> {4,1,5,2}) {2,1,2}"
170.23 +by evaluation
170.24 +
170.25 +lemma
170.26 +"eq_set ({1::nat,2,3,2} - {3,1,2,1}) {} &
170.27 + eq_set ({1::nat,2,3,2} - {4,1,5,2}) {3}"
170.28 +by evaluation
170.29 +
170.30 +lemma
170.31 +"eq_set (Union{{1::nat,2,3,2}, {3,1,2,1}}) {2,2,3,1} &
170.32 + eq_set (Union{{1::nat,2,3,2}, {4,1,5,1}}) {4,4,5,1,2,3}"
170.33 +by evaluation
170.34 +
170.35 +lemma
170.36 +"eq_set (Inter{{1::nat,2,3,2}, {3,1,2,1}}) {2,2,3,1} &
170.37 + eq_set (Inter{{1::nat,2,3,2}, {4,1,5,2}}) {2,1,2}"
170.38 +by evaluation
170.39 +
170.40 +lemma "eq_set ((%x. x+2) ` {1::nat,2,3,2}) {4,5,3,3}"
170.41 +by evaluation
170.42 +
170.43 +lemma
170.44 +"(ALL x:{1::nat,2,3,2}. EX y : {4,5,2}. x < y) &
170.45 + (EX x:{1::nat,2,3,2}. ALL y : {4,5,6}. x < y)"
170.46 +by evaluation
170.47 +
170.48 +lemma
170.49 +"eq_set {x : {4::nat,7,10}. 2 dvd x } {4,10}"
170.50 +by evaluation
170.51 +
170.52 +lemma
170.53 +"fold (op +) (5::int) {3,7,9} = 24 &
170.54 + fold_image (op *) id (2::int) {3,4,5} = 120"
170.55 +by evaluation
170.56 +
170.57 +end
171.1 --- a/src/HOL/ex/ExecutableContent.thy Tue Dec 30 08:18:54 2008 +0100
171.2 +++ b/src/HOL/ex/ExecutableContent.thy Tue Dec 30 11:10:01 2008 +0100
171.3 @@ -24,4 +24,11 @@
171.4 "~~/src/HOL/ex/Records"
171.5 begin
171.6
171.7 +text {* However, some aren't executable *}
171.8 +
171.9 +declare pair_leq_def[code del]
171.10 +declare max_weak_def[code del]
171.11 +declare min_weak_def[code del]
171.12 +declare ms_weak_def[code del]
171.13 +
171.14 end
172.1 --- a/src/HOL/ex/LexOrds.thy Tue Dec 30 08:18:54 2008 +0100
172.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
172.3 @@ -1,182 +0,0 @@
172.4 -(* Title: HOL/ex/LexOrds.thy
172.5 - ID: $Id$
172.6 - Author: Lukas Bulwahn, TU Muenchen
172.7 -*)
172.8 -
172.9 -header {* Examples and regression tests for method lexicographic order. *}
172.10 -
172.11 -theory LexOrds
172.12 -imports Main
172.13 -begin
172.14 -
172.15 -subsection {* Trivial examples *}
172.16 -
172.17 -fun identity :: "nat \<Rightarrow> nat"
172.18 -where
172.19 - "identity n = n"
172.20 -
172.21 -fun yaSuc :: "nat \<Rightarrow> nat"
172.22 -where
172.23 - "yaSuc 0 = 0"
172.24 -| "yaSuc (Suc n) = Suc (yaSuc n)"
172.25 -
172.26 -
172.27 -subsection {* Examples on natural numbers *}
172.28 -
172.29 -fun bin :: "(nat * nat) \<Rightarrow> nat"
172.30 -where
172.31 - "bin (0, 0) = 1"
172.32 -| "bin (Suc n, 0) = 0"
172.33 -| "bin (0, Suc m) = 0"
172.34 -| "bin (Suc n, Suc m) = bin (n, m) + bin (Suc n, m)"
172.35 -
172.36 -
172.37 -fun t :: "(nat * nat) \<Rightarrow> nat"
172.38 -where
172.39 - "t (0,n) = 0"
172.40 -| "t (n,0) = 0"
172.41 -| "t (Suc n, Suc m) = (if (n mod 2 = 0) then (t (Suc n, m)) else (t (n, Suc m)))"
172.42 -
172.43 -
172.44 -fun k :: "(nat * nat) * (nat * nat) \<Rightarrow> nat"
172.45 -where
172.46 - "k ((0,0),(0,0)) = 0"
172.47 -| "k ((Suc z, y), (u,v)) = k((z, y), (u, v))" (* z is descending *)
172.48 -| "k ((0, Suc y), (u,v)) = k((1, y), (u, v))" (* y is descending *)
172.49 -| "k ((0,0), (Suc u, v)) = k((1, 1), (u, v))" (* u is descending *)
172.50 -| "k ((0,0), (0, Suc v)) = k((1,1), (1,v))" (* v is descending *)
172.51 -
172.52 -
172.53 -fun gcd2 :: "nat \<Rightarrow> nat \<Rightarrow> nat"
172.54 -where
172.55 - "gcd2 x 0 = x"
172.56 -| "gcd2 0 y = y"
172.57 -| "gcd2 (Suc x) (Suc y) = (if x < y then gcd2 (Suc x) (y - x)
172.58 - else gcd2 (x - y) (Suc y))"
172.59 -
172.60 -fun ack :: "(nat * nat) \<Rightarrow> nat"
172.61 -where
172.62 - "ack (0, m) = Suc m"
172.63 -| "ack (Suc n, 0) = ack(n, 1)"
172.64 -| "ack (Suc n, Suc m) = ack (n, ack (Suc n, m))"
172.65 -
172.66 -
172.67 -fun greedy :: "nat * nat * nat * nat * nat => nat"
172.68 -where
172.69 - "greedy (Suc a, Suc b, Suc c, Suc d, Suc e) =
172.70 - (if (a < 10) then greedy (Suc a, Suc b, c, d + 2, Suc e) else
172.71 - (if (a < 20) then greedy (Suc a, b, Suc c, d, Suc e) else
172.72 - (if (a < 30) then greedy (Suc a, b, Suc c, d, Suc e) else
172.73 - (if (a < 40) then greedy (Suc a, b, Suc c, d, Suc e) else
172.74 - (if (a < 50) then greedy (Suc a, b, Suc c, d, Suc e) else
172.75 - (if (a < 60) then greedy (a, Suc b, Suc c, d, Suc e) else
172.76 - (if (a < 70) then greedy (a, Suc b, Suc c, d, Suc e) else
172.77 - (if (a < 80) then greedy (a, Suc b, Suc c, d, Suc e) else
172.78 - (if (a < 90) then greedy (Suc a, Suc b, Suc c, d, e) else
172.79 - greedy (Suc a, Suc b, Suc c, d, e))))))))))"
172.80 -| "greedy (a, b, c, d, e) = 0"
172.81 -
172.82 -
172.83 -fun blowup :: "nat => nat => nat => nat => nat => nat => nat => nat => nat => nat"
172.84 -where
172.85 - "blowup 0 0 0 0 0 0 0 0 0 = 0"
172.86 -| "blowup 0 0 0 0 0 0 0 0 (Suc i) = Suc (blowup i i i i i i i i i)"
172.87 -| "blowup 0 0 0 0 0 0 0 (Suc h) i = Suc (blowup h h h h h h h h i)"
172.88 -| "blowup 0 0 0 0 0 0 (Suc g) h i = Suc (blowup g g g g g g g h i)"
172.89 -| "blowup 0 0 0 0 0 (Suc f) g h i = Suc (blowup f f f f f f g h i)"
172.90 -| "blowup 0 0 0 0 (Suc e) f g h i = Suc (blowup e e e e e f g h i)"
172.91 -| "blowup 0 0 0 (Suc d) e f g h i = Suc (blowup d d d d e f g h i)"
172.92 -| "blowup 0 0 (Suc c) d e f g h i = Suc (blowup c c c d e f g h i)"
172.93 -| "blowup 0 (Suc b) c d e f g h i = Suc (blowup b b c d e f g h i)"
172.94 -| "blowup (Suc a) b c d e f g h i = Suc (blowup a b c d e f g h i)"
172.95 -
172.96 -
172.97 -subsection {* Simple examples with other datatypes than nat, e.g. trees and lists *}
172.98 -
172.99 -datatype tree = Node | Branch tree tree
172.100 -
172.101 -fun g_tree :: "tree * tree \<Rightarrow> tree"
172.102 -where
172.103 - "g_tree (Node, Node) = Node"
172.104 -| "g_tree (Node, Branch a b) = Branch Node (g_tree (a,b))"
172.105 -| "g_tree (Branch a b, Node) = Branch (g_tree (a,Node)) b"
172.106 -| "g_tree (Branch a b, Branch c d) = Branch (g_tree (a,c)) (g_tree (b,d))"
172.107 -
172.108 -
172.109 -fun acklist :: "'a list * 'a list \<Rightarrow> 'a list"
172.110 -where
172.111 - "acklist ([], m) = ((hd m)#m)"
172.112 -| "acklist (n#ns, []) = acklist (ns, [n])"
172.113 -| "acklist ((n#ns), (m#ms)) = acklist (ns, acklist ((n#ns), ms))"
172.114 -
172.115 -
172.116 -subsection {* Examples with mutual recursion *}
172.117 -
172.118 -fun evn od :: "nat \<Rightarrow> bool"
172.119 -where
172.120 - "evn 0 = True"
172.121 -| "od 0 = False"
172.122 -| "evn (Suc n) = od (Suc n)"
172.123 -| "od (Suc n) = evn n"
172.124 -
172.125 -
172.126 -fun sizechange_f :: "'a list => 'a list => 'a list" and
172.127 -sizechange_g :: "'a list => 'a list => 'a list => 'a list"
172.128 -where
172.129 - "sizechange_f i x = (if i=[] then x else sizechange_g (tl i) x i)"
172.130 -| "sizechange_g a b c = sizechange_f a (b @ c)"
172.131 -
172.132 -
172.133 -fun
172.134 - prod :: "nat => nat => nat => nat" and
172.135 - eprod :: "nat => nat => nat => nat" and
172.136 - oprod :: "nat => nat => nat => nat"
172.137 -where
172.138 - "prod x y z = (if y mod 2 = 0 then eprod x y z else oprod x y z)"
172.139 -| "oprod x y z = eprod x (y - 1) (z+x)"
172.140 -| "eprod x y z = (if y=0 then z else prod (2*x) (y div 2) z)"
172.141 -
172.142 -
172.143 -fun
172.144 - pedal :: "nat => nat => nat => nat"
172.145 -and
172.146 - coast :: "nat => nat => nat => nat"
172.147 -where
172.148 - "pedal 0 m c = c"
172.149 -| "pedal n 0 c = c"
172.150 -| "pedal n m c =
172.151 - (if n < m then coast (n - 1) (m - 1) (c + m)
172.152 - else pedal (n - 1) m (c + m))"
172.153 -
172.154 -| "coast n m c =
172.155 - (if n < m then coast n (m - 1) (c + n)
172.156 - else pedal n m (c + n))"
172.157 -
172.158 -
172.159 -subsection {*Examples for an unprovable termination *}
172.160 -
172.161 -text {* If termination cannot be proven, the tactic gives further information about unprovable subgoals on the arguments *}
172.162 -
172.163 -function noterm :: "(nat * nat) \<Rightarrow> nat"
172.164 -where
172.165 - "noterm (a,b) = noterm(b,a)"
172.166 -by pat_completeness auto
172.167 -(* termination by apply lexicographic_order*)
172.168 -
172.169 -function term_but_no_prove :: "nat * nat \<Rightarrow> nat"
172.170 -where
172.171 - "term_but_no_prove (0,0) = 1"
172.172 -| "term_but_no_prove (0, Suc b) = 0"
172.173 -| "term_but_no_prove (Suc a, 0) = 0"
172.174 -| "term_but_no_prove (Suc a, Suc b) = term_but_no_prove (b, a)"
172.175 -by pat_completeness auto
172.176 -(* termination by lexicographic_order *)
172.177 -
172.178 -text{* The tactic distinguishes between N = not provable AND F = False *}
172.179 -function no_proof :: "nat \<Rightarrow> nat"
172.180 -where
172.181 - "no_proof m = no_proof (Suc m)"
172.182 -by pat_completeness auto
172.183 -(* termination by lexicographic_order *)
172.184 -
172.185 -end
172.186 \ No newline at end of file
173.1 --- a/src/HOL/ex/Quickcheck.thy Tue Dec 30 08:18:54 2008 +0100
173.2 +++ b/src/HOL/ex/Quickcheck.thy Tue Dec 30 11:10:01 2008 +0100
173.3 @@ -1,11 +1,9 @@
173.4 -(* ID: $Id$
173.5 - Author: Florian Haftmann, TU Muenchen
173.6 -*)
173.7 +(* Author: Florian Haftmann, TU Muenchen *)
173.8
173.9 header {* A simple counterexample generator *}
173.10
173.11 theory Quickcheck
173.12 -imports Random Code_Eval
173.13 +imports Random Code_Eval Map
173.14 begin
173.15
173.16 subsection {* The @{text random} class *}
173.17 @@ -25,166 +23,6 @@
173.18
173.19 end
173.20
173.21 -text {* Datatypes *}
173.22 -
173.23 -definition
173.24 - collapse :: "('a \<Rightarrow> ('a \<Rightarrow> 'b \<times> 'a) \<times> 'a) \<Rightarrow> 'a \<Rightarrow> 'b \<times> 'a" where
173.25 - "collapse f = (do g \<leftarrow> f; g done)"
173.26 -
173.27 -ML {*
173.28 -structure StateMonad =
173.29 -struct
173.30 -
173.31 -fun liftT T sT = sT --> HOLogic.mk_prodT (T, sT);
173.32 -fun liftT' sT = sT --> sT;
173.33 -
173.34 -fun return T sT x = Const (@{const_name return}, T --> liftT T sT) $ x;
173.35 -
173.36 -fun scomp T1 T2 sT f g = Const (@{const_name scomp},
173.37 - liftT T1 sT --> (T1 --> liftT T2 sT) --> liftT T2 sT) $ f $ g;
173.38 -
173.39 -end;
173.40 -*}
173.41 -
173.42 -lemma random'_if:
173.43 - fixes random' :: "index \<Rightarrow> index \<Rightarrow> seed \<Rightarrow> ('a \<times> (unit \<Rightarrow> term)) \<times> seed"
173.44 - assumes "random' 0 j = (\<lambda>s. undefined)"
173.45 - and "\<And>i. random' (Suc_index i) j = rhs2 i"
173.46 - shows "random' i j s = (if i = 0 then undefined else rhs2 (i - 1) s)"
173.47 - by (cases i rule: index.exhaust) (insert assms, simp_all)
173.48 -
173.49 -setup {*
173.50 -let
173.51 - exception REC of string;
173.52 - fun mk_collapse thy ty = Sign.mk_const thy
173.53 - (@{const_name collapse}, [@{typ seed}, ty]);
173.54 - fun term_ty ty = HOLogic.mk_prodT (ty, @{typ "unit \<Rightarrow> term"});
173.55 - fun mk_split thy ty ty' = Sign.mk_const thy
173.56 - (@{const_name split}, [ty, @{typ "unit \<Rightarrow> term"}, StateMonad.liftT (term_ty ty') @{typ seed}]);
173.57 - fun mk_scomp_split thy ty ty' t t' =
173.58 - StateMonad.scomp (term_ty ty) (term_ty ty') @{typ seed} t
173.59 - (mk_split thy ty ty' $ Abs ("", ty, Abs ("", @{typ "unit \<Rightarrow> term"}, t')))
173.60 - fun mk_cons thy this_ty (c, args) =
173.61 - let
173.62 - val tys = map (fst o fst) args;
173.63 - val c_ty = tys ---> this_ty;
173.64 - val c = Const (c, tys ---> this_ty);
173.65 - val t_indices = map (curry ( op * ) 2) (length tys - 1 downto 0);
173.66 - val c_indices = map (curry ( op + ) 1) t_indices;
173.67 - val c_t = list_comb (c, map Bound c_indices);
173.68 - val t_t = Abs ("", @{typ unit}, Eval.mk_term Free Typerep.typerep
173.69 - (list_comb (c, map (fn k => Bound (k + 1)) t_indices))
173.70 - |> map_aterms (fn t as Bound _ => t $ @{term "()"} | t => t));
173.71 - val return = StateMonad.return (term_ty this_ty) @{typ seed}
173.72 - (HOLogic.mk_prod (c_t, t_t));
173.73 - val t = fold_rev (fn ((ty, _), random) =>
173.74 - mk_scomp_split thy ty this_ty random)
173.75 - args return;
173.76 - val is_rec = exists (snd o fst) args;
173.77 - in (is_rec, t) end;
173.78 - fun mk_conss thy ty [] = NONE
173.79 - | mk_conss thy ty [(_, t)] = SOME t
173.80 - | mk_conss thy ty ts = SOME (mk_collapse thy (term_ty ty) $
173.81 - (Sign.mk_const thy (@{const_name select}, [StateMonad.liftT (term_ty ty) @{typ seed}]) $
173.82 - HOLogic.mk_list (StateMonad.liftT (term_ty ty) @{typ seed}) (map snd ts)));
173.83 - fun mk_clauses thy ty (tyco, (ts_rec, ts_atom)) =
173.84 - let
173.85 - val SOME t_atom = mk_conss thy ty ts_atom;
173.86 - in case mk_conss thy ty ts_rec
173.87 - of SOME t_rec => mk_collapse thy (term_ty ty) $
173.88 - (Sign.mk_const thy (@{const_name select_default}, [StateMonad.liftT (term_ty ty) @{typ seed}]) $
173.89 - @{term "i\<Colon>index"} $ t_rec $ t_atom)
173.90 - | NONE => t_atom
173.91 - end;
173.92 - fun mk_random_eqs thy vs tycos =
173.93 - let
173.94 - val this_ty = Type (hd tycos, map TFree vs);
173.95 - val this_ty' = StateMonad.liftT (term_ty this_ty) @{typ seed};
173.96 - val random_name = NameSpace.base @{const_name random};
173.97 - val random'_name = random_name ^ "_" ^ Class.type_name (hd tycos) ^ "'";
173.98 - fun random ty = Sign.mk_const thy (@{const_name random}, [ty]);
173.99 - val random' = Free (random'_name,
173.100 - @{typ index} --> @{typ index} --> this_ty');
173.101 - fun atom ty = ((ty, false), random ty $ @{term "j\<Colon>index"});
173.102 - fun dtyp tyco = ((this_ty, true), random' $ @{term "i\<Colon>index"} $ @{term "j\<Colon>index"});
173.103 - fun rtyp tyco tys = raise REC
173.104 - ("Will not generate random elements for mutual recursive type " ^ quote (hd tycos));
173.105 - val rhss = DatatypePackage.construction_interpretation thy
173.106 - { atom = atom, dtyp = dtyp, rtyp = rtyp } vs tycos
173.107 - |> (map o apsnd o map) (mk_cons thy this_ty)
173.108 - |> (map o apsnd) (List.partition fst)
173.109 - |> map (mk_clauses thy this_ty)
173.110 - val eqss = map ((apsnd o map) (HOLogic.mk_Trueprop o HOLogic.mk_eq) o (fn rhs => ((this_ty, random'), [
173.111 - (random' $ @{term "0\<Colon>index"} $ @{term "j\<Colon>index"}, Abs ("s", @{typ seed},
173.112 - Const (@{const_name undefined}, HOLogic.mk_prodT (term_ty this_ty, @{typ seed})))),
173.113 - (random' $ @{term "Suc_index i"} $ @{term "j\<Colon>index"}, rhs)
173.114 - ]))) rhss;
173.115 - in eqss end;
173.116 - fun random_inst [tyco] thy =
173.117 - let
173.118 - val (raw_vs, _) = DatatypePackage.the_datatype_spec thy tyco;
173.119 - val vs = (map o apsnd)
173.120 - (curry (Sorts.inter_sort (Sign.classes_of thy)) @{sort random}) raw_vs;
173.121 - val { descr, index, ... } = DatatypePackage.the_datatype thy tyco;
173.122 - val ((this_ty, random'), eqs') = singleton (mk_random_eqs thy vs) tyco;
173.123 - val eq = (HOLogic.mk_Trueprop o HOLogic.mk_eq)
173.124 - (Sign.mk_const thy (@{const_name random}, [this_ty]) $ @{term "i\<Colon>index"},
173.125 - random' $ @{term "i\<Colon>index"} $ @{term "i\<Colon>index"})
173.126 - val del_func = Attrib.internal (fn _ => Thm.declaration_attribute
173.127 - (fn thm => Context.mapping (Code.del_eqn thm) I));
173.128 - fun add_code simps lthy =
173.129 - let
173.130 - val thy = ProofContext.theory_of lthy;
173.131 - val thm = @{thm random'_if}
173.132 - |> Drule.instantiate' [SOME (Thm.ctyp_of thy this_ty)] [SOME (Thm.cterm_of thy random')]
173.133 - |> (fn thm => thm OF simps)
173.134 - |> singleton (ProofContext.export lthy (ProofContext.init thy));
173.135 - val c = (fst o dest_Const o fst o strip_comb o fst
173.136 - o HOLogic.dest_eq o HOLogic.dest_Trueprop o Thm.prop_of) thm;
173.137 - in
173.138 - lthy
173.139 - |> LocalTheory.theory (Code.del_eqns c
173.140 - #> PureThy.add_thm ((fst (dest_Free random') ^ "_code", thm), [Thm.kind_internal])
173.141 - #-> Code.add_eqn)
173.142 - end;
173.143 - in
173.144 - thy
173.145 - |> TheoryTarget.instantiation ([tyco], vs, @{sort random})
173.146 - |> PrimrecPackage.add_primrec
173.147 - [(Binding.name (fst (dest_Free random')), SOME (snd (dest_Free random')), NoSyn)]
173.148 - (map (fn eq => ((Binding.empty, [del_func]), eq)) eqs')
173.149 - |-> add_code
173.150 - |> `(fn lthy => Syntax.check_term lthy eq)
173.151 - |-> (fn eq => Specification.definition (NONE, (Attrib.empty_binding, eq)))
173.152 - |> snd
173.153 - |> Class.prove_instantiation_instance (K (Class.intro_classes_tac []))
173.154 - |> LocalTheory.exit_global
173.155 - end
173.156 - | random_inst tycos thy = raise REC
173.157 - ("Will not generate random elements for mutual recursive type(s) " ^ commas (map quote tycos));
173.158 - fun add_random_inst tycos thy = random_inst tycos thy
173.159 - handle REC msg => (warning msg; thy);
173.160 -in DatatypePackage.interpretation add_random_inst end
173.161 -*}
173.162 -
173.163 -text {* Type @{typ int} *}
173.164 -
173.165 -instantiation int :: random
173.166 -begin
173.167 -
173.168 -definition
173.169 - "random n = (do
173.170 - (b, _) \<leftarrow> random n;
173.171 - (m, t) \<leftarrow> random n;
173.172 - return (if b then (int m, \<lambda>u. Code_Eval.App (Code_Eval.Const (STR ''Int.int'') TYPEREP(nat \<Rightarrow> int)) (t ()))
173.173 - else (- int m, \<lambda>u. Code_Eval.App (Code_Eval.Const (STR ''HOL.uminus_class.uminus'') TYPEREP(int \<Rightarrow> int))
173.174 - (Code_Eval.App (Code_Eval.Const (STR ''Int.int'') TYPEREP(nat \<Rightarrow> int)) (t ()))))
173.175 - done)"
173.176 -
173.177 -instance ..
173.178 -
173.179 -end
173.180 -
173.181 text {* Type @{typ "'a \<Rightarrow> 'b"} *}
173.182
173.183 ML {*
173.184 @@ -240,6 +78,170 @@
173.185
173.186 code_reserved SML Random_Engine
173.187
173.188 +text {* Datatypes *}
173.189 +
173.190 +definition
173.191 + collapse :: "('a \<Rightarrow> ('a \<Rightarrow> 'b \<times> 'a) \<times> 'a) \<Rightarrow> 'a \<Rightarrow> 'b \<times> 'a" where
173.192 + "collapse f = (do g \<leftarrow> f; g done)"
173.193 +
173.194 +ML {*
173.195 +structure StateMonad =
173.196 +struct
173.197 +
173.198 +fun liftT T sT = sT --> HOLogic.mk_prodT (T, sT);
173.199 +fun liftT' sT = sT --> sT;
173.200 +
173.201 +fun return T sT x = Const (@{const_name return}, T --> liftT T sT) $ x;
173.202 +
173.203 +fun scomp T1 T2 sT f g = Const (@{const_name scomp},
173.204 + liftT T1 sT --> (T1 --> liftT T2 sT) --> liftT T2 sT) $ f $ g;
173.205 +
173.206 +end;
173.207 +*}
173.208 +
173.209 +lemma random'_if:
173.210 + fixes random' :: "index \<Rightarrow> index \<Rightarrow> seed \<Rightarrow> ('a \<times> (unit \<Rightarrow> term)) \<times> seed"
173.211 + assumes "random' 0 j = (\<lambda>s. undefined)"
173.212 + and "\<And>i. random' (Suc_index i) j = rhs2 i"
173.213 + shows "random' i j s = (if i = 0 then undefined else rhs2 (i - 1) s)"
173.214 + by (cases i rule: index.exhaust) (insert assms, simp_all)
173.215 +
173.216 +setup {*
173.217 +let
173.218 + exception REC of string;
173.219 + exception TYP of string;
173.220 + fun mk_collapse thy ty = Sign.mk_const thy
173.221 + (@{const_name collapse}, [@{typ seed}, ty]);
173.222 + fun term_ty ty = HOLogic.mk_prodT (ty, @{typ "unit \<Rightarrow> term"});
173.223 + fun mk_split thy ty ty' = Sign.mk_const thy
173.224 + (@{const_name split}, [ty, @{typ "unit \<Rightarrow> term"}, StateMonad.liftT (term_ty ty') @{typ seed}]);
173.225 + fun mk_scomp_split thy ty ty' t t' =
173.226 + StateMonad.scomp (term_ty ty) (term_ty ty') @{typ seed} t
173.227 + (mk_split thy ty ty' $ Abs ("", ty, Abs ("", @{typ "unit \<Rightarrow> term"}, t')))
173.228 + fun mk_cons thy this_ty (c, args) =
173.229 + let
173.230 + val tys = map (fst o fst) args;
173.231 + val c_ty = tys ---> this_ty;
173.232 + val c = Const (c, tys ---> this_ty);
173.233 + val t_indices = map (curry ( op * ) 2) (length tys - 1 downto 0);
173.234 + val c_indices = map (curry ( op + ) 1) t_indices;
173.235 + val c_t = list_comb (c, map Bound c_indices);
173.236 + val t_t = Abs ("", @{typ unit}, Eval.mk_term Free Typerep.typerep
173.237 + (list_comb (c, map (fn k => Bound (k + 1)) t_indices))
173.238 + |> map_aterms (fn t as Bound _ => t $ @{term "()"} | t => t));
173.239 + val return = StateMonad.return (term_ty this_ty) @{typ seed}
173.240 + (HOLogic.mk_prod (c_t, t_t));
173.241 + val t = fold_rev (fn ((ty, _), random) =>
173.242 + mk_scomp_split thy ty this_ty random)
173.243 + args return;
173.244 + val is_rec = exists (snd o fst) args;
173.245 + in (is_rec, t) end;
173.246 + fun mk_conss thy ty [] = NONE
173.247 + | mk_conss thy ty [(_, t)] = SOME t
173.248 + | mk_conss thy ty ts = SOME (mk_collapse thy (term_ty ty) $
173.249 + (Sign.mk_const thy (@{const_name select}, [StateMonad.liftT (term_ty ty) @{typ seed}]) $
173.250 + HOLogic.mk_list (StateMonad.liftT (term_ty ty) @{typ seed}) (map snd ts)));
173.251 + fun mk_clauses thy ty (tyco, (ts_rec, ts_atom)) =
173.252 + let
173.253 + val SOME t_atom = mk_conss thy ty ts_atom;
173.254 + in case mk_conss thy ty ts_rec
173.255 + of SOME t_rec => mk_collapse thy (term_ty ty) $
173.256 + (Sign.mk_const thy (@{const_name select_default}, [StateMonad.liftT (term_ty ty) @{typ seed}]) $
173.257 + @{term "i\<Colon>index"} $ t_rec $ t_atom)
173.258 + | NONE => t_atom
173.259 + end;
173.260 + fun mk_random_eqs thy vs tycos =
173.261 + let
173.262 + val this_ty = Type (hd tycos, map TFree vs);
173.263 + val this_ty' = StateMonad.liftT (term_ty this_ty) @{typ seed};
173.264 + val random_name = NameSpace.base @{const_name random};
173.265 + val random'_name = random_name ^ "_" ^ Class.type_name (hd tycos) ^ "'";
173.266 + fun random ty = Sign.mk_const thy (@{const_name random}, [ty]);
173.267 + val random' = Free (random'_name,
173.268 + @{typ index} --> @{typ index} --> this_ty');
173.269 + fun atom ty = if Sign.of_sort thy (ty, @{sort random})
173.270 + then ((ty, false), random ty $ @{term "j\<Colon>index"})
173.271 + else raise TYP
173.272 + ("Will not generate random elements for type(s) " ^ quote (hd tycos));
173.273 + fun dtyp tyco = ((this_ty, true), random' $ @{term "i\<Colon>index"} $ @{term "j\<Colon>index"});
173.274 + fun rtyp tyco tys = raise REC
173.275 + ("Will not generate random elements for mutual recursive type " ^ quote (hd tycos));
173.276 + val rhss = DatatypePackage.construction_interpretation thy
173.277 + { atom = atom, dtyp = dtyp, rtyp = rtyp } vs tycos
173.278 + |> (map o apsnd o map) (mk_cons thy this_ty)
173.279 + |> (map o apsnd) (List.partition fst)
173.280 + |> map (mk_clauses thy this_ty)
173.281 + val eqss = map ((apsnd o map) (HOLogic.mk_Trueprop o HOLogic.mk_eq) o (fn rhs => ((this_ty, random'), [
173.282 + (random' $ @{term "0\<Colon>index"} $ @{term "j\<Colon>index"}, Abs ("s", @{typ seed},
173.283 + Const (@{const_name undefined}, HOLogic.mk_prodT (term_ty this_ty, @{typ seed})))),
173.284 + (random' $ @{term "Suc_index i"} $ @{term "j\<Colon>index"}, rhs)
173.285 + ]))) rhss;
173.286 + in eqss end;
173.287 + fun random_inst [tyco] thy =
173.288 + let
173.289 + val (raw_vs, _) = DatatypePackage.the_datatype_spec thy tyco;
173.290 + val vs = (map o apsnd)
173.291 + (curry (Sorts.inter_sort (Sign.classes_of thy)) @{sort random}) raw_vs;
173.292 + val ((this_ty, random'), eqs') = singleton (mk_random_eqs thy vs) tyco;
173.293 + val eq = (HOLogic.mk_Trueprop o HOLogic.mk_eq)
173.294 + (Sign.mk_const thy (@{const_name random}, [this_ty]) $ @{term "i\<Colon>index"},
173.295 + random' $ @{term "i\<Colon>index"} $ @{term "i\<Colon>index"})
173.296 + val del_func = Attrib.internal (fn _ => Thm.declaration_attribute
173.297 + (fn thm => Context.mapping (Code.del_eqn thm) I));
173.298 + fun add_code simps lthy =
173.299 + let
173.300 + val thy = ProofContext.theory_of lthy;
173.301 + val thm = @{thm random'_if}
173.302 + |> Drule.instantiate' [SOME (Thm.ctyp_of thy this_ty)] [SOME (Thm.cterm_of thy random')]
173.303 + |> (fn thm => thm OF simps)
173.304 + |> singleton (ProofContext.export lthy (ProofContext.init thy));
173.305 + val c = (fst o dest_Const o fst o strip_comb o fst
173.306 + o HOLogic.dest_eq o HOLogic.dest_Trueprop o Thm.prop_of) thm;
173.307 + in
173.308 + lthy
173.309 + |> LocalTheory.theory (Code.del_eqns c
173.310 + #> PureThy.add_thm ((fst (dest_Free random') ^ "_code", thm), [Thm.kind_internal])
173.311 + #-> Code.add_eqn)
173.312 + end;
173.313 + in
173.314 + thy
173.315 + |> TheoryTarget.instantiation ([tyco], vs, @{sort random})
173.316 + |> PrimrecPackage.add_primrec
173.317 + [(Binding.name (fst (dest_Free random')), SOME (snd (dest_Free random')), NoSyn)]
173.318 + (map (fn eq => ((Binding.empty, [del_func]), eq)) eqs')
173.319 + |-> add_code
173.320 + |> `(fn lthy => Syntax.check_term lthy eq)
173.321 + |-> (fn eq => Specification.definition (NONE, (Attrib.empty_binding, eq)))
173.322 + |> snd
173.323 + |> Class.prove_instantiation_instance (K (Class.intro_classes_tac []))
173.324 + |> LocalTheory.exit_global
173.325 + end
173.326 + | random_inst tycos thy = raise REC
173.327 + ("Will not generate random elements for mutual recursive type(s) " ^ commas (map quote tycos));
173.328 + fun add_random_inst tycos thy = random_inst tycos thy
173.329 + handle REC msg => (warning msg; thy)
173.330 + | TYP msg => (warning msg; thy)
173.331 +in DatatypePackage.interpretation add_random_inst end
173.332 +*}
173.333 +
173.334 +text {* Type @{typ int} *}
173.335 +
173.336 +instantiation int :: random
173.337 +begin
173.338 +
173.339 +definition
173.340 + "random n = (do
173.341 + (b, _) \<leftarrow> random n;
173.342 + (m, t) \<leftarrow> random n;
173.343 + return (if b then (int m, \<lambda>u. Code_Eval.App (Code_Eval.Const (STR ''Int.int'') TYPEREP(nat \<Rightarrow> int)) (t ()))
173.344 + else (- int m, \<lambda>u. Code_Eval.App (Code_Eval.Const (STR ''HOL.uminus_class.uminus'') TYPEREP(int \<Rightarrow> int))
173.345 + (Code_Eval.App (Code_Eval.Const (STR ''Int.int'') TYPEREP(nat \<Rightarrow> int)) (t ()))))
173.346 + done)"
173.347 +
173.348 +instance ..
173.349 +
173.350 +end
173.351 +
173.352
173.353 subsection {* Quickcheck generator *}
173.354
174.1 --- a/src/HOL/ex/ROOT.ML Tue Dec 30 08:18:54 2008 +0100
174.2 +++ b/src/HOL/ex/ROOT.ML Tue Dec 30 11:10:01 2008 +0100
174.3 @@ -56,7 +56,7 @@
174.4 "set",
174.5 "Meson_Test",
174.6 "Code_Antiq",
174.7 - "LexOrds",
174.8 + "Termination",
174.9 "Coherent"
174.10 ];
174.11
175.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
175.2 +++ b/src/HOL/ex/Termination.thy Tue Dec 30 11:10:01 2008 +0100
175.3 @@ -0,0 +1,212 @@
175.4 +(* Title: HOL/ex/Termination.thy
175.5 + ID: $Id$
175.6 + Author: Lukas Bulwahn, TU Muenchen
175.7 + Author: Alexander Krauss, TU Muenchen
175.8 +*)
175.9 +
175.10 +header {* Examples and regression tests for automated termination proofs *}
175.11 +
175.12 +theory Termination
175.13 +imports Main Multiset
175.14 +begin
175.15 +
175.16 +text {*
175.17 + The @{text fun} command uses the method @{text lexicographic_order} by default.
175.18 +*}
175.19 +
175.20 +subsection {* Trivial examples *}
175.21 +
175.22 +fun identity :: "nat \<Rightarrow> nat"
175.23 +where
175.24 + "identity n = n"
175.25 +
175.26 +fun yaSuc :: "nat \<Rightarrow> nat"
175.27 +where
175.28 + "yaSuc 0 = 0"
175.29 +| "yaSuc (Suc n) = Suc (yaSuc n)"
175.30 +
175.31 +
175.32 +subsection {* Examples on natural numbers *}
175.33 +
175.34 +fun bin :: "(nat * nat) \<Rightarrow> nat"
175.35 +where
175.36 + "bin (0, 0) = 1"
175.37 +| "bin (Suc n, 0) = 0"
175.38 +| "bin (0, Suc m) = 0"
175.39 +| "bin (Suc n, Suc m) = bin (n, m) + bin (Suc n, m)"
175.40 +
175.41 +
175.42 +fun t :: "(nat * nat) \<Rightarrow> nat"
175.43 +where
175.44 + "t (0,n) = 0"
175.45 +| "t (n,0) = 0"
175.46 +| "t (Suc n, Suc m) = (if (n mod 2 = 0) then (t (Suc n, m)) else (t (n, Suc m)))"
175.47 +
175.48 +
175.49 +fun k :: "(nat * nat) * (nat * nat) \<Rightarrow> nat"
175.50 +where
175.51 + "k ((0,0),(0,0)) = 0"
175.52 +| "k ((Suc z, y), (u,v)) = k((z, y), (u, v))" (* z is descending *)
175.53 +| "k ((0, Suc y), (u,v)) = k((1, y), (u, v))" (* y is descending *)
175.54 +| "k ((0,0), (Suc u, v)) = k((1, 1), (u, v))" (* u is descending *)
175.55 +| "k ((0,0), (0, Suc v)) = k((1,1), (1,v))" (* v is descending *)
175.56 +
175.57 +
175.58 +fun gcd2 :: "nat \<Rightarrow> nat \<Rightarrow> nat"
175.59 +where
175.60 + "gcd2 x 0 = x"
175.61 +| "gcd2 0 y = y"
175.62 +| "gcd2 (Suc x) (Suc y) = (if x < y then gcd2 (Suc x) (y - x)
175.63 + else gcd2 (x - y) (Suc y))"
175.64 +
175.65 +fun ack :: "(nat * nat) \<Rightarrow> nat"
175.66 +where
175.67 + "ack (0, m) = Suc m"
175.68 +| "ack (Suc n, 0) = ack(n, 1)"
175.69 +| "ack (Suc n, Suc m) = ack (n, ack (Suc n, m))"
175.70 +
175.71 +
175.72 +fun greedy :: "nat * nat * nat * nat * nat => nat"
175.73 +where
175.74 + "greedy (Suc a, Suc b, Suc c, Suc d, Suc e) =
175.75 + (if (a < 10) then greedy (Suc a, Suc b, c, d + 2, Suc e) else
175.76 + (if (a < 20) then greedy (Suc a, b, Suc c, d, Suc e) else
175.77 + (if (a < 30) then greedy (Suc a, b, Suc c, d, Suc e) else
175.78 + (if (a < 40) then greedy (Suc a, b, Suc c, d, Suc e) else
175.79 + (if (a < 50) then greedy (Suc a, b, Suc c, d, Suc e) else
175.80 + (if (a < 60) then greedy (a, Suc b, Suc c, d, Suc e) else
175.81 + (if (a < 70) then greedy (a, Suc b, Suc c, d, Suc e) else
175.82 + (if (a < 80) then greedy (a, Suc b, Suc c, d, Suc e) else
175.83 + (if (a < 90) then greedy (Suc a, Suc b, Suc c, d, e) else
175.84 + greedy (Suc a, Suc b, Suc c, d, e))))))))))"
175.85 +| "greedy (a, b, c, d, e) = 0"
175.86 +
175.87 +
175.88 +fun blowup :: "nat => nat => nat => nat => nat => nat => nat => nat => nat => nat"
175.89 +where
175.90 + "blowup 0 0 0 0 0 0 0 0 0 = 0"
175.91 +| "blowup 0 0 0 0 0 0 0 0 (Suc i) = Suc (blowup i i i i i i i i i)"
175.92 +| "blowup 0 0 0 0 0 0 0 (Suc h) i = Suc (blowup h h h h h h h h i)"
175.93 +| "blowup 0 0 0 0 0 0 (Suc g) h i = Suc (blowup g g g g g g g h i)"
175.94 +| "blowup 0 0 0 0 0 (Suc f) g h i = Suc (blowup f f f f f f g h i)"
175.95 +| "blowup 0 0 0 0 (Suc e) f g h i = Suc (blowup e e e e e f g h i)"
175.96 +| "blowup 0 0 0 (Suc d) e f g h i = Suc (blowup d d d d e f g h i)"
175.97 +| "blowup 0 0 (Suc c) d e f g h i = Suc (blowup c c c d e f g h i)"
175.98 +| "blowup 0 (Suc b) c d e f g h i = Suc (blowup b b c d e f g h i)"
175.99 +| "blowup (Suc a) b c d e f g h i = Suc (blowup a b c d e f g h i)"
175.100 +
175.101 +
175.102 +subsection {* Simple examples with other datatypes than nat, e.g. trees and lists *}
175.103 +
175.104 +datatype tree = Node | Branch tree tree
175.105 +
175.106 +fun g_tree :: "tree * tree \<Rightarrow> tree"
175.107 +where
175.108 + "g_tree (Node, Node) = Node"
175.109 +| "g_tree (Node, Branch a b) = Branch Node (g_tree (a,b))"
175.110 +| "g_tree (Branch a b, Node) = Branch (g_tree (a,Node)) b"
175.111 +| "g_tree (Branch a b, Branch c d) = Branch (g_tree (a,c)) (g_tree (b,d))"
175.112 +
175.113 +
175.114 +fun acklist :: "'a list * 'a list \<Rightarrow> 'a list"
175.115 +where
175.116 + "acklist ([], m) = ((hd m)#m)"
175.117 +| "acklist (n#ns, []) = acklist (ns, [n])"
175.118 +| "acklist ((n#ns), (m#ms)) = acklist (ns, acklist ((n#ns), ms))"
175.119 +
175.120 +
175.121 +subsection {* Examples with mutual recursion *}
175.122 +
175.123 +fun evn od :: "nat \<Rightarrow> bool"
175.124 +where
175.125 + "evn 0 = True"
175.126 +| "od 0 = False"
175.127 +| "evn (Suc n) = od (Suc n)"
175.128 +| "od (Suc n) = evn n"
175.129 +
175.130 +
175.131 +fun sizechange_f :: "'a list => 'a list => 'a list" and
175.132 +sizechange_g :: "'a list => 'a list => 'a list => 'a list"
175.133 +where
175.134 + "sizechange_f i x = (if i=[] then x else sizechange_g (tl i) x i)"
175.135 +| "sizechange_g a b c = sizechange_f a (b @ c)"
175.136 +
175.137 +fun
175.138 + pedal :: "nat => nat => nat => nat"
175.139 +and
175.140 + coast :: "nat => nat => nat => nat"
175.141 +where
175.142 + "pedal 0 m c = c"
175.143 +| "pedal n 0 c = c"
175.144 +| "pedal n m c =
175.145 + (if n < m then coast (n - 1) (m - 1) (c + m)
175.146 + else pedal (n - 1) m (c + m))"
175.147 +
175.148 +| "coast n m c =
175.149 + (if n < m then coast n (m - 1) (c + n)
175.150 + else pedal n m (c + n))"
175.151 +
175.152 +
175.153 +
175.154 +subsection {* Refined analysis: The @{text sizechange} method *}
175.155 +
175.156 +text {* Unsolvable for @{text lexicographic_order} *}
175.157 +
175.158 +function fun1 :: "nat * nat \<Rightarrow> nat"
175.159 +where
175.160 + "fun1 (0,0) = 1"
175.161 +| "fun1 (0, Suc b) = 0"
175.162 +| "fun1 (Suc a, 0) = 0"
175.163 +| "fun1 (Suc a, Suc b) = fun1 (b, a)"
175.164 +by pat_completeness auto
175.165 +termination by sizechange
175.166 +
175.167 +
175.168 +text {*
175.169 + @{text lexicographic_order} can do the following, but it is much slower.
175.170 +*}
175.171 +
175.172 +function
175.173 + prod :: "nat => nat => nat => nat" and
175.174 + eprod :: "nat => nat => nat => nat" and
175.175 + oprod :: "nat => nat => nat => nat"
175.176 +where
175.177 + "prod x y z = (if y mod 2 = 0 then eprod x y z else oprod x y z)"
175.178 +| "oprod x y z = eprod x (y - 1) (z+x)"
175.179 +| "eprod x y z = (if y=0 then z else prod (2*x) (y div 2) z)"
175.180 +by pat_completeness auto
175.181 +termination by sizechange
175.182 +
175.183 +text {*
175.184 + Permutations of arguments:
175.185 +*}
175.186 +
175.187 +function perm :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
175.188 +where
175.189 + "perm m n r = (if r > 0 then perm m (r - 1) n
175.190 + else if n > 0 then perm r (n - 1) m
175.191 + else m)"
175.192 +by auto
175.193 +termination by sizechange
175.194 +
175.195 +text {*
175.196 + Artificial examples and regression tests:
175.197 +*}
175.198 +
175.199 +function
175.200 + fun2 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
175.201 +where
175.202 + "fun2 x y z =
175.203 + (if x > 1000 \<and> z > 0 then
175.204 + fun2 (min x y) y (z - 1)
175.205 + else if y > 0 \<and> x > 100 then
175.206 + fun2 x (y - 1) (2 * z)
175.207 + else if z > 0 then
175.208 + fun2 (min y (z - 1)) x x
175.209 + else
175.210 + 0
175.211 + )"
175.212 +by pat_completeness auto
175.213 +termination by sizechange -- {* requires Multiset *}
175.214 +
175.215 +end
176.1 --- a/src/HOLCF/Adm.thy Tue Dec 30 08:18:54 2008 +0100
176.2 +++ b/src/HOLCF/Adm.thy Tue Dec 30 11:10:01 2008 +0100
176.3 @@ -1,5 +1,4 @@
176.4 (* Title: HOLCF/Adm.thy
176.5 - ID: $Id$
176.6 Author: Franz Regensburger and Brian Huffman
176.7 *)
176.8
177.1 --- a/src/HOLCF/Cfun.thy Tue Dec 30 08:18:54 2008 +0100
177.2 +++ b/src/HOLCF/Cfun.thy Tue Dec 30 11:10:01 2008 +0100
177.3 @@ -1,5 +1,4 @@
177.4 (* Title: HOLCF/Cfun.thy
177.5 - ID: $Id$
177.6 Author: Franz Regensburger
177.7
177.8 Definition of the type -> of continuous functions.
178.1 --- a/src/HOLCF/Cont.thy Tue Dec 30 08:18:54 2008 +0100
178.2 +++ b/src/HOLCF/Cont.thy Tue Dec 30 11:10:01 2008 +0100
178.3 @@ -1,8 +1,5 @@
178.4 (* Title: HOLCF/Cont.thy
178.5 - ID: $Id$
178.6 Author: Franz Regensburger
178.7 -
178.8 -Results about continuity and monotonicity.
178.9 *)
178.10
178.11 header {* Continuity and monotonicity *}
179.1 --- a/src/HOLCF/Cprod.thy Tue Dec 30 08:18:54 2008 +0100
179.2 +++ b/src/HOLCF/Cprod.thy Tue Dec 30 11:10:01 2008 +0100
179.3 @@ -1,8 +1,5 @@
179.4 (* Title: HOLCF/Cprod.thy
179.5 - ID: $Id$
179.6 Author: Franz Regensburger
179.7 -
179.8 -Partial ordering for cartesian product of HOL products.
179.9 *)
179.10
179.11 header {* The cpo of cartesian products *}
180.1 --- a/src/HOLCF/Discrete.thy Tue Dec 30 08:18:54 2008 +0100
180.2 +++ b/src/HOLCF/Discrete.thy Tue Dec 30 11:10:01 2008 +0100
180.3 @@ -1,8 +1,5 @@
180.4 (* Title: HOLCF/Discrete.thy
180.5 - ID: $Id$
180.6 Author: Tobias Nipkow
180.7 -
180.8 -Discrete CPOs.
180.9 *)
180.10
180.11 header {* Discrete cpo types *}
181.1 --- a/src/HOLCF/Domain.thy Tue Dec 30 08:18:54 2008 +0100
181.2 +++ b/src/HOLCF/Domain.thy Tue Dec 30 11:10:01 2008 +0100
181.3 @@ -1,5 +1,4 @@
181.4 (* Title: HOLCF/Domain.thy
181.5 - ID: $Id$
181.6 Author: Brian Huffman
181.7 *)
181.8
182.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
182.2 +++ b/src/HOLCF/Dsum.thy Tue Dec 30 11:10:01 2008 +0100
182.3 @@ -0,0 +1,251 @@
182.4 +(* Title: HOLCF/Dsum.thy
182.5 + Author: Brian Huffman
182.6 +*)
182.7 +
182.8 +header {* The cpo of disjoint sums *}
182.9 +
182.10 +theory Dsum
182.11 +imports Bifinite
182.12 +begin
182.13 +
182.14 +subsection {* Ordering on type @{typ "'a + 'b"} *}
182.15 +
182.16 +instantiation "+" :: (sq_ord, sq_ord) sq_ord
182.17 +begin
182.18 +
182.19 +definition
182.20 + less_sum_def: "x \<sqsubseteq> y \<equiv> case x of
182.21 + Inl a \<Rightarrow> (case y of Inl b \<Rightarrow> a \<sqsubseteq> b | Inr b \<Rightarrow> False) |
182.22 + Inr a \<Rightarrow> (case y of Inl b \<Rightarrow> False | Inr b \<Rightarrow> a \<sqsubseteq> b)"
182.23 +
182.24 +instance ..
182.25 +end
182.26 +
182.27 +lemma Inl_less_iff [simp]: "Inl x \<sqsubseteq> Inl y = x \<sqsubseteq> y"
182.28 +unfolding less_sum_def by simp
182.29 +
182.30 +lemma Inr_less_iff [simp]: "Inr x \<sqsubseteq> Inr y = x \<sqsubseteq> y"
182.31 +unfolding less_sum_def by simp
182.32 +
182.33 +lemma Inl_less_Inr [simp]: "\<not> Inl x \<sqsubseteq> Inr y"
182.34 +unfolding less_sum_def by simp
182.35 +
182.36 +lemma Inr_less_Inl [simp]: "\<not> Inr x \<sqsubseteq> Inl y"
182.37 +unfolding less_sum_def by simp
182.38 +
182.39 +lemma Inl_mono: "x \<sqsubseteq> y \<Longrightarrow> Inl x \<sqsubseteq> Inl y"
182.40 +by simp
182.41 +
182.42 +lemma Inr_mono: "x \<sqsubseteq> y \<Longrightarrow> Inr x \<sqsubseteq> Inr y"
182.43 +by simp
182.44 +
182.45 +lemma Inl_lessE: "\<lbrakk>Inl a \<sqsubseteq> x; \<And>b. \<lbrakk>x = Inl b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
182.46 +by (cases x, simp_all)
182.47 +
182.48 +lemma Inr_lessE: "\<lbrakk>Inr a \<sqsubseteq> x; \<And>b. \<lbrakk>x = Inr b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
182.49 +by (cases x, simp_all)
182.50 +
182.51 +lemmas sum_less_elims = Inl_lessE Inr_lessE
182.52 +
182.53 +lemma sum_less_cases:
182.54 + "\<lbrakk>x \<sqsubseteq> y;
182.55 + \<And>a b. \<lbrakk>x = Inl a; y = Inl b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R;
182.56 + \<And>a b. \<lbrakk>x = Inr a; y = Inr b; a \<sqsubseteq> b\<rbrakk> \<Longrightarrow> R\<rbrakk>
182.57 + \<Longrightarrow> R"
182.58 +by (cases x, safe elim!: sum_less_elims, auto)
182.59 +
182.60 +subsection {* Sum type is a complete partial order *}
182.61 +
182.62 +instance "+" :: (po, po) po
182.63 +proof
182.64 + fix x :: "'a + 'b"
182.65 + show "x \<sqsubseteq> x"
182.66 + by (induct x, simp_all)
182.67 +next
182.68 + fix x y :: "'a + 'b"
182.69 + assume "x \<sqsubseteq> y" and "y \<sqsubseteq> x" thus "x = y"
182.70 + by (induct x, auto elim!: sum_less_elims intro: antisym_less)
182.71 +next
182.72 + fix x y z :: "'a + 'b"
182.73 + assume "x \<sqsubseteq> y" and "y \<sqsubseteq> z" thus "x \<sqsubseteq> z"
182.74 + by (induct x, auto elim!: sum_less_elims intro: trans_less)
182.75 +qed
182.76 +
182.77 +lemma monofun_inv_Inl: "monofun (\<lambda>p. THE a. p = Inl a)"
182.78 +by (rule monofunI, erule sum_less_cases, simp_all)
182.79 +
182.80 +lemma monofun_inv_Inr: "monofun (\<lambda>p. THE b. p = Inr b)"
182.81 +by (rule monofunI, erule sum_less_cases, simp_all)
182.82 +
182.83 +lemma sum_chain_cases:
182.84 + assumes Y: "chain Y"
182.85 + assumes A: "\<And>A. \<lbrakk>chain A; Y = (\<lambda>i. Inl (A i))\<rbrakk> \<Longrightarrow> R"
182.86 + assumes B: "\<And>B. \<lbrakk>chain B; Y = (\<lambda>i. Inr (B i))\<rbrakk> \<Longrightarrow> R"
182.87 + shows "R"
182.88 + apply (cases "Y 0")
182.89 + apply (rule A)
182.90 + apply (rule ch2ch_monofun [OF monofun_inv_Inl Y])
182.91 + apply (rule ext)
182.92 + apply (cut_tac j=i in chain_mono [OF Y le0], simp)
182.93 + apply (erule Inl_lessE, simp)
182.94 + apply (rule B)
182.95 + apply (rule ch2ch_monofun [OF monofun_inv_Inr Y])
182.96 + apply (rule ext)
182.97 + apply (cut_tac j=i in chain_mono [OF Y le0], simp)
182.98 + apply (erule Inr_lessE, simp)
182.99 +done
182.100 +
182.101 +lemma is_lub_Inl: "range S <<| x \<Longrightarrow> range (\<lambda>i. Inl (S i)) <<| Inl x"
182.102 + apply (rule is_lubI)
182.103 + apply (rule ub_rangeI)
182.104 + apply (simp add: is_ub_lub)
182.105 + apply (frule ub_rangeD [where i=arbitrary])
182.106 + apply (erule Inl_lessE, simp)
182.107 + apply (erule is_lub_lub)
182.108 + apply (rule ub_rangeI)
182.109 + apply (drule ub_rangeD, simp)
182.110 +done
182.111 +
182.112 +lemma is_lub_Inr: "range S <<| x \<Longrightarrow> range (\<lambda>i. Inr (S i)) <<| Inr x"
182.113 + apply (rule is_lubI)
182.114 + apply (rule ub_rangeI)
182.115 + apply (simp add: is_ub_lub)
182.116 + apply (frule ub_rangeD [where i=arbitrary])
182.117 + apply (erule Inr_lessE, simp)
182.118 + apply (erule is_lub_lub)
182.119 + apply (rule ub_rangeI)
182.120 + apply (drule ub_rangeD, simp)
182.121 +done
182.122 +
182.123 +instance "+" :: (cpo, cpo) cpo
182.124 + apply intro_classes
182.125 + apply (erule sum_chain_cases, safe)
182.126 + apply (rule exI)
182.127 + apply (rule is_lub_Inl)
182.128 + apply (erule cpo_lubI)
182.129 + apply (rule exI)
182.130 + apply (rule is_lub_Inr)
182.131 + apply (erule cpo_lubI)
182.132 +done
182.133 +
182.134 +subsection {* Continuity of @{term Inl}, @{term Inr}, @{term sum_case} *}
182.135 +
182.136 +lemma cont2cont_Inl [simp]: "cont f \<Longrightarrow> cont (\<lambda>x. Inl (f x))"
182.137 +by (fast intro: contI is_lub_Inl elim: contE)
182.138 +
182.139 +lemma cont2cont_Inr [simp]: "cont f \<Longrightarrow> cont (\<lambda>x. Inr (f x))"
182.140 +by (fast intro: contI is_lub_Inr elim: contE)
182.141 +
182.142 +lemma cont_Inl: "cont Inl"
182.143 +by (rule cont2cont_Inl [OF cont_id])
182.144 +
182.145 +lemma cont_Inr: "cont Inr"
182.146 +by (rule cont2cont_Inr [OF cont_id])
182.147 +
182.148 +lemmas ch2ch_Inl [simp] = ch2ch_cont [OF cont_Inl]
182.149 +lemmas ch2ch_Inr [simp] = ch2ch_cont [OF cont_Inr]
182.150 +
182.151 +lemmas lub_Inl = cont2contlubE [OF cont_Inl, symmetric]
182.152 +lemmas lub_Inr = cont2contlubE [OF cont_Inr, symmetric]
182.153 +
182.154 +lemma cont_sum_case1:
182.155 + assumes f: "\<And>a. cont (\<lambda>x. f x a)"
182.156 + assumes g: "\<And>b. cont (\<lambda>x. g x b)"
182.157 + shows "cont (\<lambda>x. case y of Inl a \<Rightarrow> f x a | Inr b \<Rightarrow> g x b)"
182.158 +by (induct y, simp add: f, simp add: g)
182.159 +
182.160 +lemma cont_sum_case2: "\<lbrakk>cont f; cont g\<rbrakk> \<Longrightarrow> cont (sum_case f g)"
182.161 +apply (rule contI)
182.162 +apply (erule sum_chain_cases)
182.163 +apply (simp add: cont2contlubE [OF cont_Inl, symmetric] contE)
182.164 +apply (simp add: cont2contlubE [OF cont_Inr, symmetric] contE)
182.165 +done
182.166 +
182.167 +lemma cont2cont_sum_case [simp]:
182.168 + assumes f1: "\<And>a. cont (\<lambda>x. f x a)" and f2: "\<And>x. cont (\<lambda>a. f x a)"
182.169 + assumes g1: "\<And>b. cont (\<lambda>x. g x b)" and g2: "\<And>x. cont (\<lambda>b. g x b)"
182.170 + assumes h: "cont (\<lambda>x. h x)"
182.171 + shows "cont (\<lambda>x. case h x of Inl a \<Rightarrow> f x a | Inr b \<Rightarrow> g x b)"
182.172 +apply (rule cont2cont_app2 [OF cont2cont_lambda _ h])
182.173 +apply (rule cont_sum_case1 [OF f1 g1])
182.174 +apply (rule cont_sum_case2 [OF f2 g2])
182.175 +done
182.176 +
182.177 +subsection {* Compactness and chain-finiteness *}
182.178 +
182.179 +lemma compact_Inl: "compact a \<Longrightarrow> compact (Inl a)"
182.180 +apply (rule compactI2)
182.181 +apply (erule sum_chain_cases, safe)
182.182 +apply (simp add: lub_Inl)
182.183 +apply (erule (2) compactD2)
182.184 +apply (simp add: lub_Inr)
182.185 +done
182.186 +
182.187 +lemma compact_Inr: "compact a \<Longrightarrow> compact (Inr a)"
182.188 +apply (rule compactI2)
182.189 +apply (erule sum_chain_cases, safe)
182.190 +apply (simp add: lub_Inl)
182.191 +apply (simp add: lub_Inr)
182.192 +apply (erule (2) compactD2)
182.193 +done
182.194 +
182.195 +lemma compact_Inl_rev: "compact (Inl a) \<Longrightarrow> compact a"
182.196 +unfolding compact_def
182.197 +by (drule adm_subst [OF cont_Inl], simp)
182.198 +
182.199 +lemma compact_Inr_rev: "compact (Inr a) \<Longrightarrow> compact a"
182.200 +unfolding compact_def
182.201 +by (drule adm_subst [OF cont_Inr], simp)
182.202 +
182.203 +lemma compact_Inl_iff [simp]: "compact (Inl a) = compact a"
182.204 +by (safe elim!: compact_Inl compact_Inl_rev)
182.205 +
182.206 +lemma compact_Inr_iff [simp]: "compact (Inr a) = compact a"
182.207 +by (safe elim!: compact_Inr compact_Inr_rev)
182.208 +
182.209 +instance "+" :: (chfin, chfin) chfin
182.210 +apply intro_classes
182.211 +apply (erule compact_imp_max_in_chain)
182.212 +apply (case_tac "\<Squnion>i. Y i", simp_all)
182.213 +done
182.214 +
182.215 +instance "+" :: (finite_po, finite_po) finite_po ..
182.216 +
182.217 +instance "+" :: (discrete_cpo, discrete_cpo) discrete_cpo
182.218 +by intro_classes (simp add: less_sum_def split: sum.split)
182.219 +
182.220 +subsection {* Sum type is a bifinite domain *}
182.221 +
182.222 +instantiation "+" :: (profinite, profinite) profinite
182.223 +begin
182.224 +
182.225 +definition
182.226 + approx_sum_def: "approx =
182.227 + (\<lambda>n. \<Lambda> x. case x of Inl a \<Rightarrow> Inl (approx n\<cdot>a) | Inr b \<Rightarrow> Inr (approx n\<cdot>b))"
182.228 +
182.229 +lemma approx_Inl [simp]: "approx n\<cdot>(Inl x) = Inl (approx n\<cdot>x)"
182.230 + unfolding approx_sum_def by simp
182.231 +
182.232 +lemma approx_Inr [simp]: "approx n\<cdot>(Inr x) = Inr (approx n\<cdot>x)"
182.233 + unfolding approx_sum_def by simp
182.234 +
182.235 +instance proof
182.236 + fix i :: nat and x :: "'a + 'b"
182.237 + show "chain (approx :: nat \<Rightarrow> 'a + 'b \<rightarrow> 'a + 'b)"
182.238 + unfolding approx_sum_def
182.239 + by (rule ch2ch_LAM, case_tac x, simp_all)
182.240 + show "(\<Squnion>i. approx i\<cdot>x) = x"
182.241 + by (induct x, simp_all add: lub_Inl lub_Inr)
182.242 + show "approx i\<cdot>(approx i\<cdot>x) = approx i\<cdot>x"
182.243 + by (induct x, simp_all)
182.244 + have "{x::'a + 'b. approx i\<cdot>x = x} \<subseteq>
182.245 + {x::'a. approx i\<cdot>x = x} <+> {x::'b. approx i\<cdot>x = x}"
182.246 + by (rule subsetI, case_tac x, simp_all add: InlI InrI)
182.247 + thus "finite {x::'a + 'b. approx i\<cdot>x = x}"
182.248 + by (rule finite_subset,
182.249 + intro finite_Plus finite_fixes_approx)
182.250 +qed
182.251 +
182.252 +end
182.253 +
182.254 +end
183.1 --- a/src/HOLCF/Ffun.thy Tue Dec 30 08:18:54 2008 +0100
183.2 +++ b/src/HOLCF/Ffun.thy Tue Dec 30 11:10:01 2008 +0100
183.3 @@ -1,10 +1,5 @@
183.4 (* Title: HOLCF/FunCpo.thy
183.5 - ID: $Id$
183.6 Author: Franz Regensburger
183.7 -
183.8 -Definition of the partial ordering for the type of all functions => (fun)
183.9 -
183.10 -Class instance of => (fun) for class pcpo.
183.11 *)
183.12
183.13 header {* Class instances for the full function space *}
184.1 --- a/src/HOLCF/Fix.thy Tue Dec 30 08:18:54 2008 +0100
184.2 +++ b/src/HOLCF/Fix.thy Tue Dec 30 11:10:01 2008 +0100
184.3 @@ -1,8 +1,5 @@
184.4 (* Title: HOLCF/Fix.thy
184.5 - ID: $Id$
184.6 Author: Franz Regensburger
184.7 -
184.8 -Definitions for fixed point operator and admissibility.
184.9 *)
184.10
184.11 header {* Fixed point operator and admissibility *}
185.1 --- a/src/HOLCF/Fixrec.thy Tue Dec 30 08:18:54 2008 +0100
185.2 +++ b/src/HOLCF/Fixrec.thy Tue Dec 30 11:10:01 2008 +0100
185.3 @@ -1,5 +1,4 @@
185.4 (* Title: HOLCF/Fixrec.thy
185.5 - ID: $Id$
185.6 Author: Amber Telfer and Brian Huffman
185.7 *)
185.8
185.9 @@ -17,13 +16,13 @@
185.10 pcpodef (open) 'a maybe = "UNIV::(one ++ 'a u) set"
185.11 by simp_all
185.12
185.13 -constdefs
185.14 - fail :: "'a maybe"
185.15 - "fail \<equiv> Abs_maybe (sinl\<cdot>ONE)"
185.16 +definition
185.17 + fail :: "'a maybe" where
185.18 + "fail = Abs_maybe (sinl\<cdot>ONE)"
185.19
185.20 -constdefs
185.21 +definition
185.22 return :: "'a \<rightarrow> 'a maybe" where
185.23 - "return \<equiv> \<Lambda> x. Abs_maybe (sinr\<cdot>(up\<cdot>x))"
185.24 + "return = (\<Lambda> x. Abs_maybe (sinr\<cdot>(up\<cdot>x)))"
185.25
185.26 definition
185.27 maybe_when :: "'b \<rightarrow> ('a \<rightarrow> 'b) \<rightarrow> 'a maybe \<rightarrow> 'b::pcpo" where
185.28 @@ -59,7 +58,8 @@
185.29 cont_Abs_maybe Abs_maybe_inverse Rep_maybe_strict)
185.30
185.31 translations
185.32 - "case m of fail \<Rightarrow> t1 | return\<cdot>x \<Rightarrow> t2" == "CONST maybe_when\<cdot>t1\<cdot>(\<Lambda> x. t2)\<cdot>m"
185.33 + "case m of XCONST fail \<Rightarrow> t1 | XCONST return\<cdot>x \<Rightarrow> t2"
185.34 + == "CONST maybe_when\<cdot>t1\<cdot>(\<Lambda> x. t2)\<cdot>m"
185.35
185.36
185.37 subsubsection {* Monadic bind operator *}
185.38 @@ -164,8 +164,8 @@
185.39
185.40 subsection {* Case branch combinator *}
185.41
185.42 -constdefs
185.43 - branch :: "('a \<rightarrow> 'b maybe) \<Rightarrow> ('b \<rightarrow> 'c) \<rightarrow> ('a \<rightarrow> 'c maybe)"
185.44 +definition
185.45 + branch :: "('a \<rightarrow> 'b maybe) \<Rightarrow> ('b \<rightarrow> 'c) \<rightarrow> ('a \<rightarrow> 'c maybe)" where
185.46 "branch p \<equiv> \<Lambda> r x. bind\<cdot>(p\<cdot>x)\<cdot>(\<Lambda> y. return\<cdot>(r\<cdot>y))"
185.47
185.48 lemma branch_rews:
186.1 --- a/src/HOLCF/HOLCF.thy Tue Dec 30 08:18:54 2008 +0100
186.2 +++ b/src/HOLCF/HOLCF.thy Tue Dec 30 11:10:01 2008 +0100
186.3 @@ -1,12 +1,12 @@
186.4 (* Title: HOLCF/HOLCF.thy
186.5 - ID: $Id$
186.6 Author: Franz Regensburger
186.7
186.8 HOLCF -- a semantic extension of HOL by the LCF logic.
186.9 *)
186.10
186.11 theory HOLCF
186.12 -imports Sprod Ssum Up Lift Discrete One Tr Domain ConvexPD Algebraic Universal Main
186.13 +imports
186.14 + Domain ConvexPD Algebraic Universal Dsum Main
186.15 uses
186.16 "holcf_logic.ML"
186.17 "Tools/cont_consts.ML"
187.1 --- a/src/HOLCF/IsaMakefile Tue Dec 30 08:18:54 2008 +0100
187.2 +++ b/src/HOLCF/IsaMakefile Tue Dec 30 11:10:01 2008 +0100
187.3 @@ -41,6 +41,7 @@
187.4 Discrete.thy \
187.5 Deflation.thy \
187.6 Domain.thy \
187.7 + Dsum.thy \
187.8 Eventual.thy \
187.9 Ffun.thy \
187.10 Fixrec.thy \
188.1 --- a/src/HOLCF/Lift.thy Tue Dec 30 08:18:54 2008 +0100
188.2 +++ b/src/HOLCF/Lift.thy Tue Dec 30 11:10:01 2008 +0100
188.3 @@ -1,5 +1,4 @@
188.4 (* Title: HOLCF/Lift.thy
188.5 - ID: $Id$
188.6 Author: Olaf Mueller
188.7 *)
188.8
189.1 --- a/src/HOLCF/One.thy Tue Dec 30 08:18:54 2008 +0100
189.2 +++ b/src/HOLCF/One.thy Tue Dec 30 11:10:01 2008 +0100
189.3 @@ -1,8 +1,5 @@
189.4 (* Title: HOLCF/One.thy
189.5 - ID: $Id$
189.6 Author: Oscar Slotosch
189.7 -
189.8 -The unit domain.
189.9 *)
189.10
189.11 header {* The unit domain *}
189.12 @@ -15,8 +12,9 @@
189.13 translations
189.14 "one" <= (type) "unit lift"
189.15
189.16 -constdefs
189.17 +definition
189.18 ONE :: "one"
189.19 +where
189.20 "ONE == Def ()"
189.21
189.22 text {* Exhaustion and Elimination for type @{typ one} *}
190.1 --- a/src/HOLCF/Pcpo.thy Tue Dec 30 08:18:54 2008 +0100
190.2 +++ b/src/HOLCF/Pcpo.thy Tue Dec 30 11:10:01 2008 +0100
190.3 @@ -1,5 +1,4 @@
190.4 (* Title: HOLCF/Pcpo.thy
190.5 - ID: $Id$
190.6 Author: Franz Regensburger
190.7 *)
190.8
191.1 --- a/src/HOLCF/Pcpodef.thy Tue Dec 30 08:18:54 2008 +0100
191.2 +++ b/src/HOLCF/Pcpodef.thy Tue Dec 30 11:10:01 2008 +0100
191.3 @@ -1,5 +1,4 @@
191.4 (* Title: HOLCF/Pcpodef.thy
191.5 - ID: $Id$
191.6 Author: Brian Huffman
191.7 *)
191.8
192.1 --- a/src/HOLCF/Porder.thy Tue Dec 30 08:18:54 2008 +0100
192.2 +++ b/src/HOLCF/Porder.thy Tue Dec 30 11:10:01 2008 +0100
192.3 @@ -1,5 +1,4 @@
192.4 (* Title: HOLCF/Porder.thy
192.5 - ID: $Id$
192.6 Author: Franz Regensburger and Brian Huffman
192.7 *)
192.8
193.1 --- a/src/HOLCF/Sprod.thy Tue Dec 30 08:18:54 2008 +0100
193.2 +++ b/src/HOLCF/Sprod.thy Tue Dec 30 11:10:01 2008 +0100
193.3 @@ -1,8 +1,5 @@
193.4 (* Title: HOLCF/Sprod.thy
193.5 - ID: $Id$
193.6 Author: Franz Regensburger and Brian Huffman
193.7 -
193.8 -Strict product with typedef.
193.9 *)
193.10
193.11 header {* The type of strict products *}
194.1 --- a/src/HOLCF/Ssum.thy Tue Dec 30 08:18:54 2008 +0100
194.2 +++ b/src/HOLCF/Ssum.thy Tue Dec 30 11:10:01 2008 +0100
194.3 @@ -1,8 +1,5 @@
194.4 (* Title: HOLCF/Ssum.thy
194.5 - ID: $Id$
194.6 Author: Franz Regensburger and Brian Huffman
194.7 -
194.8 -Strict sum with typedef.
194.9 *)
194.10
194.11 header {* The type of strict sums *}
195.1 --- a/src/HOLCF/Tr.thy Tue Dec 30 08:18:54 2008 +0100
195.2 +++ b/src/HOLCF/Tr.thy Tue Dec 30 11:10:01 2008 +0100
195.3 @@ -1,8 +1,5 @@
195.4 (* Title: HOLCF/Tr.thy
195.5 - ID: $Id$
195.6 Author: Franz Regensburger
195.7 -
195.8 -Introduce infix if_then_else_fi and boolean connectives andalso, orelse.
195.9 *)
195.10
195.11 header {* The type of lifted booleans *}
196.1 --- a/src/HOLCF/Up.thy Tue Dec 30 08:18:54 2008 +0100
196.2 +++ b/src/HOLCF/Up.thy Tue Dec 30 11:10:01 2008 +0100
196.3 @@ -1,8 +1,5 @@
196.4 (* Title: HOLCF/Up.thy
196.5 - ID: $Id$
196.6 Author: Franz Regensburger and Brian Huffman
196.7 -
196.8 -Lifting.
196.9 *)
196.10
196.11 header {* The type of lifted values *}
197.1 --- a/src/HOLCF/document/root.tex Tue Dec 30 08:18:54 2008 +0100
197.2 +++ b/src/HOLCF/document/root.tex Tue Dec 30 11:10:01 2008 +0100
197.3 @@ -1,5 +1,5 @@
197.4
197.5 -% $Id$
197.6 +% HOLCF/document/root.tex
197.7
197.8 \documentclass[11pt,a4paper]{article}
197.9 \usepackage{graphicx,isabelle,isabellesym,latexsym}
197.10 @@ -21,7 +21,7 @@
197.11 \tableofcontents
197.12
197.13 \begin{center}
197.14 - \includegraphics[scale=0.7]{session_graph}
197.15 + \includegraphics[scale=0.5]{session_graph}
197.16 \end{center}
197.17
197.18 \newpage
198.1 --- a/src/Pure/Concurrent/ROOT.ML Tue Dec 30 08:18:54 2008 +0100
198.2 +++ b/src/Pure/Concurrent/ROOT.ML Tue Dec 30 11:10:01 2008 +0100
198.3 @@ -1,15 +1,12 @@
198.4 (* Title: Pure/Concurrent/ROOT.ML
198.5 - ID: $Id$
198.6 + Author: Makarius
198.7
198.8 Concurrency within the ML runtime.
198.9 *)
198.10
198.11 -val future_scheduler = ref true;
198.12 -
198.13 use "simple_thread.ML";
198.14 use "synchronized.ML";
198.15 use "mailbox.ML";
198.16 -use "schedule.ML";
198.17 use "task_queue.ML";
198.18 use "future.ML";
198.19 use "par_list.ML";
199.1 --- a/src/Pure/Concurrent/future.ML Tue Dec 30 08:18:54 2008 +0100
199.2 +++ b/src/Pure/Concurrent/future.ML Tue Dec 30 11:10:01 2008 +0100
199.3 @@ -1,5 +1,4 @@
199.4 (* Title: Pure/Concurrent/future.ML
199.5 - ID: $Id$
199.6 Author: Makarius
199.7
199.8 Future values.
199.9 @@ -28,8 +27,8 @@
199.10 signature FUTURE =
199.11 sig
199.12 val enabled: unit -> bool
199.13 - type task = TaskQueue.task
199.14 - type group = TaskQueue.group
199.15 + type task = Task_Queue.task
199.16 + type group = Task_Queue.group
199.17 val thread_data: unit -> (string * task) option
199.18 type 'a future
199.19 val task_of: 'a future -> task
199.20 @@ -40,12 +39,11 @@
199.21 val fork: (unit -> 'a) -> 'a future
199.22 val fork_group: group -> (unit -> 'a) -> 'a future
199.23 val fork_deps: 'b future list -> (unit -> 'a) -> 'a future
199.24 - val fork_background: (unit -> 'a) -> 'a future
199.25 + val fork_pri: int -> (unit -> 'a) -> 'a future
199.26 val join_results: 'a future list -> 'a Exn.result list
199.27 val join_result: 'a future -> 'a Exn.result
199.28 val join: 'a future -> 'a
199.29 val map: ('a -> 'b) -> 'a future -> 'b future
199.30 - val focus: task list -> unit
199.31 val interrupt_task: string -> unit
199.32 val cancel: 'a future -> unit
199.33 val shutdown: unit -> unit
199.34 @@ -57,14 +55,14 @@
199.35 (** future values **)
199.36
199.37 fun enabled () =
199.38 - ! future_scheduler andalso Multithreading.enabled () andalso
199.39 + Multithreading.enabled () andalso
199.40 not (Multithreading.self_critical ());
199.41
199.42
199.43 (* identifiers *)
199.44
199.45 -type task = TaskQueue.task;
199.46 -type group = TaskQueue.group;
199.47 +type task = Task_Queue.task;
199.48 +type group = Task_Queue.group;
199.49
199.50 local val tag = Universal.tag () : (string * task) option Universal.tag in
199.51 fun thread_data () = the_default NONE (Thread.getLocal tag);
199.52 @@ -86,8 +84,8 @@
199.53 fun is_finished x = is_some (peek x);
199.54
199.55 fun value x = Future
199.56 - {task = TaskQueue.new_task (),
199.57 - group = TaskQueue.new_group (),
199.58 + {task = Task_Queue.new_task 0,
199.59 + group = Task_Queue.new_group (),
199.60 result = ref (SOME (Exn.Result x))};
199.61
199.62
199.63 @@ -96,12 +94,12 @@
199.64
199.65 (* global state *)
199.66
199.67 -val queue = ref TaskQueue.empty;
199.68 +val queue = ref Task_Queue.empty;
199.69 val next = ref 0;
199.70 val workers = ref ([]: (Thread.thread * bool) list);
199.71 val scheduler = ref (NONE: Thread.thread option);
199.72 val excessive = ref 0;
199.73 -val canceled = ref ([]: TaskQueue.group list);
199.74 +val canceled = ref ([]: Task_Queue.group list);
199.75 val do_shutdown = ref false;
199.76
199.77
199.78 @@ -114,15 +112,11 @@
199.79
199.80 fun SYNCHRONIZED name = SimpleThread.synchronized name lock;
199.81
199.82 -fun wait name = (*requires SYNCHRONIZED*)
199.83 - (Multithreading.tracing 3 (fn () => name ^ ": wait ...");
199.84 +fun wait () = (*requires SYNCHRONIZED*)
199.85 ConditionVar.wait (cond, lock);
199.86 - Multithreading.tracing 3 (fn () => name ^ ": ... continue"));
199.87
199.88 -fun wait_timeout name timeout = (*requires SYNCHRONIZED*)
199.89 - (Multithreading.tracing 3 (fn () => name ^ ": wait ...");
199.90 +fun wait_timeout timeout = (*requires SYNCHRONIZED*)
199.91 ConditionVar.waitUntil (cond, lock, Time.+ (Time.now (), timeout));
199.92 - Multithreading.tracing 3 (fn () => name ^ ": ... continue"));
199.93
199.94 fun notify_all () = (*requires SYNCHRONIZED*)
199.95 ConditionVar.broadcast cond;
199.96 @@ -150,9 +144,9 @@
199.97 val _ = trace_active ();
199.98 val ok = setmp_thread_data (name, task) run ();
199.99 val _ = SYNCHRONIZED "execute" (fn () =>
199.100 - (change queue (TaskQueue.finish task);
199.101 + (change queue (Task_Queue.finish task);
199.102 if ok then ()
199.103 - else if TaskQueue.cancel (! queue) group then ()
199.104 + else if Task_Queue.cancel (! queue) group then ()
199.105 else change canceled (cons group);
199.106 notify_all ()));
199.107 in () end;
199.108 @@ -160,23 +154,23 @@
199.109
199.110 (* worker threads *)
199.111
199.112 -fun worker_wait name = (*requires SYNCHRONIZED*)
199.113 - (change_active false; wait name; change_active true);
199.114 +fun worker_wait () = (*requires SYNCHRONIZED*)
199.115 + (change_active false; wait (); change_active true);
199.116
199.117 -fun worker_next name = (*requires SYNCHRONIZED*)
199.118 +fun worker_next () = (*requires SYNCHRONIZED*)
199.119 if ! excessive > 0 then
199.120 (dec excessive;
199.121 change workers (filter_out (fn (thread, _) => Thread.equal (thread, Thread.self ())));
199.122 notify_all ();
199.123 NONE)
199.124 else
199.125 - (case change_result queue TaskQueue.dequeue of
199.126 - NONE => (worker_wait name; worker_next name)
199.127 + (case change_result queue Task_Queue.dequeue of
199.128 + NONE => (worker_wait (); worker_next ())
199.129 | some => some);
199.130
199.131 fun worker_loop name =
199.132 - (case SYNCHRONIZED name (fn () => worker_next name) of
199.133 - NONE => Multithreading.tracing 3 (fn () => name ^ ": exit")
199.134 + (case SYNCHRONIZED name worker_next of
199.135 + NONE => ()
199.136 | SOME work => (execute name work; worker_loop name));
199.137
199.138 fun worker_start name = (*requires SYNCHRONIZED*)
199.139 @@ -204,27 +198,25 @@
199.140 else ();
199.141
199.142 (*canceled groups*)
199.143 - val _ = change canceled (filter_out (TaskQueue.cancel (! queue)));
199.144 + val _ = change canceled (filter_out (Task_Queue.cancel (! queue)));
199.145
199.146 (*shutdown*)
199.147 val continue = not (! do_shutdown andalso null (! workers));
199.148 val _ = if continue then () else scheduler := NONE;
199.149
199.150 val _ = notify_all ();
199.151 - val _ = wait_timeout "scheduler" (Time.fromSeconds 3);
199.152 + val _ = wait_timeout (Time.fromSeconds 3);
199.153 in continue end;
199.154
199.155 fun scheduler_loop () =
199.156 - (while SYNCHRONIZED "scheduler" scheduler_next do ();
199.157 - Multithreading.tracing 3 (fn () => "scheduler: exit"));
199.158 + while SYNCHRONIZED "scheduler" scheduler_next do ();
199.159
199.160 fun scheduler_active () = (*requires SYNCHRONIZED*)
199.161 (case ! scheduler of NONE => false | SOME thread => Thread.isActive thread);
199.162
199.163 fun scheduler_check name = SYNCHRONIZED name (fn () =>
199.164 if not (scheduler_active ()) then
199.165 - (Multithreading.tracing 3 (fn () => "scheduler: fork");
199.166 - do_shutdown := false; scheduler := SOME (SimpleThread.fork false scheduler_loop))
199.167 + (do_shutdown := false; scheduler := SOME (SimpleThread.fork false scheduler_loop))
199.168 else if ! do_shutdown then error "Scheduler shutdown in progress"
199.169 else ());
199.170
199.171 @@ -235,7 +227,7 @@
199.172 let
199.173 val _ = scheduler_check "future check";
199.174
199.175 - val group = (case opt_group of SOME group => group | NONE => TaskQueue.new_group ());
199.176 + val group = (case opt_group of SOME group => group | NONE => Task_Queue.new_group ());
199.177
199.178 val result = ref (NONE: 'a Exn.result option);
199.179 val run = Multithreading.with_attributes (Thread.getAttributes ())
199.180 @@ -246,18 +238,18 @@
199.181 val res_ok =
199.182 (case res of
199.183 Exn.Result _ => true
199.184 - | Exn.Exn Exn.Interrupt => (TaskQueue.invalidate_group group; true)
199.185 + | Exn.Exn Exn.Interrupt => (Task_Queue.invalidate_group group; true)
199.186 | _ => false);
199.187 in res_ok end);
199.188
199.189 val task = SYNCHRONIZED "future" (fn () =>
199.190 - change_result queue (TaskQueue.enqueue group deps pri run) before notify_all ());
199.191 + change_result queue (Task_Queue.enqueue group deps pri run) before notify_all ());
199.192 in Future {task = task, group = group, result = result} end;
199.193
199.194 -fun fork e = future NONE [] true e;
199.195 -fun fork_group group e = future (SOME group) [] true e;
199.196 -fun fork_deps deps e = future NONE (map task_of deps) true e;
199.197 -fun fork_background e = future NONE [] false e;
199.198 +fun fork e = future NONE [] 0 e;
199.199 +fun fork_group group e = future (SOME group) [] 0 e;
199.200 +fun fork_deps deps e = future NONE (map task_of deps) 0 e;
199.201 +fun fork_pri pri e = future NONE [] pri e;
199.202
199.203
199.204 (* join: retrieve results *)
199.205 @@ -273,7 +265,7 @@
199.206 fun join_loop _ [] = ()
199.207 | join_loop name tasks =
199.208 (case SYNCHRONIZED name (fn () =>
199.209 - change_result queue (TaskQueue.dequeue_towards tasks)) of
199.210 + change_result queue (Task_Queue.dequeue_towards tasks)) of
199.211 NONE => ()
199.212 | SOME (work, tasks') => (execute name work; join_loop name tasks'));
199.213 val _ =
199.214 @@ -281,18 +273,18 @@
199.215 NONE =>
199.216 (*alien thread -- refrain from contending for resources*)
199.217 while exists (not o is_finished) xs
199.218 - do SYNCHRONIZED "join_thread" (fn () => wait "join_thread")
199.219 + do SYNCHRONIZED "join_thread" (fn () => wait ())
199.220 | SOME (name, task) =>
199.221 (*proper task -- actively work towards results*)
199.222 let
199.223 val unfinished = xs |> map_filter
199.224 (fn Future {task, result = ref NONE, ...} => SOME task | _ => NONE);
199.225 val _ = SYNCHRONIZED "join" (fn () =>
199.226 - (change queue (TaskQueue.depend unfinished task); notify_all ()));
199.227 + (change queue (Task_Queue.depend unfinished task); notify_all ()));
199.228 val _ = join_loop ("join_loop: " ^ name) unfinished;
199.229 val _ =
199.230 while exists (not o is_finished) xs
199.231 - do SYNCHRONIZED "join_task" (fn () => worker_wait "join_task");
199.232 + do SYNCHRONIZED "join_task" (fn () => worker_wait ());
199.233 in () end);
199.234
199.235 in xs |> map (fn Future {result = ref (SOME res), ...} => res) end) ();
199.236 @@ -300,18 +292,16 @@
199.237 fun join_result x = singleton join_results x;
199.238 fun join x = Exn.release (join_result x);
199.239
199.240 -fun map f x = fork_deps [x] (fn () => f (join x));
199.241 +fun map f x =
199.242 + let val task = task_of x
199.243 + in future NONE [task] (Task_Queue.pri_of_task task) (fn () => f (join x)) end;
199.244
199.245
199.246 (* misc operations *)
199.247
199.248 -(*focus: collection of high-priority task*)
199.249 -fun focus tasks = SYNCHRONIZED "focus" (fn () =>
199.250 - change queue (TaskQueue.focus tasks));
199.251 -
199.252 (*interrupt: permissive signal, may get ignored*)
199.253 fun interrupt_task id = SYNCHRONIZED "interrupt"
199.254 - (fn () => TaskQueue.interrupt_external (! queue) id);
199.255 + (fn () => Task_Queue.interrupt_external (! queue) id);
199.256
199.257 (*cancel: present and future group members will be interrupted eventually*)
199.258 fun cancel x =
199.259 @@ -324,12 +314,12 @@
199.260 if Multithreading.available then
199.261 (scheduler_check "shutdown check";
199.262 SYNCHRONIZED "shutdown" (fn () =>
199.263 - (while not (scheduler_active ()) do wait "shutdown: scheduler inactive";
199.264 - while not (TaskQueue.is_empty (! queue)) do wait "shutdown: join";
199.265 + (while not (scheduler_active ()) do wait ();
199.266 + while not (Task_Queue.is_empty (! queue)) do wait ();
199.267 do_shutdown := true;
199.268 notify_all ();
199.269 - while not (null (! workers)) do wait "shutdown: workers";
199.270 - while scheduler_active () do wait "shutdown: scheduler still active";
199.271 + while not (null (! workers)) do wait ();
199.272 + while scheduler_active () do wait ();
199.273 OS.Process.sleep (Time.fromMilliseconds 300))))
199.274 else ();
199.275
200.1 --- a/src/Pure/Concurrent/par_list.ML Tue Dec 30 08:18:54 2008 +0100
200.2 +++ b/src/Pure/Concurrent/par_list.ML Tue Dec 30 11:10:01 2008 +0100
200.3 @@ -30,7 +30,7 @@
200.4 fun raw_map f xs =
200.5 if Future.enabled () then
200.6 let
200.7 - val group = TaskQueue.new_group ();
200.8 + val group = Task_Queue.new_group ();
200.9 val futures = map (fn x => Future.fork_group group (fn () => f x)) xs;
200.10 val _ = List.app (ignore o Future.join_result) futures;
200.11 in Future.join_results futures end
201.1 --- a/src/Pure/Concurrent/schedule.ML Tue Dec 30 08:18:54 2008 +0100
201.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
201.3 @@ -1,85 +0,0 @@
201.4 -(* Title: Pure/Concurrent/schedule.ML
201.5 - ID: $Id$
201.6 - Author: Makarius
201.7 -
201.8 -Scheduling -- multiple threads working on a queue of tasks.
201.9 -*)
201.10 -
201.11 -signature SCHEDULE =
201.12 -sig
201.13 - datatype 'a task =
201.14 - Task of {body: unit -> unit, cont: 'a -> 'a, fail: 'a -> 'a} | Wait | Terminate;
201.15 - val schedule: int -> ('a -> 'a task * 'a) -> 'a -> exn list
201.16 -end;
201.17 -
201.18 -structure Schedule: SCHEDULE =
201.19 -struct
201.20 -
201.21 -datatype 'a task =
201.22 - Task of {body: unit -> unit, cont: 'a -> 'a, fail: 'a -> 'a} | Wait | Terminate;
201.23 -
201.24 -fun schedule n next_task = uninterruptible (fn restore_attributes => fn tasks =>
201.25 - let
201.26 - (*synchronized execution*)
201.27 - val lock = Mutex.mutex ();
201.28 - fun SYNCHRONIZED e =
201.29 - let
201.30 - val _ = Mutex.lock lock;
201.31 - val res = Exn.capture e ();
201.32 - val _ = Mutex.unlock lock;
201.33 - in Exn.release res end;
201.34 -
201.35 - (*wakeup condition*)
201.36 - val wakeup = ConditionVar.conditionVar ();
201.37 - fun wakeup_all () = ConditionVar.broadcast wakeup;
201.38 - fun wait () = ConditionVar.wait (wakeup, lock);
201.39 - fun wait_timeout () =
201.40 - ConditionVar.waitUntil (wakeup, lock, Time.+ (Time.now (), Time.fromSeconds 1));
201.41 -
201.42 - (*queue of tasks*)
201.43 - val queue = ref tasks;
201.44 - val active = ref 0;
201.45 - fun trace_active () = Multithreading.tracing 1 (fn () =>
201.46 - "SCHEDULE: " ^ string_of_int (! active) ^ " active");
201.47 - fun dequeue () =
201.48 - (case change_result queue next_task of
201.49 - Wait =>
201.50 - (dec active; trace_active ();
201.51 - wait ();
201.52 - inc active; trace_active ();
201.53 - dequeue ())
201.54 - | next => next);
201.55 -
201.56 - (*pool of running threads*)
201.57 - val status = ref ([]: exn list);
201.58 - val running = ref ([]: Thread.thread list);
201.59 - fun start f = (inc active; change running (cons (SimpleThread.fork false f)));
201.60 - fun stop () = (dec active; change running (remove Thread.equal (Thread.self ())));
201.61 -
201.62 - (*worker thread*)
201.63 - fun worker () =
201.64 - (case SYNCHRONIZED dequeue of
201.65 - Task {body, cont, fail} =>
201.66 - (case Exn.capture (restore_attributes body) () of
201.67 - Exn.Result () =>
201.68 - (SYNCHRONIZED (fn () => (change queue cont; wakeup_all ())); worker ())
201.69 - | Exn.Exn exn =>
201.70 - SYNCHRONIZED (fn () =>
201.71 - (change status (cons exn); change queue fail; stop (); wakeup_all ())))
201.72 - | Terminate => SYNCHRONIZED (fn () => (stop (); wakeup_all ())));
201.73 -
201.74 - (*main control: fork and wait*)
201.75 - fun fork 0 = ()
201.76 - | fork k = (start worker; fork (k - 1));
201.77 - val _ = SYNCHRONIZED (fn () =>
201.78 - (fork (Int.max (n, 1));
201.79 - while not (null (! running)) do
201.80 - (trace_active ();
201.81 - if not (null (! status))
201.82 - then (List.app SimpleThread.interrupt (! running))
201.83 - else ();
201.84 - wait_timeout ())));
201.85 -
201.86 - in ! status end);
201.87 -
201.88 -end;
202.1 --- a/src/Pure/Concurrent/task_queue.ML Tue Dec 30 08:18:54 2008 +0100
202.2 +++ b/src/Pure/Concurrent/task_queue.ML Tue Dec 30 11:10:01 2008 +0100
202.3 @@ -1,5 +1,4 @@
202.4 (* Title: Pure/Concurrent/task_queue.ML
202.5 - ID: $Id$
202.6 Author: Makarius
202.7
202.8 Ordered queue of grouped tasks.
202.9 @@ -8,7 +7,8 @@
202.10 signature TASK_QUEUE =
202.11 sig
202.12 eqtype task
202.13 - val new_task: unit -> task
202.14 + val new_task: int -> task
202.15 + val pri_of_task: task -> int
202.16 val str_of_task: task -> string
202.17 eqtype group
202.18 val new_group: unit -> group
202.19 @@ -17,9 +17,8 @@
202.20 type queue
202.21 val empty: queue
202.22 val is_empty: queue -> bool
202.23 - val enqueue: group -> task list -> bool -> (bool -> bool) -> queue -> task * queue
202.24 + val enqueue: group -> task list -> int -> (bool -> bool) -> queue -> task * queue
202.25 val depend: task list -> task -> queue -> queue
202.26 - val focus: task list -> queue -> queue
202.27 val dequeue: queue -> (task * group * (unit -> bool)) option * queue
202.28 val dequeue_towards: task list -> queue ->
202.29 (((task * group * (unit -> bool)) * task list) option * queue)
202.30 @@ -29,20 +28,27 @@
202.31 val cancel: queue -> group -> bool
202.32 end;
202.33
202.34 -structure TaskQueue: TASK_QUEUE =
202.35 +structure Task_Queue: TASK_QUEUE =
202.36 struct
202.37
202.38 -(* identifiers *)
202.39 +(* tasks *)
202.40
202.41 -datatype task = Task of serial;
202.42 -fun new_task () = Task (serial ());
202.43 +datatype task = Task of int * serial;
202.44 +fun new_task pri = Task (pri, serial ());
202.45
202.46 -fun str_of_task (Task i) = string_of_int i;
202.47 +fun pri_of_task (Task (pri, _)) = pri;
202.48 +fun str_of_task (Task (_, i)) = string_of_int i;
202.49
202.50 +fun task_ord (Task t1, Task t2) = prod_ord (rev_order o int_ord) int_ord (t1, t2);
202.51 +structure Task_Graph = GraphFun(type key = task val ord = task_ord);
202.52 +
202.53 +
202.54 +(* groups *)
202.55
202.56 datatype group = Group of serial * bool ref;
202.57
202.58 fun new_group () = Group (serial (), ref true);
202.59 +
202.60 fun invalidate_group (Group (_, ok)) = ok := false;
202.61
202.62 fun str_of_group (Group (i, ref ok)) =
202.63 @@ -52,50 +58,46 @@
202.64 (* jobs *)
202.65
202.66 datatype job =
202.67 - Job of bool * (bool -> bool) | (*priority, job: status -> status*)
202.68 + Job of bool -> bool |
202.69 Running of Thread.thread;
202.70
202.71 -type jobs = (group * job) IntGraph.T;
202.72 +type jobs = (group * job) Task_Graph.T;
202.73
202.74 -fun get_group (jobs: jobs) (Task id) = #1 (IntGraph.get_node jobs id);
202.75 -fun get_job (jobs: jobs) (Task id) = #2 (IntGraph.get_node jobs id);
202.76 -fun map_job (Task id) f (jobs: jobs) = IntGraph.map_node id (apsnd f) jobs;
202.77 +fun get_group (jobs: jobs) task = #1 (Task_Graph.get_node jobs task);
202.78 +fun get_job (jobs: jobs) task = #2 (Task_Graph.get_node jobs task);
202.79 +fun map_job task f (jobs: jobs) = Task_Graph.map_node task (apsnd f) jobs;
202.80
202.81 -fun add_job (Task id) (Task dep) (jobs: jobs) =
202.82 - IntGraph.add_edge_acyclic (dep, id) jobs handle IntGraph.UNDEF _ => jobs;
202.83 +fun add_job task dep (jobs: jobs) =
202.84 + Task_Graph.add_edge (dep, task) jobs handle Task_Graph.UNDEF _ => jobs;
202.85
202.86 -fun check_job (jobs: jobs) (task as Task id) =
202.87 - if can (IntGraph.get_node jobs) id then SOME task else NONE;
202.88 +fun add_job_acyclic task dep (jobs: jobs) =
202.89 + Task_Graph.add_edge_acyclic (dep, task) jobs handle Task_Graph.UNDEF _ => jobs;
202.90
202.91
202.92 (* queue of grouped jobs *)
202.93
202.94 datatype queue = Queue of
202.95 {groups: task list Inttab.table, (*groups with presently active members*)
202.96 - jobs: jobs, (*job dependency graph*)
202.97 - focus: task list}; (*particular collection of high-priority tasks*)
202.98 + jobs: jobs}; (*job dependency graph*)
202.99
202.100 -fun make_queue groups jobs focus = Queue {groups = groups, jobs = jobs, focus = focus};
202.101 +fun make_queue groups jobs = Queue {groups = groups, jobs = jobs};
202.102
202.103 -val empty = make_queue Inttab.empty IntGraph.empty [];
202.104 -fun is_empty (Queue {jobs, ...}) = IntGraph.is_empty jobs;
202.105 +val empty = make_queue Inttab.empty Task_Graph.empty;
202.106 +fun is_empty (Queue {jobs, ...}) = Task_Graph.is_empty jobs;
202.107
202.108
202.109 (* enqueue *)
202.110
202.111 -fun enqueue (group as Group (gid, _)) deps pri job (Queue {groups, jobs, focus}) =
202.112 +fun enqueue (group as Group (gid, _)) deps pri job (Queue {groups, jobs}) =
202.113 let
202.114 - val task as Task id = new_task ();
202.115 + val task = new_task pri;
202.116 val groups' = Inttab.cons_list (gid, task) groups;
202.117 val jobs' = jobs
202.118 - |> IntGraph.new_node (id, (group, Job (pri, job))) |> fold (add_job task) deps;
202.119 - in (task, make_queue groups' jobs' focus) end;
202.120 + |> Task_Graph.new_node (task, (group, Job job)) |> fold (add_job task) deps;
202.121 + in (task, make_queue groups' jobs') end;
202.122
202.123 -fun depend deps task (Queue {groups, jobs, focus}) =
202.124 - make_queue groups (fold (add_job task) deps jobs) focus;
202.125 -
202.126 -fun focus tasks (Queue {groups, jobs, ...}) =
202.127 - make_queue groups jobs (map_filter (check_job jobs) tasks);
202.128 +fun depend deps task (Queue {groups, jobs}) =
202.129 + make_queue groups (fold (add_job_acyclic task) deps jobs);
202.130
202.131
202.132 (* dequeue *)
202.133 @@ -103,38 +105,30 @@
202.134 local
202.135
202.136 fun dequeue_result NONE queue = (NONE, queue)
202.137 - | dequeue_result (SOME (result as (task, _, _))) (Queue {groups, jobs, focus}) =
202.138 - (SOME result, make_queue groups (map_job task (K (Running (Thread.self ()))) jobs) focus);
202.139 -
202.140 -fun dequeue_global req_pri (queue as Queue {jobs, ...}) =
202.141 - let
202.142 - fun ready (id, ((group as Group (_, ref ok), Job (pri, job)), ([], _))) =
202.143 - if pri = req_pri then SOME (Task id, group, (fn () => job ok)) else NONE
202.144 - | ready _ = NONE;
202.145 - in dequeue_result (IntGraph.get_first ready jobs) queue end;
202.146 -
202.147 -fun dequeue_local focus (queue as Queue {jobs, ...}) =
202.148 - let
202.149 - fun ready id =
202.150 - (case IntGraph.get_node jobs id of
202.151 - (group as Group (_, ref ok), Job (_, job)) =>
202.152 - if null (IntGraph.imm_preds jobs id) then SOME (Task id, group, (fn () => job ok))
202.153 - else NONE
202.154 - | _ => NONE);
202.155 - val ids = map (fn Task id => id) focus;
202.156 - in dequeue_result (get_first ready (IntGraph.all_preds jobs ids)) queue end;
202.157 + | dequeue_result (SOME (result as (task, _, _))) (Queue {groups, jobs}) =
202.158 + (SOME result, make_queue groups (map_job task (K (Running (Thread.self ()))) jobs));
202.159
202.160 in
202.161
202.162 -fun dequeue (queue as Queue {focus, ...}) =
202.163 - (case dequeue_local focus queue of
202.164 - (NONE, _) =>
202.165 - (case dequeue_global true queue of (NONE, _) => dequeue_global false queue | res => res)
202.166 - | res => res);
202.167 +fun dequeue (queue as Queue {jobs, ...}) =
202.168 + let
202.169 + fun ready (task, ((group as Group (_, ref ok), Job job), ([], _))) =
202.170 + SOME (task, group, (fn () => job ok))
202.171 + | ready _ = NONE;
202.172 + in dequeue_result (Task_Graph.get_first ready jobs) queue end;
202.173
202.174 fun dequeue_towards tasks (queue as Queue {jobs, ...}) =
202.175 - let val tasks' = map_filter (check_job jobs) tasks in
202.176 - (case dequeue_local tasks' queue of
202.177 + let
202.178 + val tasks' = filter (can (Task_Graph.get_node jobs)) tasks;
202.179 +
202.180 + fun ready task =
202.181 + (case Task_Graph.get_node jobs task of
202.182 + (group as Group (_, ref ok), Job job) =>
202.183 + if null (Task_Graph.imm_preds jobs task) then SOME (task, group, (fn () => job ok))
202.184 + else NONE
202.185 + | _ => NONE);
202.186 + in
202.187 + (case dequeue_result (get_first ready (Task_Graph.all_preds jobs tasks')) queue of
202.188 (NONE, queue') => (NONE, queue')
202.189 | (SOME work, queue') => (SOME (work, tasks'), queue'))
202.190 end;
202.191 @@ -147,8 +141,13 @@
202.192 fun interrupt (Queue {jobs, ...}) task =
202.193 (case try (get_job jobs) task of SOME (Running thread) => SimpleThread.interrupt thread | _ => ());
202.194
202.195 -fun interrupt_external queue str =
202.196 - (case Int.fromString str of SOME id => interrupt queue (Task id) | NONE => ());
202.197 +fun interrupt_external (queue as Queue {jobs, ...}) str =
202.198 + (case Int.fromString str of
202.199 + SOME i =>
202.200 + (case Task_Graph.get_first
202.201 + (fn (task as Task (_, j), _) => if i = j then SOME task else NONE) jobs
202.202 + of SOME task => interrupt queue task | NONE => ())
202.203 + | NONE => ());
202.204
202.205
202.206 (* misc operations *)
202.207 @@ -161,12 +160,11 @@
202.208 val _ = List.app SimpleThread.interrupt running;
202.209 in null running end;
202.210
202.211 -fun finish (task as Task id) (Queue {groups, jobs, focus}) =
202.212 +fun finish task (Queue {groups, jobs}) =
202.213 let
202.214 val Group (gid, _) = get_group jobs task;
202.215 val groups' = Inttab.remove_list (op =) (gid, task) groups;
202.216 - val jobs' = IntGraph.del_node id jobs;
202.217 - val focus' = remove (op =) task focus;
202.218 - in make_queue groups' jobs' focus' end;
202.219 + val jobs' = Task_Graph.del_node task jobs;
202.220 + in make_queue groups' jobs' end;
202.221
202.222 end;
203.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
203.2 +++ b/src/Pure/General/event_bus.scala Tue Dec 30 11:10:01 2008 +0100
203.3 @@ -0,0 +1,38 @@
203.4 +/* Title: Pure/General/event_bus.scala
203.5 + Author: Makarius
203.6 +
203.7 +Generic event bus with multiple handlers and optional exception
203.8 +logging.
203.9 +*/
203.10 +
203.11 +package isabelle
203.12 +
203.13 +import scala.collection.mutable.ListBuffer
203.14 +
203.15 +
203.16 +class EventBus[Event]
203.17 +{
203.18 + /* event handlers */
203.19 +
203.20 + type Handler = Event => Unit
203.21 + private val handlers = new ListBuffer[Handler]
203.22 +
203.23 + def += (h: Handler) = synchronized { handlers += h }
203.24 + def + (h: Handler) = { this += h; this }
203.25 +
203.26 + def -= (h: Handler) = synchronized { handlers -= h }
203.27 + def - (h: Handler) = { this -= h; this }
203.28 +
203.29 +
203.30 + /* event invocation */
203.31 +
203.32 + var logger: Throwable => Unit = throw _
203.33 +
203.34 + def event(x: Event) = {
203.35 + val log = logger
203.36 + for (h <- synchronized { handlers.toList }) {
203.37 + try { h(x) }
203.38 + catch { case e: Throwable => log(e) }
203.39 + }
203.40 + }
203.41 +}
204.1 --- a/src/Pure/General/markup.scala Tue Dec 30 08:18:54 2008 +0100
204.2 +++ b/src/Pure/General/markup.scala Tue Dec 30 11:10:01 2008 +0100
204.3 @@ -1,5 +1,4 @@
204.4 /* Title: Pure/General/markup.scala
204.5 - ID: $Id$
204.6 Author: Makarius
204.7
204.8 Common markup elements.
204.9 @@ -9,6 +8,12 @@
204.10
204.11 object Markup {
204.12
204.13 + /* name */
204.14 +
204.15 + val NAME = "name"
204.16 + val KIND = "kind"
204.17 +
204.18 +
204.19 /* position */
204.20
204.21 val LINE = "line"
204.22 @@ -20,12 +25,105 @@
204.23 val FILE = "file"
204.24 val ID = "id"
204.25
204.26 + val POSITION_PROPERTIES = Set(LINE, COLUMN, OFFSET, END_LINE, END_COLUMN, END_OFFSET, FILE, ID)
204.27 +
204.28 + val POSITION = "position"
204.29 + val LOCATION = "location"
204.30 +
204.31 +
204.32 + /* logical entities */
204.33 +
204.34 + val TCLASS = "tclass"
204.35 + val TYCON = "tycon"
204.36 + val FIXED_DECL = "fixed_decl"
204.37 + val FIXED = "fixed"
204.38 + val CONST_DECL = "const_decl"
204.39 + val CONST = "const"
204.40 + val FACT_DECL = "fact_decl"
204.41 + val FACT = "fact"
204.42 + val DYNAMIC_FACT = "dynamic_fact"
204.43 + val LOCAL_FACT_DECL = "local_fact_decl"
204.44 + val LOCAL_FACT = "local_fact"
204.45 +
204.46 +
204.47 + /* inner syntax */
204.48 +
204.49 + val TFREE = "tfree"
204.50 + val TVAR = "tvar"
204.51 + val FREE = "free"
204.52 + val SKOLEM = "skolem"
204.53 + val BOUND = "bound"
204.54 + val VAR = "var"
204.55 + val NUM = "num"
204.56 + val FLOAT = "float"
204.57 + val XNUM = "xnum"
204.58 + val XSTR = "xstr"
204.59 + val LITERAL = "literal"
204.60 + val INNER_COMMENT = "inner_comment"
204.61 +
204.62 + val SORT = "sort"
204.63 + val TYP = "typ"
204.64 + val TERM = "term"
204.65 + val PROP = "prop"
204.66 +
204.67 + val ATTRIBUTE = "attribute"
204.68 + val METHOD = "method"
204.69 +
204.70 +
204.71 + /* embedded source text */
204.72 +
204.73 + val ML_SOURCE = "ML_source"
204.74 + val DOC_SOURCE = "doc_source"
204.75 +
204.76 + val ANTIQ = "antiq"
204.77 + val ML_ANTIQ = "ML_antiq"
204.78 + val DOC_ANTIQ = "doc_antiq"
204.79 +
204.80 +
204.81 + /* outer syntax */
204.82 +
204.83 + val KEYWORD_DECL = "keyword_decl"
204.84 + val COMMAND_DECL = "command_decl"
204.85 +
204.86 + val KEYWORD = "keyword"
204.87 + val COMMAND = "command"
204.88 + val IDENT = "ident"
204.89 + val STRING = "string"
204.90 + val ALTSTRING = "altstring"
204.91 + val VERBATIM = "verbatim"
204.92 + val COMMENT = "comment"
204.93 + val CONTROL = "control"
204.94 + val MALFORMED = "malformed"
204.95 +
204.96 + val COMMAND_SPAN = "command_span"
204.97 + val IGNORED_SPAN = "ignored_span"
204.98 + val MALFORMED_SPAN = "malformed_span"
204.99 +
204.100 +
204.101 + /* toplevel */
204.102 +
204.103 + val STATE = "state"
204.104 + val SUBGOAL = "subgoal"
204.105 + val SENDBACK = "sendback"
204.106 + val HILITE = "hilite"
204.107 +
204.108 +
204.109 + /* command status */
204.110 +
204.111 + val UNPROCESSED = "unprocessed"
204.112 + val RUNNING = "running"
204.113 + val FAILED = "failed"
204.114 + val FINISHED = "finished"
204.115 + val DISPOSED = "disposed"
204.116 +
204.117
204.118 /* messages */
204.119
204.120 val PID = "pid"
204.121 val SESSION = "session"
204.122
204.123 + val MESSAGE = "message"
204.124 +
204.125
204.126 /* content */
204.127
205.1 --- a/src/Pure/General/position.scala Tue Dec 30 08:18:54 2008 +0100
205.2 +++ b/src/Pure/General/position.scala Tue Dec 30 11:10:01 2008 +0100
205.3 @@ -1,5 +1,4 @@
205.4 /* Title: Pure/General/position.scala
205.5 - ID: $Id$
205.6 Author: Makarius
205.7
205.8 Position properties.
206.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
206.2 +++ b/src/Pure/General/swing.scala Tue Dec 30 11:10:01 2008 +0100
206.3 @@ -0,0 +1,18 @@
206.4 +/* Title: Pure/General/swing.scala
206.5 + Author: Makarius
206.6 +
206.7 +Swing utilities.
206.8 +*/
206.9 +
206.10 +package isabelle
206.11 +
206.12 +import javax.swing.SwingUtilities
206.13 +
206.14 +object Swing
206.15 +{
206.16 + def now(body: => Unit) =
206.17 + SwingUtilities.invokeAndWait(new Runnable { def run = body })
206.18 +
206.19 + def later(body: => Unit) =
206.20 + SwingUtilities.invokeLater(new Runnable { def run = body })
206.21 +}
207.1 --- a/src/Pure/General/symbol.scala Tue Dec 30 08:18:54 2008 +0100
207.2 +++ b/src/Pure/General/symbol.scala Tue Dec 30 11:10:01 2008 +0100
207.3 @@ -1,5 +1,4 @@
207.4 /* Title: Pure/General/symbol.scala
207.5 - ID: $Id$
207.6 Author: Makarius
207.7
207.8 Detecting and recoding Isabelle symbols.
207.9 @@ -79,7 +78,7 @@
207.10
207.11 /** Symbol interpretation **/
207.12
207.13 - class Interpretation {
207.14 + class Interpretation(isabelle_system: IsabelleSystem) {
207.15
207.16 private var symbols = new HashMap[String, HashMap[String, String]]
207.17 private var decoder: Recoder = null
207.18 @@ -126,7 +125,7 @@
207.19 }
207.20
207.21 private def read_symbols(path: String) = {
207.22 - val file = new File(IsabelleSystem.platform_path(path))
207.23 + val file = new File(isabelle_system.platform_path(path))
207.24 if (file.canRead) {
207.25 for (line <- Source.fromFile(file).getLines) read_line(line)
207.26 }
208.1 --- a/src/Pure/General/xml.scala Tue Dec 30 08:18:54 2008 +0100
208.2 +++ b/src/Pure/General/xml.scala Tue Dec 30 11:10:01 2008 +0100
208.3 @@ -1,5 +1,4 @@
208.4 /* Title: Pure/General/xml.scala
208.5 - ID: $Id$
208.6 Author: Makarius
208.7
208.8 Simple XML tree values.
208.9 @@ -11,16 +10,56 @@
208.10 import javax.xml.parsers.DocumentBuilderFactory
208.11
208.12
208.13 -object XML {
208.14 +object XML
208.15 +{
208.16 /* datatype representation */
208.17
208.18 type Attributes = List[(String, String)]
208.19
208.20 - abstract class Tree
208.21 + abstract class Tree {
208.22 + override def toString = {
208.23 + val s = new StringBuilder
208.24 + append_tree(this, s)
208.25 + s.toString
208.26 + }
208.27 + }
208.28 case class Elem(name: String, attributes: Attributes, body: List[Tree]) extends Tree
208.29 case class Text(content: String) extends Tree
208.30
208.31
208.32 + /* string representation */
208.33 +
208.34 + private def append_text(text: String, s: StringBuilder) {
208.35 + for (c <- text.elements) c match {
208.36 + case '<' => s.append("<")
208.37 + case '>' => s.append(">")
208.38 + case '&' => s.append("&")
208.39 + case '"' => s.append(""")
208.40 + case '\'' => s.append("'")
208.41 + case _ => s.append(c)
208.42 + }
208.43 + }
208.44 +
208.45 + private def append_elem(name: String, atts: Attributes, s: StringBuilder) {
208.46 + s.append(name)
208.47 + for ((a, x) <- atts) {
208.48 + s.append(" "); s.append(a); s.append("=\""); append_text(x, s); s.append("\"")
208.49 + }
208.50 + }
208.51 +
208.52 + private def append_tree(tree: Tree, s: StringBuilder) {
208.53 + tree match {
208.54 + case Elem(name, atts, Nil) =>
208.55 + s.append("<"); append_elem(name, atts, s); s.append("/>")
208.56 + case Elem(name, atts, ts) =>
208.57 + s.append("<"); append_elem(name, atts, s); s.append(">")
208.58 + for (t <- ts) append_tree(t, s)
208.59 + s.append("</"); s.append(name); s.append(">")
208.60 + case Text(text) => append_text(text, s)
208.61 + }
208.62 + }
208.63 +
208.64 +
208.65 /* iterate over content */
208.66
208.67 private type State = Option[(String, List[Tree])]
209.1 --- a/src/Pure/General/yxml.scala Tue Dec 30 08:18:54 2008 +0100
209.2 +++ b/src/Pure/General/yxml.scala Tue Dec 30 11:10:01 2008 +0100
209.3 @@ -1,5 +1,4 @@
209.4 /* Title: Pure/General/yxml.scala
209.5 - ID: $Id$
209.6 Author: Makarius
209.7
209.8 Efficient text representation of XML trees.
209.9 @@ -70,7 +69,7 @@
209.10
209.11 var stack: List[((String, XML.Attributes), List[XML.Tree])] = null
209.12
209.13 - def add(x: XML.Tree) = stack match {
209.14 + def add(x: XML.Tree) = (stack: @unchecked) match {
209.15 case ((elem, body) :: pending) => stack = (elem, x :: body) :: pending
209.16 }
209.17
209.18 @@ -78,7 +77,7 @@
209.19 if (name == "") err_element()
209.20 else stack = ((name, atts), Nil) :: stack
209.21
209.22 - def pop() = stack match {
209.23 + def pop() = (stack: @unchecked) match {
209.24 case ((("", _), _) :: _) => err_unbalanced("")
209.25 case (((name, atts), body) :: pending) =>
209.26 stack = pending; add(XML.Elem(name, atts, body.reverse))
210.1 --- a/src/Pure/IsaMakefile Tue Dec 30 08:18:54 2008 +0100
210.2 +++ b/src/Pure/IsaMakefile Tue Dec 30 11:10:01 2008 +0100
210.3 @@ -23,27 +23,24 @@
210.4
210.5 $(OUT)/Pure: Concurrent/ROOT.ML Concurrent/future.ML \
210.6 Concurrent/mailbox.ML Concurrent/par_list.ML \
210.7 - Concurrent/par_list_dummy.ML Concurrent/schedule.ML \
210.8 - Concurrent/simple_thread.ML Concurrent/synchronized.ML \
210.9 - Concurrent/task_queue.ML General/ROOT.ML General/alist.ML \
210.10 - General/balanced_tree.ML General/basics.ML General/binding.ML \
210.11 - General/buffer.ML \
210.12 - General/file.ML General/graph.ML General/heap.ML General/integer.ML \
210.13 - General/lazy.ML General/markup.ML General/name_space.ML \
210.14 - General/ord_list.ML General/output.ML General/path.ML \
210.15 - General/position.ML General/pretty.ML General/print_mode.ML \
210.16 - General/properties.ML General/queue.ML General/scan.ML \
210.17 - General/secure.ML General/seq.ML General/source.ML General/stack.ML \
210.18 - General/symbol.ML General/symbol_pos.ML General/table.ML \
210.19 - General/url.ML General/xml.ML General/yxml.ML Isar/ROOT.ML \
210.20 - Isar/antiquote.ML Isar/args.ML Isar/attrib.ML Isar/auto_bind.ML \
210.21 - Isar/calculation.ML Isar/class.ML Isar/code.ML Isar/code_unit.ML \
210.22 - Isar/constdefs.ML Isar/context_rules.ML Isar/element.ML \
210.23 - Isar/expression.ML \
210.24 - Isar/find_theorems.ML Isar/instance.ML Isar/isar.ML Isar/isar_cmd.ML \
210.25 - Isar/isar_syn.ML Isar/local_defs.ML Isar/local_syntax.ML \
210.26 - Isar/local_theory.ML Isar/locale.ML Isar/method.ML Isar/net_rules.ML \
210.27 - Isar/new_locale.ML \
210.28 + Concurrent/par_list_dummy.ML Concurrent/simple_thread.ML \
210.29 + Concurrent/synchronized.ML Concurrent/task_queue.ML General/ROOT.ML \
210.30 + General/alist.ML General/balanced_tree.ML General/basics.ML \
210.31 + General/buffer.ML General/file.ML General/graph.ML General/heap.ML \
210.32 + General/integer.ML General/lazy.ML General/markup.ML \
210.33 + General/name_space.ML General/ord_list.ML General/output.ML \
210.34 + General/path.ML General/position.ML General/pretty.ML \
210.35 + General/print_mode.ML General/properties.ML General/queue.ML \
210.36 + General/scan.ML General/secure.ML General/seq.ML General/source.ML \
210.37 + General/stack.ML General/symbol.ML General/symbol_pos.ML \
210.38 + General/table.ML General/url.ML General/xml.ML General/yxml.ML \
210.39 + Isar/ROOT.ML Isar/antiquote.ML Isar/args.ML Isar/attrib.ML \
210.40 + Isar/auto_bind.ML Isar/calculation.ML Isar/class.ML Isar/code.ML \
210.41 + Isar/code_unit.ML Isar/constdefs.ML Isar/context_rules.ML \
210.42 + Isar/element.ML Isar/expression.ML Isar/find_theorems.ML \
210.43 + Isar/instance.ML Isar/isar.ML Isar/isar_cmd.ML Isar/isar_syn.ML \
210.44 + Isar/local_defs.ML Isar/local_syntax.ML Isar/local_theory.ML \
210.45 + Isar/locale.ML Isar/method.ML Isar/net_rules.ML Isar/new_locale.ML \
210.46 Isar/object_logic.ML Isar/obtain.ML Isar/outer_keyword.ML \
210.47 Isar/outer_lex.ML Isar/outer_parse.ML Isar/outer_syntax.ML \
210.48 Isar/overloading.ML Isar/proof.ML Isar/proof_context.ML \
210.49 @@ -77,17 +74,16 @@
210.50 Syntax/syn_trans.ML Syntax/syntax.ML Syntax/type_ext.ML Thy/html.ML \
210.51 Thy/latex.ML Thy/present.ML Thy/term_style.ML Thy/thm_deps.ML \
210.52 Thy/thy_edit.ML Thy/thy_header.ML Thy/thy_info.ML Thy/thy_load.ML \
210.53 - Thy/thy_output.ML Tools/ROOT.ML Tools/invoke.ML \
210.54 - Tools/isabelle_process.ML Tools/named_thms.ML \
210.55 - Tools/xml_syntax.ML assumption.ML axclass.ML codegen.ML config.ML \
210.56 - conjunction.ML consts.ML context.ML context_position.ML conv.ML \
210.57 - defs.ML display.ML drule.ML envir.ML facts.ML goal.ML \
210.58 - interpretation.ML library.ML logic.ML meta_simplifier.ML more_thm.ML \
210.59 - morphism.ML name.ML net.ML old_goals.ML pattern.ML primitive_defs.ML \
210.60 - proofterm.ML pure_setup.ML pure_thy.ML search.ML sign.ML \
210.61 - simplifier.ML sorts.ML subgoal.ML tactic.ML tctical.ML term.ML \
210.62 - term_subst.ML theory.ML thm.ML type.ML type_infer.ML unify.ML \
210.63 - variable.ML ../Tools/value.ML ../Tools/quickcheck.ML
210.64 + Thy/thy_output.ML Tools/ROOT.ML Tools/invoke.ML \
210.65 + Tools/isabelle_process.ML Tools/named_thms.ML Tools/xml_syntax.ML \
210.66 + assumption.ML axclass.ML codegen.ML config.ML conjunction.ML \
210.67 + consts.ML context.ML context_position.ML conv.ML defs.ML display.ML \
210.68 + drule.ML envir.ML facts.ML goal.ML interpretation.ML library.ML \
210.69 + logic.ML meta_simplifier.ML more_thm.ML morphism.ML name.ML net.ML \
210.70 + old_goals.ML pattern.ML primitive_defs.ML proofterm.ML pure_setup.ML \
210.71 + pure_thy.ML search.ML sign.ML simplifier.ML sorts.ML subgoal.ML \
210.72 + tactic.ML tctical.ML term.ML term_subst.ML theory.ML thm.ML type.ML \
210.73 + type_infer.ML unify.ML variable.ML ../Tools/quickcheck.ML
210.74 @./mk
210.75
210.76
210.77 @@ -125,9 +121,10 @@
210.78
210.79 ## Scala material
210.80
210.81 -SCALA_FILES = General/markup.scala General/position.scala \
210.82 - General/symbol.scala General/xml.scala General/yxml.scala \
210.83 - Isar/isar.scala Thy/thy_header.scala Tools/isabelle_process.scala \
210.84 +SCALA_FILES = General/event_bus.scala General/markup.scala \
210.85 + General/position.scala General/swing.scala General/symbol.scala \
210.86 + General/xml.scala General/yxml.scala Isar/isar.scala \
210.87 + Thy/thy_header.scala Tools/isabelle_process.scala \
210.88 Tools/isabelle_syntax.scala Tools/isabelle_system.scala
210.89
210.90
211.1 --- a/src/Pure/Isar/class.ML Tue Dec 30 08:18:54 2008 +0100
211.2 +++ b/src/Pure/Isar/class.ML Tue Dec 30 11:10:01 2008 +0100
211.3 @@ -60,6 +60,59 @@
211.4 structure Class : CLASS =
211.5 struct
211.6
211.7 +(*temporary adaption code to mediate between old and new locale code*)
211.8 +
211.9 +structure Old_Locale =
211.10 +struct
211.11 +
211.12 +val intro_locales_tac = Locale.intro_locales_tac; (*already forked!*)
211.13 +
211.14 +val interpretation = Locale.interpretation;
211.15 +val interpretation_in_locale = Locale.interpretation_in_locale;
211.16 +val get_interpret_morph = Locale.get_interpret_morph;
211.17 +val Locale = Locale.Locale;
211.18 +val extern = Locale.extern;
211.19 +val intros = Locale.intros;
211.20 +val dests = Locale.dests;
211.21 +val init = Locale.init;
211.22 +val Merge = Locale.Merge;
211.23 +val parameters_of_expr = Locale.parameters_of_expr;
211.24 +val empty = Locale.empty;
211.25 +val cert_expr = Locale.cert_expr;
211.26 +val read_expr = Locale.read_expr;
211.27 +val parameters_of = Locale.parameters_of;
211.28 +val add_locale = Locale.add_locale;
211.29 +
211.30 +end;
211.31 +
211.32 +structure New_Locale =
211.33 +struct
211.34 +
211.35 +val intro_locales_tac = Locale.intro_locales_tac; (*already forked!*)
211.36 +
211.37 +val interpretation = Locale.interpretation; (*!*)
211.38 +val interpretation_in_locale = Locale.interpretation_in_locale; (*!*)
211.39 +val get_interpret_morph = Locale.get_interpret_morph; (*!*)
211.40 +fun Locale loc = ([(loc, ("", Expression.Positional []))], []);
211.41 +val extern = NewLocale.extern;
211.42 +val intros = Locale.intros; (*!*)
211.43 +val dests = Locale.dests; (*!*)
211.44 +val init = NewLocale.init;
211.45 +fun Merge locs = (map (fn loc => (loc, ("", Expression.Positional []))) locs, []);
211.46 +val parameters_of_expr = Locale.parameters_of_expr; (*!*)
211.47 +val empty = ([], []);
211.48 +val cert_expr = Locale.cert_expr; (*!"*)
211.49 +val read_expr = Locale.read_expr; (*!"*)
211.50 +val parameters_of = NewLocale.params_of; (*why typ option?*)
211.51 +val add_locale = Expression.add_locale;
211.52 +
211.53 +end;
211.54 +
211.55 +structure Locale = Old_Locale;
211.56 +
211.57 +(*proper code again*)
211.58 +
211.59 +
211.60 (** auxiliary **)
211.61
211.62 fun prove_interpretation tac prfx_atts expr inst =
211.63 @@ -542,7 +595,7 @@
211.64 val suplocales = map Locale.Locale sups;
211.65 val supexpr = Locale.Merge suplocales;
211.66 val supparams = (map fst o Locale.parameters_of_expr thy) supexpr;
211.67 - val mergeexpr = Locale.Merge (suplocales);
211.68 + val mergeexpr = Locale.Merge suplocales;
211.69 val constrain = Element.Constrains ((map o apsnd o map_atyps)
211.70 (K (TFree (Name.aT, base_sort))) supparams);
211.71 fun fork_syn (Element.Fixes xs) =
212.1 --- a/src/Pure/Isar/isar.scala Tue Dec 30 08:18:54 2008 +0100
212.2 +++ b/src/Pure/Isar/isar.scala Tue Dec 30 11:10:01 2008 +0100
212.3 @@ -1,7 +1,5 @@
212.4 /* Title: Pure/Isar/isar.scala
212.5 - ID: $Id$
212.6 Author: Makarius
212.7 - Options: :folding=explicit:collapseFolds=1:
212.8
212.9 Isar toplevel editor model.
212.10 */
212.11 @@ -11,7 +9,9 @@
212.12 import java.util.Properties
212.13
212.14
212.15 -class Isar(args: String*) extends IsabelleProcess(args: _*) {
212.16 +class Isar(isabelle_system: IsabelleSystem, results: EventBus[IsabelleProcess.Result], args: String*)
212.17 + extends IsabelleProcess(isabelle_system, results, args: _*)
212.18 +{
212.19
212.20 /* basic editor commands */
212.21
213.1 --- a/src/Pure/Isar/local_theory.ML Tue Dec 30 08:18:54 2008 +0100
213.2 +++ b/src/Pure/Isar/local_theory.ML Tue Dec 30 11:10:01 2008 +0100
213.3 @@ -1,5 +1,4 @@
213.4 (* Title: Pure/Isar/local_theory.ML
213.5 - ID: $Id$
213.6 Author: Makarius
213.7
213.8 Local theory operations, with abstract target context.
214.1 --- a/src/Pure/Isar/proof.ML Tue Dec 30 08:18:54 2008 +0100
214.2 +++ b/src/Pure/Isar/proof.ML Tue Dec 30 11:10:01 2008 +0100
214.3 @@ -1,5 +1,4 @@
214.4 (* Title: Pure/Isar/proof.ML
214.5 - ID: $Id$
214.6 Author: Markus Wenzel, TU Muenchen
214.7
214.8 The Isar/VM proof language interpreter: maintains a structured flow of
214.9 @@ -826,7 +825,7 @@
214.10 |> null props ? (refine (Method.Basic (Method.assumption, Position.none)) #> Seq.hd)
214.11 end;
214.12
214.13 -fun generic_qed state =
214.14 +fun generic_qed after_ctxt state =
214.15 let
214.16 val (goal_ctxt, {statement, goal, after_qed, ...}) = current_goal state;
214.17 val outer_state = state |> close_block;
214.18 @@ -845,7 +844,7 @@
214.19 fun after_global' x y = Position.setmp_thread_data pos (fn () => after_global x y) ();
214.20 in
214.21 outer_state
214.22 - |> map_context (ProofContext.auto_bind_facts props)
214.23 + |> map_context (after_ctxt props)
214.24 |> pair ((after_local', after_global'), results)
214.25 end;
214.26
214.27 @@ -872,7 +871,8 @@
214.28
214.29 fun local_qed txt =
214.30 end_proof false txt #>
214.31 - Seq.maps (generic_qed #-> (fn ((after_qed, _), results) => after_qed results));
214.32 + Seq.maps (generic_qed ProofContext.auto_bind_facts #->
214.33 + (fn ((after_qed, _), results) => after_qed results));
214.34
214.35
214.36 (* global goals *)
214.37 @@ -892,7 +892,7 @@
214.38
214.39 fun global_qeds txt =
214.40 end_proof true txt
214.41 - #> Seq.map (generic_qed #> (fn (((_, after_qed), results), state) =>
214.42 + #> Seq.map (generic_qed (K I) #> (fn (((_, after_qed), results), state) =>
214.43 after_qed results (context_of state)))
214.44 |> Seq.DETERM; (*backtracking may destroy theory!*)
214.45
215.1 --- a/src/Pure/Isar/theory_target.ML Tue Dec 30 08:18:54 2008 +0100
215.2 +++ b/src/Pure/Isar/theory_target.ML Tue Dec 30 11:10:01 2008 +0100
215.3 @@ -1,6 +1,4 @@
215.4 (* Title: Pure/Isar/theory_target.ML
215.5 - ID: $Id$
215.6 - ID: $Id$
215.7 Author: Makarius
215.8
215.9 Common theory/locale/class/instantiation/overloading targets.
216.1 --- a/src/Pure/Isar/toplevel.ML Tue Dec 30 08:18:54 2008 +0100
216.2 +++ b/src/Pure/Isar/toplevel.ML Tue Dec 30 11:10:01 2008 +0100
216.3 @@ -718,7 +718,7 @@
216.4
216.5 val future_proof = Proof.future_proof
216.6 (fn prf =>
216.7 - Future.fork_background (fn () =>
216.8 + Future.fork_pri 1 (fn () =>
216.9 let val (states, State (result_node, _)) =
216.10 (case st' of State (SOME (Proof (_, (_, orig_gthy)), exit), prev)
216.11 => State (SOME (Proof (ProofNode.init prf, (finish, orig_gthy)), exit), prev))
217.1 --- a/src/Pure/ROOT.ML Tue Dec 30 08:18:54 2008 +0100
217.2 +++ b/src/Pure/ROOT.ML Tue Dec 30 11:10:01 2008 +0100
217.3 @@ -87,8 +87,6 @@
217.4
217.5 cd "Tools"; use "ROOT.ML"; cd "..";
217.6
217.7 -use "../Tools/value.ML";
217.8 -use "../Tools/quickcheck.ML";
217.9 use "codegen.ML";
217.10
217.11 (*configuration for Proof General*)
218.1 --- a/src/Pure/Syntax/lexicon.ML Tue Dec 30 08:18:54 2008 +0100
218.2 +++ b/src/Pure/Syntax/lexicon.ML Tue Dec 30 11:10:01 2008 +0100
218.3 @@ -145,8 +145,18 @@
218.4 val tidT = Type ("tid", []);
218.5 val tvarT = Type ("tvar", []);
218.6
218.7 -val terminals =
218.8 - ["id", "longid", "var", "tid", "tvar", "num", "float", "xnum", "xstr"];
218.9 +val terminal_kinds =
218.10 + [("id", IdentSy),
218.11 + ("longid", LongIdentSy),
218.12 + ("var", VarSy),
218.13 + ("tid", TFreeSy),
218.14 + ("tvar", TVarSy),
218.15 + ("num", NumSy),
218.16 + ("float_token", FloatSy),
218.17 + ("xnum", XNumSy),
218.18 + ("xstr", StrSy)];
218.19 +
218.20 +val terminals = map #1 terminal_kinds;
218.21 val is_terminal = member (op =) terminals;
218.22
218.23
218.24 @@ -186,16 +196,10 @@
218.25
218.26 (* predef_term *)
218.27
218.28 -fun predef_term "id" = SOME (Token (IdentSy, "id", Position.no_range))
218.29 - | predef_term "longid" = SOME (Token (LongIdentSy, "longid", Position.no_range))
218.30 - | predef_term "var" = SOME (Token (VarSy, "var", Position.no_range))
218.31 - | predef_term "tid" = SOME (Token (TFreeSy, "tid", Position.no_range))
218.32 - | predef_term "tvar" = SOME (Token (TVarSy, "tvar", Position.no_range))
218.33 - | predef_term "num" = SOME (Token (NumSy, "num", Position.no_range))
218.34 - | predef_term "float" = SOME (Token (FloatSy, "float", Position.no_range))
218.35 - | predef_term "xnum" = SOME (Token (XNumSy, "xnum", Position.no_range))
218.36 - | predef_term "xstr" = SOME (Token (StrSy, "xstr", Position.no_range))
218.37 - | predef_term _ = NONE;
218.38 +fun predef_term s =
218.39 + (case AList.lookup (op =) terminal_kinds s of
218.40 + SOME sy => SOME (Token (sy, s, Position.no_range))
218.41 + | NONE => NONE);
218.42
218.43
218.44 (* xstr tokens *)
218.45 @@ -382,21 +386,27 @@
218.46 | "0" :: "b" :: cs => (1, 2, cs)
218.47 | "-" :: cs => (~1, 10, cs)
218.48 | cs => (1, 10, cs));
218.49 - val value = sign * #1 (Library.read_radix_int radix digs);
218.50 - in {radix = radix, leading_zeros = leading_zeros digs, value = value} end;
218.51 + in
218.52 + {radix = radix,
218.53 + leading_zeros = leading_zeros digs,
218.54 + value = sign * #1 (Library.read_radix_int radix digs)}
218.55 + end;
218.56
218.57 end;
218.58
218.59 fun read_float str =
218.60 let
218.61 val (sign, cs) =
218.62 - (case Symbol.explode str of "-" :: cs => (~1, cs) | cs => (1, cs));
218.63 - val (intpart,fracpart) =
218.64 + (case Symbol.explode str of
218.65 + "-" :: cs => (~1, cs)
218.66 + | cs => (1, cs));
218.67 + val (intpart, fracpart) =
218.68 (case take_prefix Symbol.is_digit cs of
218.69 - (intpart, "." :: fracpart) => (intpart,fracpart)
218.70 - | _ => sys_error "read_float")
218.71 - in {mant = sign * #1 (Library.read_int (intpart@fracpart)),
218.72 - exp = length fracpart}
218.73 + (intpart, "." :: fracpart) => (intpart, fracpart)
218.74 + | _ => raise Fail "read_float");
218.75 + in
218.76 + {mant = sign * #1 (Library.read_int (intpart @ fracpart)),
218.77 + exp = length fracpart}
218.78 end
218.79
218.80 end;
219.1 --- a/src/Pure/Syntax/syntax.ML Tue Dec 30 08:18:54 2008 +0100
219.2 +++ b/src/Pure/Syntax/syntax.ML Tue Dec 30 11:10:01 2008 +0100
219.3 @@ -1,5 +1,4 @@
219.4 (* Title: Pure/Syntax/syntax.ML
219.5 - ID: $Id$
219.6 Author: Tobias Nipkow and Markus Wenzel, TU Muenchen
219.7
219.8 Standard Isabelle syntax, based on arbitrary context-free grammars
220.1 --- a/src/Pure/Thy/thy_header.scala Tue Dec 30 08:18:54 2008 +0100
220.2 +++ b/src/Pure/Thy/thy_header.scala Tue Dec 30 11:10:01 2008 +0100
220.3 @@ -1,5 +1,4 @@
220.4 /* Title: Pure/Thy/thy_header.scala
220.5 - ID: $Id$
220.6 Author: Makarius
220.7
220.8 Theory header keywords.
221.1 --- a/src/Pure/Thy/thy_info.ML Tue Dec 30 08:18:54 2008 +0100
221.2 +++ b/src/Pure/Thy/thy_info.ML Tue Dec 30 11:10:01 2008 +0100
221.3 @@ -315,7 +315,13 @@
221.4 datatype task = Task of (unit -> unit) | Finished | Running;
221.5 fun task_finished Finished = true | task_finished _ = false;
221.6
221.7 -fun future_schedule task_graph =
221.8 +local
221.9 +
221.10 +fun schedule_seq tasks =
221.11 + Graph.topological_order tasks
221.12 + |> List.app (fn name => (case Graph.get_node tasks name of Task body => body () | _ => ()));
221.13 +
221.14 +fun schedule_futures task_graph =
221.15 let
221.16 val tasks = Graph.topological_order task_graph |> map_filter (fn name =>
221.17 (case Graph.get_node task_graph name of Task body => SOME (name, body) | _ => NONE));
221.18 @@ -339,45 +345,14 @@
221.19 val proof_results = PureThy.join_proofs (map_filter (try get_theory o #1) tasks);
221.20 in ignore (Exn.release_all (thy_results @ proof_results)) end;
221.21
221.22 -local
221.23 -
221.24 -fun max_task (name, (Task body, m)) NONE = SOME (name: string, (body, m))
221.25 - | max_task (name, (Task body, m)) (task' as SOME (name', (_, m'))) =
221.26 - if m > m' orelse m = m' andalso name < name' then SOME (name, (body, m)) else task'
221.27 - | max_task _ task' = task';
221.28 -
221.29 -fun next_task G =
221.30 - let
221.31 - val tasks = Graph.minimals G |> map (fn name =>
221.32 - (name, (Graph.get_node G name, length (Graph.imm_succs G name))));
221.33 - val finished = filter (task_finished o fst o snd) tasks;
221.34 - in
221.35 - if not (null finished) then next_task (Graph.del_nodes (map fst finished) G)
221.36 - else if null tasks then (Schedule.Terminate, G)
221.37 - else
221.38 - (case fold max_task tasks NONE of
221.39 - NONE => (Schedule.Wait, G)
221.40 - | SOME (name, (body, _)) =>
221.41 - (Schedule.Task {body = PrintMode.closure body,
221.42 - cont = Graph.del_nodes [name], fail = K Graph.empty},
221.43 - Graph.map_node name (K Running) G))
221.44 - end;
221.45 -
221.46 -fun schedule_seq tasks =
221.47 - Graph.topological_order tasks
221.48 - |> List.app (fn name => (case Graph.get_node tasks name of Task body => body () | _ => ()));
221.49 -
221.50 in
221.51
221.52 fun schedule_tasks tasks n =
221.53 - let val m = Multithreading.max_threads_value () in
221.54 - if m <= 1 then schedule_seq tasks
221.55 - else if Multithreading.self_critical () then
221.56 + if not (Multithreading.enabled ()) then schedule_seq tasks
221.57 + else if Multithreading.self_critical () then
221.58 (warning (loader_msg "no multithreading within critical section" []);
221.59 schedule_seq tasks)
221.60 - else if Future.enabled () then future_schedule tasks
221.61 - else ignore (Exn.release_all (map Exn.Exn (Schedule.schedule (Int.min (m, n)) next_task tasks)))
221.62 - end;
221.63 + else schedule_futures tasks;
221.64
221.65 end;
221.66
222.1 --- a/src/Pure/Tools/ROOT.ML Tue Dec 30 08:18:54 2008 +0100
222.2 +++ b/src/Pure/Tools/ROOT.ML Tue Dec 30 11:10:01 2008 +0100
222.3 @@ -11,3 +11,6 @@
222.4
222.5 (*derived theory and proof elements*)
222.6 use "invoke.ML";
222.7 +
222.8 +(*quickcheck needed here because of pg preferences*)
222.9 +use "../../Tools/quickcheck.ML"
223.1 --- a/src/Pure/Tools/isabelle_process.scala Tue Dec 30 08:18:54 2008 +0100
223.2 +++ b/src/Pure/Tools/isabelle_process.scala Tue Dec 30 11:10:01 2008 +0100
223.3 @@ -1,5 +1,4 @@
223.4 /* Title: Pure/Tools/isabelle_process.ML
223.5 - ID: $Id$
223.6 Author: Makarius
223.7 Options: :folding=explicit:collapseFolds=1:
223.8
223.9 @@ -13,8 +12,6 @@
223.10 import java.io.{BufferedReader, BufferedWriter, InputStreamReader, OutputStreamWriter,
223.11 InputStream, OutputStream, IOException}
223.12
223.13 -import isabelle.{Symbol, XML}
223.14 -
223.15
223.16 object IsabelleProcess {
223.17
223.18 @@ -70,21 +67,28 @@
223.19
223.20 class Result(val kind: Kind.Value, val props: Properties, val result: String) {
223.21 override def toString = {
223.22 - val res = XML.content(YXML.parse_failsafe(result)).mkString("")
223.23 + val res = XML.content(YXML.parse_failsafe(result)).mkString
223.24 if (props == null) kind.toString + " [[" + res + "]]"
223.25 else kind.toString + " " + props.toString + " [[" + res + "]]"
223.26 }
223.27 - def is_raw() = Kind.is_raw(kind)
223.28 - def is_control() = Kind.is_control(kind)
223.29 - def is_system() = Kind.is_system(kind)
223.30 + def is_raw = Kind.is_raw(kind)
223.31 + def is_control = Kind.is_control(kind)
223.32 + def is_system = Kind.is_system(kind)
223.33 }
223.34
223.35 }
223.36
223.37
223.38 -class IsabelleProcess(args: String*) {
223.39 +class IsabelleProcess(isabelle_system: IsabelleSystem,
223.40 + results: EventBus[IsabelleProcess.Result], args: String*)
223.41 +{
223.42 + import IsabelleProcess._
223.43
223.44 - import IsabelleProcess._
223.45 +
223.46 + /* demo constructor */
223.47 +
223.48 + def this(args: String*) =
223.49 + this(new IsabelleSystem, new EventBus[IsabelleProcess.Result] + Console.println, args: _*)
223.50
223.51
223.52 /* process information */
223.53 @@ -98,21 +102,31 @@
223.54
223.55 /* results */
223.56
223.57 - private val results = new LinkedBlockingQueue[Result]
223.58 + private val result_queue = new LinkedBlockingQueue[Result]
223.59
223.60 private def put_result(kind: Kind.Value, props: Properties, result: String) {
223.61 if (kind == Kind.INIT && props != null) {
223.62 pid = props.getProperty(Markup.PID)
223.63 the_session = props.getProperty(Markup.SESSION)
223.64 }
223.65 - results.put(new Result(kind, props, result))
223.66 + result_queue.put(new Result(kind, props, result))
223.67 }
223.68
223.69 - def get_result() = results.take
223.70 + private class ResultThread extends Thread("isabelle: results") {
223.71 + override def run() = {
223.72 + var finished = false
223.73 + while (!finished) {
223.74 + val result =
223.75 + try { result_queue.take }
223.76 + catch { case _: NullPointerException => null }
223.77
223.78 - def try_result() = {
223.79 - val res = results.poll
223.80 - if (res != null) Some(res) else None
223.81 + if (result != null) {
223.82 + results.event(result) // FIXME try/catch (!??)
223.83 + if (result.kind == Kind.EXIT) finished = true
223.84 + }
223.85 + else finished = true
223.86 + }
223.87 + }
223.88 }
223.89
223.90
223.91 @@ -123,7 +137,7 @@
223.92 if (pid == null) put_result(Kind.SYSTEM, null, "Cannot interrupt: unknown pid")
223.93 else {
223.94 try {
223.95 - if (IsabelleSystem.exec("kill", "-INT", pid).waitFor == 0)
223.96 + if (isabelle_system.execute(true, "kill", "-INT", pid).waitFor == 0)
223.97 put_result(Kind.SIGNAL, null, "INT")
223.98 else
223.99 put_result(Kind.SYSTEM, null, "Cannot interrupt: kill command failed")
223.100 @@ -186,7 +200,7 @@
223.101
223.102 private class StdinThread(out_stream: OutputStream) extends Thread("isabelle: stdin") {
223.103 override def run() = {
223.104 - val writer = new BufferedWriter(new OutputStreamWriter(out_stream, IsabelleSystem.charset))
223.105 + val writer = new BufferedWriter(new OutputStreamWriter(out_stream, isabelle_system.charset))
223.106 var finished = false
223.107 while (!finished) {
223.108 try {
223.109 @@ -216,7 +230,7 @@
223.110
223.111 private class StdoutThread(in_stream: InputStream) extends Thread("isabelle: stdout") {
223.112 override def run() = {
223.113 - val reader = new BufferedReader(new InputStreamReader(in_stream, IsabelleSystem.charset))
223.114 + val reader = new BufferedReader(new InputStreamReader(in_stream, isabelle_system.charset))
223.115 var result = new StringBuilder(100)
223.116
223.117 var finished = false
223.118 @@ -254,7 +268,7 @@
223.119
223.120 private class MessageThread(fifo: String) extends Thread("isabelle: messages") {
223.121 override def run() = {
223.122 - val reader = IsabelleSystem.fifo_reader(fifo)
223.123 + val reader = isabelle_system.fifo_reader(fifo)
223.124 var kind: Kind.Value = null
223.125 var props: Properties = null
223.126 var result = new StringBuilder
223.127 @@ -332,33 +346,36 @@
223.128 }
223.129
223.130
223.131 +
223.132 /** main **/
223.133
223.134 {
223.135 /* isabelle version */
223.136
223.137 {
223.138 - val (msg, rc) = IsabelleSystem.isabelle_tool("version")
223.139 + val (msg, rc) = isabelle_system.isabelle_tool("version")
223.140 if (rc != 0) error("Version check failed -- bad Isabelle installation:\n" + msg)
223.141 put_result(Kind.SYSTEM, null, msg)
223.142 }
223.143
223.144
223.145 - /* message fifo */
223.146 + /* messages */
223.147
223.148 - val message_fifo = IsabelleSystem.mk_fifo()
223.149 - def rm_fifo() = IsabelleSystem.rm_fifo(message_fifo)
223.150 + val message_fifo = isabelle_system.mk_fifo()
223.151 + def rm_fifo() = isabelle_system.rm_fifo(message_fifo)
223.152
223.153 val message_thread = new MessageThread(message_fifo)
223.154 message_thread.start
223.155
223.156 + new ResultThread().start
223.157 +
223.158
223.159 /* exec process */
223.160
223.161 try {
223.162 val cmdline =
223.163 - List(IsabelleSystem.getenv_strict("ISABELLE_PROCESS"), "-W", message_fifo) ++ args
223.164 - proc = IsabelleSystem.exec2(cmdline: _*)
223.165 + List(isabelle_system.getenv_strict("ISABELLE_PROCESS"), "-W", message_fifo) ++ args
223.166 + proc = isabelle_system.execute(true, cmdline: _*)
223.167 }
223.168 catch {
223.169 case e: IOException =>
223.170 @@ -386,5 +403,4 @@
223.171 }.start
223.172
223.173 }
223.174 -
223.175 }
224.1 --- a/src/Pure/Tools/isabelle_syntax.scala Tue Dec 30 08:18:54 2008 +0100
224.2 +++ b/src/Pure/Tools/isabelle_syntax.scala Tue Dec 30 11:10:01 2008 +0100
224.3 @@ -1,5 +1,4 @@
224.4 /* Title: Pure/Tools/isabelle_syntax.scala
224.5 - ID: $Id$
224.6 Author: Makarius
224.7
224.8 Isabelle outer syntax.
225.1 --- a/src/Pure/Tools/isabelle_system.scala Tue Dec 30 08:18:54 2008 +0100
225.2 +++ b/src/Pure/Tools/isabelle_system.scala Tue Dec 30 11:10:01 2008 +0100
225.3 @@ -1,5 +1,4 @@
225.4 /* Title: Pure/Tools/isabelle_system.scala
225.5 - ID: $Id$
225.6 Author: Makarius
225.7
225.8 Isabelle system support -- basic Cygwin/Posix compatibility.
225.9 @@ -13,24 +12,26 @@
225.10 import scala.io.Source
225.11
225.12
225.13 -object IsabelleSystem {
225.14 +class IsabelleSystem {
225.15
225.16 val charset = "UTF-8"
225.17
225.18
225.19 /* Isabelle environment settings */
225.20
225.21 + private val environment = System.getenv
225.22 +
225.23 def getenv(name: String) = {
225.24 - val value = System.getenv(if (name == "HOME") "HOME_JVM" else name)
225.25 + val value = environment.get(if (name == "HOME") "HOME_JVM" else name)
225.26 if (value != null) value else ""
225.27 }
225.28
225.29 def getenv_strict(name: String) = {
225.30 - val value = getenv(name)
225.31 + val value = environment.get(name)
225.32 if (value != "") value else error("Undefined environment variable: " + name)
225.33 }
225.34
225.35 - def is_cygwin() = Pattern.matches(".*-cygwin", getenv_strict("ML_PLATFORM"))
225.36 + val is_cygwin = Pattern.matches(".*-cygwin", getenv_strict("ML_PLATFORM"))
225.37
225.38
225.39 /* file path specifications */
225.40 @@ -75,17 +76,22 @@
225.41 result_path.toString
225.42 }
225.43
225.44 + def platform_file(path: String) =
225.45 + new File(platform_path(path))
225.46 +
225.47
225.48 /* processes */
225.49
225.50 - private def posix_prefix() = if (is_cygwin()) List(platform_path("/bin/env")) else Nil
225.51 + def execute(redirect: Boolean, args: String*): Process = {
225.52 + val cmdline = new java.util.LinkedList[String]
225.53 + if (is_cygwin) cmdline.add(platform_path("/bin/env"))
225.54 + for (s <- args) cmdline.add(s)
225.55
225.56 - def exec(args: String*): Process = Runtime.getRuntime.exec((posix_prefix() ++ args).toArray)
225.57 -
225.58 - def exec2(args: String*): Process = {
225.59 - val cmdline = new java.util.LinkedList[String]
225.60 - for (s <- posix_prefix() ++ args) cmdline.add(s)
225.61 - new ProcessBuilder(cmdline).redirectErrorStream(true).start
225.62 + val proc = new ProcessBuilder(cmdline)
225.63 + proc.environment.clear
225.64 + proc.environment.putAll(environment)
225.65 + proc.redirectErrorStream(redirect)
225.66 + proc.start
225.67 }
225.68
225.69
225.70 @@ -93,10 +99,10 @@
225.71
225.72 def isabelle_tool(args: String*) = {
225.73 val proc =
225.74 - try { exec2((List(getenv_strict("ISABELLE_TOOL")) ++ args): _*) }
225.75 + try { execute(true, (List(getenv_strict("ISABELLE_TOOL")) ++ args): _*) }
225.76 catch { case e: IOException => error(e.getMessage) }
225.77 proc.getOutputStream.close
225.78 - val output = Source.fromInputStream(proc.getInputStream, charset).mkString("")
225.79 + val output = Source.fromInputStream(proc.getInputStream, charset).mkString
225.80 val rc = proc.waitFor
225.81 (output, rc)
225.82 }
225.83 @@ -115,9 +121,26 @@
225.84 if (rc != 0) error(result)
225.85 }
225.86
225.87 - def fifo_reader(fifo: String) = // blocks until writer is ready
225.88 - if (is_cygwin()) new BufferedReader(new InputStreamReader(Runtime.getRuntime.exec(
225.89 - Array(platform_path("/bin/cat"), fifo)).getInputStream, charset))
225.90 - else new BufferedReader(new InputStreamReader(new FileInputStream(fifo), charset))
225.91 + def fifo_reader(fifo: String) = {
225.92 + // blocks until writer is ready
225.93 + val stream =
225.94 + if (is_cygwin) execute(false, "cat", fifo).getInputStream
225.95 + else new FileInputStream(fifo)
225.96 + new BufferedReader(new InputStreamReader(stream, charset))
225.97 + }
225.98
225.99 +
225.100 + /* find logics */
225.101 +
225.102 + def find_logics() = {
225.103 + val ml_ident = getenv_strict("ML_IDENTIFIER")
225.104 + var logics: Set[String] = Set()
225.105 + for (dir <- getenv_strict("ISABELLE_PATH").split(":")) {
225.106 + val files = platform_file(dir + "/" + ml_ident).listFiles()
225.107 + if (files != null) {
225.108 + for (file <- files if file.isFile) logics += file.getName
225.109 + }
225.110 + }
225.111 + logics.toList.sort(_ < _)
225.112 + }
225.113 }
226.1 --- a/src/Pure/codegen.ML Tue Dec 30 08:18:54 2008 +0100
226.2 +++ b/src/Pure/codegen.ML Tue Dec 30 11:10:01 2008 +0100
226.3 @@ -1025,8 +1025,6 @@
226.4
226.5 val setup = add_codegen "default" default_codegen
226.6 #> add_tycodegen "default" default_tycodegen
226.7 - #> Value.add_evaluator ("SML", eval_term o ProofContext.theory_of)
226.8 - #> Quickcheck.add_generator ("SML", test_term)
226.9 #> Code.add_attribute ("unfold", Scan.succeed (Thm.declaration_attribute
226.10 (fn thm => Context.mapping (add_unfold thm #> Code.add_inline thm) I)))
226.11 #> add_preprocessor unfold_preprocessor;
227.1 --- a/src/Pure/context.ML Tue Dec 30 08:18:54 2008 +0100
227.2 +++ b/src/Pure/context.ML Tue Dec 30 11:10:01 2008 +0100
227.3 @@ -21,11 +21,10 @@
227.4 val ancestors_of: theory -> theory list
227.5 val theory_name: theory -> string
227.6 val is_stale: theory -> bool
227.7 - val PureN: string
227.8 val is_draft: theory -> bool
227.9 val reject_draft: theory -> theory
227.10 - val exists_name: string -> theory -> bool
227.11 - val names_of: theory -> string list
227.12 + val PureN: string
227.13 + val display_names: theory -> string list
227.14 val pretty_thy: theory -> Pretty.T
227.15 val string_of_thy: theory -> string
227.16 val pprint_thy: theory -> pprint_args -> unit
227.17 @@ -144,17 +143,18 @@
227.18 datatype theory =
227.19 Theory of
227.20 (*identity*)
227.21 - {self: theory ref option, (*dynamic self reference -- follows theory changes*)
227.22 - id: serial * (string * int), (*identifier/name of this theory node*)
227.23 - ids: (string * int) Inttab.table} * (*ancestors and checkpoints*)
227.24 + {self: theory ref option, (*dynamic self reference -- follows theory changes*)
227.25 + draft: bool, (*draft mode -- linear destructive changes*)
227.26 + id: serial, (*identifier*)
227.27 + ids: unit Inttab.table} * (*cumulative identifiers of non-drafts -- symbolic body content*)
227.28 (*data*)
227.29 - Object.T Datatab.table *
227.30 + Object.T Datatab.table * (*body content*)
227.31 (*ancestry*)
227.32 - {parents: theory list, (*immediate predecessors*)
227.33 - ancestors: theory list} * (*all predecessors*)
227.34 + {parents: theory list, (*immediate predecessors*)
227.35 + ancestors: theory list} * (*all predecessors -- canonical reverse order*)
227.36 (*history*)
227.37 - {name: string, (*prospective name of finished theory*)
227.38 - version: int}; (*checkpoint counter*)
227.39 + {name: string, (*official theory name*)
227.40 + stage: int}; (*checkpoint counter*)
227.41
227.42 exception THEORY of string * theory list;
227.43
227.44 @@ -165,9 +165,9 @@
227.45 val ancestry_of = #3 o rep_theory;
227.46 val history_of = #4 o rep_theory;
227.47
227.48 -fun make_identity self id ids = {self = self, id = id, ids = ids};
227.49 +fun make_identity self draft id ids = {self = self, draft = draft, id = id, ids = ids};
227.50 fun make_ancestry parents ancestors = {parents = parents, ancestors = ancestors};
227.51 -fun make_history name version = {name = name, version = version};
227.52 +fun make_history name stage = {name = name, stage = stage};
227.53
227.54 val the_self = the o #self o identity_of;
227.55 val parents_of = #parents o ancestry_of;
227.56 @@ -177,7 +177,7 @@
227.57
227.58 (* staleness *)
227.59
227.60 -fun eq_id ((i: int, _), (j, _)) = (i = j);
227.61 +fun eq_id (i: int, j) = i = j;
227.62
227.63 fun is_stale
227.64 (Theory ({self = SOME (ref (Theory ({id = id', ...}, _, _, _))), id, ...}, _, _, _)) =
227.65 @@ -185,47 +185,46 @@
227.66 | is_stale (Theory ({self = NONE, ...}, _, _, _)) = true;
227.67
227.68 fun vitalize (thy as Theory ({self = SOME r, ...}, _, _, _)) = (r := thy; thy)
227.69 - | vitalize (thy as Theory ({self = NONE, id, ids}, data, ancestry, history)) =
227.70 + | vitalize (thy as Theory ({self = NONE, draft, id, ids}, data, ancestry, history)) =
227.71 let
227.72 val r = ref thy;
227.73 - val thy' = Theory (make_identity (SOME r) id ids, data, ancestry, history);
227.74 + val thy' = Theory (make_identity (SOME r) draft id ids, data, ancestry, history);
227.75 in r := thy'; thy' end;
227.76
227.77
227.78 -(* names *)
227.79 +(* draft mode *)
227.80
227.81 -val PureN = "Pure";
227.82 -
227.83 -val draftN = "#";
227.84 -val draft_name = (draftN, ~1);
227.85 -
227.86 -fun draft_id (_, (name, _)) = (name = draftN);
227.87 -val is_draft = draft_id o #id o identity_of;
227.88 +val is_draft = #draft o identity_of;
227.89
227.90 fun reject_draft thy =
227.91 if is_draft thy then raise THEORY ("Illegal draft theory -- stable checkpoint required", [thy])
227.92 else thy;
227.93
227.94 -fun exists_name name (thy as Theory ({id = (_, (a, _)), ids, ...}, _, _, _)) =
227.95 - name = theory_name thy orelse
227.96 - name = a orelse
227.97 - Inttab.exists (fn (_, (b, _)) => b = name) ids;
227.98
227.99 -fun name_of (a, ~1) = a
227.100 - | name_of (a, i) = a ^ ":" ^ string_of_int i;
227.101 +(* names *)
227.102
227.103 -fun names_of (Theory ({id = (_, a), ids, ...}, _, _, _)) =
227.104 - rev (name_of a :: Inttab.fold (fn (_, (b, ~1)) => cons b | _ => I) ids []);
227.105 +val PureN = "Pure";
227.106 +val draftN = "#";
227.107 +val finished = ~1;
227.108
227.109 -fun pretty_thy thy =
227.110 - Pretty.str_list "{" "}" (names_of thy @ (if is_stale thy then ["!"] else []));
227.111 +fun display_names thy =
227.112 + let
227.113 + val draft = if is_draft thy then [draftN] else [];
227.114 + val {stage, ...} = history_of thy;
227.115 + val name =
227.116 + if stage = finished then theory_name thy
227.117 + else theory_name thy ^ ":" ^ string_of_int stage;
227.118 + val ancestor_names = map theory_name (ancestors_of thy);
227.119 + val stale = if is_stale thy then ["!"] else [];
227.120 + in rev (stale @ draft @ [name] @ ancestor_names) end;
227.121
227.122 +val pretty_thy = Pretty.str_list "{" "}" o display_names;
227.123 val string_of_thy = Pretty.string_of o pretty_thy;
227.124 val pprint_thy = Pretty.pprint o pretty_thy;
227.125
227.126 fun pretty_abbrev_thy thy =
227.127 let
227.128 - val names = names_of thy;
227.129 + val names = display_names thy;
227.130 val n = length names;
227.131 val abbrev = if n > 5 then "..." :: List.drop (names, n - 5) else names;
227.132 in Pretty.str_list "{" "}" abbrev end;
227.133 @@ -252,20 +251,18 @@
227.134 val pprint_thy_ref = Pretty.pprint o pretty_thy o deref;
227.135
227.136
227.137 -(* consistency *)
227.138 +(* build ids *)
227.139
227.140 -fun check_insert id ids =
227.141 - if draft_id id orelse Inttab.defined ids (#1 id) then ids
227.142 - else if Inttab.exists (fn (_, a) => a = #2 id) ids then
227.143 - error ("Different versions of theory component " ^ quote (name_of (#2 id)))
227.144 - else Inttab.update id ids;
227.145 +fun insert_id draft id ids =
227.146 + if draft then ids
227.147 + else Inttab.update (id, ()) ids;
227.148
227.149 -fun check_merge
227.150 - (Theory ({id = id1, ids = ids1, ...}, _, _, _))
227.151 - (Theory ({id = id2, ids = ids2, ...}, _, _, _)) =
227.152 - Inttab.fold check_insert ids2 ids1
227.153 - |> check_insert id1
227.154 - |> check_insert id2;
227.155 +fun merge_ids
227.156 + (Theory ({draft = draft1, id = id1, ids = ids1, ...}, _, _, _))
227.157 + (Theory ({draft = draft2, id = id2, ids = ids2, ...}, _, _, _)) =
227.158 + Inttab.merge (K true) (ids1, ids2)
227.159 + |> insert_id draft1 id1
227.160 + |> insert_id draft2 id2;
227.161
227.162
227.163 (* equality and inclusion *)
227.164 @@ -273,22 +270,35 @@
227.165 val eq_thy = eq_id o pairself (#id o identity_of);
227.166
227.167 fun proper_subthy (Theory ({id, ...}, _, _, _), Theory ({ids, ...}, _, _, _)) =
227.168 - Inttab.defined ids (#1 id);
227.169 + Inttab.defined ids id;
227.170
227.171 fun subthy thys = eq_thy thys orelse proper_subthy thys;
227.172
227.173 fun joinable (thy1, thy2) = subthy (thy1, thy2) orelse subthy (thy2, thy1);
227.174
227.175
227.176 +(* consistent ancestors *)
227.177 +
227.178 +fun extend_ancestors thy thys =
227.179 + if member eq_thy thys thy then raise THEORY ("Duplicate theory node", thy :: thys)
227.180 + else thy :: thys;
227.181 +
227.182 +fun extend_ancestors_of thy = extend_ancestors thy (ancestors_of thy);
227.183 +
227.184 +val merge_ancestors = merge (fn (thy1, thy2) =>
227.185 + eq_thy (thy1, thy2) orelse
227.186 + theory_name thy1 = theory_name thy2 andalso
227.187 + raise THEORY ("Inconsistent theory versions", [thy1, thy2]));
227.188 +
227.189 +
227.190 (* trivial merge *)
227.191
227.192 fun merge (thy1, thy2) =
227.193 if eq_thy (thy1, thy2) then thy1
227.194 else if proper_subthy (thy2, thy1) then thy1
227.195 else if proper_subthy (thy1, thy2) then thy2
227.196 - else (check_merge thy1 thy2;
227.197 - error (cat_lines ["Attempt to perform non-trivial merge of theories:",
227.198 - str_of_thy thy1, str_of_thy thy2]));
227.199 + else error (cat_lines ["Attempt to perform non-trivial merge of theories:",
227.200 + str_of_thy thy1, str_of_thy thy2]);
227.201
227.202 fun merge_refs (ref1, ref2) =
227.203 if ref1 = ref2 then ref1
227.204 @@ -300,41 +310,38 @@
227.205
227.206 (* primitives *)
227.207
227.208 -fun create_thy name self id ids data ancestry history =
227.209 +fun create_thy self draft ids data ancestry history =
227.210 + let val identity = make_identity self draft (serial ()) ids;
227.211 + in vitalize (Theory (identity, data, ancestry, history)) end;
227.212 +
227.213 +fun change_thy draft' f thy =
227.214 let
227.215 - val {version, ...} = history;
227.216 - val ids' = check_insert id ids;
227.217 - val id' = (serial (), name);
227.218 - val _ = check_insert id' ids';
227.219 - val identity' = make_identity self id' ids';
227.220 - in vitalize (Theory (identity', data, ancestry, history)) end;
227.221 -
227.222 -fun change_thy name f thy =
227.223 - let
227.224 - val Theory ({self, id, ids}, data, ancestry, history) = thy;
227.225 + val Theory ({self, draft, id, ids}, data, ancestry, history) = thy;
227.226 val (self', data', ancestry') =
227.227 - if is_draft thy then (self, data, ancestry) (*destructive change!*)
227.228 - else if #version history > 0
227.229 + if draft then (self, data, ancestry) (*destructive change!*)
227.230 + else if #stage history > 0
227.231 then (NONE, copy_data data, ancestry)
227.232 - else (NONE, extend_data data, make_ancestry [thy] (thy :: #ancestors ancestry));
227.233 + else (NONE, extend_data data, make_ancestry [thy] (extend_ancestors_of thy));
227.234 + val ids' = insert_id draft id ids;
227.235 val data'' = f data';
227.236 val thy' = NAMED_CRITICAL "theory" (fn () =>
227.237 - (check_thy thy; create_thy name self' id ids data'' ancestry' history));
227.238 + (check_thy thy; create_thy self' draft' ids' data'' ancestry' history));
227.239 in thy' end;
227.240
227.241 -fun name_thy name = change_thy name I;
227.242 -val modify_thy = change_thy draft_name;
227.243 -val extend_thy = modify_thy I;
227.244 +val name_thy = change_thy false I;
227.245 +val extend_thy = change_thy true I;
227.246 +val modify_thy = change_thy true;
227.247
227.248 fun copy_thy thy =
227.249 let
227.250 - val Theory ({id, ids, ...}, data, ancestry, history) = thy;
227.251 + val Theory ({draft, id, ids, ...}, data, ancestry, history) = thy;
227.252 + val ids' = insert_id draft id ids;
227.253 val data' = copy_data data;
227.254 val thy' = NAMED_CRITICAL "theory" (fn () =>
227.255 - (check_thy thy; create_thy draft_name NONE id ids data' ancestry history));
227.256 + (check_thy thy; create_thy NONE true ids' data' ancestry history));
227.257 in thy' end;
227.258
227.259 -val pre_pure_thy = create_thy draft_name NONE (serial (), draft_name) Inttab.empty
227.260 +val pre_pure_thy = create_thy NONE true Inttab.empty
227.261 Datatab.empty (make_ancestry [] []) (make_history PureN 0);
227.262
227.263
227.264 @@ -342,56 +349,56 @@
227.265
227.266 fun merge_thys pp (thy1, thy2) =
227.267 let
227.268 - val ids = check_merge thy1 thy2;
227.269 + val ids = merge_ids thy1 thy2;
227.270 val data = merge_data (pp thy1) (data_of thy1, data_of thy2);
227.271 val ancestry = make_ancestry [] [];
227.272 val history = make_history "" 0;
227.273 val thy' = NAMED_CRITICAL "theory" (fn () =>
227.274 - (check_thy thy1; check_thy thy2;
227.275 - create_thy draft_name NONE (serial (), draft_name) ids data ancestry history));
227.276 + (check_thy thy1; check_thy thy2; create_thy NONE true ids data ancestry history));
227.277 in thy' end;
227.278
227.279 fun maximal_thys thys =
227.280 thys |> filter_out (fn thy => exists (fn thy' => proper_subthy (thy, thy')) thys);
227.281
227.282 fun begin_thy pp name imports =
227.283 - if name = draftN then error ("Illegal theory name: " ^ quote draftN)
227.284 + if name = "" orelse name = draftN then error ("Bad theory name: " ^ quote name)
227.285 else
227.286 let
227.287 val parents = maximal_thys (distinct eq_thy imports);
227.288 - val ancestors = distinct eq_thy (parents @ maps ancestors_of parents);
227.289 - val Theory ({id, ids, ...}, data, _, _) =
227.290 + val ancestors =
227.291 + Library.foldl merge_ancestors ([], map ancestors_of parents)
227.292 + |> fold extend_ancestors parents;
227.293 +
227.294 + val Theory ({ids, ...}, data, _, _) =
227.295 (case parents of
227.296 [] => error "No parent theories"
227.297 | [thy] => extend_thy thy
227.298 | thy :: thys => Library.foldl (merge_thys pp) (thy, thys));
227.299 +
227.300 val ancestry = make_ancestry parents ancestors;
227.301 val history = make_history name 0;
227.302 val thy' = NAMED_CRITICAL "theory" (fn () =>
227.303 - (map check_thy imports; create_thy draft_name NONE id ids data ancestry history));
227.304 + (map check_thy imports; create_thy NONE true ids data ancestry history));
227.305 in thy' end;
227.306
227.307
227.308 -(* persistent checkpoints *)
227.309 +(* history stages *)
227.310 +
227.311 +fun history_stage f thy =
227.312 + let
227.313 + val {name, stage} = history_of thy;
227.314 + val _ = stage = finished andalso raise THEORY ("Theory already finished", [thy]);
227.315 + val history' = make_history name (f stage);
227.316 + val thy' as Theory (identity', data', ancestry', _) = name_thy thy;
227.317 + val thy'' = NAMED_CRITICAL "theory" (fn () =>
227.318 + (check_thy thy'; vitalize (Theory (identity', data', ancestry', history'))));
227.319 + in thy'' end;
227.320
227.321 fun checkpoint_thy thy =
227.322 - if not (is_draft thy) then thy
227.323 - else
227.324 - let
227.325 - val {name, version} = history_of thy;
227.326 - val thy' as Theory (identity', data', ancestry', _) = name_thy (name, version) thy;
227.327 - val history' = make_history name (version + 1);
227.328 - val thy'' = NAMED_CRITICAL "theory" (fn () =>
227.329 - (check_thy thy'; vitalize (Theory (identity', data', ancestry', history'))));
227.330 - in thy'' end;
227.331 + if is_draft thy then history_stage (fn stage => stage + 1) thy
227.332 + else thy;
227.333
227.334 -fun finish_thy thy = NAMED_CRITICAL "theory" (fn () =>
227.335 - let
227.336 - val name = theory_name thy;
227.337 - val Theory (identity', data', ancestry', _) = name_thy (name, ~1) thy;
227.338 - val history' = make_history name 0;
227.339 - val thy' = vitalize (Theory (identity', data', ancestry', history'));
227.340 - in thy' end);
227.341 +val finish_thy = history_stage (fn _ => finished);
227.342
227.343
227.344 (* theory data *)
228.1 --- a/src/Pure/display.ML Tue Dec 30 08:18:54 2008 +0100
228.2 +++ b/src/Pure/display.ML Tue Dec 30 11:10:01 2008 +0100
228.3 @@ -213,7 +213,7 @@
228.4 ||> List.partition (Defs.plain_args o #2 o #1);
228.5 val rests = restricts |> map (apfst (apfst extern_const)) |> sort_wrt (#1 o #1);
228.6 in
228.7 - [Pretty.strs ("names:" :: Context.names_of thy)] @
228.8 + [Pretty.strs ("names:" :: Context.display_names thy)] @
228.9 [Pretty.strs ["name prefix:", NameSpace.path_of naming],
228.10 Pretty.big_list "classes:" (map pretty_classrel clsses),
228.11 pretty_default default,
229.1 --- a/src/Pure/goal.ML Tue Dec 30 08:18:54 2008 +0100
229.2 +++ b/src/Pure/goal.ML Tue Dec 30 11:10:01 2008 +0100
229.3 @@ -179,7 +179,7 @@
229.4 val res =
229.5 if immediate orelse #maxidx (Thm.rep_cterm stmt) >= 0 orelse not (Future.enabled ())
229.6 then result ()
229.7 - else future_result ctxt' (Future.fork_background result) (Thm.term_of stmt);
229.8 + else future_result ctxt' (Future.fork_pri 1 result) (Thm.term_of stmt);
229.9 in
229.10 Conjunction.elim_balanced (length props) res
229.11 |> map (Assumption.export false ctxt' ctxt)
230.1 --- a/src/Pure/old_goals.ML Tue Dec 30 08:18:54 2008 +0100
230.2 +++ b/src/Pure/old_goals.ML Tue Dec 30 11:10:01 2008 +0100
230.3 @@ -127,7 +127,7 @@
230.4
230.5 (*Generates the list of new theories when the proof state's theory changes*)
230.6 fun thy_error (thy,thy') =
230.7 - let val names = Context.names_of thy' \\ Context.names_of thy
230.8 + let val names = Context.display_names thy' \\ Context.display_names thy
230.9 in case names of
230.10 [name] => "\nNew theory: " ^ name
230.11 | _ => "\nNew theories: " ^ space_implode ", " names
231.1 --- a/src/Pure/pure_setup.ML Tue Dec 30 08:18:54 2008 +0100
231.2 +++ b/src/Pure/pure_setup.ML Tue Dec 30 11:10:01 2008 +0100
231.3 @@ -1,5 +1,4 @@
231.4 (* Title: Pure/pure_setup.ML
231.5 - ID: $Id$
231.6 Author: Makarius
231.7
231.8 Pure theory and ML toplevel setup.
231.9 @@ -28,12 +27,13 @@
231.10
231.11 (* ML toplevel pretty printing *)
231.12
231.13 -install_pp (make_pp ["TaskQueue", "task"] (Pretty.pprint o Pretty.str o TaskQueue.str_of_task));
231.14 -install_pp (make_pp ["TaskQueue", "group"] (Pretty.pprint o Pretty.str o TaskQueue.str_of_group));
231.15 +install_pp (make_pp ["Task_Queue", "task"] (Pretty.pprint o Pretty.str o Task_Queue.str_of_task));
231.16 +install_pp (make_pp ["Task_Queue", "group"] (Pretty.pprint o Pretty.str o Task_Queue.str_of_group));
231.17 install_pp (make_pp ["Position", "T"] (Pretty.pprint o Pretty.enum "," "{" "}" o
231.18 map (fn (x, y) => Pretty.str (x ^ "=" ^ y)) o Position.properties_of));
231.19 install_pp (make_pp ["Thm", "thm"] ProofDisplay.pprint_thm);
231.20 install_pp (make_pp ["Thm", "cterm"] ProofDisplay.pprint_cterm);
231.21 +install_pp (make_pp ["Binding", "T"] (Pretty.pprint o Pretty.str o Binding.display));
231.22 install_pp (make_pp ["Thm", "ctyp"] ProofDisplay.pprint_ctyp);
231.23 install_pp (make_pp ["Context", "theory"] Context.pprint_thy);
231.24 install_pp (make_pp ["Context", "theory_ref"] Context.pprint_thy_ref);
232.1 --- a/src/Pure/pure_thy.ML Tue Dec 30 08:18:54 2008 +0100
232.2 +++ b/src/Pure/pure_thy.ML Tue Dec 30 11:10:01 2008 +0100
232.3 @@ -322,7 +322,7 @@
232.4 ("", typ "var => logic", Delimfix "_"),
232.5 ("_DDDOT", typ "logic", Delimfix "..."),
232.6 ("_constify", typ "num => num_const", Delimfix "_"),
232.7 - ("_constify", typ "float => float_const", Delimfix "_"),
232.8 + ("_constify", typ "float_token => float_const", Delimfix "_"),
232.9 ("_indexnum", typ "num_const => index", Delimfix "\\<^sub>_"),
232.10 ("_index", typ "logic => index", Delimfix "(00\\<^bsub>_\\<^esub>)"),
232.11 ("_indexdefault", typ "index", Delimfix ""),
233.1 --- a/src/Pure/theory.ML Tue Dec 30 08:18:54 2008 +0100
233.2 +++ b/src/Pure/theory.ML Tue Dec 30 11:10:01 2008 +0100
233.3 @@ -68,7 +68,7 @@
233.4 val copy = Context.copy_thy;
233.5
233.6 fun requires thy name what =
233.7 - if Context.exists_name name thy then ()
233.8 + if exists (fn thy' => Context.theory_name thy' = name) (thy :: ancestors_of thy) then ()
233.9 else error ("Require theory " ^ quote name ^ " as an ancestor for " ^ what);
233.10
233.11
234.1 --- a/src/Tools/code/code_haskell.ML Tue Dec 30 08:18:54 2008 +0100
234.2 +++ b/src/Tools/code/code_haskell.ML Tue Dec 30 11:10:01 2008 +0100
234.3 @@ -414,7 +414,10 @@
234.4 o NameSpace.explode) modlname;
234.5 val pathname = Path.append destination filename;
234.6 val _ = File.mkdir (Path.dir pathname);
234.7 - in File.write pathname (Code_Target.code_of_pretty content) end
234.8 + in File.write pathname
234.9 + ("{-# OPTIONS_GHC -fglasgow-exts #-}\n\n"
234.10 + ^ Code_Target.code_of_pretty content)
234.11 + end
234.12 in
234.13 Code_Target.mk_serialization target NONE
234.14 (fn NONE => K () o map (Code_Target.code_writeln o snd) | SOME file => K () o map (write_module file))
235.1 --- a/src/Tools/code/code_ml.ML Tue Dec 30 08:18:54 2008 +0100
235.2 +++ b/src/Tools/code/code_ml.ML Tue Dec 30 11:10:01 2008 +0100
235.3 @@ -1,5 +1,4 @@
235.4 (* Title: Tools/code/code_ml.ML
235.5 - ID: $Id$
235.6 Author: Florian Haftmann, TU Muenchen
235.7
235.8 Serializer for SML and OCaml.
235.9 @@ -25,17 +24,21 @@
235.10 val target_OCaml = "OCaml";
235.11
235.12 datatype ml_stmt =
235.13 - MLFuns of (string * (typscheme * ((iterm list * iterm) * (thm * bool)) list)) list
235.14 + MLExc of string * int
235.15 + | MLVal of string * ((typscheme * iterm) * (thm * bool))
235.16 + | MLFuns of (string * (typscheme * ((iterm list * iterm) * (thm * bool)) list)) list * string list
235.17 | MLDatas of (string * ((vname * sort) list * (string * itype list) list)) list
235.18 | MLClass of string * (vname * ((class * string) list * (string * itype) list))
235.19 | MLClassinst of string * ((class * (string * (vname * sort) list))
235.20 * ((class * (string * (string * dict list list))) list
235.21 * ((string * const) * (thm * bool)) list));
235.22
235.23 -fun stmt_names_of (MLFuns fs) = map fst fs
235.24 +fun stmt_names_of (MLExc (name, _)) = [name]
235.25 + | stmt_names_of (MLVal (name, _)) = [name]
235.26 + | stmt_names_of (MLFuns (fs, _)) = map fst fs
235.27 | stmt_names_of (MLDatas ds) = map fst ds
235.28 - | stmt_names_of (MLClass (c, _)) = [c]
235.29 - | stmt_names_of (MLClassinst (i, _)) = [i];
235.30 + | stmt_names_of (MLClass (name, _)) = [name]
235.31 + | stmt_names_of (MLClassinst (name, _)) = [name];
235.32
235.33
235.34 (** SML serailizer **)
235.35 @@ -81,144 +84,159 @@
235.36 of NONE => pr_tycoexpr fxy (tyco, tys)
235.37 | SOME (i, pr) => pr pr_typ fxy tys)
235.38 | pr_typ fxy (ITyVar v) = str ("'" ^ v);
235.39 - fun pr_term thm vars fxy (IConst c) =
235.40 - pr_app thm vars fxy (c, [])
235.41 - | pr_term thm vars fxy (IVar v) =
235.42 + fun pr_term is_closure thm vars fxy (IConst c) =
235.43 + pr_app is_closure thm vars fxy (c, [])
235.44 + | pr_term is_closure thm vars fxy (IVar v) =
235.45 str (Code_Name.lookup_var vars v)
235.46 - | pr_term thm vars fxy (t as t1 `$ t2) =
235.47 + | pr_term is_closure thm vars fxy (t as t1 `$ t2) =
235.48 (case Code_Thingol.unfold_const_app t
235.49 - of SOME c_ts => pr_app thm vars fxy c_ts
235.50 - | NONE =>
235.51 - brackify fxy [pr_term thm vars NOBR t1, pr_term thm vars BR t2])
235.52 - | pr_term thm vars fxy (t as _ `|-> _) =
235.53 + of SOME c_ts => pr_app is_closure thm vars fxy c_ts
235.54 + | NONE => brackify fxy
235.55 + [pr_term is_closure thm vars NOBR t1, pr_term is_closure thm vars BR t2])
235.56 + | pr_term is_closure thm vars fxy (t as _ `|-> _) =
235.57 let
235.58 val (binds, t') = Code_Thingol.unfold_abs t;
235.59 fun pr ((v, pat), ty) =
235.60 - pr_bind thm NOBR ((SOME v, pat), ty)
235.61 + pr_bind is_closure thm NOBR ((SOME v, pat), ty)
235.62 #>> (fn p => concat [str "fn", p, str "=>"]);
235.63 val (ps, vars') = fold_map pr binds vars;
235.64 - in brackets (ps @ [pr_term thm vars' NOBR t']) end
235.65 - | pr_term thm vars fxy (ICase (cases as (_, t0))) =
235.66 + in brackets (ps @ [pr_term is_closure thm vars' NOBR t']) end
235.67 + | pr_term is_closure thm vars fxy (ICase (cases as (_, t0))) =
235.68 (case Code_Thingol.unfold_const_app t0
235.69 of SOME (c_ts as ((c, _), _)) => if is_none (syntax_const c)
235.70 - then pr_case thm vars fxy cases
235.71 - else pr_app thm vars fxy c_ts
235.72 - | NONE => pr_case thm vars fxy cases)
235.73 - and pr_app' thm vars (app as ((c, (iss, tys)), ts)) =
235.74 - if is_cons c then let
235.75 - val k = length tys
235.76 - in if k < 2 then
235.77 - (str o deresolve) c :: map (pr_term thm vars BR) ts
235.78 - else if k = length ts then
235.79 - [(str o deresolve) c, Pretty.enum "," "(" ")" (map (pr_term thm vars NOBR) ts)]
235.80 - else [pr_term thm vars BR (Code_Thingol.eta_expand k app)] end else
235.81 + then pr_case is_closure thm vars fxy cases
235.82 + else pr_app is_closure thm vars fxy c_ts
235.83 + | NONE => pr_case is_closure thm vars fxy cases)
235.84 + and pr_app' is_closure thm vars (app as ((c, (iss, tys)), ts)) =
235.85 + if is_cons c then
235.86 + let
235.87 + val k = length tys
235.88 + in if k < 2 then
235.89 + (str o deresolve) c :: map (pr_term is_closure thm vars BR) ts
235.90 + else if k = length ts then
235.91 + [(str o deresolve) c, Pretty.enum "," "(" ")" (map (pr_term is_closure thm vars NOBR) ts)]
235.92 + else [pr_term is_closure thm vars BR (Code_Thingol.eta_expand k app)] end
235.93 + else if is_closure c
235.94 + then (str o deresolve) c @@ str "()"
235.95 + else
235.96 (str o deresolve) c
235.97 - :: (map (pr_dicts BR) o filter_out null) iss @ map (pr_term thm vars BR) ts
235.98 - and pr_app thm vars = gen_pr_app pr_app' pr_term syntax_const naming thm vars
235.99 + :: (map (pr_dicts BR) o filter_out null) iss @ map (pr_term is_closure thm vars BR) ts
235.100 + and pr_app is_closure thm vars = gen_pr_app (pr_app' is_closure) (pr_term is_closure)
235.101 + syntax_const naming thm vars
235.102 and pr_bind' ((NONE, NONE), _) = str "_"
235.103 | pr_bind' ((SOME v, NONE), _) = str v
235.104 | pr_bind' ((NONE, SOME p), _) = p
235.105 | pr_bind' ((SOME v, SOME p), _) = concat [str v, str "as", p]
235.106 - and pr_bind thm = gen_pr_bind pr_bind' pr_term thm
235.107 - and pr_case thm vars fxy (cases as ((_, [_]), _)) =
235.108 + and pr_bind is_closure = gen_pr_bind pr_bind' (pr_term is_closure)
235.109 + and pr_case is_closure thm vars fxy (cases as ((_, [_]), _)) =
235.110 let
235.111 val (binds, t') = Code_Thingol.unfold_let (ICase cases);
235.112 fun pr ((pat, ty), t) vars =
235.113 vars
235.114 - |> pr_bind thm NOBR ((NONE, SOME pat), ty)
235.115 - |>> (fn p => semicolon [str "val", p, str "=", pr_term thm vars NOBR t])
235.116 + |> pr_bind is_closure thm NOBR ((NONE, SOME pat), ty)
235.117 + |>> (fn p => semicolon [str "val", p, str "=", pr_term is_closure thm vars NOBR t])
235.118 val (ps, vars') = fold_map pr binds vars;
235.119 in
235.120 Pretty.chunks [
235.121 [str ("let"), Pretty.fbrk, Pretty.chunks ps] |> Pretty.block,
235.122 - [str ("in"), Pretty.fbrk, pr_term thm vars' NOBR t'] |> Pretty.block,
235.123 + [str ("in"), Pretty.fbrk, pr_term is_closure thm vars' NOBR t'] |> Pretty.block,
235.124 str ("end")
235.125 ]
235.126 end
235.127 - | pr_case thm vars fxy (((td, ty), b::bs), _) =
235.128 + | pr_case is_closure thm vars fxy (((td, ty), b::bs), _) =
235.129 let
235.130 fun pr delim (pat, t) =
235.131 let
235.132 - val (p, vars') = pr_bind thm NOBR ((NONE, SOME pat), ty) vars;
235.133 + val (p, vars') = pr_bind is_closure thm NOBR ((NONE, SOME pat), ty) vars;
235.134 in
235.135 - concat [str delim, p, str "=>", pr_term thm vars' NOBR t]
235.136 + concat [str delim, p, str "=>", pr_term is_closure thm vars' NOBR t]
235.137 end;
235.138 in
235.139 (Pretty.enclose "(" ")" o single o brackify fxy) (
235.140 str "case"
235.141 - :: pr_term thm vars NOBR td
235.142 + :: pr_term is_closure thm vars NOBR td
235.143 :: pr "of" b
235.144 :: map (pr "|") bs
235.145 )
235.146 end
235.147 - | pr_case thm vars fxy ((_, []), _) = str "raise Fail \"empty case\"";
235.148 - fun pr_stmt (MLFuns (funns as (funn :: funns'))) =
235.149 + | pr_case is_closure thm vars fxy ((_, []), _) = str "raise Fail \"empty case\"";
235.150 + fun pr_stmt (MLExc (name, n)) =
235.151 let
235.152 - val definer =
235.153 + val exc_str =
235.154 + (ML_Syntax.print_string o NameSpace.base o NameSpace.qualifier) name;
235.155 + in
235.156 + concat (
235.157 + str (if n = 0 then "val" else "fun")
235.158 + :: (str o deresolve) name
235.159 + :: map str (replicate n "_")
235.160 + @ str "="
235.161 + :: str "raise"
235.162 + :: str "(Fail"
235.163 + @@ str (exc_str ^ ")")
235.164 + )
235.165 + end
235.166 + | pr_stmt (MLVal (name, (((vs, ty), t), (thm, _)))) =
235.167 + let
235.168 + val consts = map_filter
235.169 + (fn c => if (is_some o syntax_const) c
235.170 + then NONE else (SOME o NameSpace.base o deresolve) c)
235.171 + (Code_Thingol.fold_constnames (insert (op =)) t []);
235.172 + val vars = reserved_names
235.173 + |> Code_Name.intro_vars consts;
235.174 + in
235.175 + concat [
235.176 + str "val",
235.177 + (str o deresolve) name,
235.178 + str ":",
235.179 + pr_typ NOBR ty,
235.180 + str "=",
235.181 + pr_term (K false) thm vars NOBR t
235.182 + ]
235.183 + end
235.184 + | pr_stmt (MLFuns (funn :: funns, pseudo_funs)) =
235.185 + let
235.186 + fun pr_funn definer (name, ((vs, ty), eqs as eq :: eqs')) =
235.187 let
235.188 - fun no_args _ (((ts, _), _) :: _) = length ts
235.189 - | no_args ty [] = (length o fst o Code_Thingol.unfold_fun) ty;
235.190 - fun mk 0 [] = "val"
235.191 - | mk 0 vs = if (null o filter_out (null o snd)) vs
235.192 - then "val" else "fun"
235.193 - | mk k _ = "fun";
235.194 - fun chk (_, ((vs, ty), eqs)) NONE = SOME (mk (no_args ty eqs) vs)
235.195 - | chk (_, ((vs, ty), eqs)) (SOME defi) =
235.196 - if defi = mk (no_args ty eqs) vs then SOME defi
235.197 - else error ("Mixing simultaneous vals and funs not implemented: "
235.198 - ^ commas (map (labelled_name o fst) funns));
235.199 - in the (fold chk funns NONE) end;
235.200 - fun pr_funn definer (name, ((vs, ty), [])) =
235.201 + val vs_dict = filter_out (null o snd) vs;
235.202 + val shift = if null eqs' then I else
235.203 + map (Pretty.block o single o Pretty.block o single);
235.204 + fun pr_eq definer ((ts, t), (thm, _)) =
235.205 let
235.206 - val vs_dict = filter_out (null o snd) vs;
235.207 - val n = length vs_dict + (length o fst o Code_Thingol.unfold_fun) ty;
235.208 - val exc_str =
235.209 - (ML_Syntax.print_string o NameSpace.base o NameSpace.qualifier) name;
235.210 + val consts = map_filter
235.211 + (fn c => if (is_some o syntax_const) c
235.212 + then NONE else (SOME o NameSpace.base o deresolve) c)
235.213 + ((fold o Code_Thingol.fold_constnames) (insert (op =)) (t :: ts) []);
235.214 + val vars = reserved_names
235.215 + |> Code_Name.intro_vars consts
235.216 + |> Code_Name.intro_vars ((fold o Code_Thingol.fold_unbound_varnames)
235.217 + (insert (op =)) ts []);
235.218 in
235.219 concat (
235.220 str definer
235.221 :: (str o deresolve) name
235.222 - :: map str (replicate n "_")
235.223 + :: (if member (op =) pseudo_funs name then [str "()"]
235.224 + else pr_tyvar_dicts vs_dict
235.225 + @ map (pr_term (member (op =) pseudo_funs) thm vars BR) ts)
235.226 @ str "="
235.227 - :: str "raise"
235.228 - :: str "(Fail"
235.229 - @@ str (exc_str ^ ")")
235.230 + @@ pr_term (member (op =) pseudo_funs) thm vars NOBR t
235.231 )
235.232 end
235.233 - | pr_funn definer (name, ((vs, ty), eqs as eq :: eqs')) =
235.234 - let
235.235 - val vs_dict = filter_out (null o snd) vs;
235.236 - val shift = if null eqs' then I else
235.237 - map (Pretty.block o single o Pretty.block o single);
235.238 - fun pr_eq definer ((ts, t), (thm, _)) =
235.239 - let
235.240 - val consts = map_filter
235.241 - (fn c => if (is_some o syntax_const) c
235.242 - then NONE else (SOME o NameSpace.base o deresolve) c)
235.243 - ((fold o Code_Thingol.fold_constnames) (insert (op =)) (t :: ts) []);
235.244 - val vars = reserved_names
235.245 - |> Code_Name.intro_vars consts
235.246 - |> Code_Name.intro_vars ((fold o Code_Thingol.fold_unbound_varnames)
235.247 - (insert (op =)) ts []);
235.248 - in
235.249 - concat (
235.250 - [str definer, (str o deresolve) name]
235.251 - @ (if null ts andalso null vs_dict
235.252 - then [str ":", pr_typ NOBR ty]
235.253 - else
235.254 - pr_tyvar_dicts vs_dict
235.255 - @ map (pr_term thm vars BR) ts)
235.256 - @ [str "=", pr_term thm vars NOBR t]
235.257 - )
235.258 - end
235.259 - in
235.260 - (Pretty.block o Pretty.fbreaks o shift) (
235.261 - pr_eq definer eq
235.262 - :: map (pr_eq "|") eqs'
235.263 - )
235.264 - end;
235.265 - val (ps, p) = split_last (pr_funn definer funn :: map (pr_funn "and") funns');
235.266 - in Pretty.chunks (ps @ [Pretty.block ([p, str ";"])]) end
235.267 + in
235.268 + (Pretty.block o Pretty.fbreaks o shift) (
235.269 + pr_eq definer eq
235.270 + :: map (pr_eq "|") eqs'
235.271 + )
235.272 + end;
235.273 + fun pr_pseudo_fun name = concat [
235.274 + str "val",
235.275 + (str o deresolve) name,
235.276 + str "=",
235.277 + (str o deresolve) name,
235.278 + str "();"
235.279 + ];
235.280 + val (ps, p) = split_last (pr_funn "fun" funn :: map (pr_funn "and") funns);
235.281 + val pseudo_ps = map pr_pseudo_fun pseudo_funs;
235.282 + in Pretty.chunks (ps @ Pretty.block ([p, str ";"]) :: pseudo_ps) end
235.283 | pr_stmt (MLDatas (datas as (data :: datas'))) =
235.284 let
235.285 fun pr_co (co, []) =
235.286 @@ -245,7 +263,7 @@
235.287 );
235.288 val (ps, p) = split_last
235.289 (pr_data "datatype" data :: map (pr_data "and") datas');
235.290 - in Pretty.chunks (ps @ [Pretty.block ([p, str ";"])]) end
235.291 + in Pretty.chunks (ps @| Pretty.block ([p, str ";"])) end
235.292 | pr_stmt (MLClass (class, (v, (superclasses, classparams)))) =
235.293 let
235.294 val w = Code_Name.first_upper v ^ "_";
235.295 @@ -301,7 +319,7 @@
235.296 concat [
235.297 (str o pr_label_classparam) classparam,
235.298 str "=",
235.299 - pr_app thm reserved_names NOBR (c_inst, [])
235.300 + pr_app (K false) thm reserved_names NOBR (c_inst, [])
235.301 ];
235.302 in
235.303 semicolon ([
235.304 @@ -374,68 +392,71 @@
235.305 of NONE => pr_tycoexpr fxy (tyco, tys)
235.306 | SOME (i, pr) => pr pr_typ fxy tys)
235.307 | pr_typ fxy (ITyVar v) = str ("'" ^ v);
235.308 - fun pr_term thm vars fxy (IConst c) =
235.309 - pr_app thm vars fxy (c, [])
235.310 - | pr_term thm vars fxy (IVar v) =
235.311 + fun pr_term is_closure thm vars fxy (IConst c) =
235.312 + pr_app is_closure thm vars fxy (c, [])
235.313 + | pr_term is_closure thm vars fxy (IVar v) =
235.314 str (Code_Name.lookup_var vars v)
235.315 - | pr_term thm vars fxy (t as t1 `$ t2) =
235.316 + | pr_term is_closure thm vars fxy (t as t1 `$ t2) =
235.317 (case Code_Thingol.unfold_const_app t
235.318 - of SOME c_ts => pr_app thm vars fxy c_ts
235.319 + of SOME c_ts => pr_app is_closure thm vars fxy c_ts
235.320 | NONE =>
235.321 - brackify fxy [pr_term thm vars NOBR t1, pr_term thm vars BR t2])
235.322 - | pr_term thm vars fxy (t as _ `|-> _) =
235.323 + brackify fxy [pr_term is_closure thm vars NOBR t1, pr_term is_closure thm vars BR t2])
235.324 + | pr_term is_closure thm vars fxy (t as _ `|-> _) =
235.325 let
235.326 val (binds, t') = Code_Thingol.unfold_abs t;
235.327 - fun pr ((v, pat), ty) = pr_bind thm BR ((SOME v, pat), ty);
235.328 + fun pr ((v, pat), ty) = pr_bind is_closure thm BR ((SOME v, pat), ty);
235.329 val (ps, vars') = fold_map pr binds vars;
235.330 - in brackets (str "fun" :: ps @ str "->" @@ pr_term thm vars' NOBR t') end
235.331 - | pr_term thm vars fxy (ICase (cases as (_, t0))) = (case Code_Thingol.unfold_const_app t0
235.332 + in brackets (str "fun" :: ps @ str "->" @@ pr_term is_closure thm vars' NOBR t') end
235.333 + | pr_term is_closure thm vars fxy (ICase (cases as (_, t0))) = (case Code_Thingol.unfold_const_app t0
235.334 of SOME (c_ts as ((c, _), _)) => if is_none (syntax_const c)
235.335 - then pr_case thm vars fxy cases
235.336 - else pr_app thm vars fxy c_ts
235.337 - | NONE => pr_case thm vars fxy cases)
235.338 - and pr_app' thm vars (app as ((c, (iss, tys)), ts)) =
235.339 + then pr_case is_closure thm vars fxy cases
235.340 + else pr_app is_closure thm vars fxy c_ts
235.341 + | NONE => pr_case is_closure thm vars fxy cases)
235.342 + and pr_app' is_closure thm vars (app as ((c, (iss, tys)), ts)) =
235.343 if is_cons c then
235.344 if length tys = length ts
235.345 then case ts
235.346 of [] => [(str o deresolve) c]
235.347 - | [t] => [(str o deresolve) c, pr_term thm vars BR t]
235.348 + | [t] => [(str o deresolve) c, pr_term is_closure thm vars BR t]
235.349 | _ => [(str o deresolve) c, Pretty.enum "," "(" ")"
235.350 - (map (pr_term thm vars NOBR) ts)]
235.351 - else [pr_term thm vars BR (Code_Thingol.eta_expand (length tys) app)]
235.352 + (map (pr_term is_closure thm vars NOBR) ts)]
235.353 + else [pr_term is_closure thm vars BR (Code_Thingol.eta_expand (length tys) app)]
235.354 + else if is_closure c
235.355 + then (str o deresolve) c @@ str "()"
235.356 else (str o deresolve) c
235.357 - :: ((map (pr_dicts BR) o filter_out null) iss @ map (pr_term thm vars BR) ts)
235.358 - and pr_app thm vars = gen_pr_app pr_app' pr_term syntax_const naming thm vars
235.359 + :: ((map (pr_dicts BR) o filter_out null) iss @ map (pr_term is_closure thm vars BR) ts)
235.360 + and pr_app is_closure = gen_pr_app (pr_app' is_closure) (pr_term is_closure)
235.361 + syntax_const naming
235.362 and pr_bind' ((NONE, NONE), _) = str "_"
235.363 | pr_bind' ((SOME v, NONE), _) = str v
235.364 | pr_bind' ((NONE, SOME p), _) = p
235.365 | pr_bind' ((SOME v, SOME p), _) = brackets [p, str "as", str v]
235.366 - and pr_bind thm = gen_pr_bind pr_bind' pr_term thm
235.367 - and pr_case thm vars fxy (cases as ((_, [_]), _)) =
235.368 + and pr_bind is_closure = gen_pr_bind pr_bind' (pr_term is_closure)
235.369 + and pr_case is_closure thm vars fxy (cases as ((_, [_]), _)) =
235.370 let
235.371 val (binds, t') = Code_Thingol.unfold_let (ICase cases);
235.372 fun pr ((pat, ty), t) vars =
235.373 vars
235.374 - |> pr_bind thm NOBR ((NONE, SOME pat), ty)
235.375 + |> pr_bind is_closure thm NOBR ((NONE, SOME pat), ty)
235.376 |>> (fn p => concat
235.377 - [str "let", p, str "=", pr_term thm vars NOBR t, str "in"])
235.378 + [str "let", p, str "=", pr_term is_closure thm vars NOBR t, str "in"])
235.379 val (ps, vars') = fold_map pr binds vars;
235.380 - in Pretty.chunks (ps @| pr_term thm vars' NOBR t') end
235.381 - | pr_case thm vars fxy (((td, ty), b::bs), _) =
235.382 + in Pretty.chunks (ps @| pr_term is_closure thm vars' NOBR t') end
235.383 + | pr_case is_closure thm vars fxy (((td, ty), b::bs), _) =
235.384 let
235.385 fun pr delim (pat, t) =
235.386 let
235.387 - val (p, vars') = pr_bind thm NOBR ((NONE, SOME pat), ty) vars;
235.388 - in concat [str delim, p, str "->", pr_term thm vars' NOBR t] end;
235.389 + val (p, vars') = pr_bind is_closure thm NOBR ((NONE, SOME pat), ty) vars;
235.390 + in concat [str delim, p, str "->", pr_term is_closure thm vars' NOBR t] end;
235.391 in
235.392 (Pretty.enclose "(" ")" o single o brackify fxy) (
235.393 str "match"
235.394 - :: pr_term thm vars NOBR td
235.395 + :: pr_term is_closure thm vars NOBR td
235.396 :: pr "with" b
235.397 :: map (pr "|") bs
235.398 )
235.399 end
235.400 - | pr_case thm vars fxy ((_, []), _) = str "failwith \"empty case\"";
235.401 + | pr_case is_closure thm vars fxy ((_, []), _) = str "failwith \"empty case\"";
235.402 fun fish_params vars eqs =
235.403 let
235.404 fun fish_param _ (w as SOME _) = w
235.405 @@ -449,7 +470,39 @@
235.406 val (fished3, _) = Name.variants fished2 Name.context;
235.407 val vars' = Code_Name.intro_vars fished3 vars;
235.408 in map (Code_Name.lookup_var vars') fished3 end;
235.409 - fun pr_stmt (MLFuns (funns as funn :: funns')) =
235.410 + fun pr_stmt (MLExc (name, n)) =
235.411 + let
235.412 + val exc_str =
235.413 + (ML_Syntax.print_string o NameSpace.base o NameSpace.qualifier) name;
235.414 + in
235.415 + concat (
235.416 + str "let"
235.417 + :: (str o deresolve) name
235.418 + :: map str (replicate n "_")
235.419 + @ str "="
235.420 + :: str "failwith"
235.421 + @@ str exc_str
235.422 + )
235.423 + end
235.424 + | pr_stmt (MLVal (name, (((vs, ty), t), (thm, _)))) =
235.425 + let
235.426 + val consts = map_filter
235.427 + (fn c => if (is_some o syntax_const) c
235.428 + then NONE else (SOME o NameSpace.base o deresolve) c)
235.429 + (Code_Thingol.fold_constnames (insert (op =)) t []);
235.430 + val vars = reserved_names
235.431 + |> Code_Name.intro_vars consts;
235.432 + in
235.433 + concat [
235.434 + str "let",
235.435 + (str o deresolve) name,
235.436 + str ":",
235.437 + pr_typ NOBR ty,
235.438 + str "=",
235.439 + pr_term (K false) thm vars NOBR t
235.440 + ]
235.441 + end
235.442 + | pr_stmt (MLFuns (funn :: funns, pseudo_funs)) =
235.443 let
235.444 fun pr_eq ((ts, t), (thm, _)) =
235.445 let
235.446 @@ -462,24 +515,12 @@
235.447 |> Code_Name.intro_vars ((fold o Code_Thingol.fold_unbound_varnames)
235.448 (insert (op =)) ts []);
235.449 in concat [
235.450 - (Pretty.block o Pretty.commas) (map (pr_term thm vars NOBR) ts),
235.451 + (Pretty.block o Pretty.commas)
235.452 + (map (pr_term (member (op =) pseudo_funs) thm vars NOBR) ts),
235.453 str "->",
235.454 - pr_term thm vars NOBR t
235.455 + pr_term (member (op =) pseudo_funs) thm vars NOBR t
235.456 ] end;
235.457 - fun pr_eqs name ty [] =
235.458 - let
235.459 - val n = (length o fst o Code_Thingol.unfold_fun) ty;
235.460 - val exc_str =
235.461 - (ML_Syntax.print_string o NameSpace.base o NameSpace.qualifier) name;
235.462 - in
235.463 - concat (
235.464 - map str (replicate n "_")
235.465 - @ str "="
235.466 - :: str "failwith"
235.467 - @@ str exc_str
235.468 - )
235.469 - end
235.470 - | pr_eqs _ _ [((ts, t), (thm, _))] =
235.471 + fun pr_eqs is_pseudo [((ts, t), (thm, _))] =
235.472 let
235.473 val consts = map_filter
235.474 (fn c => if (is_some o syntax_const) c
235.475 @@ -491,12 +532,13 @@
235.476 (insert (op =)) ts []);
235.477 in
235.478 concat (
235.479 - map (pr_term thm vars BR) ts
235.480 + (if is_pseudo then [str "()"]
235.481 + else map (pr_term (member (op =) pseudo_funs) thm vars BR) ts)
235.482 @ str "="
235.483 - @@ pr_term thm vars NOBR t
235.484 + @@ pr_term (member (op =) pseudo_funs) thm vars NOBR t
235.485 )
235.486 end
235.487 - | pr_eqs _ _ (eqs as (eq as (([_], _), _)) :: eqs') =
235.488 + | pr_eqs _ (eqs as (eq as (([_], _), _)) :: eqs') =
235.489 Pretty.block (
235.490 str "="
235.491 :: Pretty.brk 1
235.492 @@ -506,7 +548,7 @@
235.493 :: maps (append [Pretty.fbrk, str "|", Pretty.brk 1]
235.494 o single o pr_eq) eqs'
235.495 )
235.496 - | pr_eqs _ _ (eqs as eq :: eqs') =
235.497 + | pr_eqs _ (eqs as eq :: eqs') =
235.498 let
235.499 val consts = map_filter
235.500 (fn c => if (is_some o syntax_const) c
235.501 @@ -538,11 +580,20 @@
235.502 str definer
235.503 :: (str o deresolve) name
235.504 :: pr_tyvar_dicts (filter_out (null o snd) vs)
235.505 - @| pr_eqs name ty eqs
235.506 + @| pr_eqs (member (op =) pseudo_funs name) eqs
235.507 );
235.508 + fun pr_pseudo_fun name = concat [
235.509 + str "let",
235.510 + (str o deresolve) name,
235.511 + str "=",
235.512 + (str o deresolve) name,
235.513 + str "();;"
235.514 + ];
235.515 + val (ps, p) = split_last (pr_funn "fun" funn :: map (pr_funn "and") funns);
235.516 val (ps, p) = split_last
235.517 - (pr_funn "let rec" funn :: map (pr_funn "and") funns');
235.518 - in Pretty.chunks (ps @ [Pretty.block ([p, str ";;"])]) end
235.519 + (pr_funn "let rec" funn :: map (pr_funn "and") funns);
235.520 + val pseudo_ps = map pr_pseudo_fun pseudo_funs;
235.521 + in Pretty.chunks (ps @ Pretty.block ([p, str ";;"]) :: pseudo_ps) end
235.522 | pr_stmt (MLDatas (datas as (data :: datas'))) =
235.523 let
235.524 fun pr_co (co, []) =
235.525 @@ -569,7 +620,7 @@
235.526 );
235.527 val (ps, p) = split_last
235.528 (pr_data "type" data :: map (pr_data "and") datas');
235.529 - in Pretty.chunks (ps @ [Pretty.block ([p, str ";;"])]) end
235.530 + in Pretty.chunks (ps @| Pretty.block ([p, str ";;"])) end
235.531 | pr_stmt (MLClass (class, (v, (superclasses, classparams)))) =
235.532 let
235.533 val w = "_" ^ Code_Name.first_upper v;
235.534 @@ -613,7 +664,7 @@
235.535 concat [
235.536 (str o deresolve) classparam,
235.537 str "=",
235.538 - pr_app thm reserved_names NOBR (c_inst, [])
235.539 + pr_app (K false) thm reserved_names NOBR (c_inst, [])
235.540 ];
235.541 in
235.542 concat (
235.543 @@ -721,15 +772,33 @@
235.544 val base' = if upper then Code_Name.first_upper base else base;
235.545 val ([base''], nsp') = Name.variants [base'] nsp;
235.546 in (base'', nsp') end;
235.547 - fun add_funs stmts =
235.548 - fold_map
235.549 + fun rearrange_fun name (tysm as (vs, ty), raw_eqs) =
235.550 + let
235.551 + val eqs = filter (snd o snd) raw_eqs;
235.552 + val (eqs', is_value) = if null (filter_out (null o snd) vs) then case eqs
235.553 + of [(([], t), thm)] => if (not o null o fst o Code_Thingol.unfold_fun) ty
235.554 + then ([(([IVar "x"], t `$ IVar "x"), thm)], false)
235.555 + else (eqs, not (Code_Thingol.fold_constnames
235.556 + (fn name' => fn b => b orelse name = name') t false))
235.557 + | _ => (eqs, false)
235.558 + else (eqs, false)
235.559 + in ((name, (tysm, eqs')), is_value) end;
235.560 + fun check_kind [((name, (tysm, [(([], t), thm)])), true)] = MLVal (name, ((tysm, t), thm))
235.561 + | check_kind [((name, ((vs, ty), [])), _)] =
235.562 + MLExc (name, (length o filter_out (null o snd)) vs + (length o fst o Code_Thingol.unfold_fun) ty)
235.563 + | check_kind funns =
235.564 + MLFuns (map fst funns, map_filter
235.565 + (fn ((name, ((vs, _), [(([], _), _)])), _) =>
235.566 + if null (filter_out (null o snd) vs) then SOME name else NONE
235.567 + | _ => NONE) funns);
235.568 + fun add_funs stmts = fold_map
235.569 (fn (name, Code_Thingol.Fun (_, stmt)) =>
235.570 - map_nsp_fun_yield (mk_name_stmt false name) #>>
235.571 - rpair (name, stmt |> apsnd (filter (snd o snd)))
235.572 + map_nsp_fun_yield (mk_name_stmt false name)
235.573 + #>> rpair (rearrange_fun name stmt)
235.574 | (name, _) =>
235.575 error ("Function block containing illegal statement: " ^ labelled_name name)
235.576 ) stmts
235.577 - #>> (split_list #> apsnd MLFuns);
235.578 + #>> (split_list #> apsnd check_kind);
235.579 fun add_datatypes stmts =
235.580 fold_map
235.581 (fn (name, Code_Thingol.Datatype (_, stmt)) =>